From d90db51cbcb94d0ad7d70b09b5b9ccb8a6016317 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Fri, 26 Jan 2024 16:01:38 -0500 Subject: [PATCH 001/103] Begin making DHExp look like UExp --- src/haz3lcore/dynamics/Builtins.re | 64 +++---- src/haz3lcore/dynamics/DH.re | 166 ++++++++----------- src/haz3lcore/dynamics/DHPat.re | 29 ++-- src/haz3lcore/dynamics/Elaborator.re | 61 +++---- src/haz3lcore/dynamics/EvalCtx.re | 106 +++++------- src/haz3lcore/dynamics/EvaluatorPost.re | 92 ++++------ src/haz3lcore/dynamics/EvaluatorStep.re | 46 ++--- src/haz3lcore/dynamics/FilterMatcher.re | 75 ++++----- src/haz3lcore/dynamics/PatternMatch.re | 95 +++++------ src/haz3lcore/dynamics/Stepper.re | 48 ++---- src/haz3lcore/dynamics/Substitution.re | 34 ++-- src/haz3lcore/dynamics/Transition.re | 157 +++++++++--------- src/haz3lcore/dynamics/ValueChecker.re | 2 +- src/haz3lcore/statics/TermBase.re | 63 +++---- src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 78 ++++----- src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re | 16 +- 16 files changed, 483 insertions(+), 649 deletions(-) diff --git a/src/haz3lcore/dynamics/Builtins.re b/src/haz3lcore/dynamics/Builtins.re index 385f6e0317..606a426694 100644 --- a/src/haz3lcore/dynamics/Builtins.re +++ b/src/haz3lcore/dynamics/Builtins.re @@ -32,13 +32,13 @@ let fn = module Pervasives = { module Impls = { /* constants */ - let infinity = DHExp.FloatLit(Float.infinity); - let neg_infinity = DHExp.FloatLit(Float.neg_infinity); - let nan = DHExp.FloatLit(Float.nan); - let epsilon_float = DHExp.FloatLit(epsilon_float); - let pi = DHExp.FloatLit(Float.pi); - let max_int = DHExp.IntLit(Int.max_int); - let min_int = DHExp.IntLit(Int.min_int); + let infinity = DHExp.Float(Float.infinity); + let neg_infinity = DHExp.Float(Float.neg_infinity); + let nan = DHExp.Float(Float.nan); + let epsilon_float = DHExp.Float(epsilon_float); + let pi = DHExp.Float(Float.pi); + let max_int = DHExp.Int(Int.max_int); + let min_int = DHExp.Int(Int.min_int); let unary = (f: DHExp.t => result, r: DHExp.t) => switch (f(r)) { @@ -49,70 +49,70 @@ module Pervasives = { let is_finite = unary( fun - | FloatLit(f) => Ok(BoolLit(Float.is_finite(f))) + | Float(f) => Ok(Bool(Float.is_finite(f))) | d => Error(InvalidBoxedFloatLit(d)), ); let is_infinite = unary( fun - | FloatLit(f) => Ok(BoolLit(Float.is_infinite(f))) + | Float(f) => Ok(Bool(Float.is_infinite(f))) | d => Error(InvalidBoxedFloatLit(d)), ); let is_nan = unary( fun - | FloatLit(f) => Ok(BoolLit(Float.is_nan(f))) + | Float(f) => Ok(Bool(Float.is_nan(f))) | d => Error(InvalidBoxedFloatLit(d)), ); let string_of_int = unary( fun - | IntLit(n) => Ok(StringLit(string_of_int(n))) + | Int(n) => Ok(String(string_of_int(n))) | d => Error(InvalidBoxedIntLit(d)), ); let string_of_float = unary( fun - | FloatLit(f) => Ok(StringLit(string_of_float(f))) + | Float(f) => Ok(String(string_of_float(f))) | d => Error(InvalidBoxedFloatLit(d)), ); let string_of_bool = unary( fun - | BoolLit(b) => Ok(StringLit(string_of_bool(b))) + | Bool(b) => Ok(String(string_of_bool(b))) | d => Error(InvalidBoxedBoolLit(d)), ); let int_of_float = unary( fun - | FloatLit(f) => Ok(IntLit(int_of_float(f))) + | Float(f) => Ok(Int(int_of_float(f))) | d => Error(InvalidBoxedFloatLit(d)), ); let float_of_int = unary( fun - | IntLit(n) => Ok(FloatLit(float_of_int(n))) + | Int(n) => Ok(Float(float_of_int(n))) | d => Error(InvalidBoxedIntLit(d)), ); let abs = unary( fun - | IntLit(n) => Ok(IntLit(abs(n))) + | Int(n) => Ok(Int(abs(n))) | d => Error(InvalidBoxedIntLit(d)), ); let float_op = fn => unary( fun - | FloatLit(f) => Ok(FloatLit(fn(f))) + | Float(f) => Ok(Float(fn(f))) | d => Error(InvalidBoxedFloatLit(d)), ); @@ -134,7 +134,7 @@ module Pervasives = { (convert: string => option('a), wrap: 'a => DHExp.t, name: string) => unary( fun - | StringLit(s) as d => + | String(s) as d => switch (convert(s)) { | Some(n) => Ok(wrap(n)) | None => @@ -144,20 +144,20 @@ module Pervasives = { | d => Error(InvalidBoxedStringLit(d)), ); - let int_of_string = of_string(int_of_string_opt, n => IntLit(n)); - let float_of_string = of_string(float_of_string_opt, f => FloatLit(f)); - let bool_of_string = of_string(bool_of_string_opt, b => BoolLit(b)); + let int_of_string = of_string(int_of_string_opt, n => Int(n)); + let float_of_string = of_string(float_of_string_opt, f => Float(f)); + let bool_of_string = of_string(bool_of_string_opt, b => Bool(b)); let int_mod = (name, d1) => switch (d1) { - | Tuple([IntLit(n), IntLit(m)]) => + | Tuple([Int(n), Int(m)]) => switch (m) { | 0 => InvalidOperation( DHExp.Ap(DHExp.BuiltinFun(name), d1), DivideByZero, ) - | _ => IntLit(n mod m) + | _ => Int(n mod m) } | d1 => raise(EvaluatorError.Exception(InvalidBoxedTuple(d1))) }; @@ -165,37 +165,37 @@ module Pervasives = { let string_length = unary( fun - | StringLit(s) => Ok(IntLit(String.length(s))) + | String(s) => Ok(Int(String.length(s))) | d => Error(InvalidBoxedStringLit(d)), ); let string_compare = unary( fun - | Tuple([StringLit(s1), StringLit(s2)]) => - Ok(IntLit(String.compare(s1, s2))) + | Tuple([String(s1), String(s2)]) => + Ok(Int(String.compare(s1, s2))) | d => Error(InvalidBoxedTuple(d)), ); let string_trim = unary( fun - | StringLit(s) => Ok(StringLit(String.trim(s))) + | String(s) => Ok(String(String.trim(s))) | d => Error(InvalidBoxedStringLit(d)), ); let string_of: DHExp.t => option(string) = fun - | StringLit(s) => Some(s) + | String(s) => Some(s) | _ => None; let string_concat = unary( fun - | Tuple([StringLit(s1), ListLit(_, _, _, xs)]) => + | Tuple([String(s1), ListLit(_, _, _, xs)]) => switch (xs |> List.map(string_of) |> Util.OptUtil.sequence) { | None => Error(InvalidBoxedStringLit(List.hd(xs))) - | Some(xs) => Ok(StringLit(String.concat(s1, xs))) + | Some(xs) => Ok(String(String.concat(s1, xs))) } | d => Error(InvalidBoxedTuple(d)), ); @@ -203,8 +203,8 @@ module Pervasives = { let string_sub = name => unary( fun - | Tuple([StringLit(s), IntLit(idx), IntLit(len)]) as d => - try(Ok(StringLit(String.sub(s, idx, len)))) { + | Tuple([String(s), Int(idx), Int(len)]) as d => + try(Ok(String(String.sub(s, idx, len)))) { | _ => let d' = DHExp.Ap(DHExp.BuiltinFun(name), d); Ok(InvalidOperation(d', IndexOutOfBounds)); diff --git a/src/haz3lcore/dynamics/DH.re b/src/haz3lcore/dynamics/DH.re index daf30b8158..03703cf783 100644 --- a/src/haz3lcore/dynamics/DH.re +++ b/src/haz3lcore/dynamics/DH.re @@ -8,44 +8,48 @@ type if_consistency = module rec DHExp: { [@deriving (show({with_path: false}), sexp, yojson)] type t = + // TODO: Add IDs + /* TODO: ADD: + UnOp + TyAlias [and ignore] + Parens + */ + // TODO: Work out how to reconcile the invalids | EmptyHole(MetaVar.t, HoleInstanceId.t) | NonEmptyHole(ErrStatus.HoleReason.t, MetaVar.t, HoleInstanceId.t, t) | ExpandingKeyword(MetaVar.t, HoleInstanceId.t, ExpandingKeyword.t) | FreeVar(MetaVar.t, HoleInstanceId.t, Var.t) | InvalidText(MetaVar.t, HoleInstanceId.t, string) | InconsistentBranches(MetaVar.t, HoleInstanceId.t, case) - | Closure([@show.opaque] ClosureEnvironment.t, t) - | Filter(DHFilter.t, t) - | BoundVar(Var.t) - | Sequence(t, t) - | Let(DHPat.t, t, t) - | FixF(Var.t, Typ.t, t) - | Fun(DHPat.t, Typ.t, t, option(Var.t)) - | Ap(t, t) - | ApBuiltin(string, t) - | BuiltinFun(string) - | Test(KeywordID.t, t) - | BoolLit(bool) - | IntLit(int) - | FloatLit(float) - | StringLit(string) - | BinBoolOp(TermBase.UExp.op_bin_bool, t, t) - | BinIntOp(TermBase.UExp.op_bin_int, t, t) - | BinFloatOp(TermBase.UExp.op_bin_float, t, t) - | BinStringOp(TermBase.UExp.op_bin_string, t, t) - | ListLit(MetaVar.t, MetaVarInst.t, Typ.t, list(t)) - | Cons(t, t) - | ListConcat(t, t) - | Tuple(list(t)) - | Prj(t, int) - | Constructor(string) - | ConsistentCase(case) - | Cast(t, Typ.t, Typ.t) - | FailedCast(t, Typ.t, Typ.t) | InvalidOperation(t, InvalidOperationError.t) - | IfThenElse(if_consistency, t, t, t) // use bool tag to track if branches are consistent + | FailedCast(t, Typ.t, Typ.t) + | Closure([@show.opaque] ClosureEnvironment.t, t) // > UEXP + | Filter(DHFilter.t, t) // DONE [UEXP TO BE CHANGED] + | Var(Var.t) // DONE [ALREADY] + | Seq(t, t) // DONE [ALREADY] + | Let(DHPat.t, t, t) // DONE [ALREADY] + | FixF(Var.t, Typ.t, t) // TODO: ! REMOVE, LEAVE AS LETS? + | Fun(DHPat.t, Typ.t, t, option(Var.t)) // TODO: Move type into pattern?; name > UEXP + | Ap(t, t) // TODO: Add reverse application + | ApBuiltin(string, t) // DONE [TO ADD TO UEXP] + | BuiltinFun(string) // DONE [TO ADD TO UEXP] + | Test(KeywordID.t, t) // TODO: ! ID + | Bool(bool) // DONE + | Int(int) // DONE + | Float(float) // DONE + | String(string) // DONE + | BinOp(TermBase.UExp.op_bin, t, t) // DONE + | ListLit(MetaVar.t, MetaVarInst.t, Typ.t, list(t)) // TODO: afaict the first three arguments here are never used? + | Cons(t, t) // DONE [ALREADY] + | ListConcat(t, t) // DONE [ALREADY] + | Tuple(list(t)) // DONE [ALREADY] + | Prj(t, int) // TODO: ! REMOVE, LEAVE AS LETS? + | Constructor(string) // DONE [ALREADY] + | ConsistentCase(case) // TODO: CONSISTENCY? + | Cast(t, Typ.t, Typ.t) // TODO: Add to uexp or remove + | If(if_consistency, t, t, t) // TODO: CONSISTENCY? use bool tag to track if branches are consistent and case = - | Case(t, list(rule), int) + | Case(t, list(rule), int) // is the int really necessary? and rule = | Rule(DHPat.t, t); @@ -69,12 +73,14 @@ module rec DHExp: { | FreeVar(MetaVar.t, HoleInstanceId.t, Var.t) | InvalidText(MetaVar.t, HoleInstanceId.t, string) | InconsistentBranches(MetaVar.t, HoleInstanceId.t, case) + | InvalidOperation(t, InvalidOperationError.t) + | FailedCast(t, Typ.t, Typ.t) /* Generalized closures */ | Closure([@show.opaque] ClosureEnvironment.t, t) | Filter(DHFilter.t, t) /* Other expressions forms */ - | BoundVar(Var.t) - | Sequence(t, t) + | Var(Var.t) + | Seq(t, t) | Let(DHPat.t, t, t) | FixF(Var.t, Typ.t, t) | Fun(DHPat.t, Typ.t, t, option(Var.t)) @@ -82,14 +88,11 @@ module rec DHExp: { | ApBuiltin(string, t) | BuiltinFun(string) | Test(KeywordID.t, t) - | BoolLit(bool) - | IntLit(int) - | FloatLit(float) - | StringLit(string) - | BinBoolOp(TermBase.UExp.op_bin_bool, t, t) - | BinIntOp(TermBase.UExp.op_bin_int, t, t) - | BinFloatOp(TermBase.UExp.op_bin_float, t, t) - | BinStringOp(TermBase.UExp.op_bin_string, t, t) + | Bool(bool) + | Int(int) + | Float(float) + | String(string) + | BinOp(TermBase.UExp.op_bin, t, t) | ListLit(MetaVar.t, MetaVarInst.t, Typ.t, list(t)) | Cons(t, t) | ListConcat(t, t) @@ -98,9 +101,7 @@ module rec DHExp: { | Constructor(string) | ConsistentCase(case) | Cast(t, Typ.t, Typ.t) - | FailedCast(t, Typ.t, Typ.t) - | InvalidOperation(t, InvalidOperationError.t) - | IfThenElse(if_consistency, t, t, t) + | If(if_consistency, t, t, t) and case = | Case(t, list(rule), int) and rule = @@ -113,8 +114,8 @@ module rec DHExp: { | ExpandingKeyword(_, _, _) => "ExpandingKeyword" | FreeVar(_, _, _) => "FreeVar" | InvalidText(_) => "InvalidText" - | BoundVar(_) => "BoundVar" - | Sequence(_, _) => "Sequence" + | Var(_) => "Var" + | Seq(_, _) => "Seq" | Filter(_, _) => "Filter" | Let(_, _, _) => "Let" | FixF(_, _, _) => "FixF" @@ -124,14 +125,11 @@ module rec DHExp: { | ApBuiltin(_, _) => "ApBuiltin" | BuiltinFun(_) => "BuiltinFun" | Test(_) => "Test" - | BoolLit(_) => "BoolLit" - | IntLit(_) => "IntLit" - | FloatLit(_) => "FloatLit" - | StringLit(_) => "StringLit" - | BinBoolOp(_, _, _) => "BinBoolOp" - | BinIntOp(_, _, _) => "BinIntOp" - | BinFloatOp(_, _, _) => "BinFloatOp" - | BinStringOp(_, _, _) => "BinStringOp" + | Bool(_) => "Bool" + | Int(_) => "Int" + | Float(_) => "Float" + | String(_) => "String" + | BinOp(_, _, _) => "BinOp" | ListLit(_) => "ListLit" | Cons(_, _) => "Cons" | ListConcat(_, _) => "ListConcat" @@ -143,7 +141,7 @@ module rec DHExp: { | Cast(_, _, _) => "Cast" | FailedCast(_, _, _) => "FailedCast" | InvalidOperation(_) => "InvalidOperation" - | IfThenElse(_, _, _, _) => "IfThenElse" + | If(_, _, _, _) => "If" }; let mk_tuple: list(t) => t = @@ -173,7 +171,7 @@ module rec DHExp: { | ListConcat(d1, d2) => ListConcat(strip_casts(d1), strip_casts(d2)) | ListLit(a, b, c, ds) => ListLit(a, b, c, List.map(strip_casts, ds)) | NonEmptyHole(err, u, i, d) => NonEmptyHole(err, u, i, strip_casts(d)) - | Sequence(a, b) => Sequence(strip_casts(a), strip_casts(b)) + | Seq(a, b) => Seq(strip_casts(a), strip_casts(b)) | Filter(f, b) => Filter(DHFilter.strip_casts(f), strip_casts(b)) | Let(dp, b, c) => Let(dp, strip_casts(b), strip_casts(c)) | FixF(a, b, c) => FixF(a, b, strip_casts(c)) @@ -182,11 +180,7 @@ module rec DHExp: { | Test(id, a) => Test(id, strip_casts(a)) | ApBuiltin(fn, args) => ApBuiltin(fn, strip_casts(args)) | BuiltinFun(fn) => BuiltinFun(fn) - | BinBoolOp(a, b, c) => BinBoolOp(a, strip_casts(b), strip_casts(c)) - | BinIntOp(a, b, c) => BinIntOp(a, strip_casts(b), strip_casts(c)) - | BinFloatOp(a, b, c) => BinFloatOp(a, strip_casts(b), strip_casts(c)) - | BinStringOp(a, b, c) => - BinStringOp(a, strip_casts(b), strip_casts(c)) + | BinOp(a, b, c) => BinOp(a, strip_casts(b), strip_casts(c)) | ConsistentCase(Case(a, rs, b)) => ConsistentCase( Case(strip_casts(a), List.map(strip_casts_rule, rs), b), @@ -201,37 +195,32 @@ module rec DHExp: { | ExpandingKeyword(_) as d | FreeVar(_) as d | InvalidText(_) as d - | BoundVar(_) as d - | BoolLit(_) as d - | IntLit(_) as d - | FloatLit(_) as d - | StringLit(_) as d + | Var(_) as d + | Bool(_) as d + | Int(_) as d + | Float(_) as d + | String(_) as d | Constructor(_) as d | InvalidOperation(_) as d => d - | IfThenElse(consistent, c, d1, d2) => - IfThenElse( - consistent, - strip_casts(c), - strip_casts(d1), - strip_casts(d2), - ) + | If(consistent, c, d1, d2) => + If(consistent, strip_casts(c), strip_casts(d1), strip_casts(d2)) and strip_casts_rule = (Rule(a, d)) => Rule(a, strip_casts(d)); let rec fast_equal = (d1: t, d2: t): bool => { switch (d1, d2) { /* Primitive forms: regular structural equality */ - | (BoundVar(_), _) + | (Var(_), _) /* TODO: Not sure if this is right... */ - | (BoolLit(_), _) - | (IntLit(_), _) - | (FloatLit(_), _) + | (Bool(_), _) + | (Int(_), _) + | (Float(_), _) | (Constructor(_), _) => d1 == d2 - | (StringLit(s1), StringLit(s2)) => String.equal(s1, s2) - | (StringLit(_), _) => false + | (String(s1), String(s2)) => String.equal(s1, s2) + | (String(_), _) => false /* Non-hole forms: recurse */ | (Test(id1, d1), Test(id2, d2)) => id1 == id2 && fast_equal(d1, d2) - | (Sequence(d11, d21), Sequence(d12, d22)) => + | (Seq(d11, d21), Seq(d12, d22)) => fast_equal(d11, d12) && fast_equal(d21, d22) | (Filter(f1, d1), Filter(f2, d2)) => DHFilter.fast_equal(f1, f2) && fast_equal(d1, d2) @@ -255,13 +244,7 @@ module rec DHExp: { | (ListLit(_, _, _, ds1), ListLit(_, _, _, ds2)) => List.length(ds1) == List.length(ds2) && List.for_all2(fast_equal, ds1, ds2) - | (BinBoolOp(op1, d11, d21), BinBoolOp(op2, d12, d22)) => - op1 == op2 && fast_equal(d11, d12) && fast_equal(d21, d22) - | (BinIntOp(op1, d11, d21), BinIntOp(op2, d12, d22)) => - op1 == op2 && fast_equal(d11, d12) && fast_equal(d21, d22) - | (BinFloatOp(op1, d11, d21), BinFloatOp(op2, d12, d22)) => - op1 == op2 && fast_equal(d11, d12) && fast_equal(d21, d22) - | (BinStringOp(op1, d11, d21), BinStringOp(op2, d12, d22)) => + | (BinOp(op1, d11, d21), BinOp(op2, d12, d22)) => op1 == op2 && fast_equal(d11, d12) && fast_equal(d21, d22) | (Cast(d1, ty11, ty21), Cast(d2, ty12, ty22)) | (FailedCast(d1, ty11, ty21), FailedCast(d2, ty12, ty22)) => @@ -270,14 +253,14 @@ module rec DHExp: { fast_equal(d1, d2) && reason1 == reason2 | (ConsistentCase(case1), ConsistentCase(case2)) => fast_equal_case(case1, case2) - | (IfThenElse(c1, d11, d12, d13), IfThenElse(c2, d21, d22, d23)) => + | (If(c1, d11, d12, d13), If(c2, d21, d22, d23)) => c1 == c2 && fast_equal(d11, d21) && fast_equal(d12, d22) && fast_equal(d13, d23) /* We can group these all into a `_ => false` clause; separating these so that we get exhaustiveness checking. */ - | (Sequence(_), _) + | (Seq(_), _) | (Filter(_), _) | (Let(_), _) | (FixF(_), _) @@ -291,14 +274,11 @@ module rec DHExp: { | (ListLit(_), _) | (Tuple(_), _) | (Prj(_), _) - | (BinBoolOp(_), _) - | (BinIntOp(_), _) - | (BinFloatOp(_), _) - | (BinStringOp(_), _) + | (BinOp(_), _) | (Cast(_), _) | (FailedCast(_), _) | (InvalidOperation(_), _) - | (IfThenElse(_), _) + | (If(_), _) | (ConsistentCase(_), _) => false /* Hole forms: when checking environments, only check that diff --git a/src/haz3lcore/dynamics/DHPat.re b/src/haz3lcore/dynamics/DHPat.re index 4909fce337..21bdea3ba4 100644 --- a/src/haz3lcore/dynamics/DHPat.re +++ b/src/haz3lcore/dynamics/DHPat.re @@ -3,16 +3,19 @@ open Sexplib.Std; [@deriving (show({with_path: false}), sexp, yojson)] type t = | EmptyHole(MetaVar.t, MetaVarInst.t) + // TODO: Work out what to do with invalids | NonEmptyHole(ErrStatus.HoleReason.t, MetaVar.t, MetaVarInst.t, t) - | Wild | ExpandingKeyword(MetaVar.t, MetaVarInst.t, ExpandingKeyword.t) + // Same + | Wild + | Int(int) + | Float(float) + | Bool(bool) + | String(string) + // TODO: | InvalidText(MetaVar.t, MetaVarInst.t, string) | BadConstructor(MetaVar.t, MetaVarInst.t, string) | Var(Var.t) - | IntLit(int) - | FloatLit(float) - | BoolLit(bool) - | StringLit(string) | ListLit(Typ.t, list(t)) | Cons(t, t) | Tuple(list(t)) @@ -35,10 +38,10 @@ let rec binds_var = (x: Var.t, dp: t): bool => | Wild | InvalidText(_) | BadConstructor(_) - | IntLit(_) - | FloatLit(_) - | BoolLit(_) - | StringLit(_) + | Int(_) + | Float(_) + | Bool(_) + | String(_) | Constructor(_) | ExpandingKeyword(_, _, _) => false | Var(y) => Var.eq(x, y) @@ -57,10 +60,10 @@ let rec bound_vars = (dp: t): list(Var.t) => | Wild | InvalidText(_) | BadConstructor(_) - | IntLit(_) - | FloatLit(_) - | BoolLit(_) - | StringLit(_) + | Int(_) + | Float(_) + | Bool(_) + | String(_) | Constructor(_) | ExpandingKeyword(_, _, _) => [] | Var(y) => [y] diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 199a7a7e7f..034dfac7d4 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -8,13 +8,6 @@ module ElaborationResult = { | DoesNotElaborate; }; -let exp_binop_of: Term.UExp.op_bin => (Typ.t, (_, _) => DHExp.t) = - fun - | Int(op) => (Int, ((e1, e2) => BinIntOp(op, e1, e2))) - | Float(op) => (Float, ((e1, e2) => BinFloatOp(op, e1, e2))) - | Bool(op) => (Bool, ((e1, e2) => BinBoolOp(op, e1, e2))) - | String(op) => (String, ((e1, e2) => BinStringOp(op, e1, e2))); - let fixed_exp_typ = (m: Statics.Map.t, e: Term.UExp.t): option(Typ.t) => switch (Id.Map.find_opt(Term.UExp.rep_id(e), m)) { | Some(InfoExp({ty, _})) => Some(ty) @@ -70,8 +63,8 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => /* Forms with special ana rules but no particular typing requirements */ | ConsistentCase(_) | InconsistentBranches(_) - | IfThenElse(_) - | Sequence(_) + | If(_) + | Seq(_) | Let(_) | FixF(_) => d /* Hole-like forms: Don't cast */ @@ -87,19 +80,16 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => | FailedCast(_) | InvalidOperation(_) => d /* Normal cases: wrap */ - | BoundVar(_) + | Var(_) | Ap(_) | ApBuiltin(_) | BuiltinFun(_) | Prj(_) - | BoolLit(_) - | IntLit(_) - | FloatLit(_) - | StringLit(_) - | BinBoolOp(_) - | BinIntOp(_) - | BinFloatOp(_) - | BinStringOp(_) + | Bool(_) + | Int(_) + | Float(_) + | String(_) + | BinOp(_) | Test(_) => DHExp.cast(d, self_ty, ana_ty) }; }; @@ -138,10 +128,10 @@ let rec dhexp_of_uexp = to avoid casting issues. */ Some(EmptyHole(id, 0)) | Triv => Some(Tuple([])) - | Bool(b) => Some(BoolLit(b)) - | Int(n) => Some(IntLit(n)) - | Float(n) => Some(FloatLit(n)) - | String(s) => Some(StringLit(s)) + | Bool(b) => Some(Bool(b)) + | Int(n) => Some(Int(n)) + | Float(n) => Some(Float(n)) + | String(s) => Some(String(s)) | ListLit(es) => let* ds = es |> List.map(dhexp_of_uexp(m)) |> OptUtil.sequence; let+ ty = fixed_exp_typ(m, uexp); @@ -171,13 +161,13 @@ let rec dhexp_of_uexp = } | UnOp(Int(Minus), e) => let+ dc = dhexp_of_uexp(m, e); - DHExp.BinIntOp(Minus, IntLit(0), dc); + DHExp.BinOp(Int(Minus), Int(0), dc); | UnOp(Bool(Not), e) => let+ d_scrut = dhexp_of_uexp(m, e); let d_rules = DHExp.[ - Rule(BoolLit(true), BoolLit(false)), - Rule(BoolLit(false), BoolLit(true)), + Rule(Bool(true), Bool(false)), + Rule(Bool(false), Bool(true)), ]; let d = DHExp.ConsistentCase(DHExp.Case(d_scrut, d_rules, 0)); /* Manually construct cast (case is not otherwise cast) */ @@ -186,15 +176,14 @@ let rec dhexp_of_uexp = | _ => d }; | BinOp(op, e1, e2) => - let (_, cons) = exp_binop_of(op); let* dc1 = dhexp_of_uexp(m, e1); let+ dc2 = dhexp_of_uexp(m, e2); - cons(dc1, dc2); + DHExp.BinOp(op, dc1, dc2); | Parens(e) => dhexp_of_uexp(m, e) | Seq(e1, e2) => let* d1 = dhexp_of_uexp(m, e1); let+ d2 = dhexp_of_uexp(m, e2); - DHExp.Sequence(d1, d2); + DHExp.Seq(d1, d2); | Test(test) => let+ dtest = dhexp_of_uexp(m, test); DHExp.Test(id, dtest); @@ -205,7 +194,7 @@ let rec dhexp_of_uexp = | Var(name) => switch (err_status) { | InHole(FreeVariable(_)) => Some(FreeVar(id, 0, name)) - | _ => Some(BoundVar(name)) + | _ => Some(Var(name)) } | Constructor(name) => switch (err_status) { @@ -241,7 +230,7 @@ let rec dhexp_of_uexp = }; let uniq_id = List.nth(def.ids, 0); let self_id = "__mutual__" ++ Id.to_string(uniq_id); - let self_var = DHExp.BoundVar(self_id); + let self_var = DHExp.Var(self_id); let (_, substituted_def) = fs |> List.fold_left( @@ -266,8 +255,8 @@ let rec dhexp_of_uexp = // Use tag to mark inconsistent branches switch (err_status) { | InHole(Common(Inconsistent(Internal(_)))) => - DHExp.IfThenElse(DH.InconsistentIf, c', d1, d2) - | _ => DHExp.IfThenElse(DH.ConsistentIf, c', d1, d2) + DHExp.If(DH.InconsistentIf, c', d1, d2) + | _ => DHExp.If(DH.ConsistentIf, c', d1, d2) }; | Match(scrut, rules) => let* d_scrut = dhexp_of_uexp(m, scrut); @@ -316,10 +305,10 @@ and dhpat_of_upat = (m: Statics.Map.t, upat: Term.UPat.t): option(DHPat.t) => { // TODO: dhexp, eval for multiholes Some(EmptyHole(u, 0)) | Wild => wrap(Wild) - | Bool(b) => wrap(BoolLit(b)) - | Int(n) => wrap(IntLit(n)) - | Float(n) => wrap(FloatLit(n)) - | String(s) => wrap(StringLit(s)) + | Bool(b) => wrap(Bool(b)) + | Int(n) => wrap(Int(n)) + | Float(n) => wrap(Float(n)) + | String(s) => wrap(String(s)) | Triv => wrap(Tuple([])) | ListLit(ps) => let* ds = ps |> List.map(dhpat_of_upat(m)) |> OptUtil.sequence; diff --git a/src/haz3lcore/dynamics/EvalCtx.re b/src/haz3lcore/dynamics/EvalCtx.re index 85ba47f5dd..dd82037df8 100644 --- a/src/haz3lcore/dynamics/EvalCtx.re +++ b/src/haz3lcore/dynamics/EvalCtx.re @@ -7,25 +7,19 @@ type cls = | Closure | FilterPattern | Filter - | Sequence1 - | Sequence2 + | Seq1 + | Seq2 | Let1 | Let2 | Ap1 | Ap2 | Fun | FixF - | BinBoolOp1 - | BinBoolOp2 - | BinIntOp1 - | BinIntOp2 - | BinFloatOp1 - | BinFloatOp2 - | BinStringOp1 - | BinStringOp2 - | IfThenElse1 - | IfThenElse2 - | IfThenElse3 + | BinOp1 + | BinOp2 + | If1 + | If2 + | If3 | Tuple(int) | ListLit(int) | ApBuiltin @@ -52,25 +46,19 @@ type t = | Mark | Closure([@show.opaque] ClosureEnvironment.t, t) | Filter(DH.DHFilter.t, t) - | Sequence1(t, DHExp.t) - | Sequence2(DHExp.t, t) + | Seq1(t, DHExp.t) + | Seq2(DHExp.t, t) | Let1(DHPat.t, t, DHExp.t) | Let2(DHPat.t, DHExp.t, t) | Fun(DHPat.t, Typ.t, t, option(Var.t)) | FixF(Var.t, Typ.t, t) | Ap1(t, DHExp.t) | Ap2(DHExp.t, t) - | IfThenElse1(if_consistency, t, DHExp.t, DHExp.t) - | IfThenElse2(if_consistency, DHExp.t, t, DHExp.t) - | IfThenElse3(if_consistency, DHExp.t, DHExp.t, t) - | BinBoolOp1(TermBase.UExp.op_bin_bool, t, DHExp.t) - | BinBoolOp2(TermBase.UExp.op_bin_bool, DHExp.t, t) - | BinIntOp1(TermBase.UExp.op_bin_int, t, DHExp.t) - | BinIntOp2(TermBase.UExp.op_bin_int, DHExp.t, t) - | BinFloatOp1(TermBase.UExp.op_bin_float, t, DHExp.t) - | BinFloatOp2(TermBase.UExp.op_bin_float, DHExp.t, t) - | BinStringOp1(TermBase.UExp.op_bin_string, t, DHExp.t) - | BinStringOp2(TermBase.UExp.op_bin_string, DHExp.t, t) + | If1(if_consistency, t, DHExp.t, DHExp.t) + | If2(if_consistency, DHExp.t, t, DHExp.t) + | If3(if_consistency, DHExp.t, DHExp.t, t) + | BinOp1(TermBase.UExp.op_bin, t, DHExp.t) + | BinOp2(TermBase.UExp.op_bin, DHExp.t, t) | Tuple(t, (list(DHExp.t), list(DHExp.t))) | ApBuiltin(string, t) | Test(KeywordID.t, t) @@ -120,25 +108,19 @@ let rec fuzzy_mark = | Cast(x, _, _) | FailedCast(x, _, _) | Filter(_, x) => fuzzy_mark(x) - | Sequence1(_) - | Sequence2(_) + | Seq1(_) + | Seq2(_) | Let1(_) | Let2(_) | Fun(_) | FixF(_) | Ap1(_) | Ap2(_) - | IfThenElse1(_) - | IfThenElse2(_) - | IfThenElse3(_) - | BinBoolOp1(_) - | BinBoolOp2(_) - | BinIntOp1(_) - | BinIntOp2(_) - | BinFloatOp1(_) - | BinFloatOp2(_) - | BinStringOp1(_) - | BinStringOp2(_) + | If1(_) + | If2(_) + | If3(_) + | BinOp1(_) + | BinOp2(_) | Tuple(_) | ApBuiltin(_) | ListLit(_) @@ -166,25 +148,19 @@ let rec unwrap = (ctx: t, sel: cls): option(t) => { | (NonEmptyHole, NonEmptyHole(_, _, _, c)) | (Closure, Closure(_, c)) | (Filter, Filter(_, c)) - | (Sequence1, Sequence1(c, _)) - | (Sequence2, Sequence2(_, c)) + | (Seq1, Seq1(c, _)) + | (Seq2, Seq2(_, c)) | (Let1, Let1(_, c, _)) | (Let2, Let2(_, _, c)) | (Fun, Fun(_, _, c, _)) | (FixF, FixF(_, _, c)) | (Ap1, Ap1(c, _)) | (Ap2, Ap2(_, c)) - | (BinBoolOp1, BinBoolOp1(_, c, _)) - | (BinBoolOp2, BinBoolOp2(_, _, c)) - | (BinIntOp1, BinIntOp1(_, c, _)) - | (BinIntOp2, BinIntOp2(_, _, c)) - | (BinFloatOp1, BinFloatOp1(_, c, _)) - | (BinFloatOp2, BinFloatOp2(_, _, c)) - | (BinStringOp1, BinStringOp1(_, c, _)) - | (BinStringOp2, BinStringOp2(_, _, c)) - | (IfThenElse1, IfThenElse1(_, c, _, _)) - | (IfThenElse2, IfThenElse2(_, _, c, _)) - | (IfThenElse3, IfThenElse3(_, _, _, c)) + | (BinOp1, BinOp1(_, c, _)) + | (BinOp2, BinOp2(_, _, c)) + | (If1, If1(_, c, _, _)) + | (If2, If2(_, _, c, _)) + | (If3, If3(_, _, _, c)) | (Cons1, Cons1(c, _)) | (Cons2, Cons2(_, c)) | (ListConcat1, ListConcat1(c, _)) @@ -216,26 +192,20 @@ let rec unwrap = (ctx: t, sel: cls): option(t) => { | (FailedCast, FailedCast(c, _, _)) => Some(c) | (Ap1, Ap2(_, _)) | (Ap2, Ap1(_, _)) - | (IfThenElse1, IfThenElse2(_)) - | (IfThenElse1, IfThenElse3(_)) - | (IfThenElse2, IfThenElse1(_)) - | (IfThenElse2, IfThenElse3(_)) - | (IfThenElse3, IfThenElse1(_)) - | (IfThenElse3, IfThenElse2(_)) + | (If1, If2(_)) + | (If1, If3(_)) + | (If2, If1(_)) + | (If2, If3(_)) + | (If3, If1(_)) + | (If3, If2(_)) | (Let1, Let2(_)) | (Let2, Let1(_)) - | (BinBoolOp1, BinBoolOp2(_)) - | (BinBoolOp2, BinBoolOp1(_)) - | (BinIntOp1, BinIntOp2(_)) - | (BinIntOp2, BinIntOp1(_)) - | (BinFloatOp1, BinFloatOp2(_)) - | (BinFloatOp2, BinFloatOp1(_)) - | (BinStringOp1, BinStringOp2(_)) - | (BinStringOp2, BinStringOp1(_)) + | (BinOp1, BinOp2(_)) + | (BinOp2, BinOp1(_)) | (Cons1, Cons2(_)) | (Cons2, Cons1(_)) - | (Sequence1, Sequence2(_)) - | (Sequence2, Sequence1(_)) + | (Seq1, Seq2(_)) + | (Seq2, Seq1(_)) | (ListConcat1, ListConcat2(_)) | (ListConcat2, ListConcat1(_)) => None | (FilterPattern, _) => None diff --git a/src/haz3lcore/dynamics/EvaluatorPost.re b/src/haz3lcore/dynamics/EvaluatorPost.re index 4966e7a914..d87d9bc82a 100644 --- a/src/haz3lcore/dynamics/EvaluatorPost.re +++ b/src/haz3lcore/dynamics/EvaluatorPost.re @@ -42,16 +42,16 @@ let rec pp_eval = (d: DHExp.t): m(DHExp.t) => switch (d) { /* Non-hole expressions: recurse through subexpressions */ | Test(_) - | BoolLit(_) - | IntLit(_) - | FloatLit(_) - | StringLit(_) + | Bool(_) + | Int(_) + | Float(_) + | String(_) | Constructor(_) => d |> return - | Sequence(d1, d2) => + | Seq(d1, d2) => let* d1' = pp_eval(d1); let+ d2' = pp_eval(d2); - Sequence(d1', d2'); + Seq(d1', d2'); | Filter(f, dbody) => let+ dbody' = pp_eval(dbody); @@ -66,28 +66,13 @@ let rec pp_eval = (d: DHExp.t): m(DHExp.t) => let* d1' = pp_eval(d1); ApBuiltin(f, d1') |> return; - | BinBoolOp(op, d1, d2) => + | BinOp(op, d1, d2) => let* d1' = pp_eval(d1); let* d2' = pp_eval(d2); - BinBoolOp(op, d1', d2') |> return; + BinOp(op, d1', d2') |> return; | BuiltinFun(f) => BuiltinFun(f) |> return - | BinIntOp(op, d1, d2) => - let* d1' = pp_eval(d1); - let* d2' = pp_eval(d2); - BinIntOp(op, d1', d2') |> return; - - | BinFloatOp(op, d1, d2) => - let* d1' = pp_eval(d1); - let* d2' = pp_eval(d2); - BinFloatOp(op, d1', d2') |> return; - - | BinStringOp(op, d1, d2) => - let* d1' = pp_eval(d1); - let* d2' = pp_eval(d2); - BinStringOp(op, d1', d2') |> return; - | Cons(d1, d2) => let* d1' = pp_eval(d1); let* d2' = pp_eval(d2); @@ -140,14 +125,14 @@ let rec pp_eval = (d: DHExp.t): m(DHExp.t) => let* d'' = pp_eval(d'); InvalidOperation(d'', reason) |> return; - | IfThenElse(consistent, c, d1, d2) => + | If(consistent, c, d1, d2) => let* c' = pp_eval(c); let* d1' = pp_eval(d1); let* d2' = pp_eval(d2); - IfThenElse(consistent, c', d1', d2') |> return; + If(consistent, c', d1', d2') |> return; /* These expression forms should not exist outside closure in evaluated result */ - | BoundVar(_) + | Var(_) | Let(_) | ConsistentCase(_) | Fun(_) @@ -260,27 +245,27 @@ and pp_uneval = (env: ClosureEnvironment.t, d: DHExp.t): m(DHExp.t) => switch (d) { /* Bound variables should be looked up within the closure environment. If lookup fails, then variable is not bound. */ - | BoundVar(x) => + | Var(x) => switch (ClosureEnvironment.lookup(env, x)) { | Some(d') => d' |> return | None => d |> return } /* Non-hole expressions: expand recursively */ - | BoolLit(_) - | IntLit(_) - | FloatLit(_) - | StringLit(_) + | Bool(_) + | Int(_) + | Float(_) + | String(_) | Constructor(_) => d |> return | Test(id, d1) => let+ d1' = pp_uneval(env, d1); Test(id, d1'); - | Sequence(d1, d2) => + | Seq(d1, d2) => let* d1' = pp_uneval(env, d1); let+ d2' = pp_uneval(env, d2); - Sequence(d1', d2'); + Seq(d1', d2'); | Filter(flt, dbody) => let+ dbody' = pp_uneval(env, dbody); @@ -308,30 +293,16 @@ and pp_uneval = (env: ClosureEnvironment.t, d: DHExp.t): m(DHExp.t) => ApBuiltin(f, d1') |> return; | BuiltinFun(f) => BuiltinFun(f) |> return - | BinBoolOp(op, d1, d2) => - let* d1' = pp_uneval(env, d1); - let* d2' = pp_uneval(env, d2); - BinBoolOp(op, d1', d2') |> return; - | BinIntOp(op, d1, d2) => - let* d1' = pp_uneval(env, d1); - let* d2' = pp_uneval(env, d2); - BinIntOp(op, d1', d2') |> return; - - | BinFloatOp(op, d1, d2) => - let* d1' = pp_uneval(env, d1); - let* d2' = pp_uneval(env, d2); - BinFloatOp(op, d1', d2') |> return; - - | BinStringOp(op, d1, d2) => + | BinOp(op, d1, d2) => let* d1' = pp_uneval(env, d1); let* d2' = pp_uneval(env, d2); - BinStringOp(op, d1', d2') |> return; + BinOp(op, d1', d2') |> return; - | IfThenElse(consistent, c, d1, d2) => + | If(consistent, c, d1, d2) => let* c' = pp_uneval(env, c); let* d1' = pp_uneval(env, d1); let* d2' = pp_uneval(env, d2); - IfThenElse(consistent, c', d1', d2') |> return; + If(consistent, c', d1', d2') |> return; | Cons(d1, d2) => let* d1' = pp_uneval(env, d1); @@ -454,12 +425,12 @@ let rec track_children_of_hole = : HoleInstanceInfo.t => switch (d) { | Constructor(_) - | BoolLit(_) - | IntLit(_) - | FloatLit(_) - | StringLit(_) + | Bool(_) + | Int(_) + | Float(_) + | String(_) | BuiltinFun(_) - | BoundVar(_) => hii + | Var(_) => hii | Test(_, d) | FixF(_, _, d) | Fun(_, _, d, _) @@ -467,13 +438,10 @@ let rec track_children_of_hole = | Cast(d, _, _) | FailedCast(d, _, _) | InvalidOperation(d, _) => track_children_of_hole(hii, parent, d) - | Sequence(d1, d2) + | Seq(d1, d2) | Let(_, d1, d2) | Ap(d1, d2) - | BinBoolOp(_, d1, d2) - | BinIntOp(_, d1, d2) - | BinFloatOp(_, d1, d2) - | BinStringOp(_, d1, d2) + | BinOp(_, d1, d2) | Cons(d1, d2) => let hii = track_children_of_hole(hii, parent, d1); track_children_of_hole(hii, parent, d2); @@ -494,7 +462,7 @@ let rec track_children_of_hole = ds, hii, ) - | IfThenElse(_, c, d1, d2) => + | If(_, c, d1, d2) => let hii = track_children_of_hole(hii, parent, c); let hii = track_children_of_hole(hii, parent, d1); track_children_of_hole(hii, parent, d2); diff --git a/src/haz3lcore/dynamics/EvaluatorStep.re b/src/haz3lcore/dynamics/EvaluatorStep.re index b6fad324f2..2e9dfc69bb 100644 --- a/src/haz3lcore/dynamics/EvaluatorStep.re +++ b/src/haz3lcore/dynamics/EvaluatorStep.re @@ -222,12 +222,12 @@ let rec compose = (ctx: EvalCtx.t, d: DHExp.t): DHExp.t => { | Filter(flt, ctx) => let d = compose(ctx, d); Filter(flt, d); - | Sequence1(ctx, d2) => + | Seq1(ctx, d2) => let d1 = compose(ctx, d); - Sequence(d1, d2); - | Sequence2(d1, ctx) => + Seq(d1, d2); + | Seq2(d1, ctx) => let d2 = compose(ctx, d); - Sequence(d1, d2); + Seq(d1, d2); | Ap1(ctx, d2) => let d1 = compose(ctx, d); Ap(d1, d2); @@ -237,42 +237,24 @@ let rec compose = (ctx: EvalCtx.t, d: DHExp.t): DHExp.t => { | ApBuiltin(s, ctx) => let d' = compose(ctx, d); ApBuiltin(s, d'); - | IfThenElse1(c, ctx, d2, d3) => + | If1(c, ctx, d2, d3) => let d' = compose(ctx, d); - IfThenElse(c, d', d2, d3); - | IfThenElse2(c, d1, ctx, d3) => + If(c, d', d2, d3); + | If2(c, d1, ctx, d3) => let d' = compose(ctx, d); - IfThenElse(c, d1, d', d3); - | IfThenElse3(c, d1, d2, ctx) => + If(c, d1, d', d3); + | If3(c, d1, d2, ctx) => let d' = compose(ctx, d); - IfThenElse(c, d1, d2, d'); + If(c, d1, d2, d'); | Test(lit, ctx) => let d1 = compose(ctx, d); Test(lit, d1); - | BinBoolOp1(op, ctx, d2) => + | BinOp1(op, ctx, d2) => let d1 = compose(ctx, d); - BinBoolOp(op, d1, d2); - | BinBoolOp2(op, d1, ctx) => + BinOp(op, d1, d2); + | BinOp2(op, d1, ctx) => let d2 = compose(ctx, d); - BinBoolOp(op, d1, d2); - | BinIntOp1(op, ctx, d2) => - let d1 = compose(ctx, d); - BinIntOp(op, d1, d2); - | BinIntOp2(op, d1, ctx) => - let d2 = compose(ctx, d); - BinIntOp(op, d1, d2); - | BinFloatOp1(op, ctx, d2) => - let d1 = compose(ctx, d); - BinFloatOp(op, d1, d2); - | BinFloatOp2(op, d1, ctx) => - let d2 = compose(ctx, d); - BinFloatOp(op, d1, d2); - | BinStringOp1(op, ctx, d2) => - let d1 = compose(ctx, d); - BinStringOp(op, d1, d2); - | BinStringOp2(op, d1, ctx) => - let d2 = compose(ctx, d); - BinStringOp(op, d1, d2); + BinOp(op, d1, d2); | Cons1(ctx, d2) => let d1 = compose(ctx, d); Cons(d1, d2); diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index dd501b3563..7cc492bccf 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -42,8 +42,8 @@ let rec matches_exp = | (Cast(d, _, _), _) => matches_exp(env, d, f) | (FailedCast(d, _, _), _) => matches_exp(env, d, f) - | (BoundVar(dx), BoundVar(fx)) => dx == fx - | (BoundVar(dx), _) => + | (Var(dx), Var(fx)) => dx == fx + | (Var(dx), _) => let d = ClosureEnvironment.lookup(env, dx) |> Util.OptUtil.get(() => { @@ -51,7 +51,7 @@ let rec matches_exp = raise(EvaluatorError.Exception(FreeInvalidVar(dx))); }); matches_exp(env, d, f); - | (_, BoundVar(fx)) => + | (_, Var(fx)) => switch (ClosureEnvironment.lookup(env, fx)) { | Some(f) => matches_exp(env, d, f) | None => false @@ -63,17 +63,17 @@ let rec matches_exp = DH.DHFilter.fast_equal(df, ff) && matches_exp(env, dd, fd) | (Filter(_), _) => false - | (BoolLit(dv), BoolLit(fv)) => dv == fv - | (BoolLit(_), _) => false + | (Bool(dv), Bool(fv)) => dv == fv + | (Bool(_), _) => false - | (IntLit(dv), IntLit(fv)) => dv == fv - | (IntLit(_), _) => false + | (Int(dv), Int(fv)) => dv == fv + | (Int(_), _) => false - | (FloatLit(dv), FloatLit(fv)) => dv == fv - | (FloatLit(_), _) => false + | (Float(dv), Float(fv)) => dv == fv + | (Float(_), _) => false - | (StringLit(dv), StringLit(fv)) => dv == fv - | (StringLit(_), _) => false + | (String(dv), String(fv)) => dv == fv + | (String(_), _) => false | (Constructor(_), Ap(Constructor("~MVal"), Tuple([]))) => true | (Constructor(dt), Constructor(ft)) => dt == ft @@ -103,16 +103,16 @@ let rec matches_exp = matches_exp(env, d1, f1) && matches_exp(env, d2, f2) | (Ap(_), _) => false - | (IfThenElse(dc, d1, d2, d3), IfThenElse(fc, f1, f2, f3)) => + | (If(dc, d1, d2, d3), If(fc, f1, f2, f3)) => dc == fc && matches_exp(env, d1, f1) && matches_exp(env, d2, f2) && matches_exp(env, d3, f3) - | (IfThenElse(_), _) => false + | (If(_), _) => false - | (Sequence(d1, d2), Sequence(f1, f2)) => + | (Seq(d1, d2), Seq(f1, f2)) => matches_exp(env, d1, f1) && matches_exp(env, d2, f2) - | (Sequence(_), _) => false + | (Seq(_), _) => false | (Test(id1, d2), Test(id2, f2)) => id1 == id2 && matches_exp(env, d2, f2) @@ -141,31 +141,12 @@ let rec matches_exp = ) | (Tuple(_), _) => false - | (BinBoolOp(d_op_bin, d1, d2), BinBoolOp(f_op_bin, f1, f2)) => - d_op_bin == f_op_bin - && matches_exp(env, d1, f1) - && matches_exp(env, d2, f2) - - | (BinBoolOp(_), _) => false - - | (BinIntOp(d_op_bin, d1, d2), BinIntOp(f_op_bin, f1, f2)) => - d_op_bin == f_op_bin - && matches_exp(env, d1, f1) - && matches_exp(env, d2, f2) - | (BinIntOp(_), _) => false - - | (BinFloatOp(d_op_bin, d1, d2), BinFloatOp(f_op_bin, f1, f2)) => - d_op_bin == f_op_bin - && matches_exp(env, d1, f1) - && matches_exp(env, d2, f2) - | (BinFloatOp(_), _) => false - - | (BinStringOp(d_op_bin, d1, d2), BinStringOp(f_op_bin, f1, f2)) => - d_op_bin == f_op_bin - && matches_exp(env, d1, f1) - && matches_exp(env, d2, f2) - | (BinStringOp(_), _) => false + | (BinOp(d_op, d1, d2), BinOp(f_op, f1, f2)) => + d_op == f_op && matches_exp(env, d1, f1) && matches_exp(env, d2, f2) + | (BinOp(_), _) => false + | (ListConcat(d1, d2), ListConcat(f1, f2)) => + matches_exp(env, d1, f1) && matches_exp(env, d2, f2) | (ListConcat(_), _) => false | ( @@ -211,14 +192,14 @@ and matches_pat = (d: DHPat.t, f: DHPat.t): bool => { | (_, EmptyHole(_)) => true | (Wild, Wild) => true | (Wild, _) => false - | (IntLit(dv), IntLit(fv)) => dv == fv - | (IntLit(_), _) => false - | (FloatLit(dv), FloatLit(fv)) => dv == fv - | (FloatLit(_), _) => false - | (BoolLit(dv), BoolLit(fv)) => dv == fv - | (BoolLit(_), _) => false - | (StringLit(dv), StringLit(fv)) => dv == fv - | (StringLit(_), _) => false + | (Int(dv), Int(fv)) => dv == fv + | (Int(_), _) => false + | (Float(dv), Float(fv)) => dv == fv + | (Float(_), _) => false + | (Bool(dv), Bool(fv)) => dv == fv + | (Bool(_), _) => false + | (String(dv), String(fv)) => dv == fv + | (String(_), _) => false | (ListLit(dty1, dl), ListLit(fty1, fl)) => switch ( List.fold_left2((res, d, f) => res && matches_pat(d, f), true, dl, fl) diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index 5b4d417406..113f022489 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -30,7 +30,7 @@ let cast_sum_maps = let rec matches = (dp: DHPat.t, d: DHExp.t): match_result => switch (dp, d) { - | (_, BoundVar(_)) => DoesNotMatch + | (_, Var(_)) => DoesNotMatch | (EmptyHole(_), _) | (NonEmptyHole(_), _) => IndetMatch | (Wild, _) => Matches(Environment.empty) @@ -49,51 +49,49 @@ let rec matches = (dp: DHPat.t, d: DHExp.t): match_result => | (_, Let(_)) => IndetMatch | (_, FixF(_)) => DoesNotMatch | (_, Fun(_)) => DoesNotMatch - | (_, BinBoolOp(_)) => IndetMatch - | (_, BinIntOp(_)) => IndetMatch - | (_, BinFloatOp(_)) => IndetMatch + | (_, BinOp(_)) => IndetMatch | (_, ConsistentCase(Case(_))) => IndetMatch /* Closure should match like underlying expression. */ | (_, Closure(_, d')) | (_, Filter(_, d')) => matches(dp, d') - | (BoolLit(b1), BoolLit(b2)) => + | (Bool(b1), Bool(b2)) => if (b1 == b2) { Matches(Environment.empty); } else { DoesNotMatch; } - | (BoolLit(_), Cast(d, Bool, Unknown(_))) => matches(dp, d) - | (BoolLit(_), Cast(d, Unknown(_), Bool)) => matches(dp, d) - | (BoolLit(_), _) => DoesNotMatch - | (IntLit(n1), IntLit(n2)) => + | (Bool(_), Cast(d, Bool, Unknown(_))) => matches(dp, d) + | (Bool(_), Cast(d, Unknown(_), Bool)) => matches(dp, d) + | (Bool(_), _) => DoesNotMatch + | (Int(n1), Int(n2)) => if (n1 == n2) { Matches(Environment.empty); } else { DoesNotMatch; } - | (IntLit(_), Cast(d, Int, Unknown(_))) => matches(dp, d) - | (IntLit(_), Cast(d, Unknown(_), Int)) => matches(dp, d) - | (IntLit(_), _) => DoesNotMatch - | (FloatLit(n1), FloatLit(n2)) => + | (Int(_), Cast(d, Int, Unknown(_))) => matches(dp, d) + | (Int(_), Cast(d, Unknown(_), Int)) => matches(dp, d) + | (Int(_), _) => DoesNotMatch + | (Float(n1), Float(n2)) => if (n1 == n2) { Matches(Environment.empty); } else { DoesNotMatch; } - | (FloatLit(_), Cast(d, Float, Unknown(_))) => matches(dp, d) - | (FloatLit(_), Cast(d, Unknown(_), Float)) => matches(dp, d) - | (FloatLit(_), _) => DoesNotMatch - | (StringLit(s1), StringLit(s2)) => + | (Float(_), Cast(d, Float, Unknown(_))) => matches(dp, d) + | (Float(_), Cast(d, Unknown(_), Float)) => matches(dp, d) + | (Float(_), _) => DoesNotMatch + | (String(s1), String(s2)) => if (s1 == s2) { Matches(Environment.empty); } else { DoesNotMatch; } - | (StringLit(_), Cast(d, String, Unknown(_))) => matches(dp, d) - | (StringLit(_), Cast(d, Unknown(_), String)) => matches(dp, d) - | (StringLit(_), _) => DoesNotMatch + | (String(_), Cast(d, String, Unknown(_))) => matches(dp, d) + | (String(_), Cast(d, Unknown(_), String)) => matches(dp, d) + | (String(_), _) => DoesNotMatch | (Ap(dp1, dp2), Ap(d1, d2)) => switch (matches(dp1, d1)) { @@ -242,10 +240,7 @@ and matches_cast_Sum = | Let(_) | Ap(_) | ApBuiltin(_) - | BinBoolOp(_) - | BinIntOp(_) - | BinFloatOp(_) - | BinStringOp(_) + | BinOp(_) | InconsistentBranches(_) | EmptyHole(_) | NonEmptyHole(_) @@ -254,19 +249,19 @@ and matches_cast_Sum = | InvalidOperation(_) | ConsistentCase(_) | Prj(_) - | IfThenElse(_) + | If(_) | BuiltinFun(_) => IndetMatch | Cast(_) - | BoundVar(_) + | Var(_) | FixF(_) | Fun(_) - | BoolLit(_) - | IntLit(_) - | FloatLit(_) - | StringLit(_) + | Bool(_) + | Int(_) + | Float(_) + | String(_) | ListLit(_) | Tuple(_) - | Sequence(_, _) + | Seq(_, _) | Closure(_) | Filter(_) | Cons(_) @@ -328,7 +323,7 @@ and matches_cast_Tuple = List.map2(List.cons, List.combine(tys, tys'), elt_casts), ); | Cast(_, _, _) => DoesNotMatch - | BoundVar(_) => DoesNotMatch + | Var(_) => DoesNotMatch | FreeVar(_) => IndetMatch | InvalidText(_) => IndetMatch | ExpandingKeyword(_) => IndetMatch @@ -340,17 +335,14 @@ and matches_cast_Tuple = | Filter(_, _) => IndetMatch | Ap(_, _) => IndetMatch | ApBuiltin(_, _) => IndetMatch - | BinBoolOp(_, _, _) - | BinIntOp(_, _, _) - | BinFloatOp(_, _, _) - | BinStringOp(_) - | BoolLit(_) => DoesNotMatch - | IntLit(_) => DoesNotMatch - | Sequence(_) + | BinOp(_, _, _) + | Bool(_) => DoesNotMatch + | Int(_) => DoesNotMatch + | Seq(_) | BuiltinFun(_) | Test(_) => DoesNotMatch - | FloatLit(_) => DoesNotMatch - | StringLit(_) => DoesNotMatch + | Float(_) => DoesNotMatch + | String(_) => DoesNotMatch | ListLit(_) => DoesNotMatch | Cons(_, _) => DoesNotMatch | ListConcat(_) => DoesNotMatch @@ -362,7 +354,7 @@ and matches_cast_Tuple = | NonEmptyHole(_) => IndetMatch | FailedCast(_, _, _) => IndetMatch | InvalidOperation(_) => IndetMatch - | IfThenElse(_) => IndetMatch + | If(_) => IndetMatch } and matches_cast_Cons = (dp: DHPat.t, d: DHExp.t, elt_casts: list((Typ.t, Typ.t))): match_result => @@ -468,7 +460,7 @@ and matches_cast_Cons = | Cast(d', Unknown(_), List(ty2)) => matches_cast_Cons(dp, d', [(Unknown(Internal), ty2), ...elt_casts]) | Cast(_, _, _) => DoesNotMatch - | BoundVar(_) => DoesNotMatch + | Var(_) => DoesNotMatch | FreeVar(_) => IndetMatch | InvalidText(_) => IndetMatch | ExpandingKeyword(_) => IndetMatch @@ -479,18 +471,15 @@ and matches_cast_Cons = | Filter(_, d') => matches_cast_Cons(dp, d', elt_casts) | Ap(_, _) => IndetMatch | ApBuiltin(_, _) => IndetMatch - | BinBoolOp(_, _, _) - | BinIntOp(_, _, _) - | BinFloatOp(_, _, _) - | BinStringOp(_) + | BinOp(_, _, _) | ListConcat(_) | BuiltinFun(_) => DoesNotMatch - | BoolLit(_) => DoesNotMatch - | IntLit(_) => DoesNotMatch - | Sequence(_) + | Bool(_) => DoesNotMatch + | Int(_) => DoesNotMatch + | Seq(_) | Test(_) => DoesNotMatch - | FloatLit(_) => DoesNotMatch - | StringLit(_) => DoesNotMatch + | Float(_) => DoesNotMatch + | String(_) => DoesNotMatch | Tuple(_) => DoesNotMatch | Prj(_) => IndetMatch | Constructor(_) => DoesNotMatch @@ -500,5 +489,5 @@ and matches_cast_Cons = | NonEmptyHole(_) => IndetMatch | FailedCast(_, _, _) => IndetMatch | InvalidOperation(_) => IndetMatch - | IfThenElse(_) => IndetMatch + | If(_) => IndetMatch }; diff --git a/src/haz3lcore/dynamics/Stepper.re b/src/haz3lcore/dynamics/Stepper.re index 0f481a341e..8212fd33de 100644 --- a/src/haz3lcore/dynamics/Stepper.re +++ b/src/haz3lcore/dynamics/Stepper.re @@ -66,12 +66,12 @@ let rec matches = } else { (ract, ridx, rctx); }; - | Sequence1(ctx, d2) => + | Seq1(ctx, d2) => let+ ctx = matches(env, flt, ctx, exp, act, idx); - Sequence1(ctx, d2); - | Sequence2(d1, ctx) => + Seq1(ctx, d2); + | Seq2(d1, ctx) => let+ ctx = matches(env, flt, ctx, exp, act, idx); - Sequence2(d1, ctx); + Seq2(d1, ctx); | Let1(d1, ctx, d3) => let+ ctx = matches(env, flt, ctx, exp, act, idx); Let1(d1, ctx, d3); @@ -90,39 +90,21 @@ let rec matches = | Ap2(d1, ctx) => let+ ctx = matches(env, flt, ctx, exp, act, idx); Ap2(d1, ctx); - | IfThenElse1(c, ctx, d2, d3) => + | If1(c, ctx, d2, d3) => let+ ctx = matches(env, flt, ctx, exp, act, idx); - IfThenElse1(c, ctx, d2, d3); - | IfThenElse2(c, d1, ctx, d3) => + If1(c, ctx, d2, d3); + | If2(c, d1, ctx, d3) => let+ ctx = matches(env, flt, ctx, exp, act, idx); - IfThenElse2(c, d1, ctx, d3); - | IfThenElse3(c, d1, d2, ctx) => + If2(c, d1, ctx, d3); + | If3(c, d1, d2, ctx) => let+ ctx = matches(env, flt, ctx, exp, act, idx); - IfThenElse3(c, d1, d2, ctx); - | BinBoolOp1(op, ctx, d1) => + If3(c, d1, d2, ctx); + | BinOp1(op, ctx, d1) => let+ ctx = matches(env, flt, ctx, exp, act, idx); - BinBoolOp1(op, ctx, d1); - | BinBoolOp2(op, d1, ctx) => + BinOp1(op, ctx, d1); + | BinOp2(op, d1, ctx) => let+ ctx = matches(env, flt, ctx, exp, act, idx); - BinBoolOp2(op, d1, ctx); - | BinIntOp1(op, ctx, d2) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - BinIntOp1(op, ctx, d2); - | BinIntOp2(op, d1, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - BinIntOp2(op, d1, ctx); - | BinFloatOp1(op, ctx, d2) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - BinFloatOp1(op, ctx, d2); - | BinFloatOp2(op, d1, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - BinFloatOp2(op, d1, ctx); - | BinStringOp1(op, ctx, d2) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - BinStringOp1(op, ctx, d2); - | BinStringOp2(op, d1, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - BinStringOp2(op, d1, ctx); + BinOp2(op, d1, ctx); | Tuple(ctx, ds) => let+ ctx = matches(env, flt, ctx, exp, act, idx); Tuple(ctx, ds); @@ -394,7 +376,7 @@ let step_backward = (~settings, s: t) => let get_justification: step_kind => string = fun | LetBind => "substitution" - | Sequence => "sequence" + | Seq => "sequence" | FixUnwrap => "unroll fixpoint" | UpdateTest => "update test" | FunAp => "apply function" diff --git a/src/haz3lcore/dynamics/Substitution.re b/src/haz3lcore/dynamics/Substitution.re index cb08e83231..d762c99d13 100644 --- a/src/haz3lcore/dynamics/Substitution.re +++ b/src/haz3lcore/dynamics/Substitution.re @@ -1,7 +1,7 @@ /* closed substitution [d1/x]d2 */ let rec subst_var = (d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => switch (d2) { - | BoundVar(y) => + | Var(y) => if (Var.eq(x, y)) { d1; } else { @@ -10,10 +10,10 @@ let rec subst_var = (d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => | FreeVar(_) => d2 | InvalidText(_) => d2 | ExpandingKeyword(_) => d2 - | Sequence(d3, d4) => + | Seq(d3, d4) => let d3 = subst_var(d1, x, d3); let d4 = subst_var(d1, x, d4); - Sequence(d3, d4); + Seq(d3, d4); | Filter(filter, dbody) => let dbody = subst_var(d1, x, dbody); let filter = subst_var_filter(d1, x, filter); @@ -57,10 +57,10 @@ let rec subst_var = (d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => ApBuiltin(ident, d2); | BuiltinFun(ident) => BuiltinFun(ident) | Test(id, d3) => Test(id, subst_var(d1, x, d3)) - | BoolLit(_) - | IntLit(_) - | FloatLit(_) - | StringLit(_) + | Bool(_) + | Int(_) + | Float(_) + | String(_) | Constructor(_) => d2 | ListLit(a, b, c, ds) => ListLit(a, b, c, List.map(subst_var(d1, x), ds)) @@ -74,22 +74,10 @@ let rec subst_var = (d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => ListConcat(d3, d4); | Tuple(ds) => Tuple(List.map(subst_var(d1, x), ds)) | Prj(d, n) => Prj(subst_var(d1, x, d), n) - | BinBoolOp(op, d3, d4) => + | BinOp(op, d3, d4) => let d3 = subst_var(d1, x, d3); let d4 = subst_var(d1, x, d4); - BinBoolOp(op, d3, d4); - | BinIntOp(op, d3, d4) => - let d3 = subst_var(d1, x, d3); - let d4 = subst_var(d1, x, d4); - BinIntOp(op, d3, d4); - | BinFloatOp(op, d3, d4) => - let d3 = subst_var(d1, x, d3); - let d4 = subst_var(d1, x, d4); - BinFloatOp(op, d3, d4); - | BinStringOp(op, d3, d4) => - let d3 = subst_var(d1, x, d3); - let d4 = subst_var(d1, x, d4); - BinStringOp(op, d3, d4); + BinOp(op, d3, d4); | ConsistentCase(Case(d3, rules, n)) => let d3 = subst_var(d1, x, d3); let rules = subst_var_rules(d1, x, rules); @@ -111,11 +99,11 @@ let rec subst_var = (d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => | InvalidOperation(d, err) => let d' = subst_var(d1, x, d); InvalidOperation(d', err); - | IfThenElse(d3, d4, d5, d6) => + | If(d3, d4, d5, d6) => let d4' = subst_var(d1, x, d4); let d5' = subst_var(d1, x, d5); let d6' = subst_var(d1, x, d6); - IfThenElse(d3, d4', d5', d6'); + If(d3, d4', d5', d6'); } and subst_var_rules = diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index dfe896ca06..48da4ef3f5 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -8,12 +8,12 @@ open DH; This module defines the evaluation semantics of Hazel in terms of small step evaluation. These small steps are wrapped up into a big step in Evaluator.re. - I'll use the Sequence case as an example: + I'll use the Seq case as an example: - | Sequence(d1, d2) => - let. _ = otherwise(d1 => Sequence(d1, d2)) + | Seq(d1, d2) => + let. _ = otherwise(d1 => Seq(d1, d2)) and. _ = req_final(req(state, env), 0, d1); - Step({apply: () => d2, kind: Sequence, final: false}); + Step({apply: () => d2, kind: Seq, final: false}); Each step semantics starts with a `let. () = otherwise(...)` that defines how @@ -48,7 +48,7 @@ open DH; type step_kind = | InvalidStep | VarLookup - | Sequence + | Seq | LetBind | FunClosure | FixUnwrap @@ -195,18 +195,18 @@ module Transition = (EV: EV_MODE) => { let transition = (req, state, env, d): 'a => switch (d) { - | BoundVar(x) => - let. _ = otherwise(env, BoundVar(x)); + | Var(x) => + let. _ = otherwise(env, Var(x)); let d = ClosureEnvironment.lookup(env, x) |> OptUtil.get(() => { raise(EvaluatorError.Exception(FreeInvalidVar(x))) }); Step({apply: () => d, kind: VarLookup, value: false}); - | Sequence(d1, d2) => - let. _ = otherwise(env, d1 => Sequence(d1, d2)) - and. _ = req_final(req(state, env), d1 => Sequence1(d1, d2), d1); - Step({apply: () => d2, kind: Sequence, value: false}); + | Seq(d1, d2) => + let. _ = otherwise(env, d1 => Seq(d1, d2)) + and. _ = req_final(req(state, env), d1 => Seq1(d1, d2), d1); + Step({apply: () => d2, kind: Seq, value: false}); | Let(dp, d1, d2) => let. _ = otherwise(env, d1 => Let(dp, d1, d2)) and. d1' = req_final(req(state, env), d1 => Let1(dp, d1, d2), d1); @@ -239,10 +239,10 @@ module Transition = (EV: EV_MODE) => { Step({ apply: () => switch (d') { - | BoolLit(true) => + | Bool(true) => update_test(state, id, (d', Pass)); Tuple([]); - | BoolLit(false) => + | Bool(false) => update_test(state, id, (d', Fail)); Tuple([]); /* Hack: assume if final and not Bool, then Indet; this won't catch errors in statics */ @@ -305,24 +305,20 @@ module Transition = (EV: EV_MODE) => { kind: BuiltinAp(ident), value: false // Not necessarily a value because of InvalidOperations }); - | BoolLit(_) - | IntLit(_) - | FloatLit(_) - | StringLit(_) + | Bool(_) + | Int(_) + | Float(_) + | String(_) | Constructor(_) | BuiltinFun(_) => let. _ = otherwise(env, d); Constructor; - | IfThenElse(consistent, c, d1, d2) => - let. _ = otherwise(env, c => IfThenElse(consistent, c, d1, d2)) + | If(consistent, c, d1, d2) => + let. _ = otherwise(env, c => If(consistent, c, d1, d2)) and. c' = - req_value( - req(state, env), - c => IfThenElse1(consistent, c, d1, d2), - c, - ); + req_value(req(state, env), c => If1(consistent, c, d1, d2), c); switch (consistent, c') { - | (ConsistentIf, BoolLit(b)) => + | (ConsistentIf, Bool(b)) => Step({ apply: () => { b ? d1 : d2; @@ -343,67 +339,68 @@ module Transition = (EV: EV_MODE) => { // Inconsistent branches should be Indet | (InconsistentIf, _) => Indet }; - | BinBoolOp(And, d1, d2) => - let. _ = otherwise(env, d1 => BinBoolOp(And, d1, d2)) + | BinOp(Bool(And), d1, d2) => + let. _ = otherwise(env, d1 => BinOp(Bool(And), d1, d2)) and. d1' = - req_value(req(state, env), d1 => BinBoolOp1(And, d1, d2), d1); + req_value(req(state, env), d1 => BinOp1(Bool(And), d1, d2), d1); Step({ apply: () => switch (d1') { - | BoolLit(true) => d2 - | BoolLit(false) => BoolLit(false) + | Bool(true) => d2 + | Bool(false) => Bool(false) | _ => raise(EvaluatorError.Exception(InvalidBoxedBoolLit(d1'))) }, kind: BinBoolOp(And), value: false, }); - | BinBoolOp(Or, d1, d2) => - let. _ = otherwise(env, d1 => BinBoolOp(Or, d1, d2)) + | BinOp(Bool(Or), d1, d2) => + let. _ = otherwise(env, d1 => BinOp(Bool(Or), d1, d2)) and. d1' = - req_value(req(state, env), d1 => BinBoolOp1(Or, d1, d2), d1); + req_value(req(state, env), d1 => BinOp1(Bool(Or), d1, d2), d1); Step({ apply: () => switch (d1') { - | BoolLit(true) => BoolLit(true) - | BoolLit(false) => d2 + | Bool(true) => Bool(true) + | Bool(false) => d2 | _ => raise(EvaluatorError.Exception(InvalidBoxedBoolLit(d2))) }, kind: BinBoolOp(Or), value: false, }); - | BinIntOp(op, d1, d2) => - let. _ = otherwise(env, (d1, d2) => BinIntOp(op, d1, d2)) - and. d1' = req_value(req(state, env), d1 => BinIntOp1(op, d1, d2), d1) + | BinOp(Int(op), d1, d2) => + let. _ = otherwise(env, (d1, d2) => BinOp(Int(op), d1, d2)) + and. d1' = + req_value(req(state, env), d1 => BinOp1(Int(op), d1, d2), d1) and. d2' = - req_value(req(state, env), d2 => BinIntOp2(op, d1, d2), d2); + req_value(req(state, env), d2 => BinOp2(Int(op), d1, d2), d2); Step({ apply: () => switch (d1', d2') { - | (IntLit(n1), IntLit(n2)) => + | (Int(n1), Int(n2)) => switch (op) { - | Plus => IntLit(n1 + n2) - | Minus => IntLit(n1 - n2) + | Plus => Int(n1 + n2) + | Minus => Int(n1 - n2) | Power when n2 < 0 => InvalidOperation( - BinIntOp(op, IntLit(n1), IntLit(n2)), + BinOp(Int(op), Int(n1), Int(n2)), NegativeExponent, ) - | Power => IntLit(IntUtil.ipow(n1, n2)) - | Times => IntLit(n1 * n2) + | Power => Int(IntUtil.ipow(n1, n2)) + | Times => Int(n1 * n2) | Divide when n2 == 0 => InvalidOperation( - BinIntOp(op, IntLit(n1), IntLit(n2)), + BinOp(Int(op), Int(n1), Int(n2)), DivideByZero, ) - | Divide => IntLit(n1 / n2) - | LessThan => BoolLit(n1 < n2) - | LessThanOrEqual => BoolLit(n1 <= n2) - | GreaterThan => BoolLit(n1 > n2) - | GreaterThanOrEqual => BoolLit(n1 >= n2) - | Equals => BoolLit(n1 == n2) - | NotEquals => BoolLit(n1 != n2) + | Divide => Int(n1 / n2) + | LessThan => Bool(n1 < n2) + | LessThanOrEqual => Bool(n1 <= n2) + | GreaterThan => Bool(n1 > n2) + | GreaterThanOrEqual => Bool(n1 >= n2) + | Equals => Bool(n1 == n2) + | NotEquals => Bool(n1 != n2) } - | (IntLit(_), _) => + | (Int(_), _) => raise(EvaluatorError.Exception(InvalidBoxedIntLit(d2'))) | _ => raise(EvaluatorError.Exception(InvalidBoxedIntLit(d1'))) }, @@ -411,51 +408,51 @@ module Transition = (EV: EV_MODE) => { // False so that InvalidOperations are caught and made indet by the next step value: false, }); - | BinFloatOp(op, d1, d2) => - let. _ = otherwise(env, (d1, d2) => BinFloatOp(op, d1, d2)) + | BinOp(Float(op), d1, d2) => + let. _ = otherwise(env, (d1, d2) => BinOp(Float(op), d1, d2)) and. d1' = - req_value(req(state, env), d1 => BinFloatOp1(op, d1, d2), d1) + req_value(req(state, env), d1 => BinOp1(Float(op), d1, d2), d1) and. d2' = - req_value(req(state, env), d2 => BinFloatOp2(op, d1, d2), d2); + req_value(req(state, env), d2 => BinOp2(Float(op), d1, d2), d2); Step({ apply: () => switch (d1', d2') { - | (FloatLit(n1), FloatLit(n2)) => + | (Float(n1), Float(n2)) => switch (op) { - | Plus => FloatLit(n1 +. n2) - | Minus => FloatLit(n1 -. n2) - | Power => FloatLit(n1 ** n2) - | Times => FloatLit(n1 *. n2) - | Divide => FloatLit(n1 /. n2) - | LessThan => BoolLit(n1 < n2) - | LessThanOrEqual => BoolLit(n1 <= n2) - | GreaterThan => BoolLit(n1 > n2) - | GreaterThanOrEqual => BoolLit(n1 >= n2) - | Equals => BoolLit(n1 == n2) - | NotEquals => BoolLit(n1 != n2) + | Plus => Float(n1 +. n2) + | Minus => Float(n1 -. n2) + | Power => Float(n1 ** n2) + | Times => Float(n1 *. n2) + | Divide => Float(n1 /. n2) + | LessThan => Bool(n1 < n2) + | LessThanOrEqual => Bool(n1 <= n2) + | GreaterThan => Bool(n1 > n2) + | GreaterThanOrEqual => Bool(n1 >= n2) + | Equals => Bool(n1 == n2) + | NotEquals => Bool(n1 != n2) } - | (FloatLit(_), _) => + | (Float(_), _) => raise(EvaluatorError.Exception(InvalidBoxedFloatLit(d2'))) | _ => raise(EvaluatorError.Exception(InvalidBoxedFloatLit(d1'))) }, kind: BinFloatOp(op), value: true, }); - | BinStringOp(op, d1, d2) => - let. _ = otherwise(env, (d1, d2) => BinStringOp(op, d1, d2)) + | BinOp(String(op), d1, d2) => + let. _ = otherwise(env, (d1, d2) => BinOp(String(op), d1, d2)) and. d1' = - req_value(req(state, env), d1 => BinStringOp1(op, d1, d2), d1) + req_value(req(state, env), d1 => BinOp1(String(op), d1, d2), d1) and. d2' = - req_value(req(state, env), d2 => BinStringOp2(op, d1, d2), d2); + req_value(req(state, env), d2 => BinOp2(String(op), d1, d2), d2); Step({ apply: () => switch (d1', d2') { - | (StringLit(s1), StringLit(s2)) => + | (String(s1), String(s2)) => switch (op) { - | Concat => StringLit(s1 ++ s2) - | Equals => BoolLit(s1 == s2) + | Concat => String(s1 ++ s2) + | Equals => Bool(s1 == s2) } - | (StringLit(_), _) => + | (String(_), _) => raise(EvaluatorError.Exception(InvalidBoxedStringLit(d2'))) | _ => raise(EvaluatorError.Exception(InvalidBoxedStringLit(d1'))) }, @@ -647,7 +644,7 @@ module Transition = (EV: EV_MODE) => { let should_hide_step = (~settings: CoreSettings.Evaluation.t) => fun | LetBind - | Sequence + | Seq | UpdateTest | FunAp | BuiltinAp(_) diff --git a/src/haz3lcore/dynamics/ValueChecker.re b/src/haz3lcore/dynamics/ValueChecker.re index 4bc7fea3d4..28a7c95646 100644 --- a/src/haz3lcore/dynamics/ValueChecker.re +++ b/src/haz3lcore/dynamics/ValueChecker.re @@ -82,7 +82,7 @@ let check_value = check_value(); let rec check_value_mod_ctx = ((), env) => fun - | BoundVar(x) => + | Var(x) => check_value_mod_ctx( (), env, diff --git a/src/haz3lcore/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index e0f756b0dd..daa72d7cd2 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -135,7 +135,7 @@ and UExp: { | Invalid(string) | EmptyHole | MultiHole(list(Any.t)) - | Triv + | Triv // TODO: Replace with empty tuple | Bool(bool) | Int(int) | Float(float) @@ -263,36 +263,41 @@ and UExp: { [@deriving (show({with_path: false}), sexp, yojson)] type term = - | Invalid(string) - | EmptyHole - | MultiHole(list(Any.t)) - | Triv - | Bool(bool) - | Int(int) - | Float(float) - | String(string) - | ListLit(list(t)) - | Constructor(string) - | Fun(UPat.t, t) - | Tuple(list(t)) - | Var(Var.t) - | Let(UPat.t, t, t) - | TyAlias(UTPat.t, UTyp.t, t) - | Ap(t, t) - | Pipeline(t, t) - | If(t, t, t) - | Seq(t, t) - | Test(t) - | Filter(FilterAction.t, t, t) - | Parens(t) // ( - | Cons(t, t) - | ListConcat(t, t) - | UnOp(op_un, t) - | BinOp(op_bin, t, t) - | Match(t, list((UPat.t, t))) + /* TODO: ADD: + Filter() + ApBuiltin(string, t) // These two are different to `var` to allow shadowing of builtins + BuiltinFun(string) + */ + | Invalid(string) // TODO: Reconcile the invalids + | EmptyHole // DONE + | MultiHole(list(Any.t)) // TODO: Reconcile the invalids + | Triv // REMOVE, REPLACE WITH EMPTY TUPLE + | Bool(bool) // DONE [DH CHANGED] + | Int(int) // DONE [DH CHANGED] + | Float(float) // DONE [DH CHANGED] + | String(string) // DONE [DH CHANGED] + | ListLit(list(t)) // DONE [DH TO BE CHANGED] + | Constructor(string) // DONE [ALREADY] + | Fun(UPat.t, t) // TODO: Add option(Var.t) name field to end + | Tuple(list(t)) // DONE [EXCEPT FOR TRIV] + | Var(Var.t) // DONE [ALREADY] + | Let(UPat.t, t, t) // DONE [ALREADY] + | TyAlias(UTPat.t, UTyp.t, t) // [TO ADD TO DHEXP] + | Ap(t, t) // TODO: Combine Ap and Pipeline? [alt: add pipeline to dhexp] + | Pipeline(t, t) // TODO: Above + | If(t, t, t) // TODO: What to do about consistency? + | Seq(t, t) // DONE [ALREADY] + | Test(t) // [DHEXP TO CHANGE] + | Filter(FilterAction.t, t, t) // TODO: Change to reflect DHExp + | Parens(t) // [TO ADD TO DHEXP] + | Cons(t, t) // DONE [ALREADY] + | ListConcat(t, t) // DONE [ALREADY] + | UnOp(op_un, t) // [TO ADD TO DHEXP] + | BinOp(op_bin, t, t) // DONE [DH CHANGED] + | Match(t, list((UPat.t, t))) // DONE [DH TO CHANGE] and t = { // invariant: nonempty - ids: list(Id.t), + ids: list(Id.t), // > DHEXP // Multiple ids?? // Add source?? term, }; diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index 310ce39e2c..70ffd4b1eb 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -45,23 +45,23 @@ let precedence_bin_string_op = (bso: TermBase.UExp.op_bin_string) => let rec precedence = (~show_casts: bool, d: DHExp.t) => { let precedence' = precedence(~show_casts); switch (d) { - | BoundVar(_) + | Var(_) | FreeVar(_) | InvalidText(_) | ExpandingKeyword(_) - | BoolLit(_) - | IntLit(_) - | Sequence(_) + | Bool(_) + | Int(_) + | Seq(_) | Test(_) - | FloatLit(_) - | StringLit(_) + | Float(_) + | String(_) | ListLit(_) | Prj(_) | EmptyHole(_) | Constructor(_) | FailedCast(_) | InvalidOperation(_) - | IfThenElse(_) + | If(_) | Closure(_) | BuiltinFun(_) | Filter(_) => DHDoc_common.precedence_const @@ -78,10 +78,10 @@ let rec precedence = (~show_casts: bool, d: DHExp.t) => { | ConsistentCase(_) | InconsistentBranches(_) => DHDoc_common.precedence_max - | BinBoolOp(op, _, _) => precedence_bin_bool_op(op) - | BinIntOp(op, _, _) => precedence_bin_int_op(op) - | BinFloatOp(op, _, _) => precedence_bin_float_op(op) - | BinStringOp(op, _, _) => precedence_bin_string_op(op) + | BinOp(Bool(op), _, _) => precedence_bin_bool_op(op) + | BinOp(Int(op), _, _) => precedence_bin_int_op(op) + | BinOp(Float(op), _, _) => precedence_bin_float_op(op) + | BinOp(String(op), _, _) => precedence_bin_string_op(op) | NonEmptyHole(_, _, _, d) => precedence'(d) }; @@ -139,7 +139,7 @@ let mk = | (FixUnwrap, _) // TODO[Matt]: Could do something here? | (InvalidStep, _) | (VarLookup, _) - | (Sequence, _) + | (Seq, _) | (FunClosure, _) | (UpdateTest, _) | (CastAp, _) @@ -318,15 +318,15 @@ let mk = | InconsistentBranches(u, i, Case(dscrut, drs, _)) => go_case(dscrut, drs, false) |> annot(DHAnnot.InconsistentBranches((u, i))) - | BoundVar(x) when List.mem(x, recursive_calls) => text(x) - | BoundVar(x) when settings.show_lookup_steps => text(x) - | BoundVar(x) => + | Var(x) when List.mem(x, recursive_calls) => text(x) + | Var(x) when settings.show_lookup_steps => text(x) + | Var(x) => switch (ClosureEnvironment.lookup(env, x)) { | None => text(x) | Some(d') => if (List.mem(x, recent_subst)) { hcats([ - go'(~env=ClosureEnvironment.empty, BoundVar(x), BoundVar) + go'(~env=ClosureEnvironment.empty, Var(x), BoundVar) |> annot(DHAnnot.Substituted), go'(~env=ClosureEnvironment.empty, d', BoundVar), ]); @@ -336,13 +336,13 @@ let mk = } | BuiltinFun(f) => text(f) | Constructor(name) => DHDoc_common.mk_ConstructorLit(name) - | BoolLit(b) => DHDoc_common.mk_BoolLit(b) - | IntLit(n) => DHDoc_common.mk_IntLit(n) - | FloatLit(f) => DHDoc_common.mk_FloatLit(f) - | StringLit(s) => DHDoc_common.mk_StringLit(s) + | Bool(b) => DHDoc_common.mk_BoolLit(b) + | Int(n) => DHDoc_common.mk_IntLit(n) + | Float(f) => DHDoc_common.mk_FloatLit(f) + | String(s) => DHDoc_common.mk_StringLit(s) | Test(_, d) => DHDoc_common.mk_Test(go'(d, Test)) - | Sequence(d1, d2) => - let (doc1, doc2) = (go'(d1, Sequence1), go'(d2, Sequence2)); + | Seq(d1, d2) => + let (doc1, doc2) = (go'(d1, Seq1), go'(d2, Seq2)); DHDoc_common.mk_Sequence(doc1, doc2); | ListLit(_, _, _, d_list) => let ol = d_list |> List.mapi((i, d) => go'(d, ListLit(i))); @@ -360,31 +360,31 @@ let mk = go_formattable(d, ApBuiltin) |> parenthesize(precedence(d) > DHDoc_common.precedence_Ap), ) - | BinIntOp(op, d1, d2) => + | BinOp(Int(op), d1, d2) => // TODO assumes all bin int ops are left associative let (doc1, doc2) = mk_left_associative_operands( precedence_bin_int_op(op), - (d1, BinIntOp1), - (d2, BinIntOp2), + (d1, BinOp1), + (d2, BinOp2), ); hseps([doc1, mk_bin_int_op(op), doc2]); - | BinFloatOp(op, d1, d2) => + | BinOp(Float(op), d1, d2) => // TODO assumes all bin float ops are left associative let (doc1, doc2) = mk_left_associative_operands( precedence_bin_float_op(op), - (d1, BinFloatOp1), - (d2, BinFloatOp2), + (d1, BinOp1), + (d2, BinOp2), ); hseps([doc1, mk_bin_float_op(op), doc2]); - | BinStringOp(op, d1, d2) => + | BinOp(String(op), d1, d2) => // TODO assumes all bin string ops are left associative let (doc1, doc2) = mk_left_associative_operands( precedence_bin_string_op(op), - (d1, BinStringOp1), - (d2, BinStringOp2), + (d1, BinOp1), + (d2, BinOp2), ); hseps([doc1, mk_bin_string_op(op), doc2]); | Cons(d1, d2) => @@ -403,12 +403,12 @@ let mk = (d2, ListConcat2), ); DHDoc_common.mk_ListConcat(doc1, doc2); - | BinBoolOp(op, d1, d2) => + | BinOp(Bool(op), d1, d2) => let (doc1, doc2) = mk_right_associative_operands( precedence_bin_bool_op(op), - (d1, BinBoolOp1), - (d2, BinBoolOp2), + (d1, BinOp1), + (d2, BinOp2), ); hseps([doc1, mk_bin_bool_op(op), doc2]); | Tuple([]) => DHDoc_common.Delim.triv @@ -486,10 +486,10 @@ let mk = |> annot(DHAnnot.OperationError(err)); hcats([d_doc, decoration]); - | IfThenElse(_, c, d1, d2) => - let c_doc = go_formattable(c, IfThenElse1); - let d1_doc = go_formattable(d1, IfThenElse2); - let d2_doc = go_formattable(d2, IfThenElse3); + | If(_, c, d1, d2) => + let c_doc = go_formattable(c, If1); + let d1_doc = go_formattable(d1, If2); + let d2_doc = go_formattable(d2, If3); hcats([ DHDoc_common.Delim.mk("("), DHDoc_common.Delim.mk("if"), @@ -648,7 +648,7 @@ let mk = ); let doc = switch (substitution) { - | Some({d_loc: BoundVar(v), _}) when List.mem(v, recent_subst) => + | Some({d_loc: Var(v), _}) when List.mem(v, recent_subst) => hcats([text(v) |> annot(DHAnnot.Substituted), doc]) | Some(_) | None => doc diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re index c27aa21b07..af3e8b6760 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re @@ -10,10 +10,10 @@ let precedence = (dp: DHPat.t) => | InvalidText(_) | BadConstructor(_) | Var(_) - | IntLit(_) - | FloatLit(_) - | BoolLit(_) - | StringLit(_) + | Int(_) + | Float(_) + | Bool(_) + | String(_) | ListLit(_) | Constructor(_) => DHDoc_common.precedence_const | Tuple(_) => DHDoc_common.precedence_Comma @@ -44,10 +44,10 @@ let rec mk = | Var(x) => Doc.text(x) | Wild => DHDoc_common.Delim.wild | Constructor(name) => DHDoc_common.mk_ConstructorLit(name) - | IntLit(n) => DHDoc_common.mk_IntLit(n) - | FloatLit(f) => DHDoc_common.mk_FloatLit(f) - | BoolLit(b) => DHDoc_common.mk_BoolLit(b) - | StringLit(s) => DHDoc_common.mk_StringLit(s) + | Int(n) => DHDoc_common.mk_IntLit(n) + | Float(f) => DHDoc_common.mk_FloatLit(f) + | Bool(b) => DHDoc_common.mk_BoolLit(b) + | String(s) => DHDoc_common.mk_StringLit(s) | ListLit(_, d_list) => let ol = List.map(mk', d_list); DHDoc_common.mk_ListLit(ol); From 272d3a5a216960de7a98230cc93996c8e5ce3b60 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Tue, 30 Jan 2024 10:46:23 -0500 Subject: [PATCH 002/103] Make matches consistent across dhexp, uexp --- src/haz3lcore/dynamics/DH.re | 76 +++++++------------- src/haz3lcore/dynamics/Elaborator.re | 25 +++---- src/haz3lcore/dynamics/EvalCtx.re | 53 +++++--------- src/haz3lcore/dynamics/EvaluatorPost.re | 41 ++++++----- src/haz3lcore/dynamics/EvaluatorStep.re | 20 ++---- src/haz3lcore/dynamics/FilterMatcher.re | 28 +++----- src/haz3lcore/dynamics/PatternMatch.re | 11 ++- src/haz3lcore/dynamics/Stepper.re | 15 ++-- src/haz3lcore/dynamics/Substitution.re | 35 ++++----- src/haz3lcore/dynamics/Transition.re | 53 +++++++------- src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 34 ++++----- 11 files changed, 143 insertions(+), 248 deletions(-) diff --git a/src/haz3lcore/dynamics/DH.re b/src/haz3lcore/dynamics/DH.re index 03703cf783..b3d89a8ad3 100644 --- a/src/haz3lcore/dynamics/DH.re +++ b/src/haz3lcore/dynamics/DH.re @@ -1,9 +1,9 @@ open Sexplib.Std; [@deriving (show({with_path: false}), sexp, yojson)] -type if_consistency = - | ConsistentIf - | InconsistentIf; +type consistency = + | Consistent + | Inconsistent(MetaVar.t, HoleInstanceId.t); module rec DHExp: { [@deriving (show({with_path: false}), sexp, yojson)] @@ -20,7 +20,6 @@ module rec DHExp: { | ExpandingKeyword(MetaVar.t, HoleInstanceId.t, ExpandingKeyword.t) | FreeVar(MetaVar.t, HoleInstanceId.t, Var.t) | InvalidText(MetaVar.t, HoleInstanceId.t, string) - | InconsistentBranches(MetaVar.t, HoleInstanceId.t, case) | InvalidOperation(t, InvalidOperationError.t) | FailedCast(t, Typ.t, Typ.t) | Closure([@show.opaque] ClosureEnvironment.t, t) // > UEXP @@ -45,13 +44,9 @@ module rec DHExp: { | Tuple(list(t)) // DONE [ALREADY] | Prj(t, int) // TODO: ! REMOVE, LEAVE AS LETS? | Constructor(string) // DONE [ALREADY] - | ConsistentCase(case) // TODO: CONSISTENCY? + | Match(consistency, t, list((DHPat.t, t))) | Cast(t, Typ.t, Typ.t) // TODO: Add to uexp or remove - | If(if_consistency, t, t, t) // TODO: CONSISTENCY? use bool tag to track if branches are consistent - and case = - | Case(t, list(rule), int) // is the int really necessary? - and rule = - | Rule(DHPat.t, t); + | If(consistency, t, t, t); // TODO: CONSISTENCY? use bool tag to track if branches are consistent let constructor_string: t => string; @@ -72,7 +67,6 @@ module rec DHExp: { | ExpandingKeyword(MetaVar.t, HoleInstanceId.t, ExpandingKeyword.t) | FreeVar(MetaVar.t, HoleInstanceId.t, Var.t) | InvalidText(MetaVar.t, HoleInstanceId.t, string) - | InconsistentBranches(MetaVar.t, HoleInstanceId.t, case) | InvalidOperation(t, InvalidOperationError.t) | FailedCast(t, Typ.t, Typ.t) /* Generalized closures */ @@ -99,13 +93,9 @@ module rec DHExp: { | Tuple(list(t)) | Prj(t, int) | Constructor(string) - | ConsistentCase(case) + | Match(consistency, t, list((DHPat.t, t))) | Cast(t, Typ.t, Typ.t) - | If(if_consistency, t, t, t) - and case = - | Case(t, list(rule), int) - and rule = - | Rule(DHPat.t, t); + | If(consistency, t, t, t); let constructor_string = (d: t): string => switch (d) { @@ -136,8 +126,7 @@ module rec DHExp: { | Tuple(_) => "Tuple" | Prj(_) => "Prj" | Constructor(_) => "Constructor" - | ConsistentCase(_) => "ConsistentCase" - | InconsistentBranches(_, _, _) => "InconsistentBranches" + | Match(_) => "Match" | Cast(_, _, _) => "Cast" | FailedCast(_, _, _) => "FailedCast" | InvalidOperation(_) => "InvalidOperation" @@ -181,15 +170,11 @@ module rec DHExp: { | ApBuiltin(fn, args) => ApBuiltin(fn, strip_casts(args)) | BuiltinFun(fn) => BuiltinFun(fn) | BinOp(a, b, c) => BinOp(a, strip_casts(b), strip_casts(c)) - | ConsistentCase(Case(a, rs, b)) => - ConsistentCase( - Case(strip_casts(a), List.map(strip_casts_rule, rs), b), - ) - | InconsistentBranches(u, i, Case(scrut, rules, n)) => - InconsistentBranches( - u, - i, - Case(strip_casts(scrut), List.map(strip_casts_rule, rules), n), + | Match(c, a, rules) => + Match( + c, + strip_casts(a), + List.map(((k, v)) => (k, strip_casts(v)), rules), ) | EmptyHole(_) as d | ExpandingKeyword(_) as d @@ -203,8 +188,7 @@ module rec DHExp: { | Constructor(_) as d | InvalidOperation(_) as d => d | If(consistent, c, d1, d2) => - If(consistent, strip_casts(c), strip_casts(d1), strip_casts(d2)) - and strip_casts_rule = (Rule(a, d)) => Rule(a, strip_casts(d)); + If(consistent, strip_casts(c), strip_casts(d1), strip_casts(d2)); let rec fast_equal = (d1: t, d2: t): bool => { switch (d1, d2) { @@ -251,8 +235,15 @@ module rec DHExp: { fast_equal(d1, d2) && ty11 == ty12 && ty21 == ty22 | (InvalidOperation(d1, reason1), InvalidOperation(d2, reason2)) => fast_equal(d1, d2) && reason1 == reason2 - | (ConsistentCase(case1), ConsistentCase(case2)) => - fast_equal_case(case1, case2) + | (Match(c1, s1, rs1), Match(c2, s2, rs2)) => + c1 == c2 + && fast_equal(s1, s2) + && List.length(rs2) == List.length(rs2) + && List.for_all2( + ((k1, v1), (k2, v2)) => k1 == k2 && fast_equal(v1, v2), + rs1, + rs2, + ) | (If(c1, d11, d12, d13), If(c2, d21, d22, d23)) => c1 == c2 && fast_equal(d11, d21) @@ -279,7 +270,7 @@ module rec DHExp: { | (FailedCast(_), _) | (InvalidOperation(_), _) | (If(_), _) - | (ConsistentCase(_), _) => false + | (Match(_), _) => false /* Hole forms: when checking environments, only check that environment ID's are equal, don't check structural equality. @@ -296,30 +287,13 @@ module rec DHExp: { u1 == u2 && i1 == i2 && text1 == text2 | (Closure(sigma1, d1), Closure(sigma2, d2)) => ClosureEnvironment.id_equal(sigma1, sigma2) && fast_equal(d1, d2) - | ( - InconsistentBranches(u1, i1, case1), - InconsistentBranches(u2, i2, case2), - ) => - u1 == u2 && i1 == i2 && fast_equal_case(case1, case2) | (EmptyHole(_), _) | (NonEmptyHole(_), _) | (ExpandingKeyword(_), _) | (FreeVar(_), _) | (InvalidText(_), _) - | (Closure(_), _) - | (InconsistentBranches(_), _) => false + | (Closure(_), _) => false }; - } - and fast_equal_case = (Case(d1, rules1, i1), Case(d2, rules2, i2)) => { - fast_equal(d1, d2) - && List.length(rules1) == List.length(rules2) - && List.for_all2( - (Rule(dp1, d1), Rule(dp2, d2)) => - dp1 == dp2 && fast_equal(d1, d2), - rules1, - rules2, - ) - && i1 == i2; }; } diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 034dfac7d4..03857f0f76 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -61,8 +61,7 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => | _ => d } /* Forms with special ana rules but no particular typing requirements */ - | ConsistentCase(_) - | InconsistentBranches(_) + | Match(_) | If(_) | Seq(_) | Let(_) @@ -164,12 +163,11 @@ let rec dhexp_of_uexp = DHExp.BinOp(Int(Minus), Int(0), dc); | UnOp(Bool(Not), e) => let+ d_scrut = dhexp_of_uexp(m, e); - let d_rules = - DHExp.[ - Rule(Bool(true), Bool(false)), - Rule(Bool(false), Bool(true)), - ]; - let d = DHExp.ConsistentCase(DHExp.Case(d_scrut, d_rules, 0)); + let d_rules = [ + (DHPat.Bool(true), DHExp.Bool(false)), + (DHPat.Bool(false), DHExp.Bool(true)), + ]; + let d = DHExp.(Match(Consistent, d_scrut, d_rules)); /* Manually construct cast (case is not otherwise cast) */ switch (mode) { | Ana(ana_ty) => DHExp.cast(d, Bool, ana_ty) @@ -255,8 +253,8 @@ let rec dhexp_of_uexp = // Use tag to mark inconsistent branches switch (err_status) { | InHole(Common(Inconsistent(Internal(_)))) => - DHExp.If(DH.InconsistentIf, c', d1, d2) - | _ => DHExp.If(DH.ConsistentIf, c', d1, d2) + DHExp.If(DH.Inconsistent(id, 0), c', d1, d2) + | _ => DHExp.If(DH.Consistent, c', d1, d2) }; | Match(scrut, rules) => let* d_scrut = dhexp_of_uexp(m, scrut); @@ -265,16 +263,15 @@ let rec dhexp_of_uexp = ((p, e)) => { let* d_p = dhpat_of_upat(m, p); let+ d_e = dhexp_of_uexp(m, e); - DHExp.Rule(d_p, d_e); + (d_p, d_e); }, rules, ) |> OptUtil.sequence; - let d = DHExp.Case(d_scrut, d_rules, 0); switch (err_status) { | InHole(Common(Inconsistent(Internal(_)))) => - DHExp.InconsistentBranches(id, 0, d) - | _ => ConsistentCase(d) + DHExp.Match(Inconsistent(id, 0), d_scrut, d_rules) + | _ => DHExp.Match(Consistent, d_scrut, d_rules) }; | TyAlias(_, _, e) => dhexp_of_uexp(m, e) }; diff --git a/src/haz3lcore/dynamics/EvalCtx.re b/src/haz3lcore/dynamics/EvalCtx.re index dd82037df8..14414e0d2c 100644 --- a/src/haz3lcore/dynamics/EvalCtx.re +++ b/src/haz3lcore/dynamics/EvalCtx.re @@ -33,10 +33,8 @@ type cls = | Cast | FailedCast | InvalidOperation - | ConsistentCase - | ConsistentCaseRule(int) - | InconsistentBranches - | InconsistentBranchesRule(int) + | MatchScrut + | MatchRule(int) | FailedCastCast // Used when entering a bound variable expression in substitution mode | BoundVar; @@ -54,9 +52,9 @@ type t = | FixF(Var.t, Typ.t, t) | Ap1(t, DHExp.t) | Ap2(DHExp.t, t) - | If1(if_consistency, t, DHExp.t, DHExp.t) - | If2(if_consistency, DHExp.t, t, DHExp.t) - | If3(if_consistency, DHExp.t, DHExp.t, t) + | If1(consistency, t, DHExp.t, DHExp.t) + | If2(consistency, DHExp.t, t, DHExp.t) + | If3(consistency, DHExp.t, DHExp.t, t) | BinOp1(TermBase.UExp.op_bin, t, DHExp.t) | BinOp2(TermBase.UExp.op_bin, DHExp.t, t) | Tuple(t, (list(DHExp.t), list(DHExp.t))) @@ -78,27 +76,14 @@ type t = | Cast(t, Typ.t, Typ.t) | FailedCast(t, Typ.t, Typ.t) | InvalidOperation(t, InvalidOperationError.t) - | ConsistentCase(case) - | ConsistentCaseRule( + | MatchScrut(DH.consistency, t, list((DHPat.t, DHExp.t))) + | MatchRule( + DH.consistency, DHExp.t, DHPat.t, t, - (list(DHExp.rule), list(DHExp.rule)), - int, - ) - | InconsistentBranches(MetaVar.t, HoleInstanceId.t, case) - | InconsistentBranchesRule( - DHExp.t, - MetaVar.t, - HoleInstanceId.t, - DHPat.t, - t, - (list(DHExp.rule), list(DHExp.rule)), - int, - ) -and case = - | Case(t, list(rule), int) -and rule = DHExp.rule; + (list((DHPat.t, DHExp.t)), list((DHPat.t, DHExp.t))), + ); let rec fuzzy_mark = fun @@ -131,10 +116,8 @@ let rec fuzzy_mark = | Prj(_) | NonEmptyHole(_) | InvalidOperation(_) - | ConsistentCase(_) - | ConsistentCaseRule(_) - | InconsistentBranches(_) - | InconsistentBranchesRule(_) => false; + | MatchScrut(_) + | MatchRule(_) => false; let rec unwrap = (ctx: t, sel: cls): option(t) => { switch (sel, ctx) { @@ -174,19 +157,13 @@ let rec unwrap = (ctx: t, sel: cls): option(t) => { } else { None; } - | (ConsistentCaseRule(n), ConsistentCaseRule(_, _, c, (ld, _), _)) - | ( - InconsistentBranchesRule(n), - InconsistentBranchesRule(_, _, _, _, c, (ld, _), _), - ) => + | (MatchScrut, MatchScrut(_, scr, _)) => Some(scr) + | (MatchRule(n), MatchRule(_, _, _, c, (ld, _))) => if (List.length(ld) == n) { Some(c); } else { None; } - | (InconsistentBranches, InconsistentBranches(_, _, Case(scrut, _, _))) => - Some(scrut) - | (ConsistentCase, ConsistentCase(Case(scrut, _, _))) => Some(scrut) | (Cast, Cast(c, _, _)) | (FailedCastCast, FailedCast(Cast(c, _, _), _, _)) | (FailedCast, FailedCast(c, _, _)) => Some(c) @@ -209,6 +186,8 @@ let rec unwrap = (ctx: t, sel: cls): option(t) => { | (ListConcat1, ListConcat2(_)) | (ListConcat2, ListConcat1(_)) => None | (FilterPattern, _) => None + | (MatchScrut, MatchRule(_)) + | (MatchRule(_), MatchScrut(_)) => None | (Filter, _) => Some(ctx) | (tag, Filter(_, c)) => unwrap(c, tag) | (Closure, _) => Some(ctx) diff --git a/src/haz3lcore/dynamics/EvaluatorPost.re b/src/haz3lcore/dynamics/EvaluatorPost.re index d87d9bc82a..df33fefdff 100644 --- a/src/haz3lcore/dynamics/EvaluatorPost.re +++ b/src/haz3lcore/dynamics/EvaluatorPost.re @@ -131,17 +131,18 @@ let rec pp_eval = (d: DHExp.t): m(DHExp.t) => let* d2' = pp_eval(d2); If(consistent, c', d1', d2') |> return; + // TODO: Add consistent case + /* These expression forms should not exist outside closure in evaluated result */ | Var(_) | Let(_) - | ConsistentCase(_) + | Match(_) | Fun(_) | EmptyHole(_) | NonEmptyHole(_) | ExpandingKeyword(_) | FreeVar(_) - | InvalidText(_) - | InconsistentBranches(_) => raise(Exception(UnevalOutsideClosure)) + | InvalidText(_) => raise(Exception(UnevalOutsideClosure)) | FixF(_) => raise(Exception(FixFOutsideClosureEnv)) @@ -167,7 +168,7 @@ let rec pp_eval = (d: DHExp.t): m(DHExp.t) => let* d2 = pp_uneval(env, d2); Let(dp, d1, d2) |> return; - | ConsistentCase(Case(scrut, rules, i)) => + | Match(Consistent, scrut, rules) => /* scrut should already be evaluated, rule bodies are not */ let* scrut = Util.TimeUtil.measure_time("pp_eval(scrut)", true, () => @@ -177,7 +178,7 @@ let rec pp_eval = (d: DHExp.t): m(DHExp.t) => Util.TimeUtil.measure_time("pp_uneval_rules", true, () => pp_uneval_rules(env, rules) ); - ConsistentCase(Case(scrut, rules, i)) |> return; + Match(Consistent, scrut, rules) |> return; /* Hole constructs inside closures. @@ -191,11 +192,10 @@ let rec pp_eval = (d: DHExp.t): m(DHExp.t) => let* i = hii_add_instance(u, env); Closure(env, NonEmptyHole(reason, u, i, d)) |> return; - | InconsistentBranches(u, _, Case(scrut, rules, case_i)) => + | Match(Inconsistent(u, _), scrut, rules) => let* scrut = pp_eval(scrut); let* i = hii_add_instance(u, env); - Closure(env, InconsistentBranches(u, i, Case(scrut, rules, case_i))) - |> return; + Closure(env, Match(Inconsistent(u, i), scrut, rules)) |> return; | EmptyHole(_) | ExpandingKeyword(_) @@ -356,10 +356,10 @@ and pp_uneval = (env: ClosureEnvironment.t, d: DHExp.t): m(DHExp.t) => let* d'' = pp_uneval(env, d'); InvalidOperation(d'', reason) |> return; - | ConsistentCase(Case(scrut, rules, i)) => + | Match(Consistent, scrut, rules) => let* scrut' = pp_uneval(env, scrut); let* rules' = pp_uneval_rules(env, rules); - ConsistentCase(Case(scrut', rules', i)) |> return; + Match(Consistent, scrut', rules') |> return; /* Closures shouldn't exist inside other closures */ | Closure(_) => raise(Exception(ClosureInsideClosure)) @@ -390,21 +390,20 @@ and pp_uneval = (env: ClosureEnvironment.t, d: DHExp.t): m(DHExp.t) => let* i = hii_add_instance(u, env); Closure(env, InvalidText(u, i, text)) |> return; - | InconsistentBranches(u, _, Case(scrut, rules, case_i)) => + | Match(Inconsistent(u, _), scrut, rules) => let* scrut = pp_uneval(env, scrut); let* rules = pp_uneval_rules(env, rules); let* i = hii_add_instance(u, env); - Closure(env, InconsistentBranches(u, i, Case(scrut, rules, case_i))) - |> return; + Closure(env, Match(Inconsistent(u, i), scrut, rules)) |> return; } and pp_uneval_rules = - (env: ClosureEnvironment.t, rules: list(DHExp.rule)) - : m(list(DHExp.rule)) => { + (env: ClosureEnvironment.t, rules: list((DHPat.t, DHExp.t))) + : m(list((DHPat.t, DHExp.t))) => { rules - |> List.map((Rule(dp, d)) => { + |> List.map(((dp, d)) => { let* d' = pp_uneval(env, d); - Rule(dp, d') |> return; + (dp, d') |> return; }) |> sequence; }; @@ -467,7 +466,7 @@ let rec track_children_of_hole = let hii = track_children_of_hole(hii, parent, d1); track_children_of_hole(hii, parent, d2); - | ConsistentCase(Case(scrut, rules, _)) => + | Match(Consistent, scrut, rules) => let hii = Util.TimeUtil.measure_time("track_children_of_hole(scrut)", true, () => track_children_of_hole(hii, parent, scrut) @@ -482,7 +481,7 @@ let rec track_children_of_hole = | NonEmptyHole(_, u, i, d) => let hii = track_children_of_hole(hii, parent, d); hii |> HoleInstanceInfo.add_parent((u, i), parent); - | InconsistentBranches(u, i, Case(scrut, rules, _)) => + | Match(Inconsistent(u, i), scrut, rules) => let hii = track_children_of_hole(hii, parent, scrut); let hii = track_children_of_hole_rules(hii, parent, rules); hii |> HoleInstanceInfo.add_parent((u, i), parent); @@ -503,11 +502,11 @@ and track_children_of_hole_rules = ( hii: HoleInstanceInfo.t, parent: HoleInstanceParents.t_, - rules: list(DHExp.rule), + rules: list((DHPat.t, DHExp.t)), ) : HoleInstanceInfo.t => List.fold_right( - (DHExp.Rule(_, d), hii) => track_children_of_hole(hii, parent, d), + ((_, d), hii) => track_children_of_hole(hii, parent, d), rules, hii, ); diff --git a/src/haz3lcore/dynamics/EvaluatorStep.re b/src/haz3lcore/dynamics/EvaluatorStep.re index 2e9dfc69bb..046a793a26 100644 --- a/src/haz3lcore/dynamics/EvaluatorStep.re +++ b/src/haz3lcore/dynamics/EvaluatorStep.re @@ -300,24 +300,12 @@ let rec compose = (ctx: EvalCtx.t, d: DHExp.t): DHExp.t => { | NonEmptyHole(reason, u, i, ctx) => let d = compose(ctx, d); NonEmptyHole(reason, u, i, d); - | ConsistentCase(Case(ctx, rule, n)) => + | MatchScrut(c, ctx, rules) => let d = compose(ctx, d); - ConsistentCase(Case(d, rule, n)); - | ConsistentCaseRule(scr, p, ctx, (lr, rr), n) => + Match(c, d, rules); + | MatchRule(c, scr, p, ctx, (lr, rr)) => let d = compose(ctx, d); - ConsistentCase( - Case(scr, rev_concat(lr, [(Rule(p, d): DHExp.rule), ...rr]), n), - ); - | InconsistentBranches(u, i, Case(ctx, rule, n)) => - let d = compose(ctx, d); - InconsistentBranches(u, i, Case(d, rule, n)); - | InconsistentBranchesRule(scr, mv, hi, p, ctx, (lr, rr), n) => - let d = compose(ctx, d); - InconsistentBranches( - mv, - hi, - Case(scr, rev_concat(lr, [(Rule(p, d): DHExp.rule), ...rr]), n), - ); + Match(c, scr, rev_concat(lr, [(p, d), ...rr])); } ); }; diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index 7cc492bccf..55928a2ed2 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -149,20 +149,14 @@ let rec matches_exp = matches_exp(env, d1, f1) && matches_exp(env, d2, f2) | (ListConcat(_), _) => false - | ( - ConsistentCase(Case(dscrut, drule, _)), - ConsistentCase(Case(fscrut, frule, _)), - ) - | ( - InconsistentBranches(_, _, Case(dscrut, drule, _)), - InconsistentBranches(_, _, Case(fscrut, frule, _)), - ) => - matches_exp(env, dscrut, fscrut) + | (Match(dc, dscrut, drule), Match(fc, fscrut, frule)) => + dc == fc + && matches_exp(env, dscrut, fscrut) && ( switch ( - List.fold_left2( - (res, drule, frule) => res && matches_rul(env, drule, frule), - true, + List.for_all2( + ((dk, dv), (fk, fv)) => + matches_pat(dk, fk) && matches_exp(env, dv, fv), drule, frule, ) @@ -171,8 +165,7 @@ let rec matches_exp = | res => res } ) - | (ConsistentCase(_), _) - | (InconsistentBranches(_), _) => false + | (Match(_), _) => false | (NonEmptyHole(_), _) => false | (ExpandingKeyword(_), _) => false @@ -236,11 +229,8 @@ and matches_pat = (d: DHPat.t, f: DHPat.t): bool => { and matches_typ = (d: Typ.t, f: Typ.t) => { Typ.eq(d, f); } -and matches_rul = (env, d: DHExp.rule, f: DHExp.rule) => { - switch (d, f) { - | (Rule(dp, d), Rule(fp, f)) => - matches_pat(dp, fp) && matches_exp(env, d, f) - }; +and matches_rul = (env, (dp, d), (fp, f)) => { + matches_pat(dp, fp) && matches_exp(env, d, f); }; let matches = diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index 113f022489..a33094c98f 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -50,7 +50,7 @@ let rec matches = (dp: DHPat.t, d: DHExp.t): match_result => | (_, FixF(_)) => DoesNotMatch | (_, Fun(_)) => DoesNotMatch | (_, BinOp(_)) => IndetMatch - | (_, ConsistentCase(Case(_))) => IndetMatch + | (_, Match(Consistent, _, _)) => IndetMatch /* Closure should match like underlying expression. */ | (_, Closure(_, d')) @@ -241,13 +241,12 @@ and matches_cast_Sum = | Ap(_) | ApBuiltin(_) | BinOp(_) - | InconsistentBranches(_) | EmptyHole(_) | NonEmptyHole(_) | FailedCast(_, _, _) | Test(_) | InvalidOperation(_) - | ConsistentCase(_) + | Match(_) | Prj(_) | If(_) | BuiltinFun(_) => IndetMatch @@ -348,8 +347,7 @@ and matches_cast_Tuple = | ListConcat(_) => DoesNotMatch | Prj(_) => IndetMatch | Constructor(_) => DoesNotMatch - | ConsistentCase(_) - | InconsistentBranches(_) => IndetMatch + | Match(_) => IndetMatch | EmptyHole(_) => IndetMatch | NonEmptyHole(_) => IndetMatch | FailedCast(_, _, _) => IndetMatch @@ -483,8 +481,7 @@ and matches_cast_Cons = | Tuple(_) => DoesNotMatch | Prj(_) => IndetMatch | Constructor(_) => DoesNotMatch - | ConsistentCase(_) - | InconsistentBranches(_) => IndetMatch + | Match(_) => IndetMatch | EmptyHole(_) => IndetMatch | NonEmptyHole(_) => IndetMatch | FailedCast(_, _, _) => IndetMatch diff --git a/src/haz3lcore/dynamics/Stepper.re b/src/haz3lcore/dynamics/Stepper.re index 8212fd33de..fdfcd42b26 100644 --- a/src/haz3lcore/dynamics/Stepper.re +++ b/src/haz3lcore/dynamics/Stepper.re @@ -144,18 +144,12 @@ let rec matches = | InvalidOperation(ctx, error) => let+ ctx = matches(env, flt, ctx, exp, act, idx); InvalidOperation(ctx, error); - | ConsistentCase(Case(ctx, rs, i)) => + | MatchScrut(c, ctx, rs) => let+ ctx = matches(env, flt, ctx, exp, act, idx); - ConsistentCase(Case(ctx, rs, i)); - | ConsistentCaseRule(dexp, dpat, ctx, rs, i) => + MatchScrut(c, ctx, rs); + | MatchRule(c, scr, p, ctx, rs) => let+ ctx = matches(env, flt, ctx, exp, act, idx); - ConsistentCaseRule(dexp, dpat, ctx, rs, i); - | InconsistentBranches(u, i, Case(ctx, rs, ri)) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - InconsistentBranches(u, i, Case(ctx, rs, ri)); - | InconsistentBranchesRule(dexp, u, i, dpat, ctx, rs, ri) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - InconsistentBranchesRule(dexp, u, i, dpat, ctx, rs, ri); + MatchRule(c, scr, p, ctx, rs); }; switch (ctx) { | Filter(_) => (ract, ridx, rctx) @@ -395,7 +389,6 @@ let get_justification: step_kind => string = | ListCons => "list manipulation" | ListConcat => "list manipulation" | CaseApply => "case selection" - | CaseNext => "case discarding" | Projection => "projection" // TODO(Matt): We don't want to show projection to the user | InvalidStep => "error" | VarLookup => "variable lookup" diff --git a/src/haz3lcore/dynamics/Substitution.re b/src/haz3lcore/dynamics/Substitution.re index d762c99d13..2503a6e7b1 100644 --- a/src/haz3lcore/dynamics/Substitution.re +++ b/src/haz3lcore/dynamics/Substitution.re @@ -78,14 +78,19 @@ let rec subst_var = (d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => let d3 = subst_var(d1, x, d3); let d4 = subst_var(d1, x, d4); BinOp(op, d3, d4); - | ConsistentCase(Case(d3, rules, n)) => - let d3 = subst_var(d1, x, d3); - let rules = subst_var_rules(d1, x, rules); - ConsistentCase(Case(d3, rules, n)); - | InconsistentBranches(u, i, Case(d3, rules, n)) => - let d3 = subst_var(d1, x, d3); - let rules = subst_var_rules(d1, x, rules); - InconsistentBranches(u, i, Case(d3, rules, n)); + | Match(c, ds, rules) => + let ds = subst_var(d1, x, ds); + let rules = + List.map( + ((p, v)) => + if (DHPat.binds_var(x, p)) { + (p, v); + } else { + (p, subst_var(d1, x, v)); + }, + rules, + ); + Match(c, ds, rules); | EmptyHole(u, i) => EmptyHole(u, i) | NonEmptyHole(reason, u, i, d3) => let d3' = subst_var(d1, x, d3); @@ -106,20 +111,6 @@ let rec subst_var = (d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => If(d3, d4', d5', d6'); } -and subst_var_rules = - (d1: DHExp.t, x: Var.t, rules: list(DHExp.rule)): list(DHExp.rule) => - rules - |> List.map((r: DHExp.rule) => - switch (r) { - | Rule(dp, d2) => - if (DHPat.binds_var(x, dp)) { - r; - } else { - Rule(dp, subst_var(d1, x, d2)); - } - } - ) - and subst_var_env = (d1: DHExp.t, x: Var.t, env: ClosureEnvironment.t): ClosureEnvironment.t => { let id = env |> ClosureEnvironment.id_of; diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index 48da4ef3f5..dbe3e1dd69 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -66,7 +66,6 @@ type step_kind = | ListCons | ListConcat | CaseApply - | CaseNext | CompleteClosure | CompleteFilter | Cast @@ -318,7 +317,7 @@ module Transition = (EV: EV_MODE) => { and. c' = req_value(req(state, env), c => If1(consistent, c, d1, d2), c); switch (consistent, c') { - | (ConsistentIf, Bool(b)) => + | (Consistent, Bool(b)) => Step({ apply: () => { b ? d1 : d2; @@ -328,7 +327,7 @@ module Transition = (EV: EV_MODE) => { value: false, }) // Use a seperate case for invalid conditionals. Makes extracting the bool from BoolLit (above) easier. - | (ConsistentIf, _) => + | (Consistent, _) => Step({ apply: () => { raise(EvaluatorError.Exception(InvalidBoxedBoolLit(c'))); @@ -337,7 +336,7 @@ module Transition = (EV: EV_MODE) => { value: true, }) // Inconsistent branches should be Indet - | (InconsistentIf, _) => Indet + | (Inconsistent(_), _) => Indet }; | BinOp(Bool(And), d1, d2) => let. _ = otherwise(env, d1 => BinOp(Bool(And), d1, d2)) @@ -523,35 +522,34 @@ module Transition = (EV: EV_MODE) => { ds, ); Constructor; - // TODO(Matt): This will currently re-traverse d1 if it is a large constructor - | ConsistentCase(Case(d1, rules, n)) => - let. _ = otherwise(env, d1 => ConsistentCase(Case(d1, rules, n))) - and. d1' = + | Match(Consistent, d1, rules) => + let. _ = otherwise(env, d1 => Match(Consistent, d1, rules)) + and. d1 = req_final( req(state, env), - d1 => ConsistentCase(Case(d1, rules, n)), + d1 => MatchScrut(Consistent, d1, rules), d1, ); - switch (List.nth_opt(rules, n)) { + let rec next_rule = ( + fun + | [] => None + | [(dp, d2), ...rules] => + switch (matches(dp, d1)) { + | Matches(env') => Some((env', d2)) + | DoesNotMatch => next_rule(rules) + | IndetMatch => None + } + ); + switch (next_rule(rules)) { + | Some((env', d2)) => + Step({ + apply: () => Closure(evaluate_extend_env(env', env), d2), + kind: CaseApply, + value: false, + }) | None => Indet - | Some(Rule(dp, d2)) => - switch (matches(dp, d1')) { - | Matches(env') => - Step({ - apply: () => Closure(evaluate_extend_env(env', env), d2), - kind: CaseApply, - value: false, - }) - | DoesNotMatch => - Step({ - apply: () => ConsistentCase(Case(d1', rules, n + 1)), - kind: CaseNext, - value: false, - }) - | IndetMatch => Indet - } }; - | InconsistentBranches(_) as d => + | Match(Inconsistent(_, _), _, _) as d => let. _ = otherwise(env, d); Indet; | Closure(env', d) => @@ -662,7 +660,6 @@ let should_hide_step = (~settings: CoreSettings.Evaluation.t) => | VarLookup => !settings.show_lookup_steps | CastAp | Cast => !settings.show_casts - | CaseNext | CompleteClosure | CompleteFilter | FixUnwrap diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index 70ffd4b1eb..29bb9c94a0 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -75,8 +75,7 @@ let rec precedence = (~show_casts: bool, d: DHExp.t) => { | Fun(_) => DHDoc_common.precedence_max | Let(_) | FixF(_) - | ConsistentCase(_) - | InconsistentBranches(_) => DHDoc_common.precedence_max + | Match(_) => DHDoc_common.precedence_max | BinOp(Bool(op), _, _) => precedence_bin_bool_op(op) | BinOp(Int(op), _, _) => precedence_bin_int_op(op) @@ -153,7 +152,6 @@ let mk = | (ListCons, _) | (ListConcat, _) | (CaseApply, _) - | (CaseNext, _) | (CompleteClosure, _) | (CompleteFilter, _) | (Cast, _) @@ -204,15 +202,8 @@ let mk = } else { doc(~enforce_inline); }; - let go_case_rule = - (consistent: bool, rule_idx: int, Rule(dp, dclause): DHExp.rule) - : DHDoc.t => { - let kind: EvalCtx.cls = - if (consistent) { - ConsistentCaseRule(rule_idx); - } else { - InconsistentBranchesRule(rule_idx); - }; + let go_case_rule = (rule_idx: int, (dp, dclause)): DHDoc.t => { + let kind: EvalCtx.cls = MatchRule(rule_idx); let hidden_clause = annot(DHAnnot.Collapsed, text(Unicode.ellipsis)); let clause_doc = settings.show_case_clauses @@ -235,24 +226,24 @@ let mk = clause_doc, ]); }; - let go_case = (dscrut, drs, consistent) => + let go_case = (dscrut, drs) => if (enforce_inline) { fail(); } else { - let kind: EvalCtx.cls = - if (consistent) {ConsistentCase} else {InconsistentBranches}; let scrut_doc = choices([ - hcats([space(), go'(~enforce_inline=true, dscrut, kind)]), + hcats([space(), go'(~enforce_inline=true, dscrut, MatchScrut)]), hcats([ linebreak(), - indent_and_align(go'(~enforce_inline=false, dscrut, kind)), + indent_and_align( + go'(~enforce_inline=false, dscrut, MatchScrut), + ), ]), ]); vseps( List.concat([ [hcat(DHDoc_common.Delim.open_Case, scrut_doc)], - drs |> List.mapi(go_case_rule(consistent)), + drs |> List.mapi(go_case_rule), [DHDoc_common.Delim.close_Case], ]), ); @@ -315,9 +306,8 @@ let mk = | FreeVar(u, i, x) => text(x) |> annot(DHAnnot.VarHole(Free, (u, i))) | InvalidText(u, i, t) => DHDoc_common.mk_InvalidText(t, (u, i)) - | InconsistentBranches(u, i, Case(dscrut, drs, _)) => - go_case(dscrut, drs, false) - |> annot(DHAnnot.InconsistentBranches((u, i))) + | Match(Inconsistent(u, i), dscrut, drs) => + go_case(dscrut, drs) |> annot(DHAnnot.InconsistentBranches((u, i))) | Var(x) when List.mem(x, recursive_calls) => text(x) | Var(x) when settings.show_lookup_steps => text(x) | Var(x) => @@ -415,7 +405,7 @@ let mk = | Tuple(ds) => DHDoc_common.mk_Tuple(ds |> List.mapi((i, d) => go'(d, Tuple(i)))) | Prj(d, n) => DHDoc_common.mk_Prj(go'(d, Prj), n) - | ConsistentCase(Case(dscrut, drs, _)) => go_case(dscrut, drs, true) + | Match(Consistent, dscrut, drs) => go_case(dscrut, drs) | Cast(d, _, ty) when settings.show_casts => // TODO[Matt]: Roll multiple casts into one cast let doc = go'(d, Cast); From 5389bdd6b85423e62c1268da55a60f60414e7b4d Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 25 Jan 2024 11:13:57 -0500 Subject: [PATCH 003/103] Add d_loc' and make step data structure more consistent --- src/haz3lcore/dynamics/EvaluatorStep.re | 1 + src/haz3lcore/dynamics/Stepper.re | 39 +++++++++++++------------ src/haz3lweb/view/StepperView.re | 2 +- 3 files changed, 23 insertions(+), 19 deletions(-) diff --git a/src/haz3lcore/dynamics/EvaluatorStep.re b/src/haz3lcore/dynamics/EvaluatorStep.re index 046a793a26..4cdd745a44 100644 --- a/src/haz3lcore/dynamics/EvaluatorStep.re +++ b/src/haz3lcore/dynamics/EvaluatorStep.re @@ -5,6 +5,7 @@ type step = { d: DHExp.t, // technically can be calculated from d_loc and ctx state: EvaluatorState.t, d_loc: DHExp.t, // the expression at the location given by ctx + d_loc': DHExp.t, ctx: EvalCtx.t, knd: step_kind, }; diff --git a/src/haz3lcore/dynamics/Stepper.re b/src/haz3lcore/dynamics/Stepper.re index fdfcd42b26..51d4dd1b76 100644 --- a/src/haz3lcore/dynamics/Stepper.re +++ b/src/haz3lcore/dynamics/Stepper.re @@ -13,9 +13,14 @@ type step_with_previous = { [@deriving (show({with_path: false}), sexp, yojson)] type current = | StepperOK(DHExp.t, EvaluatorState.t) - | StepperError(ProgramEvaluatorError.t) // Must have at least one in previous - | StepTimeout // Must have at least one in previous - | StepPending(DHExp.t, EvaluatorState.t, option(EvalObj.t)); // StepPending(_,Some(_)) cannot be saved + | StepperError( + DHExp.t, + EvaluatorState.t, + EvalObj.t, + ProgramEvaluatorError.t, + ) // Must have at least one in previous + | StepTimeout(DHExp.t, EvaluatorState.t, EvalObj.t) // Must have at least one in previous + | StepPending(DHExp.t, EvaluatorState.t, option(EvalObj.t)); // none [@deriving (show({with_path: false}), sexp, yojson)] type t = { @@ -192,11 +197,11 @@ let get_elab = ({elab, _}: t) => elab; let get_next_steps = s => s.next; let current_expr = (s: t) => - switch (s.current, s.previous) { - | (StepperOK(d, _), _) - | (StepPending(d, _, _), _) => d - | (StepperError(_) | StepTimeout, [x, ..._]) => x.d - | (StepperError(_) | StepTimeout, []) => s.elab + switch (s.current) { + | StepperOK(d, _) + | StepPending(d, _, _) + | StepperError(d, _, _, _) + | StepTimeout(d, _, _) => d }; let step_pending = (eo: EvalObj.t, {elab, previous, current, next}: t) => @@ -208,7 +213,7 @@ let step_pending = (eo: EvalObj.t, {elab, previous, current, next}: t) => next, } | StepperError(_) - | StepTimeout => { + | StepTimeout(_) => { elab, previous: List.tl(previous), current: @@ -256,7 +261,7 @@ let rec evaluate_pending = (~settings, s: t) => { switch (s.current) { | StepperOK(_) | StepperError(_) - | StepTimeout => s + | StepTimeout(_) => s | StepPending(d, state, Some(eo)) => let state_ref = ref(state); let d_loc' = @@ -268,7 +273,7 @@ let rec evaluate_pending = (~settings, s: t) => { { elab: s.elab, previous: [ - {d, d_loc: eo.d_loc, ctx: eo.ctx, knd: eo.knd, state}, + {d, d_loc: eo.d_loc, d_loc', ctx: eo.ctx, knd: eo.knd, state}, ...s.previous, ], current: StepPending(d', state_ref^, None), @@ -299,7 +304,7 @@ let rec evaluate_pending = (~settings, s: t) => { let rec evaluate_full = (~settings, s: t) => { switch (s.current) { | StepperError(_) - | StepTimeout => s + | StepTimeout(_) => s | StepperOK(_) when s.next == [] => s | StepperOK(_) => s |> step_pending(List.hd(s.next)) |> evaluate_full(~settings) @@ -312,16 +317,14 @@ let timeout = fun | {elab, previous, current: StepPending(d, state, Some(eo)), next} => { elab, - previous: [ - {d, d_loc: eo.d_loc, ctx: eo.ctx, knd: eo.knd, state}, - ...previous, - ], - current: StepTimeout, + previous, + current: StepTimeout(d, state, eo), next, } | { current: - StepperError(_) | StepTimeout | StepperOK(_) | StepPending(_, _, None), + StepperError(_) | StepTimeout(_) | StepperOK(_) | + StepPending(_, _, None), _, } as s => s; diff --git a/src/haz3lweb/view/StepperView.re b/src/haz3lweb/view/StepperView.re index 2ea8d6954f..a12037d5f2 100644 --- a/src/haz3lweb/view/StepperView.re +++ b/src/haz3lweb/view/StepperView.re @@ -88,7 +88,7 @@ let stepper_view = ) // TODO[Matt]: show errors and waiting | StepperError(_) - | StepTimeout + | StepTimeout(_) | StepPending(_, _, _) => div([]) }; From 99539211c27225de12ce95360ef453f891b9d6af Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 1 Feb 2024 09:54:41 -0500 Subject: [PATCH 004/103] Add ids to DHExp --- src/haz3lcore/dynamics/Builtins.re | 261 ++++++++++++------- src/haz3lcore/dynamics/DH.re | 135 ++++++---- src/haz3lcore/dynamics/DHPat.re | 6 - src/haz3lcore/dynamics/Elaborator.re | 139 ++++++---- src/haz3lcore/dynamics/EvalCtx.re | 4 +- src/haz3lcore/dynamics/EvaluatorPost.re | 146 ++++++----- src/haz3lcore/dynamics/EvaluatorStep.re | 70 ++--- src/haz3lcore/dynamics/FilterMatcher.re | 21 +- src/haz3lcore/dynamics/PatternMatch.re | 38 +-- src/haz3lcore/dynamics/Stepper.re | 18 +- src/haz3lcore/dynamics/Substitution.re | 71 ++--- src/haz3lcore/dynamics/Transition.re | 256 ++++++++++-------- src/haz3lcore/dynamics/ValueChecker.re | 7 +- src/haz3lcore/prog/Interface.re | 4 +- src/haz3lweb/view/ExplainThis.re | 3 +- src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 64 +++-- 16 files changed, 736 insertions(+), 507 deletions(-) diff --git a/src/haz3lcore/dynamics/Builtins.re b/src/haz3lcore/dynamics/Builtins.re index 606a426694..d3c08ae0b4 100644 --- a/src/haz3lcore/dynamics/Builtins.re +++ b/src/haz3lcore/dynamics/Builtins.re @@ -32,88 +32,121 @@ let fn = module Pervasives = { module Impls = { /* constants */ - let infinity = DHExp.Float(Float.infinity); - let neg_infinity = DHExp.Float(Float.neg_infinity); - let nan = DHExp.Float(Float.nan); - let epsilon_float = DHExp.Float(epsilon_float); - let pi = DHExp.Float(Float.pi); - let max_int = DHExp.Int(Int.max_int); - let min_int = DHExp.Int(Int.min_int); - - let unary = (f: DHExp.t => result, r: DHExp.t) => - switch (f(r)) { + let infinity = DHExp.Float(Float.infinity) |> fresh; + let neg_infinity = DHExp.Float(Float.neg_infinity) |> fresh; + let nan = DHExp.Float(Float.nan) |> fresh; + let epsilon_float = DHExp.Float(epsilon_float) |> fresh; + let pi = DHExp.Float(Float.pi) |> fresh; + let max_int = DHExp.Int(Int.max_int) |> fresh; + let min_int = DHExp.Int(Int.min_int) |> fresh; + + let unary = (f: DHExp.t => result, d: DHExp.t) => { + switch (f(d)) { | Ok(r') => r' | Error(e) => EvaluatorError.Exception(e) |> raise }; + }; + + let binary = (f: (DHExp.t, DHExp.t) => result, d: DHExp.t) => { + switch (term_of(d)) { + | Tuple([d1, d2]) => + switch (f(d1, d2)) { + | Ok(r) => r + | Error(e) => EvaluatorError.Exception(e) |> raise + } + | _ => raise(EvaluatorError.Exception(InvalidBoxedTuple(d))) + }; + }; + + let ternary = (f: (DHExp.t, DHExp.t, DHExp.t) => result, d: DHExp.t) => { + switch (term_of(d)) { + | Tuple([d1, d2, d3]) => + switch (f(d1, d2, d3)) { + | Ok(r) => r + | Error(e) => EvaluatorError.Exception(e) |> raise + } + | _ => raise(EvaluatorError.Exception(InvalidBoxedTuple(d))) + }; + }; let is_finite = - unary( - fun - | Float(f) => Ok(Bool(Float.is_finite(f))) - | d => Error(InvalidBoxedFloatLit(d)), + unary(d => + switch (term_of(d)) { + | Float(f) => Ok(fresh(Bool(Float.is_finite(f)))) + | _ => Error(InvalidBoxedFloatLit(d)) + } ); let is_infinite = - unary( - fun - | Float(f) => Ok(Bool(Float.is_infinite(f))) - | d => Error(InvalidBoxedFloatLit(d)), + unary(d => + switch (term_of(d)) { + | Float(f) => Ok(fresh(Bool(Float.is_infinite(f)))) + | _ => Error(InvalidBoxedFloatLit(d)) + } ); let is_nan = - unary( - fun - | Float(f) => Ok(Bool(Float.is_nan(f))) - | d => Error(InvalidBoxedFloatLit(d)), + unary(d => + switch (term_of(d)) { + | Float(f) => Ok(fresh(Bool(Float.is_nan(f)))) + | _ => Error(InvalidBoxedFloatLit(d)) + } ); let string_of_int = - unary( - fun - | Int(n) => Ok(String(string_of_int(n))) - | d => Error(InvalidBoxedIntLit(d)), + unary(d => + switch (term_of(d)) { + | Int(n) => Ok(fresh(String(string_of_int(n)))) + | _ => Error(InvalidBoxedIntLit(d)) + } ); let string_of_float = - unary( - fun - | Float(f) => Ok(String(string_of_float(f))) - | d => Error(InvalidBoxedFloatLit(d)), + unary(d => + switch (term_of(d)) { + | Float(f) => Ok(fresh(String(string_of_float(f)))) + | _ => Error(InvalidBoxedFloatLit(d)) + } ); let string_of_bool = - unary( - fun - | Bool(b) => Ok(String(string_of_bool(b))) - | d => Error(InvalidBoxedBoolLit(d)), + unary(d => + switch (term_of(d)) { + | Bool(b) => Ok(fresh(String(string_of_bool(b)))) + | _ => Error(InvalidBoxedBoolLit(d)) + } ); let int_of_float = - unary( - fun - | Float(f) => Ok(Int(int_of_float(f))) - | d => Error(InvalidBoxedFloatLit(d)), + unary(d => + switch (term_of(d)) { + | Float(f) => Ok(fresh(Int(int_of_float(f)))) + | _ => Error(InvalidBoxedFloatLit(d)) + } ); let float_of_int = - unary( - fun - | Int(n) => Ok(Float(float_of_int(n))) - | d => Error(InvalidBoxedIntLit(d)), + unary(d => + switch (term_of(d)) { + | Int(n) => Ok(fresh(Float(float_of_int(n)))) + | _ => Error(InvalidBoxedIntLit(d)) + } ); let abs = - unary( - fun - | Int(n) => Ok(Int(abs(n))) - | d => Error(InvalidBoxedIntLit(d)), + unary(d => + switch (term_of(d)) { + | Int(n) => Ok(fresh(Int(abs(n)))) + | _ => Error(InvalidBoxedIntLit(d)) + } ); let float_op = fn => - unary( - fun - | Float(f) => Ok(Float(fn(f))) - | d => Error(InvalidBoxedFloatLit(d)), + unary(d => + switch (term_of(d)) { + | Float(f) => Ok(fresh(Float(fn(f)))) + | _ => Error(InvalidBoxedFloatLit(d)) + } ); let abs_float = float_op(abs_float); @@ -132,84 +165,109 @@ module Pervasives = { let of_string = (convert: string => option('a), wrap: 'a => DHExp.t, name: string) => - unary( - fun - | String(s) as d => + unary(d => + switch (term_of(d)) { + | String(s) => switch (convert(s)) { | Some(n) => Ok(wrap(n)) | None => - let d' = DHExp.Ap(DHExp.BuiltinFun(name), d); - Ok(InvalidOperation(d', InvalidOfString)); + let d' = DHExp.BuiltinFun(name) |> DHExp.fresh; + let d' = DHExp.Ap(d', d) |> DHExp.fresh; + let d' = InvalidOperation(d', InvalidOfString) |> DHExp.fresh; + Ok(d'); } - | d => Error(InvalidBoxedStringLit(d)), + | _ => Error(InvalidBoxedStringLit(d)) + } ); - let int_of_string = of_string(int_of_string_opt, n => Int(n)); - let float_of_string = of_string(float_of_string_opt, f => Float(f)); - let bool_of_string = of_string(bool_of_string_opt, b => Bool(b)); + let int_of_string = + of_string(int_of_string_opt, n => Int(n) |> DHExp.fresh); + let float_of_string = + of_string(float_of_string_opt, f => Float(f) |> DHExp.fresh); + let bool_of_string = + of_string(bool_of_string_opt, b => Bool(b) |> DHExp.fresh); let int_mod = (name, d1) => - switch (d1) { - | Tuple([Int(n), Int(m)]) => - switch (m) { - | 0 => - InvalidOperation( - DHExp.Ap(DHExp.BuiltinFun(name), d1), - DivideByZero, - ) - | _ => Int(n mod m) - } - | d1 => raise(EvaluatorError.Exception(InvalidBoxedTuple(d1))) - }; + binary( + (d1, d2) => + switch (term_of(d1), term_of(d2)) { + | (Int(_), Int(0)) => + Ok( + fresh( + InvalidOperation( + DHExp.Ap(DHExp.BuiltinFun(name) |> fresh, d1) |> fresh, + DivideByZero, + ), + ), + ) + | (Int(n), Int(m)) => Ok(Int(n mod m) |> fresh) + | (Int(_), _) => + raise(EvaluatorError.Exception(InvalidBoxedIntLit(d2))) + | (_, _) => + raise(EvaluatorError.Exception(InvalidBoxedIntLit(d1))) + }, + d1, + ); let string_length = - unary( - fun - | String(s) => Ok(Int(String.length(s))) - | d => Error(InvalidBoxedStringLit(d)), + unary(d => + switch (term_of(d)) { + | String(s) => Ok(Int(String.length(s)) |> fresh) + | _ => Error(InvalidBoxedStringLit(d)) + } ); let string_compare = - unary( - fun - | Tuple([String(s1), String(s2)]) => - Ok(Int(String.compare(s1, s2))) - | d => Error(InvalidBoxedTuple(d)), + binary((d1, d2) => + switch (term_of(d1), term_of(d2)) { + | (String(s1), String(s2)) => + Ok(Int(String.compare(s1, s2)) |> fresh) + | (String(_), _) => Error(InvalidBoxedStringLit(d2)) + | (_, _) => Error(InvalidBoxedStringLit(d1)) + } ); let string_trim = - unary( - fun - | String(s) => Ok(String(String.trim(s))) - | d => Error(InvalidBoxedStringLit(d)), + unary(d => + switch (term_of(d)) { + | String(s) => Ok(String(String.trim(s)) |> fresh) + | _ => Error(InvalidBoxedStringLit(d)) + } ); let string_of: DHExp.t => option(string) = - fun - | String(s) => Some(s) - | _ => None; + d => + switch (term_of(d)) { + | String(s) => Some(s) + | _ => None + }; let string_concat = - unary( - fun - | Tuple([String(s1), ListLit(_, _, _, xs)]) => + binary((d1, d2) => + switch (term_of(d1), term_of(d2)) { + | (String(s1), ListLit(_, _, _, xs)) => switch (xs |> List.map(string_of) |> Util.OptUtil.sequence) { | None => Error(InvalidBoxedStringLit(List.hd(xs))) - | Some(xs) => Ok(String(String.concat(s1, xs))) + | Some(xs) => Ok(String(String.concat(s1, xs)) |> fresh) } - | d => Error(InvalidBoxedTuple(d)), + | (String(_), _) => Error(InvalidBoxedListLit(d2)) + | (_, _) => Error(InvalidBoxedStringLit(d1)) + } ); - let string_sub = name => - unary( - fun - | Tuple([String(s), Int(idx), Int(len)]) as d => - try(Ok(String(String.sub(s, idx, len)))) { + let string_sub = _ => + ternary((d1, d2, d3) => + switch (term_of(d1), term_of(d2), term_of(d3)) { + | (String(s), Int(idx), Int(len)) => + try(Ok(String(String.sub(s, idx, len)) |> fresh)) { | _ => - let d' = DHExp.Ap(DHExp.BuiltinFun(name), d); - Ok(InvalidOperation(d', IndexOutOfBounds)); + // TODO: make it clear that the problem could be with d3 too + Ok(InvalidOperation(d2, IndexOutOfBounds) |> fresh) } - | d => Error(InvalidBoxedTuple(d)), + | (String(_), Int(_), _) => Error(InvalidBoxedIntLit(d3)) + | (String(_), _, _) => Error(InvalidBoxedIntLit(d2)) + | (_, _, _) => Error(InvalidBoxedIntLit(d1)) + } ); }; @@ -303,7 +361,8 @@ let env_init: Environment.t = env => fun | (name, Const(_, d)) => Environment.extend(env, (name, d)) - | (name, Fn(_)) => Environment.extend(env, (name, BuiltinFun(name))), + | (name, Fn(_)) => + Environment.extend(env, (name, BuiltinFun(name) |> fresh)), Environment.empty, Pervasives.builtins, ); diff --git a/src/haz3lcore/dynamics/DH.re b/src/haz3lcore/dynamics/DH.re index b3d89a8ad3..43322a0f1f 100644 --- a/src/haz3lcore/dynamics/DH.re +++ b/src/haz3lcore/dynamics/DH.re @@ -7,7 +7,7 @@ type consistency = module rec DHExp: { [@deriving (show({with_path: false}), sexp, yojson)] - type t = + type term = // TODO: Add IDs /* TODO: ADD: UnOp @@ -28,7 +28,7 @@ module rec DHExp: { | Seq(t, t) // DONE [ALREADY] | Let(DHPat.t, t, t) // DONE [ALREADY] | FixF(Var.t, Typ.t, t) // TODO: ! REMOVE, LEAVE AS LETS? - | Fun(DHPat.t, Typ.t, t, option(Var.t)) // TODO: Move type into pattern?; name > UEXP + | Fun(DHPat.t, Typ.t, t, option(ClosureEnvironment.t), option(Var.t)) // TODO: Move type into pattern?; name > UEXP | Ap(t, t) // TODO: Add reverse application | ApBuiltin(string, t) // DONE [TO ADD TO UEXP] | BuiltinFun(string) // DONE [TO ADD TO UEXP] @@ -46,13 +46,20 @@ module rec DHExp: { | Constructor(string) // DONE [ALREADY] | Match(consistency, t, list((DHPat.t, t))) | Cast(t, Typ.t, Typ.t) // TODO: Add to uexp or remove - | If(consistency, t, t, t); // TODO: CONSISTENCY? use bool tag to track if branches are consistent + | If(consistency, t, t, t) + and t; // TODO: CONSISTENCY? use bool tag to track if branches are consistent - let constructor_string: t => string; + let rep_id: t => Id.t; + let term_of: t => term; + let fast_copy: (Id.t, t) => t; + // All children of term must have expression-unique ids. + let fresh: term => t; + let mk: (list(Id.t), term) => t; + let unwrap: t => (term, term => t); - let mk_tuple: list(t) => t; + let constructor_string: t => string; - let cast: (t, Typ.t, Typ.t) => t; + let fresh_cast: (t, Typ.t, Typ.t) => t; let apply_casts: (t, list((Typ.t, Typ.t))) => t; let strip_casts: t => t; @@ -60,7 +67,7 @@ module rec DHExp: { let fast_equal: (t, t) => bool; } = { [@deriving (show({with_path: false}), sexp, yojson)] - type t = + type term = /* Hole types */ | EmptyHole(MetaVar.t, HoleInstanceId.t) | NonEmptyHole(ErrStatus.HoleReason.t, MetaVar.t, HoleInstanceId.t, t) @@ -77,7 +84,7 @@ module rec DHExp: { | Seq(t, t) | Let(DHPat.t, t, t) | FixF(Var.t, Typ.t, t) - | Fun(DHPat.t, Typ.t, t, option(Var.t)) + | Fun(DHPat.t, Typ.t, t, option(ClosureEnvironment.t), option(Var.t)) | Ap(t, t) | ApBuiltin(string, t) | BuiltinFun(string) @@ -95,9 +102,37 @@ module rec DHExp: { | Constructor(string) | Match(consistency, t, list((DHPat.t, t))) | Cast(t, Typ.t, Typ.t) - | If(consistency, t, t, t); + | If(consistency, t, t, t) + and t = { + /* invariant: nonempty, TODO: what happens to later ids in DHExp */ + ids: list(Id.t), + /*TODO: Verify: Always true in UExp, not necessarily in DHExp + if some id is not unique, then one of its parents will be flagged false */ + ids_are_unique: bool, + term, + }; + + let rep_id = ({ids, _}) => List.hd(ids); + let term_of = ({term, _}) => term; + let fast_copy = (id, {term, _}) => { + ids: [id], + term, + ids_are_unique: false, + }; + // All children of term must have expression-unique ids. + let fresh = term => { + {ids: [Id.mk()], ids_are_unique: true, term}; + }; + let unwrap = ({ids, term, ids_are_unique}) => ( + term, + term => {ids, term, ids_are_unique}, + ); + + let mk = (ids, term) => { + {ids, ids_are_unique: true, term}; + }; - let constructor_string = (d: t): string => + let constructor_string = ({term: d, _}: t): string => switch (d) { | EmptyHole(_, _) => "EmptyHole" | NonEmptyHole(_, _, _, _) => "NonEmptyHole" @@ -109,7 +144,7 @@ module rec DHExp: { | Filter(_, _) => "Filter" | Let(_, _, _) => "Let" | FixF(_, _, _) => "FixF" - | Fun(_, _, _, _) => "Fun" + | Fun(_, _, _, _, _) => "Fun" | Closure(_, _) => "Closure" | Ap(_, _) => "Ap" | ApBuiltin(_, _) => "ApBuiltin" @@ -133,49 +168,50 @@ module rec DHExp: { | If(_, _, _, _) => "If" }; - let mk_tuple: list(t) => t = - fun - | [] - | [_] => failwith("mk_tuple: expected at least 2 elements") - | xs => Tuple(xs); - - let cast = (d: t, t1: Typ.t, t2: Typ.t): t => + // All children of d must have expression-unique ids. + let fresh_cast = (d: t, t1: Typ.t, t2: Typ.t): t => if (Typ.eq(t1, t2) || t2 == Unknown(SynSwitch)) { d; } else { - Cast(d, t1, t2); + fresh(Cast(d, t1, t2)); }; let apply_casts = (d: t, casts: list((Typ.t, Typ.t))): t => - List.fold_left((d, (ty1, ty2)) => cast(d, ty1, ty2), d, casts); + List.fold_left((d, (ty1, ty2)) => fresh_cast(d, ty1, ty2), d, casts); - let rec strip_casts = - fun - | Closure(ei, d) => Closure(ei, strip_casts(d)) + let rec strip_casts = d => { + let (term, rewrap) = unwrap(d); + switch (term) { + | Closure(ei, d) => Closure(ei, strip_casts(d)) |> rewrap | Cast(d, _, _) => strip_casts(d) | FailedCast(d, _, _) => strip_casts(d) - | Tuple(ds) => Tuple(ds |> List.map(strip_casts)) - | Prj(d, n) => Prj(strip_casts(d), n) - | Cons(d1, d2) => Cons(strip_casts(d1), strip_casts(d2)) - | ListConcat(d1, d2) => ListConcat(strip_casts(d1), strip_casts(d2)) - | ListLit(a, b, c, ds) => ListLit(a, b, c, List.map(strip_casts, ds)) - | NonEmptyHole(err, u, i, d) => NonEmptyHole(err, u, i, strip_casts(d)) - | Seq(a, b) => Seq(strip_casts(a), strip_casts(b)) - | Filter(f, b) => Filter(DHFilter.strip_casts(f), strip_casts(b)) - | Let(dp, b, c) => Let(dp, strip_casts(b), strip_casts(c)) - | FixF(a, b, c) => FixF(a, b, strip_casts(c)) - | Fun(a, b, c, d) => Fun(a, b, strip_casts(c), d) - | Ap(a, b) => Ap(strip_casts(a), strip_casts(b)) - | Test(id, a) => Test(id, strip_casts(a)) - | ApBuiltin(fn, args) => ApBuiltin(fn, strip_casts(args)) - | BuiltinFun(fn) => BuiltinFun(fn) - | BinOp(a, b, c) => BinOp(a, strip_casts(b), strip_casts(c)) + | Tuple(ds) => Tuple(ds |> List.map(strip_casts)) |> rewrap + | Prj(d, n) => Prj(strip_casts(d), n) |> rewrap + | Cons(d1, d2) => Cons(strip_casts(d1), strip_casts(d2)) |> rewrap + | ListConcat(d1, d2) => + ListConcat(strip_casts(d1), strip_casts(d2)) |> rewrap + | ListLit(a, b, c, ds) => + ListLit(a, b, c, List.map(strip_casts, ds)) |> rewrap + | NonEmptyHole(err, u, i, d) => + NonEmptyHole(err, u, i, strip_casts(d)) |> rewrap + | Seq(a, b) => Seq(strip_casts(a), strip_casts(b)) |> rewrap + | Filter(f, b) => + Filter(DHFilter.strip_casts(f), strip_casts(b)) |> rewrap + | Let(dp, b, c) => Let(dp, strip_casts(b), strip_casts(c)) |> rewrap + | FixF(a, b, c) => FixF(a, b, strip_casts(c)) |> rewrap + | Fun(a, b, c, e, d) => Fun(a, b, strip_casts(c), e, d) |> rewrap + | Ap(a, b) => Ap(strip_casts(a), strip_casts(b)) |> rewrap + | Test(id, a) => Test(id, strip_casts(a)) |> rewrap + | ApBuiltin(fn, args) => ApBuiltin(fn, strip_casts(args)) |> rewrap + | BuiltinFun(fn) => BuiltinFun(fn) |> rewrap + | BinOp(a, b, c) => BinOp(a, strip_casts(b), strip_casts(c)) |> rewrap | Match(c, a, rules) => Match( c, strip_casts(a), List.map(((k, v)) => (k, strip_casts(v)), rules), ) + |> rewrap | EmptyHole(_) as d | ExpandingKeyword(_) as d | FreeVar(_) as d @@ -186,11 +222,14 @@ module rec DHExp: { | Float(_) as d | String(_) as d | Constructor(_) as d - | InvalidOperation(_) as d => d + | InvalidOperation(_) as d => d |> rewrap | If(consistent, c, d1, d2) => - If(consistent, strip_casts(c), strip_casts(d1), strip_casts(d2)); + If(consistent, strip_casts(c), strip_casts(d1), strip_casts(d2)) + |> rewrap + }; + }; - let rec fast_equal = (d1: t, d2: t): bool => { + let rec fast_equal = ({term: d1, _}, {term: d2, _}): bool => { switch (d1, d2) { /* Primitive forms: regular structural equality */ | (Var(_), _) @@ -212,8 +251,17 @@ module rec DHExp: { dp1 == dp2 && fast_equal(d11, d12) && fast_equal(d21, d22) | (FixF(f1, ty1, d1), FixF(f2, ty2, d2)) => f1 == f2 && ty1 == ty2 && fast_equal(d1, d2) - | (Fun(dp1, ty1, d1, s1), Fun(dp2, ty2, d2, s2)) => + | (Fun(dp1, ty1, d1, None, s1), Fun(dp2, ty2, d2, None, s2)) => dp1 == dp2 && ty1 == ty2 && fast_equal(d1, d2) && s1 == s2 + | ( + Fun(dp1, ty1, d1, Some(env1), s1), + Fun(dp2, ty2, d2, Some(env2), s2), + ) => + dp1 == dp2 + && ty1 == ty2 + && fast_equal(d1, d2) + && ClosureEnvironment.id_equal(env1, env2) + && s1 == s2 | (Ap(d11, d21), Ap(d12, d22)) | (Cons(d11, d21), Cons(d12, d22)) => fast_equal(d11, d12) && fast_equal(d21, d22) @@ -453,7 +501,6 @@ and Filter: { let fast_equal = (f1: t, f2: t): bool => { DHExp.fast_equal(f1.pat, f2.pat) && f1.act == f2.act; }; - let strip_casts = (f: t): t => {...f, pat: f.pat |> DHExp.strip_casts}; } diff --git a/src/haz3lcore/dynamics/DHPat.re b/src/haz3lcore/dynamics/DHPat.re index 21bdea3ba4..271126defb 100644 --- a/src/haz3lcore/dynamics/DHPat.re +++ b/src/haz3lcore/dynamics/DHPat.re @@ -22,12 +22,6 @@ type t = | Constructor(string) | Ap(t, t); -let mk_tuple: list(t) => t = - fun - | [] - | [_] => failwith("mk_tuple: expected at least 2 elements") - | dps => Tuple(dps); - /** * Whether dp contains the variable x outside of a hole. */ diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 03857f0f76..faaffe4fde 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -26,40 +26,56 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => | SynFun => switch (self_ty) { | Unknown(prov) => - DHExp.cast(d, Unknown(prov), Arrow(Unknown(prov), Unknown(prov))) + DHExp.fresh_cast( + d, + Unknown(prov), + Arrow(Unknown(prov), Unknown(prov)), + ) | Arrow(_) => d | _ => failwith("Elaborator.wrap: SynFun non-arrow-type") } | Ana(ana_ty) => let ana_ty = Typ.normalize(ctx, ana_ty); /* Forms with special ana rules get cast from their appropriate Matched types */ - switch (d) { + switch (DHExp.term_of(d)) { | ListLit(_) | ListConcat(_) | Cons(_) => switch (ana_ty) { - | Unknown(prov) => DHExp.cast(d, List(Unknown(prov)), Unknown(prov)) + | Unknown(prov) => + DHExp.fresh_cast(d, List(Unknown(prov)), Unknown(prov)) | _ => d } | Fun(_) => /* See regression tests in Documentation/Dynamics */ let (_, ana_out) = Typ.matched_arrow(ctx, ana_ty); let (self_in, _) = Typ.matched_arrow(ctx, self_ty); - DHExp.cast(d, Arrow(self_in, ana_out), ana_ty); + DHExp.fresh_cast(d, Arrow(self_in, ana_out), ana_ty); | Tuple(ds) => switch (ana_ty) { | Unknown(prov) => let us = List.init(List.length(ds), _ => Typ.Unknown(prov)); - DHExp.cast(d, Prod(us), Unknown(prov)); + DHExp.fresh_cast(d, Prod(us), Unknown(prov)); | _ => d } - | Ap(Constructor(_), _) | Constructor(_) => switch (ana_ty, self_ty) { | (Unknown(prov), Rec(_, Sum(_))) - | (Unknown(prov), Sum(_)) => DHExp.cast(d, self_ty, Unknown(prov)) + | (Unknown(prov), Sum(_)) => + DHExp.fresh_cast(d, self_ty, Unknown(prov)) | _ => d } + | Ap(f, _) => + switch (DHExp.term_of(f)) { + | Constructor(_) => + switch (ana_ty, self_ty) { + | (Unknown(prov), Rec(_, Sum(_))) + | (Unknown(prov), Sum(_)) => + DHExp.fresh_cast(d, self_ty, Unknown(prov)) + | _ => d + } + | _ => DHExp.fresh_cast(d, self_ty, ana_ty) + } /* Forms with special ana rules but no particular typing requirements */ | Match(_) | If(_) @@ -80,7 +96,6 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => | InvalidOperation(_) => d /* Normal cases: wrap */ | Var(_) - | Ap(_) | ApBuiltin(_) | BuiltinFun(_) | Prj(_) @@ -89,7 +104,7 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => | Float(_) | String(_) | BinOp(_) - | Test(_) => DHExp.cast(d, self_ty, ana_ty) + | Test(_) => DHExp.fresh_cast(d, self_ty, ana_ty) }; }; @@ -104,7 +119,7 @@ let wrap = (ctx: Ctx.t, u: Id.t, mode: Mode.t, self, d: DHExp.t): DHExp.t => | None => Unknown(Internal) }; cast(ctx, mode, self_ty, d); - | InHole(_) => NonEmptyHole(TypeInconsistent, u, 0, d) + | InHole(_) => DHExp.fresh(NonEmptyHole(TypeInconsistent, u, 0, d)) }; let rec dhexp_of_uexp = @@ -117,95 +132,100 @@ let rec dhexp_of_uexp = | Some(InfoExp({mode, self, ctx, _})) => let err_status = Info.status_exp(ctx, mode, self); let id = Term.UExp.rep_id(uexp); /* NOTE: using term uids for hole ids */ + let rewrap = DHExp.mk(uexp.ids); let+ d: DHExp.t = switch (uexp.term) { - | Invalid(t) => Some(DHExp.InvalidText(id, 0, t)) - | EmptyHole => Some(DHExp.EmptyHole(id, 0)) + | Invalid(t) => Some(DHExp.InvalidText(id, 0, t) |> rewrap) + | EmptyHole => Some(DHExp.EmptyHole(id, 0) |> rewrap) | MultiHole(_tms) => /* TODO: add a dhexp case and eval logic for multiholes. Make sure new dhexp form is properly considered Indet to avoid casting issues. */ - Some(EmptyHole(id, 0)) - | Triv => Some(Tuple([])) - | Bool(b) => Some(Bool(b)) - | Int(n) => Some(Int(n)) - | Float(n) => Some(Float(n)) - | String(s) => Some(String(s)) + Some(EmptyHole(id, 0) |> rewrap) + | Triv => Some(Tuple([]) |> rewrap) + | Bool(b) => Some(Bool(b) |> rewrap) + | Int(n) => Some(Int(n) |> rewrap) + | Float(n) => Some(Float(n) |> rewrap) + | String(s) => Some(String(s) |> rewrap) | ListLit(es) => let* ds = es |> List.map(dhexp_of_uexp(m)) |> OptUtil.sequence; let+ ty = fixed_exp_typ(m, uexp); let ty = Typ.matched_list(ctx, ty); - DHExp.ListLit(id, 0, ty, ds); + DHExp.ListLit(id, 0, ty, ds) |> rewrap; | Fun(p, body) => let* dp = dhpat_of_upat(m, p); let* d1 = dhexp_of_uexp(m, body); let+ ty = fixed_pat_typ(m, p); - DHExp.Fun(dp, ty, d1, None); + DHExp.Fun(dp, ty, d1, None, None) |> rewrap; | Tuple(es) => let+ ds = es |> List.map(dhexp_of_uexp(m)) |> OptUtil.sequence; - DHExp.Tuple(ds); + DHExp.Tuple(ds) |> rewrap; | Cons(e1, e2) => let* dc1 = dhexp_of_uexp(m, e1); let+ dc2 = dhexp_of_uexp(m, e2); - DHExp.Cons(dc1, dc2); + DHExp.Cons(dc1, dc2) |> rewrap; | ListConcat(e1, e2) => let* dc1 = dhexp_of_uexp(m, e1); let+ dc2 = dhexp_of_uexp(m, e2); - DHExp.ListConcat(dc1, dc2); + DHExp.ListConcat(dc1, dc2) |> rewrap; | UnOp(Meta(Unquote), e) => switch (e.term) { - | Var("e") when in_filter => Some(Constructor("$e")) - | Var("v") when in_filter => Some(Constructor("$v")) - | _ => Some(DHExp.EmptyHole(id, 0)) + | Var("e") when in_filter => Some(Constructor("$e") |> DHExp.fresh) + | Var("v") when in_filter => Some(Constructor("$v") |> DHExp.fresh) + | _ => Some(DHExp.EmptyHole(id, 0) |> rewrap) } | UnOp(Int(Minus), e) => let+ dc = dhexp_of_uexp(m, e); - DHExp.BinOp(Int(Minus), Int(0), dc); + DHExp.BinOp(Int(Minus), DHExp.fresh(Int(0)), dc) |> rewrap; | UnOp(Bool(Not), e) => let+ d_scrut = dhexp_of_uexp(m, e); let d_rules = [ - (DHPat.Bool(true), DHExp.Bool(false)), - (DHPat.Bool(false), DHExp.Bool(true)), + (DHPat.Bool(true), DHExp.(fresh(Bool(false)))), + (DHPat.Bool(false), DHExp.(fresh(Bool(true)))), ]; - let d = DHExp.(Match(Consistent, d_scrut, d_rules)); + let d = DHExp.(fresh(Match(Consistent, d_scrut, d_rules))); /* Manually construct cast (case is not otherwise cast) */ switch (mode) { - | Ana(ana_ty) => DHExp.cast(d, Bool, ana_ty) + | Ana(ana_ty) => DHExp.fresh_cast(d, Bool, ana_ty) | _ => d }; | BinOp(op, e1, e2) => let* dc1 = dhexp_of_uexp(m, e1); let+ dc2 = dhexp_of_uexp(m, e2); - DHExp.BinOp(op, dc1, dc2); + DHExp.BinOp(op, dc1, dc2) |> rewrap; | Parens(e) => dhexp_of_uexp(m, e) | Seq(e1, e2) => let* d1 = dhexp_of_uexp(m, e1); let+ d2 = dhexp_of_uexp(m, e2); - DHExp.Seq(d1, d2); + DHExp.Seq(d1, d2) |> rewrap; | Test(test) => let+ dtest = dhexp_of_uexp(m, test); - DHExp.Test(id, dtest); + DHExp.Test(id, dtest) |> rewrap; | Filter(act, cond, body) => let* dcond = dhexp_of_uexp(~in_filter=true, m, cond); let+ dbody = dhexp_of_uexp(m, body); - DHExp.Filter(Filter(Filter.mk(dcond, act)), dbody); + DHExp.Filter(Filter(Filter.mk(dcond, act)), dbody) |> rewrap; | Var(name) => switch (err_status) { - | InHole(FreeVariable(_)) => Some(FreeVar(id, 0, name)) - | _ => Some(Var(name)) + | InHole(FreeVariable(_)) => Some(FreeVar(id, 0, name) |> rewrap) + | _ => Some(Var(name) |> rewrap) } | Constructor(name) => switch (err_status) { | InHole(Common(NoType(FreeConstructor(_)))) => - Some(FreeVar(id, 0, name)) - | _ => Some(Constructor(name)) + Some(FreeVar(id, 0, name) |> rewrap) + | _ => Some(Constructor(name) |> rewrap) } | Let(p, def, body) => let add_name: (option(string), DHExp.t) => DHExp.t = ( - name => - fun - | Fun(p, ty, e, _) => DHExp.Fun(p, ty, e, name) - | d => d + (name, d) => { + let (term, rewrap) = DHExp.unwrap(d); + switch (term) { + | Fun(p, ty, e, ctx, _) => + DHExp.Fun(p, ty, e, ctx, name) |> rewrap + | _ => d + }; + } ); let* dp = dhpat_of_upat(m, p); let* ddef = dhexp_of_uexp(m, def); @@ -215,37 +235,50 @@ let rec dhexp_of_uexp = | None => /* not recursive */ DHExp.Let(dp, add_name(Term.UPat.get_var(p), ddef), dbody) + |> rewrap | Some([f]) => /* simple recursion */ - Let(dp, FixF(f, ty, add_name(Some(f), ddef)), dbody) + Let( + dp, + FixF(f, ty, add_name(Some(f), ddef)) |> DHExp.fresh, + dbody, + ) + |> rewrap | Some(fs) => /* mutual recursion */ let ddef = - switch (ddef) { + switch (DHExp.term_of(ddef)) { | Tuple(a) => DHExp.Tuple(List.map2(s => add_name(Some(s)), fs, a)) + |> DHExp.fresh | _ => ddef }; let uniq_id = List.nth(def.ids, 0); let self_id = "__mutual__" ++ Id.to_string(uniq_id); - let self_var = DHExp.Var(self_id); + // TODO: Re-use IDs here instead of using fresh + let self_var = DHExp.Var(self_id) |> DHExp.fresh; let (_, substituted_def) = fs |> List.fold_left( ((i, ddef), f) => { let ddef = - Substitution.subst_var(DHExp.Prj(self_var, i), f, ddef); + Substitution.subst_var( + DHExp.Prj(self_var, i) |> DHExp.fresh, + f, + ddef, + ); (i + 1, ddef); }, (0, ddef), ); - Let(dp, FixF(self_id, ty, substituted_def), dbody); + Let(dp, FixF(self_id, ty, substituted_def) |> DHExp.fresh, dbody) + |> rewrap; }; | Ap(fn, arg) | Pipeline(arg, fn) => let* c_fn = dhexp_of_uexp(m, fn); let+ c_arg = dhexp_of_uexp(m, arg); - DHExp.Ap(c_fn, c_arg); + DHExp.Ap(c_fn, c_arg) |> rewrap; | If(c, e1, e2) => let* c' = dhexp_of_uexp(m, c); let* d1 = dhexp_of_uexp(m, e1); @@ -253,8 +286,8 @@ let rec dhexp_of_uexp = // Use tag to mark inconsistent branches switch (err_status) { | InHole(Common(Inconsistent(Internal(_)))) => - DHExp.If(DH.Inconsistent(id, 0), c', d1, d2) - | _ => DHExp.If(DH.Consistent, c', d1, d2) + DHExp.If(DH.Inconsistent(id, 0), c', d1, d2) |> rewrap + | _ => DHExp.If(DH.Consistent, c', d1, d2) |> rewrap }; | Match(scrut, rules) => let* d_scrut = dhexp_of_uexp(m, scrut); @@ -270,8 +303,8 @@ let rec dhexp_of_uexp = |> OptUtil.sequence; switch (err_status) { | InHole(Common(Inconsistent(Internal(_)))) => - DHExp.Match(Inconsistent(id, 0), d_scrut, d_rules) - | _ => DHExp.Match(Consistent, d_scrut, d_rules) + DHExp.Match(Inconsistent(id, 0), d_scrut, d_rules) |> rewrap + | _ => DHExp.Match(Consistent, d_scrut, d_rules) |> rewrap }; | TyAlias(_, _, e) => dhexp_of_uexp(m, e) }; diff --git a/src/haz3lcore/dynamics/EvalCtx.re b/src/haz3lcore/dynamics/EvalCtx.re index 14414e0d2c..a2dbe8e6d8 100644 --- a/src/haz3lcore/dynamics/EvalCtx.re +++ b/src/haz3lcore/dynamics/EvalCtx.re @@ -48,7 +48,7 @@ type t = | Seq2(DHExp.t, t) | Let1(DHPat.t, t, DHExp.t) | Let2(DHPat.t, DHExp.t, t) - | Fun(DHPat.t, Typ.t, t, option(Var.t)) + | Fun(DHPat.t, Typ.t, t, option(ClosureEnvironment.t), option(Var.t)) | FixF(Var.t, Typ.t, t) | Ap1(t, DHExp.t) | Ap2(DHExp.t, t) @@ -135,7 +135,7 @@ let rec unwrap = (ctx: t, sel: cls): option(t) => { | (Seq2, Seq2(_, c)) | (Let1, Let1(_, c, _)) | (Let2, Let2(_, _, c)) - | (Fun, Fun(_, _, c, _)) + | (Fun, Fun(_, _, c, _, _)) | (FixF, FixF(_, _, c)) | (Ap1, Ap1(c, _)) | (Ap2, Ap2(_, c)) diff --git a/src/haz3lcore/dynamics/EvaluatorPost.re b/src/haz3lcore/dynamics/EvaluatorPost.re index df33fefdff..d51a9b4b96 100644 --- a/src/haz3lcore/dynamics/EvaluatorPost.re +++ b/src/haz3lcore/dynamics/EvaluatorPost.re @@ -38,8 +38,9 @@ exception Exception(error); /** Postprocess inside evaluation boundary. */ -let rec pp_eval = (d: DHExp.t): m(DHExp.t) => - switch (d) { +let rec pp_eval = (d: DHExp.t): m(DHExp.t) => { + let (term, rewrap) = DHExp.unwrap(d); + switch (term) { /* Non-hole expressions: recurse through subexpressions */ | Test(_) | Bool(_) @@ -51,37 +52,37 @@ let rec pp_eval = (d: DHExp.t): m(DHExp.t) => | Seq(d1, d2) => let* d1' = pp_eval(d1); let+ d2' = pp_eval(d2); - Seq(d1', d2'); + Seq(d1', d2') |> rewrap; | Filter(f, dbody) => let+ dbody' = pp_eval(dbody); - Filter(f, dbody'); + Filter(f, dbody') |> rewrap; | Ap(d1, d2) => let* d1' = pp_eval(d1); let* d2' = pp_eval(d2); - Ap(d1', d2') |> return; + Ap(d1', d2') |> rewrap |> return; | ApBuiltin(f, d1) => let* d1' = pp_eval(d1); - ApBuiltin(f, d1') |> return; + ApBuiltin(f, d1') |> rewrap |> return; | BinOp(op, d1, d2) => let* d1' = pp_eval(d1); let* d2' = pp_eval(d2); - BinOp(op, d1', d2') |> return; + BinOp(op, d1', d2') |> rewrap |> return; - | BuiltinFun(f) => BuiltinFun(f) |> return + | BuiltinFun(f) => BuiltinFun(f) |> rewrap |> return | Cons(d1, d2) => let* d1' = pp_eval(d1); let* d2' = pp_eval(d2); - Cons(d1', d2') |> return; + Cons(d1', d2') |> rewrap |> return; | ListConcat(d1, d2) => let* d1' = pp_eval(d1); let* d2' = pp_eval(d2); - ListConcat(d1', d2') |> return; + ListConcat(d1', d2') |> rewrap |> return; | ListLit(a, b, c, ds) => let+ ds = @@ -94,7 +95,7 @@ let rec pp_eval = (d: DHExp.t): m(DHExp.t) => }, return([]), ); - ListLit(a, b, c, ds); + ListLit(a, b, c, ds) |> rewrap; | Tuple(ds) => let+ ds = @@ -107,37 +108,37 @@ let rec pp_eval = (d: DHExp.t): m(DHExp.t) => }, return([]), ); - Tuple(ds); + Tuple(ds) |> rewrap; | Prj(d, n) => let+ d = pp_eval(d); - Prj(d, n); + Prj(d, n) |> rewrap; | Cast(d', ty1, ty2) => let* d'' = pp_eval(d'); - Cast(d'', ty1, ty2) |> return; + Cast(d'', ty1, ty2) |> rewrap |> return; | FailedCast(d', ty1, ty2) => let* d'' = pp_eval(d'); - FailedCast(d'', ty1, ty2) |> return; + FailedCast(d'', ty1, ty2) |> rewrap |> return; | InvalidOperation(d', reason) => let* d'' = pp_eval(d'); - InvalidOperation(d'', reason) |> return; + InvalidOperation(d'', reason) |> rewrap |> return; | If(consistent, c, d1, d2) => let* c' = pp_eval(c); let* d1' = pp_eval(d1); let* d2' = pp_eval(d2); - If(consistent, c', d1', d2') |> return; + If(consistent, c', d1', d2') |> rewrap |> return; // TODO: Add consistent case /* These expression forms should not exist outside closure in evaluated result */ | Var(_) | Let(_) + | Fun(_, _, _, None, _) | Match(_) - | Fun(_) | EmptyHole(_) | NonEmptyHole(_) | ExpandingKeyword(_) @@ -151,22 +152,27 @@ let rec pp_eval = (d: DHExp.t): m(DHExp.t) => Some parts of `d'` may lie inside and outside the evaluation boundary, use `pp_eval` and `pp_uneval` as necessary. */ + | Fun(dp, ty, d, Some(env), s) => + let* env = + Util.TimeUtil.measure_time("pp_eval_env/FunClosure", true, () => + pp_eval_env(env) + ); + let* d = pp_uneval(env, d); + Fun(dp, ty, d, Some(env), s) |> rewrap |> return; + | Closure(env, d) => let* env = Util.TimeUtil.measure_time("pp_eval_env/Closure", true, () => pp_eval_env(env) ); - switch (d) { + let (term, rewrap) = DHExp.unwrap(d); + switch (term) { /* Non-hole constructs inside closures. */ - | Fun(dp, ty, d, s) => - let* d = pp_uneval(env, d); - Fun(dp, ty, d, s) |> return; - | Let(dp, d1, d2) => /* d1 should already be evaluated, d2 is not */ let* d1 = pp_eval(d1); let* d2 = pp_uneval(env, d2); - Let(dp, d1, d2) |> return; + Let(dp, d1, d2) |> rewrap |> return; | Match(Consistent, scrut, rules) => /* scrut should already be evaluated, rule bodies are not */ @@ -178,7 +184,7 @@ let rec pp_eval = (d: DHExp.t): m(DHExp.t) => Util.TimeUtil.measure_time("pp_uneval_rules", true, () => pp_uneval_rules(env, rules) ); - Match(Consistent, scrut, rules) |> return; + Match(Consistent, scrut, rules) |> rewrap |> return; /* Hole constructs inside closures. @@ -190,12 +196,16 @@ let rec pp_eval = (d: DHExp.t): m(DHExp.t) => | NonEmptyHole(reason, u, _, d) => let* d = pp_eval(d); let* i = hii_add_instance(u, env); - Closure(env, NonEmptyHole(reason, u, i, d)) |> return; + Closure(env, NonEmptyHole(reason, u, i, d) |> rewrap) + |> fresh + |> return; | Match(Inconsistent(u, _), scrut, rules) => let* scrut = pp_eval(scrut); let* i = hii_add_instance(u, env); - Closure(env, Match(Inconsistent(u, i), scrut, rules)) |> return; + Closure(env, Match(Inconsistent(u, i), scrut, rules) |> rewrap) + |> fresh + |> return; | EmptyHole(_) | ExpandingKeyword(_) @@ -205,7 +215,8 @@ let rec pp_eval = (d: DHExp.t): m(DHExp.t) => /* Other expression forms cannot be directly in a closure. */ | _ => raise(Exception(InvalidClosureBody)) }; - } + }; +} /* Recurse through environments, using memoized result if available. */ and pp_eval_env = (env: ClosureEnvironment.t): m(ClosureEnvironment.t) => { @@ -220,13 +231,15 @@ and pp_eval_env = (env: ClosureEnvironment.t): m(ClosureEnvironment.t) => { |> ClosureEnvironment.fold( ((x, d), env') => { let* env' = env'; - let* d' = - switch (d) { + let* d' = { + let (term, rewrap) = DHExp.unwrap(d); + switch (term) { | FixF(f, ty, d1) => let+ d1 = pp_uneval(env', d1); - FixF(f, ty, d1); - | d => pp_eval(d) + FixF(f, ty, d1) |> rewrap; + | _ => pp_eval(d) }; + }; ClosureEnvironment.extend(env', (x, d')) |> return; }, Environment.empty |> ClosureEnvironment.wrap(ei) |> return, @@ -241,8 +254,9 @@ and pp_eval_env = (env: ClosureEnvironment.t): m(ClosureEnvironment.t) => { Postprocess inside evaluation boundary. Environment should already be postprocessed. */ -and pp_uneval = (env: ClosureEnvironment.t, d: DHExp.t): m(DHExp.t) => - switch (d) { +and pp_uneval = (env: ClosureEnvironment.t, d: DHExp.t): m(DHExp.t) => { + let (term, rewrap) = DHExp.unwrap(d); + switch (term) { /* Bound variables should be looked up within the closure environment. If lookup fails, then variable is not bound. */ | Var(x) => @@ -260,59 +274,59 @@ and pp_uneval = (env: ClosureEnvironment.t, d: DHExp.t): m(DHExp.t) => | Test(id, d1) => let+ d1' = pp_uneval(env, d1); - Test(id, d1'); + Test(id, d1') |> rewrap; | Seq(d1, d2) => let* d1' = pp_uneval(env, d1); let+ d2' = pp_uneval(env, d2); - Seq(d1', d2'); + Seq(d1', d2') |> rewrap; | Filter(flt, dbody) => let+ dbody' = pp_uneval(env, dbody); - Filter(flt, dbody'); + Filter(flt, dbody') |> rewrap; | Let(dp, d1, d2) => let* d1' = pp_uneval(env, d1); let* d2' = pp_uneval(env, d2); - Let(dp, d1', d2') |> return; + Let(dp, d1', d2') |> rewrap |> return; | FixF(f, ty, d1) => let* d1' = pp_uneval(env, d1); - FixF(f, ty, d1') |> return; + FixF(f, ty, d1') |> rewrap |> return; - | Fun(dp, ty, d', s) => + | Fun(dp, ty, d', None, s) => let* d'' = pp_uneval(env, d'); - Fun(dp, ty, d'', s) |> return; + Fun(dp, ty, d'', None, s) |> rewrap |> return; | Ap(d1, d2) => let* d1' = pp_uneval(env, d1); let* d2' = pp_uneval(env, d2); - Ap(d1', d2') |> return; + Ap(d1', d2') |> rewrap |> return; | ApBuiltin(f, d1) => let* d1' = pp_uneval(env, d1); - ApBuiltin(f, d1') |> return; - | BuiltinFun(f) => BuiltinFun(f) |> return + ApBuiltin(f, d1') |> rewrap |> return; + | BuiltinFun(f) => BuiltinFun(f) |> rewrap |> return | BinOp(op, d1, d2) => let* d1' = pp_uneval(env, d1); let* d2' = pp_uneval(env, d2); - BinOp(op, d1', d2') |> return; + BinOp(op, d1', d2') |> rewrap |> return; | If(consistent, c, d1, d2) => let* c' = pp_uneval(env, c); let* d1' = pp_uneval(env, d1); let* d2' = pp_uneval(env, d2); - If(consistent, c', d1', d2') |> return; + If(consistent, c', d1', d2') |> rewrap |> return; | Cons(d1, d2) => let* d1' = pp_uneval(env, d1); let* d2' = pp_uneval(env, d2); - Cons(d1', d2') |> return; + Cons(d1', d2') |> rewrap |> return; | ListConcat(d1, d2) => let* d1' = pp_uneval(env, d1); let* d2' = pp_uneval(env, d2); - ListConcat(d1', d2') |> return; + ListConcat(d1', d2') |> rewrap |> return; | ListLit(a, b, c, ds) => let+ ds = @@ -325,7 +339,7 @@ and pp_uneval = (env: ClosureEnvironment.t, d: DHExp.t): m(DHExp.t) => }, return([]), ); - ListLit(a, b, c, ds); + ListLit(a, b, c, ds) |> rewrap; | Tuple(ds) => let+ ds = @@ -338,30 +352,31 @@ and pp_uneval = (env: ClosureEnvironment.t, d: DHExp.t): m(DHExp.t) => }, return([]), ); - Tuple(ds); + Tuple(ds) |> rewrap; | Prj(d, n) => let+ d = pp_uneval(env, d); - Prj(d, n); + Prj(d, n) |> rewrap; | Cast(d', ty1, ty2) => let* d'' = pp_uneval(env, d'); - Cast(d'', ty1, ty2) |> return; + Cast(d'', ty1, ty2) |> rewrap |> return; | FailedCast(d', ty1, ty2) => let* d'' = pp_uneval(env, d'); - FailedCast(d'', ty1, ty2) |> return; + FailedCast(d'', ty1, ty2) |> rewrap |> return; | InvalidOperation(d', reason) => let* d'' = pp_uneval(env, d'); - InvalidOperation(d'', reason) |> return; + InvalidOperation(d'', reason) |> rewrap |> return; | Match(Consistent, scrut, rules) => let* scrut' = pp_uneval(env, scrut); let* rules' = pp_uneval_rules(env, rules); - Match(Consistent, scrut', rules') |> return; + Match(Consistent, scrut', rules') |> rewrap |> return; /* Closures shouldn't exist inside other closures */ + | Fun(_, _, _, Some(_), _) | Closure(_) => raise(Exception(ClosureInsideClosure)) /* Hole expressions: @@ -371,31 +386,34 @@ and pp_uneval = (env: ClosureEnvironment.t, d: DHExp.t): m(DHExp.t) => */ | EmptyHole(u, _) => let* i = hii_add_instance(u, env); - Closure(env, EmptyHole(u, i)) |> return; + Closure(env, EmptyHole(u, i) |> rewrap) |> fresh |> return; | NonEmptyHole(reason, u, _, d') => let* d' = pp_uneval(env, d'); let* i = hii_add_instance(u, env); - Closure(env, NonEmptyHole(reason, u, i, d')) |> return; + Closure(env, NonEmptyHole(reason, u, i, d') |> rewrap) |> fresh |> return; | ExpandingKeyword(u, _, kw) => let* i = hii_add_instance(u, env); - Closure(env, ExpandingKeyword(u, i, kw)) |> return; + Closure(env, ExpandingKeyword(u, i, kw) |> rewrap) |> fresh |> return; | FreeVar(u, _, x) => let* i = hii_add_instance(u, env); - Closure(env, FreeVar(u, i, x)) |> return; + Closure(env, FreeVar(u, i, x) |> rewrap) |> fresh |> return; | InvalidText(u, _, text) => let* i = hii_add_instance(u, env); - Closure(env, InvalidText(u, i, text)) |> return; + Closure(env, InvalidText(u, i, text) |> rewrap) |> fresh |> return; | Match(Inconsistent(u, _), scrut, rules) => let* scrut = pp_uneval(env, scrut); let* rules = pp_uneval_rules(env, rules); let* i = hii_add_instance(u, env); - Closure(env, Match(Inconsistent(u, i), scrut, rules)) |> return; - } + Closure(env, Match(Inconsistent(u, i), scrut, rules) |> rewrap) + |> fresh + |> return; + }; +} and pp_uneval_rules = (env: ClosureEnvironment.t, rules: list((DHPat.t, DHExp.t))) @@ -422,7 +440,7 @@ and pp_uneval_rules = let rec track_children_of_hole = (hii: HoleInstanceInfo.t, parent: HoleInstanceParents.t_, d: DHExp.t) : HoleInstanceInfo.t => - switch (d) { + switch (DHExp.term_of(d)) { | Constructor(_) | Bool(_) | Int(_) @@ -432,7 +450,7 @@ let rec track_children_of_hole = | Var(_) => hii | Test(_, d) | FixF(_, _, d) - | Fun(_, _, d, _) + | Fun(_, _, d, _, _) | Prj(d, _) | Cast(d, _, _) | FailedCast(d, _, _) diff --git a/src/haz3lcore/dynamics/EvaluatorStep.re b/src/haz3lcore/dynamics/EvaluatorStep.re index 4cdd745a44..37cc72f87f 100644 --- a/src/haz3lcore/dynamics/EvaluatorStep.re +++ b/src/haz3lcore/dynamics/EvaluatorStep.re @@ -8,6 +8,8 @@ type step = { d_loc': DHExp.t, ctx: EvalCtx.t, knd: step_kind, + from_id: Id.t, + to_id: Id.t, }; let unwrap = (step, sel: EvalCtx.cls) => @@ -150,11 +152,13 @@ module Decompose = { module Decomp = Transition(DecomposeEVMode); let rec decompose = (state, env, exp) => { - switch (exp) { + let (term, rewrap) = DHExp.unwrap(exp); + switch (term) { | DHExp.Filter(flt, d1) => DecomposeEVMode.( { - let. _ = otherwise(env, (d1) => (Filter(flt, d1): DHExp.t)) + let. _ = + otherwise(env, (d1) => (Filter(flt, d1) |> rewrap: DHExp.t)) and. d1 = req_final(decompose(state, env), d1 => Filter(flt, d1), d1); Step({apply: () => d1, kind: CompleteFilter, value: true}); @@ -219,94 +223,94 @@ let rec compose = (ctx: EvalCtx.t, d: DHExp.t): DHExp.t => { | Mark => d | Closure(env, ctx) => let d = compose(ctx, d); - Closure(env, d); + Closure(env, d) |> fresh; | Filter(flt, ctx) => let d = compose(ctx, d); - Filter(flt, d); + Filter(flt, d) |> fresh; | Seq1(ctx, d2) => let d1 = compose(ctx, d); - Seq(d1, d2); + Seq(d1, d2) |> fresh; | Seq2(d1, ctx) => let d2 = compose(ctx, d); - Seq(d1, d2); + Seq(d1, d2) |> fresh; | Ap1(ctx, d2) => let d1 = compose(ctx, d); - Ap(d1, d2); + Ap(d1, d2) |> fresh; | Ap2(d1, ctx) => let d2 = compose(ctx, d); - Ap(d1, d2); + Ap(d1, d2) |> fresh; | ApBuiltin(s, ctx) => let d' = compose(ctx, d); - ApBuiltin(s, d'); + ApBuiltin(s, d') |> fresh; | If1(c, ctx, d2, d3) => let d' = compose(ctx, d); - If(c, d', d2, d3); + If(c, d', d2, d3) |> fresh; | If2(c, d1, ctx, d3) => let d' = compose(ctx, d); - If(c, d1, d', d3); + If(c, d1, d', d3) |> fresh; | If3(c, d1, d2, ctx) => let d' = compose(ctx, d); - If(c, d1, d2, d'); + If(c, d1, d2, d') |> fresh; | Test(lit, ctx) => let d1 = compose(ctx, d); - Test(lit, d1); + Test(lit, d1) |> fresh; | BinOp1(op, ctx, d2) => let d1 = compose(ctx, d); - BinOp(op, d1, d2); + BinOp(op, d1, d2) |> fresh; | BinOp2(op, d1, ctx) => let d2 = compose(ctx, d); - BinOp(op, d1, d2); + BinOp(op, d1, d2) |> fresh; | Cons1(ctx, d2) => let d1 = compose(ctx, d); - Cons(d1, d2); + Cons(d1, d2) |> fresh; | Cons2(d1, ctx) => let d2 = compose(ctx, d); - Cons(d1, d2); + Cons(d1, d2) |> fresh; | ListConcat1(ctx, d2) => let d1 = compose(ctx, d); - ListConcat(d1, d2); + ListConcat(d1, d2) |> fresh; | ListConcat2(d1, ctx) => let d2 = compose(ctx, d); - ListConcat(d1, d2); + ListConcat(d1, d2) |> fresh; | Tuple(ctx, (ld, rd)) => let d = compose(ctx, d); - Tuple(rev_concat(ld, [d, ...rd])); + Tuple(rev_concat(ld, [d, ...rd])) |> fresh; | ListLit(m, i, t, ctx, (ld, rd)) => let d = compose(ctx, d); - ListLit(m, i, t, rev_concat(ld, [d, ...rd])); + ListLit(m, i, t, rev_concat(ld, [d, ...rd])) |> fresh; | Let1(dp, ctx, d2) => let d = compose(ctx, d); - Let(dp, d, d2); + Let(dp, d, d2) |> fresh; | Let2(dp, d1, ctx) => let d = compose(ctx, d); - Let(dp, d1, d); - | Fun(dp, t, ctx, v) => + Let(dp, d1, d) |> fresh; + | Fun(dp, t, ctx, env, v) => let d = compose(ctx, d); - Fun(dp, t, d, v); + Fun(dp, t, d, env, v) |> fresh; | FixF(v, t, ctx) => let d = compose(ctx, d); - FixF(v, t, d); + FixF(v, t, d) |> fresh; | Prj(ctx, n) => let d = compose(ctx, d); - Prj(d, n); + Prj(d, n) |> fresh; | Cast(ctx, ty1, ty2) => let d = compose(ctx, d); - Cast(d, ty1, ty2); + Cast(d, ty1, ty2) |> fresh; | FailedCast(ctx, ty1, ty2) => let d = compose(ctx, d); - FailedCast(d, ty1, ty2); + FailedCast(d, ty1, ty2) |> fresh; | InvalidOperation(ctx, err) => let d = compose(ctx, d); - InvalidOperation(d, err); + InvalidOperation(d, err) |> fresh; | NonEmptyHole(reason, u, i, ctx) => let d = compose(ctx, d); - NonEmptyHole(reason, u, i, d); + NonEmptyHole(reason, u, i, d) |> fresh; | MatchScrut(c, ctx, rules) => let d = compose(ctx, d); - Match(c, d, rules); + Match(c, d, rules) |> fresh; | MatchRule(c, scr, p, ctx, (lr, rr)) => let d = compose(ctx, d); - Match(c, scr, rev_concat(lr, [(p, d), ...rr])); + Match(c, scr, rev_concat(lr, [(p, d), ...rr])) |> fresh; } ); }; diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index 55928a2ed2..554fb63ad1 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -1,27 +1,29 @@ let rec matches_exp = (env: ClosureEnvironment.t, d: DHExp.t, f: DHExp.t): bool => { - switch (d, f) { + switch (DHExp.term_of(d), DHExp.term_of(f)) { | (Constructor("$e"), _) => failwith("$e in matched expression") | (Constructor("$v"), _) => failwith("$v in matched expression") // HACK[Matt]: ignore fixpoints in comparison, to allow pausing on fixpoint steps - | (FixF(dp, _, dc), f) => + | (FixF(dp, _, dc), _) => matches_exp( env, Closure( Transition.evaluate_extend_env(Environment.singleton((dp, dc)), env), dc, - ), + ) + |> DHExp.fresh, f, ) - | (d, FixF(fp, _, fc)) => + | (_, FixF(fp, _, fc)) => matches_exp( env, d, Closure( Transition.evaluate_extend_env(Environment.singleton((fp, fc)), env), fc, - ), + ) + |> DHExp.fresh, ) | (_, Constructor("$v")) => @@ -75,14 +77,19 @@ let rec matches_exp = | (String(dv), String(fv)) => dv == fv | (String(_), _) => false - | (Constructor(_), Ap(Constructor("~MVal"), Tuple([]))) => true + | (Constructor(_), Ap(d1, d2)) => + switch (DHExp.term_of(d1), DHExp.term_of(d2)) { + | (Constructor("~MVal"), Tuple([])) => true + | _ => false + } | (Constructor(dt), Constructor(ft)) => dt == ft | (Constructor(_), _) => false | (BuiltinFun(dn), BuiltinFun(fn)) => dn == fn | (BuiltinFun(_), _) => false - | (Fun(dp1, dty1, d1, dname1), Fun(fp1, fty1, f1, fname1)) => + // Not sure if we should be checking functions for closures here + | (Fun(dp1, dty1, d1, _, dname1), Fun(fp1, fty1, f1, _, fname1)) => matches_pat(dp1, fp1) && dty1 == fty1 && matches_exp(env, d1, f1) diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index a33094c98f..78d7881a4b 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -29,7 +29,7 @@ let cast_sum_maps = }; let rec matches = (dp: DHPat.t, d: DHExp.t): match_result => - switch (dp, d) { + switch (dp, DHExp.term_of(d)) { | (_, Var(_)) => DoesNotMatch | (EmptyHole(_), _) | (NonEmptyHole(_), _) => IndetMatch @@ -207,7 +207,7 @@ and matches_cast_Sum = castmaps: list(ConstructorMap.t((Typ.t, Typ.t))), ) : match_result => - switch (d) { + switch (DHExp.term_of(d)) { | Constructor(ctr') => switch ( dp, @@ -217,14 +217,20 @@ and matches_cast_Sum = ctr == ctr' ? Matches(Environment.empty) : DoesNotMatch | _ => DoesNotMatch } - | Ap(Constructor(ctr'), d') => - switch ( - dp, - castmaps |> List.map(ConstructorMap.find_opt(ctr')) |> OptUtil.sequence, - ) { - | (Some(dp), Some(side_casts)) => - matches(dp, DHExp.apply_casts(d', side_casts)) - | _ => DoesNotMatch + | Ap(d1, d2) => + switch (DHExp.term_of(d1)) { + | Constructor(ctr') => + switch ( + dp, + castmaps + |> List.map(ConstructorMap.find_opt(ctr')) + |> OptUtil.sequence, + ) { + | (Some(dp), Some(side_casts)) => + matches(dp, DHExp.apply_casts(d2, side_casts)) + | _ => DoesNotMatch + } + | _ => IndetMatch } | Cast(d', Sum(sm1) | Rec(_, Sum(sm1)), Sum(sm2) | Rec(_, Sum(sm2))) => switch (cast_sum_maps(sm1, sm2)) { @@ -238,7 +244,6 @@ and matches_cast_Sum = | ExpandingKeyword(_) | InvalidText(_) | Let(_) - | Ap(_) | ApBuiltin(_) | BinOp(_) | EmptyHole(_) @@ -273,7 +278,7 @@ and matches_cast_Tuple = elt_casts: list(list((Typ.t, Typ.t))), ) : match_result => - switch (d) { + switch (DHExp.term_of(d)) { | Tuple(ds) => if (List.length(dps) != List.length(ds)) { DoesNotMatch; @@ -328,8 +333,7 @@ and matches_cast_Tuple = | ExpandingKeyword(_) => IndetMatch | Let(_, _, _) => IndetMatch | FixF(_, _, _) => DoesNotMatch - | Fun(_, _, _, _) => DoesNotMatch - | Closure(_, Fun(_)) => DoesNotMatch + | Fun(_, _, _, _, _) => DoesNotMatch | Closure(_, _) => IndetMatch | Filter(_, _) => IndetMatch | Ap(_, _) => IndetMatch @@ -356,7 +360,7 @@ and matches_cast_Tuple = } and matches_cast_Cons = (dp: DHPat.t, d: DHExp.t, elt_casts: list((Typ.t, Typ.t))): match_result => - switch (d) { + switch (DHExp.term_of(d)) { | ListLit(_, _, _, []) => switch (dp) { | ListLit(_, []) => Matches(Environment.empty) @@ -377,7 +381,7 @@ and matches_cast_Cons = }, elt_casts, ); - let d2 = DHExp.ListLit(u, i, ty, dtl); + let d2 = DHExp.ListLit(u, i, ty, dtl) |> DHExp.fresh; switch (matches(dp2, DHExp.apply_casts(d2, list_casts))) { | DoesNotMatch => DoesNotMatch | IndetMatch => IndetMatch @@ -464,7 +468,7 @@ and matches_cast_Cons = | ExpandingKeyword(_) => IndetMatch | Let(_, _, _) => IndetMatch | FixF(_, _, _) => DoesNotMatch - | Fun(_, _, _, _) => DoesNotMatch + | Fun(_, _, _, _, _) => DoesNotMatch | Closure(_, d') => matches_cast_Cons(dp, d', elt_casts) | Filter(_, d') => matches_cast_Cons(dp, d', elt_casts) | Ap(_, _) => IndetMatch diff --git a/src/haz3lcore/dynamics/Stepper.re b/src/haz3lcore/dynamics/Stepper.re index 51d4dd1b76..644b511776 100644 --- a/src/haz3lcore/dynamics/Stepper.re +++ b/src/haz3lcore/dynamics/Stepper.re @@ -83,9 +83,10 @@ let rec matches = | Let2(d1, d2, ctx) => let+ ctx = matches(env, flt, ctx, exp, act, idx); Let2(d1, d2, ctx); - | Fun(dp, ty, ctx, name) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Fun(dp, ty, ctx, name); + | Fun(dp, ty, ctx, env', name) => + let+ ctx = + matches(Option.value(~default=env, env'), flt, ctx, exp, act, idx); + Fun(dp, ty, ctx, env', name); | FixF(name, ty, ctx) => let+ ctx = matches(env, flt, ctx, exp, act, idx); FixF(name, ty, ctx); @@ -273,7 +274,16 @@ let rec evaluate_pending = (~settings, s: t) => { { elab: s.elab, previous: [ - {d, d_loc: eo.d_loc, d_loc', ctx: eo.ctx, knd: eo.knd, state}, + { + d, + d_loc: eo.d_loc, + d_loc', + ctx: eo.ctx, + knd: eo.knd, + state, + from_id: DHExp.rep_id(eo.d_loc), + to_id: DHExp.rep_id(d_loc'), + }, ...s.previous, ], current: StepPending(d', state_ref^, None), diff --git a/src/haz3lcore/dynamics/Substitution.re b/src/haz3lcore/dynamics/Substitution.re index 2503a6e7b1..ad9b94bf97 100644 --- a/src/haz3lcore/dynamics/Substitution.re +++ b/src/haz3lcore/dynamics/Substitution.re @@ -1,6 +1,7 @@ /* closed substitution [d1/x]d2 */ -let rec subst_var = (d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => - switch (d2) { +let rec subst_var = (d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => { + let (term, rewrap) = DHExp.unwrap(d2); + switch (term) { | Var(y) => if (Var.eq(x, y)) { d1; @@ -13,11 +14,11 @@ let rec subst_var = (d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => | Seq(d3, d4) => let d3 = subst_var(d1, x, d3); let d4 = subst_var(d1, x, d4); - Seq(d3, d4); + Seq(d3, d4) |> rewrap; | Filter(filter, dbody) => let dbody = subst_var(d1, x, dbody); let filter = subst_var_filter(d1, x, filter); - Filter(filter, dbody); + Filter(filter, dbody) |> rewrap; | Let(dp, d3, d4) => let d3 = subst_var(d1, x, d3); let d4 = @@ -26,7 +27,7 @@ let rec subst_var = (d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => } else { subst_var(d1, x, d4); }; - Let(dp, d3, d4); + Let(dp, d3, d4) |> rewrap; | FixF(y, ty, d3) => let d3 = if (Var.eq(x, y)) { @@ -34,50 +35,53 @@ let rec subst_var = (d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => } else { subst_var(d1, x, d3); }; - FixF(y, ty, d3); - | Fun(dp, ty, d3, s) => + FixF(y, ty, d3) |> rewrap; + | Fun(dp, ty, d3, env, s) => + /* Function closure shouldn't appear during substitution + (which only is called from elaboration currently) */ + let env' = Option.map(subst_var_env(d1, x), env); if (DHPat.binds_var(x, dp)) { - Fun(dp, ty, d3, s); + Fun(dp, ty, d3, env', s) |> rewrap; } else { let d3 = subst_var(d1, x, d3); - Fun(dp, ty, d3, s); - } + Fun(dp, ty, d3, env', s) |> rewrap; + }; | Closure(env, d3) => /* Closure shouldn't appear during substitution (which only is called from elaboration currently) */ let env' = subst_var_env(d1, x, env); let d3' = subst_var(d1, x, d3); - Closure(env', d3'); + Closure(env', d3') |> rewrap; | Ap(d3, d4) => let d3 = subst_var(d1, x, d3); let d4 = subst_var(d1, x, d4); - Ap(d3, d4); + Ap(d3, d4) |> rewrap; | ApBuiltin(ident, d1) => let d2 = subst_var(d1, x, d1); - ApBuiltin(ident, d2); - | BuiltinFun(ident) => BuiltinFun(ident) - | Test(id, d3) => Test(id, subst_var(d1, x, d3)) + ApBuiltin(ident, d2) |> rewrap; + | BuiltinFun(_) => d2 + | Test(id, d3) => Test(id, subst_var(d1, x, d3)) |> rewrap | Bool(_) | Int(_) | Float(_) | String(_) | Constructor(_) => d2 | ListLit(a, b, c, ds) => - ListLit(a, b, c, List.map(subst_var(d1, x), ds)) + ListLit(a, b, c, List.map(subst_var(d1, x), ds)) |> rewrap | Cons(d3, d4) => let d3 = subst_var(d1, x, d3); let d4 = subst_var(d1, x, d4); - Cons(d3, d4); + Cons(d3, d4) |> rewrap; | ListConcat(d3, d4) => let d3 = subst_var(d1, x, d3); let d4 = subst_var(d1, x, d4); - ListConcat(d3, d4); - | Tuple(ds) => Tuple(List.map(subst_var(d1, x), ds)) - | Prj(d, n) => Prj(subst_var(d1, x, d), n) + ListConcat(d3, d4) |> rewrap; + | Tuple(ds) => Tuple(List.map(subst_var(d1, x), ds)) |> rewrap + | Prj(d, n) => Prj(subst_var(d1, x, d), n) |> rewrap | BinOp(op, d3, d4) => let d3 = subst_var(d1, x, d3); let d4 = subst_var(d1, x, d4); - BinOp(op, d3, d4); + BinOp(op, d3, d4) |> rewrap; | Match(c, ds, rules) => let ds = subst_var(d1, x, ds); let rules = @@ -90,26 +94,27 @@ let rec subst_var = (d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => }, rules, ); - Match(c, ds, rules); - | EmptyHole(u, i) => EmptyHole(u, i) + Match(c, ds, rules) |> rewrap; + | EmptyHole(u, i) => EmptyHole(u, i) |> rewrap | NonEmptyHole(reason, u, i, d3) => let d3' = subst_var(d1, x, d3); - NonEmptyHole(reason, u, i, d3'); + NonEmptyHole(reason, u, i, d3') |> rewrap; | Cast(d, ty1, ty2) => let d' = subst_var(d1, x, d); - Cast(d', ty1, ty2); + Cast(d', ty1, ty2) |> rewrap; | FailedCast(d, ty1, ty2) => let d' = subst_var(d1, x, d); - FailedCast(d', ty1, ty2); + FailedCast(d', ty1, ty2) |> rewrap; | InvalidOperation(d, err) => let d' = subst_var(d1, x, d); - InvalidOperation(d', err); + InvalidOperation(d', err) |> rewrap; | If(d3, d4, d5, d6) => let d4' = subst_var(d1, x, d4); let d5' = subst_var(d1, x, d5); let d6' = subst_var(d1, x, d6); - If(d3, d4', d5', d6'); - } + If(d3, d4', d5', d6') |> rewrap; + }; +} and subst_var_env = (d1: DHExp.t, x: Var.t, env: ClosureEnvironment.t): ClosureEnvironment.t => { @@ -120,16 +125,16 @@ and subst_var_env = |> Environment.foldo( ((x', d': DHExp.t), map) => { let d' = - switch (d') { + switch (DHExp.term_of(d')) { /* Substitute each previously substituted binding into the * fixpoint. */ - | FixF(_) as d => + | FixF(_) => map |> Environment.foldo( ((x'', d''), d) => subst_var(d'', x'', d), - d, + d', ) - | d => d + | _ => d' }; /* Substitute. */ diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index dbe3e1dd69..4678084073 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -192,78 +192,101 @@ module Transition = (EV: EV_MODE) => { | Matches(env') => r(evaluate_extend_env(env', env)) }; - let transition = (req, state, env, d): 'a => - switch (d) { + /* Note[Matt]: For IDs, I'm currently using a fresh id + if anything about the current node changes, if only its + children change, we use rewrap */ + + let transition = (req, state, env, d): 'a => { + let (term, rewrap) = DHExp.unwrap(d); + switch (term) { | Var(x) => - let. _ = otherwise(env, Var(x)); - let d = - ClosureEnvironment.lookup(env, x) - |> OptUtil.get(() => { - raise(EvaluatorError.Exception(FreeInvalidVar(x))) - }); - Step({apply: () => d, kind: VarLookup, value: false}); + let. _ = otherwise(env, Var(x) |> rewrap); + let to_id = Id.mk(); + Step({ + apply: () => { + let d = + ClosureEnvironment.lookup(env, x) + |> OptUtil.get(() => { + raise(EvaluatorError.Exception(FreeInvalidVar(x))) + }); + d |> fast_copy(to_id); + }, + kind: VarLookup, + value: false, + }); | Seq(d1, d2) => - let. _ = otherwise(env, d1 => Seq(d1, d2)) + let. _ = otherwise(env, d1 => Seq(d1, d2) |> rewrap) and. _ = req_final(req(state, env), d1 => Seq1(d1, d2), d1); Step({apply: () => d2, kind: Seq, value: false}); | Let(dp, d1, d2) => - let. _ = otherwise(env, d1 => Let(dp, d1, d2)) + let. _ = otherwise(env, d1 => Let(dp, d1, d2) |> rewrap) and. d1' = req_final(req(state, env), d1 => Let1(dp, d1, d2), d1); let.match env' = (env, matches(dp, d1')); - Step({apply: () => Closure(env', d2), kind: LetBind, value: false}); - | Fun(_, _, Closure(_), _) => + Step({ + apply: () => Closure(env', d2) |> fresh, + kind: LetBind, + value: false, + }); + | Fun(_, _, _, Some(_), _) => let. _ = otherwise(env, d); Constructor; - | Fun(p, t, d, v) => - let. _ = otherwise(env, Fun(p, t, d, v)); + | Fun(p, t, d1, None, v) => + let. _ = otherwise(env, d); Step({ - apply: () => Fun(p, t, Closure(env, d), v), + apply: () => Fun(p, t, d1, Some(env), v) |> fresh, kind: FunClosure, value: true, }); | FixF(f, t, d1) => - let. _ = otherwise(env, FixF(f, t, d1)); + let. _ = otherwise(env, FixF(f, t, d1) |> rewrap); Step({ apply: () => Closure( evaluate_extend_env(Environment.singleton((f, d1)), env), d1, - ), + ) + |> fresh, kind: FixUnwrap, value: false, }); | Test(id, d) => - let. _ = otherwise(env, d => Test(id, d)) + let. _ = otherwise(env, d => Test(id, d) |> rewrap) and. d' = req_final(req(state, env), d => Test(id, d), d); Step({ apply: () => - switch (d') { + switch (DHExp.term_of(d')) { | Bool(true) => update_test(state, id, (d', Pass)); - Tuple([]); + Tuple([]) |> fresh; | Bool(false) => update_test(state, id, (d', Fail)); - Tuple([]); + Tuple([]) |> fresh; /* Hack: assume if final and not Bool, then Indet; this won't catch errors in statics */ | _ => update_test(state, id, (d', Indet)); - Tuple([]); + Tuple([]) |> fresh; }, kind: UpdateTest, value: true, }); | Ap(d1, d2) => - let. _ = otherwise(env, (d1, d2) => Ap(d1, d2)) + let. _ = otherwise(env, (d1, d2) => Ap(d1, d2) |> rewrap) and. d1' = req_value(req(state, env), d1 => Ap1(d1, d2), d1) and. d2' = req_final(req(state, env), d2 => Ap2(d1, d2), d2); - switch (d1') { + switch (DHExp.term_of(d1')) { | Constructor(_) => Constructor - | Fun(dp, _, Closure(env', d3), _) => + | Fun(dp, _, d3, Some(env'), _) => let.match env'' = (env', matches(dp, d2')); - Step({apply: () => Closure(env'', d3), kind: FunAp, value: false}); + Step({ + apply: () => Closure(env'', d3) |> fresh, + kind: FunAp, + value: false, + }); | Cast(d3', Arrow(ty1, ty2), Arrow(ty1', ty2')) => Step({ - apply: () => Cast(Ap(d3', Cast(d2', ty1', ty1)), ty2, ty2'), + apply: () => + Cast(Ap(d3', Cast(d2', ty1', ty1) |> fresh) |> fresh, ty2, ty2') + |> fresh, kind: CastAp, value: false, }) @@ -271,10 +294,7 @@ module Transition = (EV: EV_MODE) => { Step({ apply: () => { //HACK[Matt]: This step is just so we can check that d2' is not indet - ApBuiltin( - ident, - d2', - ); + ApBuiltin(ident, d2') |> fresh; }, kind: BuiltinWrap, value: false // Not necessarily a value because of InvalidOperations @@ -289,7 +309,7 @@ module Transition = (EV: EV_MODE) => { }) }; | ApBuiltin(ident, arg) => - let. _ = otherwise(env, arg => ApBuiltin(ident, arg)) + let. _ = otherwise(env, arg => ApBuiltin(ident, arg) |> rewrap) and. arg' = req_value(req(state, env), arg => ApBuiltin(ident, arg), arg); Step({ @@ -313,10 +333,10 @@ module Transition = (EV: EV_MODE) => { let. _ = otherwise(env, d); Constructor; | If(consistent, c, d1, d2) => - let. _ = otherwise(env, c => If(consistent, c, d1, d2)) + let. _ = otherwise(env, c => If(consistent, c, d1, d2) |> rewrap) and. c' = req_value(req(state, env), c => If1(consistent, c, d1, d2), c); - switch (consistent, c') { + switch (consistent, DHExp.term_of(c')) { | (Consistent, Bool(b)) => Step({ apply: () => { @@ -339,27 +359,27 @@ module Transition = (EV: EV_MODE) => { | (Inconsistent(_), _) => Indet }; | BinOp(Bool(And), d1, d2) => - let. _ = otherwise(env, d1 => BinOp(Bool(And), d1, d2)) + let. _ = otherwise(env, d1 => BinOp(Bool(And), d1, d2) |> rewrap) and. d1' = req_value(req(state, env), d1 => BinOp1(Bool(And), d1, d2), d1); Step({ apply: () => - switch (d1') { + switch (DHExp.term_of(d1')) { | Bool(true) => d2 - | Bool(false) => Bool(false) + | Bool(false) => Bool(false) |> fresh | _ => raise(EvaluatorError.Exception(InvalidBoxedBoolLit(d1'))) }, kind: BinBoolOp(And), value: false, }); | BinOp(Bool(Or), d1, d2) => - let. _ = otherwise(env, d1 => BinOp(Bool(Or), d1, d2)) + let. _ = otherwise(env, d1 => BinOp(Bool(Or), d1, d2) |> rewrap) and. d1' = req_value(req(state, env), d1 => BinOp1(Bool(Or), d1, d2), d1); Step({ apply: () => - switch (d1') { - | Bool(true) => Bool(true) + switch (DHExp.term_of(d1')) { + | Bool(true) => Bool(true) |> fresh | Bool(false) => d2 | _ => raise(EvaluatorError.Exception(InvalidBoxedBoolLit(d2))) }, @@ -367,38 +387,43 @@ module Transition = (EV: EV_MODE) => { value: false, }); | BinOp(Int(op), d1, d2) => - let. _ = otherwise(env, (d1, d2) => BinOp(Int(op), d1, d2)) + let. _ = otherwise(env, (d1, d2) => BinOp(Int(op), d1, d2) |> rewrap) and. d1' = req_value(req(state, env), d1 => BinOp1(Int(op), d1, d2), d1) and. d2' = req_value(req(state, env), d2 => BinOp2(Int(op), d1, d2), d2); Step({ apply: () => - switch (d1', d2') { + switch (DHExp.term_of(d1'), DHExp.term_of(d2')) { | (Int(n1), Int(n2)) => - switch (op) { - | Plus => Int(n1 + n2) - | Minus => Int(n1 - n2) - | Power when n2 < 0 => - InvalidOperation( - BinOp(Int(op), Int(n1), Int(n2)), - NegativeExponent, - ) - | Power => Int(IntUtil.ipow(n1, n2)) - | Times => Int(n1 * n2) - | Divide when n2 == 0 => - InvalidOperation( - BinOp(Int(op), Int(n1), Int(n2)), - DivideByZero, - ) - | Divide => Int(n1 / n2) - | LessThan => Bool(n1 < n2) - | LessThanOrEqual => Bool(n1 <= n2) - | GreaterThan => Bool(n1 > n2) - | GreaterThanOrEqual => Bool(n1 >= n2) - | Equals => Bool(n1 == n2) - | NotEquals => Bool(n1 != n2) - } + ( + switch (op) { + | Plus => Int(n1 + n2) + | Minus => Int(n1 - n2) + | Power when n2 < 0 => + InvalidOperation( + BinOp(Int(op), Int(n1) |> fresh, Int(n2) |> fresh) + |> fresh, + NegativeExponent, + ) + | Power => Int(IntUtil.ipow(n1, n2)) + | Times => Int(n1 * n2) + | Divide when n2 == 0 => + InvalidOperation( + BinOp(Int(op), Int(n1) |> fresh, Int(n2) |> fresh) + |> fresh, + DivideByZero, + ) + | Divide => Int(n1 / n2) + | LessThan => Bool(n1 < n2) + | LessThanOrEqual => Bool(n1 <= n2) + | GreaterThan => Bool(n1 > n2) + | GreaterThanOrEqual => Bool(n1 >= n2) + | Equals => Bool(n1 == n2) + | NotEquals => Bool(n1 != n2) + } + ) + |> fresh | (Int(_), _) => raise(EvaluatorError.Exception(InvalidBoxedIntLit(d2'))) | _ => raise(EvaluatorError.Exception(InvalidBoxedIntLit(d1'))) @@ -408,28 +433,32 @@ module Transition = (EV: EV_MODE) => { value: false, }); | BinOp(Float(op), d1, d2) => - let. _ = otherwise(env, (d1, d2) => BinOp(Float(op), d1, d2)) + let. _ = + otherwise(env, (d1, d2) => BinOp(Float(op), d1, d2) |> rewrap) and. d1' = req_value(req(state, env), d1 => BinOp1(Float(op), d1, d2), d1) and. d2' = req_value(req(state, env), d2 => BinOp2(Float(op), d1, d2), d2); Step({ apply: () => - switch (d1', d2') { + switch (DHExp.term_of(d1'), DHExp.term_of(d2')) { | (Float(n1), Float(n2)) => - switch (op) { - | Plus => Float(n1 +. n2) - | Minus => Float(n1 -. n2) - | Power => Float(n1 ** n2) - | Times => Float(n1 *. n2) - | Divide => Float(n1 /. n2) - | LessThan => Bool(n1 < n2) - | LessThanOrEqual => Bool(n1 <= n2) - | GreaterThan => Bool(n1 > n2) - | GreaterThanOrEqual => Bool(n1 >= n2) - | Equals => Bool(n1 == n2) - | NotEquals => Bool(n1 != n2) - } + ( + switch (op) { + | Plus => Float(n1 +. n2) + | Minus => Float(n1 -. n2) + | Power => Float(n1 ** n2) + | Times => Float(n1 *. n2) + | Divide => Float(n1 /. n2) + | LessThan => Bool(n1 < n2) + | LessThanOrEqual => Bool(n1 <= n2) + | GreaterThan => Bool(n1 > n2) + | GreaterThanOrEqual => Bool(n1 >= n2) + | Equals => Bool(n1 == n2) + | NotEquals => Bool(n1 != n2) + } + ) + |> fresh | (Float(_), _) => raise(EvaluatorError.Exception(InvalidBoxedFloatLit(d2'))) | _ => raise(EvaluatorError.Exception(InvalidBoxedFloatLit(d1'))) @@ -438,18 +467,19 @@ module Transition = (EV: EV_MODE) => { value: true, }); | BinOp(String(op), d1, d2) => - let. _ = otherwise(env, (d1, d2) => BinOp(String(op), d1, d2)) + let. _ = + otherwise(env, (d1, d2) => BinOp(String(op), d1, d2) |> rewrap) and. d1' = req_value(req(state, env), d1 => BinOp1(String(op), d1, d2), d1) and. d2' = req_value(req(state, env), d2 => BinOp2(String(op), d1, d2), d2); Step({ apply: () => - switch (d1', d2') { + switch (DHExp.term_of(d1'), DHExp.term_of(d2')) { | (String(s1), String(s2)) => switch (op) { - | Concat => String(s1 ++ s2) - | Equals => Bool(s1 == s2) + | Concat => String(s1 ++ s2) |> fresh + | Equals => Bool(s1 == s2) |> fresh } | (String(_), _) => raise(EvaluatorError.Exception(InvalidBoxedStringLit(d2'))) @@ -459,37 +489,40 @@ module Transition = (EV: EV_MODE) => { value: true, }); | Tuple(ds) => - let. _ = otherwise(env, ds => Tuple(ds)) + let. _ = otherwise(env, ds => Tuple(ds) |> rewrap) and. _ = req_all_final(req(state, env), (d1, ds) => Tuple(d1, ds), ds); Constructor; | Prj(d1, n) => - let. _ = otherwise(env, d1 => Prj(d1, n)) + let. _ = otherwise(env, d1 => Prj(d1, n) |> rewrap) and. d1' = req_final(req(state, env), d1 => Prj(d1, n), d1); Step({ - apply: () => - switch (d1') { + apply: () => { + switch (DHExp.term_of(d1')) { | Tuple(ds) when n < 0 || List.length(ds) <= n => raise(EvaluatorError.Exception(InvalidProjection(n))) | Tuple(ds) => List.nth(ds, n) | Cast(_, Prod(ts), Prod(_)) when n < 0 || List.length(ts) <= n => raise(EvaluatorError.Exception(InvalidProjection(n))) | Cast(d2, Prod(ts1), Prod(ts2)) => - Cast(Prj(d2, n), List.nth(ts1, n), List.nth(ts2, n)) + Cast(Prj(d2, n) |> rewrap, List.nth(ts1, n), List.nth(ts2, n)) + |> fresh | _ => raise(EvaluatorError.Exception(InvalidProjection(n))) - }, + }; + }, kind: Projection, value: false, }); // TODO(Matt): Can we do something cleverer when the list structure is complete but the contents aren't? | Cons(d1, d2) => - let. _ = otherwise(env, (d1, d2) => Cons(d1, d2)) + let. _ = otherwise(env, (d1, d2) => Cons(d1, d2) |> rewrap) and. d1' = req_final(req(state, env), d1 => Cons1(d1, d2), d1) and. d2' = req_value(req(state, env), d2 => Cons2(d1, d2), d2); Step({ apply: () => - switch (d2') { - | ListLit(u, i, ty, ds) => ListLit(u, i, ty, [d1', ...ds]) + switch (term_of(d2')) { + | ListLit(u, i, ty, ds) => + ListLit(u, i, ty, [d1', ...ds]) |> fresh | _ => raise(EvaluatorError.Exception(InvalidBoxedListLit(d2'))) }, kind: ListCons, @@ -497,14 +530,14 @@ module Transition = (EV: EV_MODE) => { }); | ListConcat(d1, d2) => // TODO(Matt): Can we do something cleverer when the list structure is complete but the contents aren't? - let. _ = otherwise(env, (d1, d2) => ListConcat(d1, d2)) + let. _ = otherwise(env, (d1, d2) => ListConcat(d1, d2) |> rewrap) and. d1' = req_value(req(state, env), d1 => ListConcat1(d1, d2), d1) and. d2' = req_value(req(state, env), d2 => ListConcat2(d1, d2), d2); Step({ apply: () => - switch (d1', d2') { + switch (term_of(d1'), term_of(d2')) { | (ListLit(u1, i1, t1, ds1), ListLit(_, _, _, ds2)) => - ListLit(u1, i1, t1, ds1 @ ds2) + ListLit(u1, i1, t1, ds1 @ ds2) |> fresh | (ListLit(_), _) => raise(EvaluatorError.Exception(InvalidBoxedListLit(d2'))) | (_, _) => @@ -514,7 +547,7 @@ module Transition = (EV: EV_MODE) => { value: true, }); | ListLit(u, i, ty, ds) => - let. _ = otherwise(env, ds => ListLit(u, i, ty, ds)) + let. _ = otherwise(env, ds => ListLit(u, i, ty, ds) |> rewrap) and. _ = req_all_final( req(state, env), @@ -523,7 +556,7 @@ module Transition = (EV: EV_MODE) => { ); Constructor; | Match(Consistent, d1, rules) => - let. _ = otherwise(env, d1 => Match(Consistent, d1, rules)) + let. _ = otherwise(env, d1 => Match(Consistent, d1, rules) |> rewrap) and. d1 = req_final( req(state, env), @@ -543,21 +576,21 @@ module Transition = (EV: EV_MODE) => { switch (next_rule(rules)) { | Some((env', d2)) => Step({ - apply: () => Closure(evaluate_extend_env(env', env), d2), + apply: () => Closure(evaluate_extend_env(env', env), d2) |> fresh, kind: CaseApply, value: false, }) | None => Indet }; - | Match(Inconsistent(_, _), _, _) as d => + | Match(Inconsistent(_, _), _, _) => let. _ = otherwise(env, d); Indet; | Closure(env', d) => - let. _ = otherwise(env, d => Closure(env', d)) + let. _ = otherwise(env, d => Closure(env', d) |> rewrap) and. d' = req_value(req(state, env'), d1 => Closure(env', d1), d); Step({apply: () => d', kind: CompleteClosure, value: true}); | NonEmptyHole(reason, u, i, d1) => - let. _ = otherwise(env, d1 => NonEmptyHole(reason, u, i, d1)) + let. _ = otherwise(env, d1 => NonEmptyHole(reason, u, i, d1) |> rewrap) and. _ = req_final( req(state, env), @@ -575,7 +608,7 @@ module Transition = (EV: EV_MODE) => { | Cast(d, t1, t2) => open CastHelpers; /* Cast calculus */ - let. _ = otherwise(env, d => Cast(d, t1, t2)) + let. _ = otherwise(env, d => Cast(d, t1, t2) |> rewrap) and. d' = req_final(req(state, env), d => Cast(d, t1, t2), d); switch (ground_cases_of(t1), ground_cases_of(t2)) { | (Hole, Hole) @@ -586,14 +619,14 @@ module Transition = (EV: EV_MODE) => { /* can't remove the cast or do anything else here, so we're done */ Constructor | (Hole, Ground) => - switch (d') { + switch (term_of(d')) { | Cast(d2, t3, Unknown(_)) => /* by canonical forms, d1' must be of the form d ?> */ if (Typ.eq(t3, t2)) { Step({apply: () => d2, kind: Cast, value: true}); } else { Step({ - apply: () => FailedCast(d', t1, t2), + apply: () => FailedCast(d', t1, t2) |> fresh, kind: Cast, value: false, }); @@ -604,7 +637,8 @@ module Transition = (EV: EV_MODE) => { /* ITExpand rule */ Step({ apply: () => - DHExp.Cast(Cast(d', t1, t2_grounded), t2_grounded, t2), + DHExp.Cast(Cast(d', t1, t2_grounded) |> fresh, t2_grounded, t2) + |> fresh, kind: Cast, value: false, }) @@ -612,7 +646,8 @@ module Transition = (EV: EV_MODE) => { /* ITGround rule */ Step({ apply: () => - DHExp.Cast(Cast(d', t1, t1_grounded), t1_grounded, t2), + DHExp.Cast(Cast(d', t1, t1_grounded) |> fresh, t1_grounded, t2) + |> fresh, kind: Cast, value: false, }) @@ -629,14 +664,15 @@ module Transition = (EV: EV_MODE) => { } }; | FailedCast(d1, t1, t2) => - let. _ = otherwise(env, d1 => FailedCast(d1, t1, t2)) + let. _ = otherwise(env, d1 => FailedCast(d1, t1, t2) |> rewrap) and. _ = req_final(req(state, env), d1 => FailedCast(d1, t1, t2), d1); Indet; | Filter(f1, d1) => - let. _ = otherwise(env, d1 => Filter(f1, d1)) + let. _ = otherwise(env, d1 => Filter(f1, d1) |> rewrap) and. d1 = req_final(req(state, env), d1 => Filter(f1, d1), d1); Step({apply: () => d1, kind: CompleteFilter, value: true}); }; + }; }; let should_hide_step = (~settings: CoreSettings.Evaluation.t) => diff --git a/src/haz3lcore/dynamics/ValueChecker.re b/src/haz3lcore/dynamics/ValueChecker.re index 28a7c95646..8975c48bbe 100644 --- a/src/haz3lcore/dynamics/ValueChecker.re +++ b/src/haz3lcore/dynamics/ValueChecker.re @@ -80,8 +80,8 @@ let rec check_value = ((), env, d) => CV.transition(check_value, (), env, d); let check_value = check_value(); -let rec check_value_mod_ctx = ((), env) => - fun +let rec check_value_mod_ctx = ((), env, d) => + switch (DHExp.term_of(d)) { | Var(x) => check_value_mod_ctx( (), @@ -92,6 +92,7 @@ let rec check_value_mod_ctx = ((), env) => raise(EvaluatorError.Exception(FreeInvalidVar(x))); }), ) - | d => CV.transition(check_value_mod_ctx, (), env, d); + | _ => CV.transition(check_value_mod_ctx, (), env, d) + }; let check_value_mod_ctx = check_value_mod_ctx(); diff --git a/src/haz3lcore/prog/Interface.re b/src/haz3lcore/prog/Interface.re index ab6d3a4acb..24d5978a5c 100644 --- a/src/haz3lcore/prog/Interface.re +++ b/src/haz3lcore/prog/Interface.re @@ -33,7 +33,7 @@ module Statics = { }; let dh_err = (error: string): DHExp.t => - InvalidText(Id.invalid, -666, error); + InvalidText(Id.invalid, -666, error) |> DHExp.fresh; let elaborate = Core.Memo.general(~cache_size_bound=1000, Elaborator.uexp_elab); @@ -130,7 +130,7 @@ let evaluate = let init = (d: DHExp.t): ProgramResult.t => { let es = EvaluatorState.init; let env = ClosureEnvironment.of_environment(Builtins.env_init); - (Indet(Closure(env, d)), es); + (Indet(Closure(env, d) |> DHExp.fresh), es); }; let eval_z = diff --git a/src/haz3lweb/view/ExplainThis.re b/src/haz3lweb/view/ExplainThis.re index 0fdebc8992..5d76b26120 100644 --- a/src/haz3lweb/view/ExplainThis.re +++ b/src/haz3lweb/view/ExplainThis.re @@ -439,7 +439,7 @@ let example_view = DHExp.Filter( Filter( Filter.mk( - Constructor("$e"), + Constructor("$e") |> DHExp.fresh, (FilterAction.Eval, FilterAction.All), ), ), @@ -447,6 +447,7 @@ let example_view = ); let stepper = dhexp + |> DHExp.fresh |> Stepper.init |> Stepper.evaluate_full(~settings=settings.core.evaluation); let (hidden, previous) = diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index 29bb9c94a0..81e6a917ed 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -44,7 +44,7 @@ let precedence_bin_string_op = (bso: TermBase.UExp.op_bin_string) => }; let rec precedence = (~show_casts: bool, d: DHExp.t) => { let precedence' = precedence(~show_casts); - switch (d) { + switch (DHExp.term_of(d)) { | Var(_) | FreeVar(_) | InvalidText(_) @@ -130,8 +130,12 @@ let mk = let recent_subst = switch (previous_step) { | Some(ps) when ps.ctx == Mark => - switch (ps.knd, ps.d_loc) { - | (FunAp, Ap(Fun(p, _, _, _), _)) => DHPat.bound_vars(p) + switch (ps.knd, DHExp.term_of(ps.d_loc)) { + | (FunAp, Ap(d2, _)) => + switch (DHExp.term_of(d2)) { + | Fun(p, _, _, _, _) => DHPat.bound_vars(p) + | _ => [] + } | (FunAp, _) => [] | (LetBind, Let(p, _, _)) => DHPat.bound_vars(p) | (LetBind, _) => [] @@ -258,7 +262,7 @@ let mk = go_formattable(d2, r) |> parenthesize(precedence(d2) > precedence_op), ); let doc = { - switch (d) { + switch (DHExp.term_of(d)) { | Closure(env', d') => go'(d', Closure, ~env=env') | Filter(flt, d') => if (settings.show_stepper_filters) { @@ -316,7 +320,7 @@ let mk = | Some(d') => if (List.mem(x, recent_subst)) { hcats([ - go'(~env=ClosureEnvironment.empty, Var(x), BoundVar) + go'(~env=ClosureEnvironment.empty, d, BoundVar) |> annot(DHAnnot.Substituted), go'(~env=ClosureEnvironment.empty, d', BoundVar), ]); @@ -453,22 +457,24 @@ let mk = ), ]); } - | FailedCast(Cast(d, ty1, ty2), ty2', ty3) when Typ.eq(ty2, ty2') => - let d_doc = go'(d, FailedCastCast); - let cast_decoration = - hcats([ - DHDoc_common.Delim.open_FailedCast, - hseps([ - DHDoc_Typ.mk(~enforce_inline=true, ty1), - DHDoc_common.Delim.arrow_FailedCast, - DHDoc_Typ.mk(~enforce_inline=true, ty3), - ]), - DHDoc_common.Delim.close_FailedCast, - ]) - |> annot(DHAnnot.FailedCastDecoration); - hcats([d_doc, cast_decoration]); - | FailedCast(_d, _ty1, _ty2) => - failwith("unexpected FailedCast without inner cast") + | FailedCast(d1, ty2', ty3) => + switch (DHExp.term_of(d1)) { + | Cast(d, ty1, ty2) when Typ.eq(ty2, ty2') => + let d_doc = go'(d, FailedCastCast); + let cast_decoration = + hcats([ + DHDoc_common.Delim.open_FailedCast, + hseps([ + DHDoc_Typ.mk(~enforce_inline=true, ty1), + DHDoc_common.Delim.arrow_FailedCast, + DHDoc_Typ.mk(~enforce_inline=true, ty3), + ]), + DHDoc_common.Delim.close_FailedCast, + ]) + |> annot(DHAnnot.FailedCastDecoration); + hcats([d_doc, cast_decoration]); + | _ => failwith("unexpected FailedCast without inner cast") + } | InvalidOperation(d, err) => let d_doc = go'(d, InvalidOperation); let decoration = @@ -502,7 +508,7 @@ let mk = ), DHDoc_common.Delim.mk(")"), ]); - | Fun(dp, ty, Closure(env', d), s) => + | Fun(dp, ty, d, Some(env'), s) => if (settings.show_fn_bodies) { let bindings = DHPat.bound_vars(dp); let body_doc = @@ -510,7 +516,8 @@ let mk = Closure( ClosureEnvironment.without_keys(Option.to_list(s), env'), d, - ), + ) + |> DHExp.fresh, ~env= ClosureEnvironment.without_keys( DHPat.bound_vars(dp) @ Option.to_list(s), @@ -551,7 +558,7 @@ let mk = | Some(name) => annot(DHAnnot.Collapsed, text("<" ++ name ++ ">")) }; } - | Fun(dp, ty, dbody, s) => + | Fun(dp, ty, dbody, None, s) => if (settings.show_fn_bodies) { let bindings = DHPat.bound_vars(dp); let body_doc = @@ -638,9 +645,12 @@ let mk = ); let doc = switch (substitution) { - | Some({d_loc: Var(v), _}) when List.mem(v, recent_subst) => - hcats([text(v) |> annot(DHAnnot.Substituted), doc]) - | Some(_) + | Some(step) => + switch (DHExp.term_of(step.d_loc)) { + | Var(v) when List.mem(v, recent_subst) => + hcats([text(v) |> annot(DHAnnot.Substituted), doc]) + | _ => doc + } | None => doc }; let doc = From e3328e5b20eba0b1798c6c190ff012b59effc352 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 1 Feb 2024 12:58:43 -0500 Subject: [PATCH 005/103] Switch to id-based stepper --- src/haz3lcore/dynamics/EvalCtx.re | 159 --------- src/haz3lcore/dynamics/EvaluatorStep.re | 9 - src/haz3lcore/dynamics/Stepper.re | 345 ++++++++----------- src/haz3lcore/prog/ModelResult.re | 5 +- src/haz3lweb/view/Cell.re | 1 + src/haz3lweb/view/ExplainThis.re | 70 +--- src/haz3lweb/view/StepperView.re | 139 ++++---- src/haz3lweb/view/dhcode/DHCode.re | 4 +- src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 184 ++++------ src/util/Aba.re | 17 + 10 files changed, 292 insertions(+), 641 deletions(-) diff --git a/src/haz3lcore/dynamics/EvalCtx.re b/src/haz3lcore/dynamics/EvalCtx.re index a2dbe8e6d8..aba9a650da 100644 --- a/src/haz3lcore/dynamics/EvalCtx.re +++ b/src/haz3lcore/dynamics/EvalCtx.re @@ -1,44 +1,6 @@ open Sexplib.Std; open DH; -[@deriving (show({with_path: false}), sexp, yojson)] -type cls = - | Mark - | Closure - | FilterPattern - | Filter - | Seq1 - | Seq2 - | Let1 - | Let2 - | Ap1 - | Ap2 - | Fun - | FixF - | BinOp1 - | BinOp2 - | If1 - | If2 - | If3 - | Tuple(int) - | ListLit(int) - | ApBuiltin - | Test - | Cons1 - | Cons2 - | ListConcat1 - | ListConcat2 - | Prj - | NonEmptyHole - | Cast - | FailedCast - | InvalidOperation - | MatchScrut - | MatchRule(int) - | FailedCastCast - // Used when entering a bound variable expression in substitution mode - | BoundVar; - [@deriving (show({with_path: false}), sexp, yojson)] type t = | Mark @@ -84,124 +46,3 @@ type t = t, (list((DHPat.t, DHExp.t)), list((DHPat.t, DHExp.t))), ); - -let rec fuzzy_mark = - fun - | Mark => true - | Closure(_, x) - | Test(_, x) - | Cast(x, _, _) - | FailedCast(x, _, _) - | Filter(_, x) => fuzzy_mark(x) - | Seq1(_) - | Seq2(_) - | Let1(_) - | Let2(_) - | Fun(_) - | FixF(_) - | Ap1(_) - | Ap2(_) - | If1(_) - | If2(_) - | If3(_) - | BinOp1(_) - | BinOp2(_) - | Tuple(_) - | ApBuiltin(_) - | ListLit(_) - | Cons1(_) - | Cons2(_) - | ListConcat1(_) - | ListConcat2(_) - | Prj(_) - | NonEmptyHole(_) - | InvalidOperation(_) - | MatchScrut(_) - | MatchRule(_) => false; - -let rec unwrap = (ctx: t, sel: cls): option(t) => { - switch (sel, ctx) { - | (Mark, _) => - print_endline( - "Mark does not match with " - ++ Sexplib.Sexp.to_string_hum(sexp_of_t(ctx)), - ); - raise(EvaluatorError.Exception(StepDoesNotMatch)); - | (BoundVar, c) - | (NonEmptyHole, NonEmptyHole(_, _, _, c)) - | (Closure, Closure(_, c)) - | (Filter, Filter(_, c)) - | (Seq1, Seq1(c, _)) - | (Seq2, Seq2(_, c)) - | (Let1, Let1(_, c, _)) - | (Let2, Let2(_, _, c)) - | (Fun, Fun(_, _, c, _, _)) - | (FixF, FixF(_, _, c)) - | (Ap1, Ap1(c, _)) - | (Ap2, Ap2(_, c)) - | (BinOp1, BinOp1(_, c, _)) - | (BinOp2, BinOp2(_, _, c)) - | (If1, If1(_, c, _, _)) - | (If2, If2(_, _, c, _)) - | (If3, If3(_, _, _, c)) - | (Cons1, Cons1(c, _)) - | (Cons2, Cons2(_, c)) - | (ListConcat1, ListConcat1(c, _)) - | (ListConcat2, ListConcat2(_, c)) - | (Test, Test(_, c)) - | (Prj, Prj(c, _)) => Some(c) - | (ListLit(n), ListLit(_, _, _, c, (ld, _))) - | (Tuple(n), Tuple(c, (ld, _))) => - if (List.length(ld) == n) { - Some(c); - } else { - None; - } - | (MatchScrut, MatchScrut(_, scr, _)) => Some(scr) - | (MatchRule(n), MatchRule(_, _, _, c, (ld, _))) => - if (List.length(ld) == n) { - Some(c); - } else { - None; - } - | (Cast, Cast(c, _, _)) - | (FailedCastCast, FailedCast(Cast(c, _, _), _, _)) - | (FailedCast, FailedCast(c, _, _)) => Some(c) - | (Ap1, Ap2(_, _)) - | (Ap2, Ap1(_, _)) - | (If1, If2(_)) - | (If1, If3(_)) - | (If2, If1(_)) - | (If2, If3(_)) - | (If3, If1(_)) - | (If3, If2(_)) - | (Let1, Let2(_)) - | (Let2, Let1(_)) - | (BinOp1, BinOp2(_)) - | (BinOp2, BinOp1(_)) - | (Cons1, Cons2(_)) - | (Cons2, Cons1(_)) - | (Seq1, Seq2(_)) - | (Seq2, Seq1(_)) - | (ListConcat1, ListConcat2(_)) - | (ListConcat2, ListConcat1(_)) => None - | (FilterPattern, _) => None - | (MatchScrut, MatchRule(_)) - | (MatchRule(_), MatchScrut(_)) => None - | (Filter, _) => Some(ctx) - | (tag, Filter(_, c)) => unwrap(c, tag) - | (Closure, _) => Some(ctx) - | (tag, Closure(_, c)) => unwrap(c, tag) - | (Cast, _) => Some(ctx) - | (tag, Cast(c, _, _)) => unwrap(c, tag) - | (_, Mark) => None - | (_, _) => - // print_endline( - // Sexplib.Sexp.to_string_hum(sexp_of_cls(tag)) - // ++ " does not match with " - // ++ Sexplib.Sexp.to_string_hum(sexp_of_t(ctx)), - // ); - None - // raise(EvaluatorError.Exception(StepDoesNotMatch)); - }; -}; diff --git a/src/haz3lcore/dynamics/EvaluatorStep.re b/src/haz3lcore/dynamics/EvaluatorStep.re index 37cc72f87f..1dbfeb76be 100644 --- a/src/haz3lcore/dynamics/EvaluatorStep.re +++ b/src/haz3lcore/dynamics/EvaluatorStep.re @@ -8,17 +8,8 @@ type step = { d_loc': DHExp.t, ctx: EvalCtx.t, knd: step_kind, - from_id: Id.t, - to_id: Id.t, }; -let unwrap = (step, sel: EvalCtx.cls) => - EvalCtx.unwrap(step.ctx, sel) |> Option.map(ctx => {...step, ctx}); - -let unwrap_unsafe = (step, sel: EvalCtx.cls) => - // TODO[Matt]: bring back "safe" version - EvalCtx.unwrap(step.ctx, sel) |> Option.map(ctx => {...step, ctx}); - module EvalObj = { [@deriving (show({with_path: false}), sexp, yojson)] type t = { diff --git a/src/haz3lcore/dynamics/Stepper.re b/src/haz3lcore/dynamics/Stepper.re index 644b511776..b6f34fc0ec 100644 --- a/src/haz3lcore/dynamics/Stepper.re +++ b/src/haz3lcore/dynamics/Stepper.re @@ -1,35 +1,26 @@ open Sexplib.Std; open EvaluatorStep; open Transition; +open Util; exception Exception; -type step_with_previous = { - step, - previous: option(step), - hidden: list(step), -}; +[@deriving (show({with_path: false}), sexp, yojson)] +type stepper_state = + | StepPending(EvalObj.t) + | StepperReady + | StepperDone + | StepperError(EvalObj.t, ProgramEvaluatorError.t) + | StepTimeout(EvalObj.t); [@deriving (show({with_path: false}), sexp, yojson)] -type current = - | StepperOK(DHExp.t, EvaluatorState.t) - | StepperError( - DHExp.t, - EvaluatorState.t, - EvalObj.t, - ProgramEvaluatorError.t, - ) // Must have at least one in previous - | StepTimeout(DHExp.t, EvaluatorState.t, EvalObj.t) // Must have at least one in previous - | StepPending(DHExp.t, EvaluatorState.t, option(EvalObj.t)); // none +type history = Aba.t((DHExp.t, EvaluatorState.t), step); [@deriving (show({with_path: false}), sexp, yojson)] type t = { - /* Might be different to first expression in previous because - steps are taken automatically (this may no longer be true - Matt) */ - elab: DHExp.t, - previous: list(step), - current, - next: list(EvalObj.t), + history, + next_options: list(EvalObj.t), + stepper_state, }; let rec matches = @@ -193,77 +184,39 @@ let should_hide_step = (~settings, x: step): (FilterAction.action, step) => }; }; -let get_elab = ({elab, _}: t) => elab; +let get_elab = ({history, _}: t) => Aba.last_a(history) |> fst; -let get_next_steps = s => s.next; +let get_next_steps = s => s.next_options; -let current_expr = (s: t) => - switch (s.current) { - | StepperOK(d, _) - | StepPending(d, _, _) - | StepperError(d, _, _, _) - | StepTimeout(d, _, _) => d - }; +let current_expr = ({history, _}: t) => Aba.hd(history); -let step_pending = (eo: EvalObj.t, {elab, previous, current, next}: t) => - switch (current) { - | StepperOK(d, s) => { - elab, - previous, - current: StepPending(d, s, Some(eo)), - next, - } - | StepperError(_) - | StepTimeout(_) => { - elab, - previous: List.tl(previous), - current: - StepPending( - List.hd(previous).d, - List.hd(previous).state, - Some(eo), - ), - next, - } - | StepPending(d, s, _) => { - elab, - previous, - current: StepPending(d, s, Some(eo)), - next, - } - }; +let step_pending = (eo: EvalObj.t, stepper: t) => { + ...stepper, + stepper_state: StepPending(eo), +}; let init = (elab: DHExp.t) => { { - elab, - previous: [], - current: StepPending(elab, EvaluatorState.init, None), - next: decompose(elab), + history: Aba.singleton((elab, EvaluatorState.init)), + next_options: decompose(elab), + stepper_state: StepperReady, }; }; -let update_result = - ( - ( - d: DHExp.t, - state: EvaluatorState.t, - next_eval_objs: list(EvalObj.t), - skipped_steps: list(step), - ), - s: t, - ) => { - previous: skipped_steps @ s.previous, - current: StepperOK(d, state), - next: next_eval_objs, - elab: s.elab, -}; - let rec evaluate_pending = (~settings, s: t) => { - switch (s.current) { - | StepperOK(_) + switch (s.stepper_state) { + | StepperDone | StepperError(_) | StepTimeout(_) => s - | StepPending(d, state, Some(eo)) => + | StepperReady => + let next' = s.next_options |> List.map(should_hide_eval_obj(~settings)); + switch (List.find_opt(((act, _)) => act == FilterAction.Eval, next')) { + | Some((_, eo)) => + {...s, stepper_state: StepPending(eo)} |> evaluate_pending(~settings) + | None => {...s, stepper_state: StepperDone} + }; + | StepPending(eo) => + let (d, state) = Aba.hd(s.history); let state_ref = ref(state); let d_loc' = switch (take_step(state_ref, eo.env, eo.d_loc)) { @@ -271,53 +224,31 @@ let rec evaluate_pending = (~settings, s: t) => { | None => raise(Exception) }; let d' = compose(eo.ctx, d_loc'); + let new_step = { + d, + d_loc: eo.d_loc, + d_loc', + ctx: eo.ctx, + knd: eo.knd, + state, + }; { - elab: s.elab, - previous: [ - { - d, - d_loc: eo.d_loc, - d_loc', - ctx: eo.ctx, - knd: eo.knd, - state, - from_id: DHExp.rep_id(eo.d_loc), - to_id: DHExp.rep_id(d_loc'), - }, - ...s.previous, - ], - current: StepPending(d', state_ref^, None), - next: decompose(d'), + history: s.history |> Aba.cons((d', state_ref^), new_step), + stepper_state: StepperReady, + next_options: decompose(d'), } |> evaluate_pending(~settings); - | StepPending(d, state, None) => - let next' = s.next |> List.map(should_hide_eval_obj(~settings)); - switch (List.find_opt(((act, _)) => act == FilterAction.Eval, next')) { - | Some((_, eo)) => - { - elab: s.elab, - previous: s.previous, - current: StepPending(d, state, Some(eo)), - next: next' |> List.map(snd), - } - |> evaluate_pending(~settings) - | None => { - elab: s.elab, - previous: s.previous, - current: StepperOK(d, state), - next: next' |> List.map(snd), - } - }; }; }; let rec evaluate_full = (~settings, s: t) => { - switch (s.current) { + switch (s.stepper_state) { | StepperError(_) | StepTimeout(_) => s - | StepperOK(_) when s.next == [] => s - | StepperOK(_) => - s |> step_pending(List.hd(s.next)) |> evaluate_full(~settings) + | StepperDone when s.next_options == [] => s + | StepperDone => + s |> step_pending(List.hd(s.next_options)) |> evaluate_full(~settings) + | StepperReady | StepPending(_) => evaluate_pending(~settings, s) |> evaluate_full(~settings) }; @@ -325,60 +256,38 @@ let rec evaluate_full = (~settings, s: t) => { let timeout = fun - | {elab, previous, current: StepPending(d, state, Some(eo)), next} => { - elab, - previous, - current: StepTimeout(d, state, eo), - next, + | {stepper_state: StepPending(eo), _} as s => { + ...s, + stepper_state: StepTimeout(eo), } | { - current: - StepperError(_) | StepTimeout(_) | StepperOK(_) | - StepPending(_, _, None), + stepper_state: + StepperError(_) | StepTimeout(_) | StepperReady | StepperDone, _, } as s => s; -// let rec step_forward = (~settings, e: EvalObj.t, s: t) => { -// let current = compose(e.ctx, e.apply()); -// skip_steps( -// ~settings, -// { -// current, -// previous: [{d: s.current, step: e}, ...s.previous], -// next: decompose(current), -// }, -// ); -// } -// and skip_steps = (~settings, s) => { -// switch ( -// List.find_opt( -// (x: EvalObj.t) => should_hide_step(~settings, x.knd), -// s.next, -// ) -// ) { -// | None => s -// | Some(e) => step_forward(~settings, e, s) -// }; -// }; - -let rec undo_point = - (~settings): (list(step) => option((step, list(step)))) => +let rec truncate_history = (~settings) => fun - | [] => None - | [x, ...xs] when should_hide_step(~settings, x) |> fst == Eval => - undo_point(~settings, xs) - | [x, ...xs] => Some((x, xs)); + | ([_, ...as_], [b, ...bs]) + when should_hide_step(~settings, b) |> fst == Eval => + truncate_history(~settings, (as_, bs)) + | ([_, ...as_], [_, ...bs]) => Some((as_, bs)) + | _ => None; -let step_backward = (~settings, s: t) => - switch (undo_point(~settings, s.previous)) { - | None => failwith("cannot step backwards") - | Some((x, xs)) => { - current: StepperOK(x.d, x.state), - next: decompose(x.d), - previous: xs, - elab: s.elab, - } +let step_backward = (~settings, s: t) => { + let h' = + truncate_history(~settings, s.history) + |> Option.value(~default=s.history); + { + history: h', + next_options: decompose(Aba.hd(h') |> fst), + stepper_state: StepperDone, }; +}; + +let can_undo = (~settings, s: t) => { + truncate_history(~settings, s.history) |> Option.is_some; +}; let get_justification: step_kind => string = fun @@ -412,54 +321,78 @@ let get_justification: step_kind => string = | FunClosure => "unidentified step" | Skip => "skipped steps"; +type step_info = { + d: DHExp.t, + previous_step: option((step, Id.t)), // The step that will be displayed above this one (an Id in included because it may have changed since the step was taken) + hidden_steps: list((step, Id.t)), // The hidden steps between previous_step and the current one (an Id in included because it may have changed since the step was taken) + chosen_step: option(step) // The step that was taken next +}; + let get_history = (~settings, stepper) => { - let rec get_history': - list(step) => (list(step), list(step_with_previous)) = - fun - | [] => ([], []) - | [step, ...steps] => { - let (hidden, ss) = get_history'(steps); - switch (step |> should_hide_step(~settings) |> fst) { - | Eval => ([step, ...hidden], ss) - | Step => ( - [], - [ - { - step, - previous: - Option.map( - (x: step_with_previous) => x.step, - List.nth_opt(ss, 0), - ), - hidden, - }, - ...ss, - ], - ) - }; - }; - stepper.previous |> get_history'; + let should_skip_step = step => + step |> should_hide_step(~settings) |> fst == Eval; + let _ = print_int(List.length(fst(stepper.history))); + let grouped_steps = + stepper.history + |> Aba.fold_right( + ((d, _), step, result) => { + print_string("e"); + print_int(result |> fst |> List.length); + print_int(result |> snd |> List.length); + if (should_skip_step(step)) { + Aba.map_hd(((_, hs)) => (d, [step, ...hs]), result); + } else { + Aba.cons((d, []), step, result); + }; + }, + ((d, _)) => Aba.singleton((d, [])), + ); + let _ = print_int(List.length(fst(grouped_steps))); + let _ = print_int(List.length(snd(grouped_steps))); + let replace_id = (x, y, (s, z)) => (s, x == z ? y : z); + let track_ids = + ( + ( + chosen_step: option(step), + (d: DHExp.t, hidden_steps: list(step)), + previous_step: option(step), + ), + ) => { + let (previous_step, hidden_steps) = + List.fold_left( + ((ps, hs), h: step) => { + let replacement = + replace_id(h.d_loc |> DHExp.rep_id, h.d_loc' |> DHExp.rep_id); + ( + Option.map(replacement, ps), + [(h, h.d_loc' |> DHExp.rep_id), ...List.map(replacement, hs)], + ); + }, + (Option.map(x => (x, x.d_loc' |> DHExp.rep_id), previous_step), []), + hidden_steps, + ); + {d, previous_step, hidden_steps, chosen_step}; + }; + let padded = grouped_steps |> Aba.bab_triples; + let _ = print_int(List.length(padded)); + let result = padded |> List.map(track_ids); + let _ = print_int(List.length(result)); + print_endline(""); + result; + //grouped_steps |> Aba.bab_triples |> List.map(track_ids); }; [@deriving (show({with_path: false}), sexp, yojson)] -type persistent = { - elab: DHExp.t, - previous: list(step), - current, -}; +type persistent = {history}; // Remove EvalObj.t objects from stepper to prevent problems when loading -let to_persistent: t => persistent = - fun - | {elab, previous, current: StepPending(d, state, Some(_)), _} => { - elab, - previous, - current: StepPending(d, state, None), - } - | {elab, previous, current, _} => {elab, previous, current}; +let to_persistent: t => persistent = ({history, _}) => {history: history}; let from_persistent: persistent => t = - ({elab, previous, current}) => { - let s = {elab, previous, current, next: []}; - {elab, previous, current, next: decompose(current_expr(s))}; + ({history}) => { + { + history, + next_options: decompose(Aba.hd(history) |> fst), + stepper_state: StepperDone, + }; }; diff --git a/src/haz3lcore/prog/ModelResult.re b/src/haz3lcore/prog/ModelResult.re index aae371fa7c..552651f77a 100644 --- a/src/haz3lcore/prog/ModelResult.re +++ b/src/haz3lcore/prog/ModelResult.re @@ -21,7 +21,7 @@ let update_elab = elab => fun | NoElab | Evaluation(_) => Evaluation({elab, evaluation: ResultPending}) - | Stepper({elab: elab2, _}) as s when DHExp.fast_equal(elab, elab2) => s + | Stepper(s) as s' when DHExp.fast_equal(elab, Stepper.get_elab(s)) => s' | Stepper(_) => Stepper(Stepper.init(elab)); let update_stepper = f => @@ -74,7 +74,8 @@ let toggle_stepper = fun | NoElab => NoElab | Evaluation({elab, _}) => Stepper(Stepper.init(elab)) - | Stepper({elab, _}) => Evaluation({elab, evaluation: ResultPending}); + | Stepper(s) => + Evaluation({elab: Stepper.get_elab(s), evaluation: ResultPending}); let get_simple = fun diff --git a/src/haz3lweb/view/Cell.re b/src/haz3lweb/view/Cell.re index 30579ea546..e921d6f442 100644 --- a/src/haz3lweb/view/Cell.re +++ b/src/haz3lweb/view/Cell.re @@ -359,6 +359,7 @@ let footer = ~settings=settings.core.evaluation, ~font_metrics, ~result_key, + ~read_only=false, s, ) }; diff --git a/src/haz3lweb/view/ExplainThis.re b/src/haz3lweb/view/ExplainThis.re index 5d76b26120..7206789fdd 100644 --- a/src/haz3lweb/view/ExplainThis.re +++ b/src/haz3lweb/view/ExplainThis.re @@ -445,71 +445,17 @@ let example_view = ), dhexp, ); - let stepper = + let result_view = dhexp |> DHExp.fresh |> Stepper.init - |> Stepper.evaluate_full(~settings=settings.core.evaluation); - let (hidden, previous) = - Stepper.get_history( - ~settings=settings.core.evaluation, - stepper, - ); - let dh_code_current = - div( - ~attr=Attr.classes(["result"]), - [ - DHCode.view( - ~inject, - ~settings=settings.core.evaluation, - ~selected_hole_instance=None, - ~font_metrics, - ~width=80, - ~previous_step= - previous - |> List.nth_opt(_, 0) - |> Option.map((x: Stepper.step_with_previous) => x.step), - ~next_steps=stepper.next, - ~hidden_steps= - List.map((x: EvaluatorStep.step) => x, hidden), - ~result_key="", - Stepper.current_expr(stepper), - ), - ], - ); - let dh_code_previous = - (step_with_previous: Stepper.step_with_previous) => - div( - ~attr=Attr.classes(["result"]), - [ - DHCode.view( - ~inject, - ~settings=settings.core.evaluation, - ~selected_hole_instance=None, - ~font_metrics, - ~width=80, - ~previous_step= - Option.map( - (x: EvaluatorStep.step) => x, - step_with_previous.previous, - ), - ~chosen_step=Some(step_with_previous.step), - ~hidden_steps= - List.map( - (x: EvaluatorStep.step) => x, - step_with_previous.hidden, - ), - ~result_key="", - step_with_previous.step.d, - ), - ], - ); - let result_view = - previous - |> List.map(dh_code_previous) - |> List.fold_left( - (x, y) => List.cons(y, x), - [dh_code_current], + |> Stepper.evaluate_full(~settings=settings.core.evaluation) + |> StepperView.stepper_view( + ~inject, + ~settings=settings.core.evaluation, + ~font_metrics, + ~result_key="", + ~read_only=true, ); let code_container = view => div(~attr=clss(["code-container"]), view); diff --git a/src/haz3lweb/view/StepperView.re b/src/haz3lweb/view/StepperView.re index a12037d5f2..b112bb27e8 100644 --- a/src/haz3lweb/view/StepperView.re +++ b/src/haz3lweb/view/StepperView.re @@ -8,22 +8,14 @@ let stepper_view = ~settings: CoreSettings.Evaluation.t, ~font_metrics, ~result_key, + ~read_only: bool, stepper: Stepper.t, ) => { - let button_back = - Widgets.button_d( - Icons.undo, - inject(UpdateAction.StepperAction(result_key, StepBackward)), - ~disabled=Stepper.undo_point(~settings, stepper.previous) == None, - ~tooltip="Step Backwards", - ); - let (hidden, previous) = - if (settings.stepper_history) { - Stepper.get_history(~settings, stepper); - } else { - ([], []); - }; - let dh_code_current = d => + let step_dh_code = + ( + ~next_steps, + {previous_step, hidden_steps, chosen_step, d}: Stepper.step_info, + ) => div( ~attr=Attr.classes(["result"]), [ @@ -33,78 +25,73 @@ let stepper_view = ~selected_hole_instance=None, ~font_metrics, ~width=80, - ~previous_step= - previous - |> List.nth_opt(_, 0) - |> Option.map((x: Stepper.step_with_previous) => x.step), - ~next_steps=Stepper.get_next_steps(stepper), - ~hidden_steps=hidden, + ~previous_step, + ~chosen_step, + ~hidden_steps, ~result_key, + ~next_steps, d, ), ], ); - let dh_code_previous = (step_with_previous: Stepper.step_with_previous) => - div( - ~attr=Attr.classes(["result"]), - [ - DHCode.view( - ~inject, - ~settings, - ~selected_hole_instance=None, - ~font_metrics, - ~width=80, - ~previous_step=step_with_previous.previous, - ~chosen_step=Some(step_with_previous.step), - ~hidden_steps=step_with_previous.hidden, - ~result_key, - step_with_previous.step.d, - ), - ], - ); - let hide_stepper = - Widgets.toggle(~tooltip="Show Stepper", "s", true, _ => - inject(UpdateAction.ToggleStepper(result_key)) - ); - let show_history = - Widgets.toggle(~tooltip="Show History", "h", settings.stepper_history, _ => - inject(Set(Evaluation(ShowRecord))) - ); - let eval_settings = - Widgets.button(Icons.gear, _ => inject(Set(Evaluation(ShowSettings)))); - let current = - switch (stepper.current) { - | StepperOK(d, _) => + let history = Stepper.get_history(~settings, stepper); + switch (history) { + | [] => [] + | [hd, ...tl] => + let button_back = + Widgets.button_d( + Icons.undo, + inject(UpdateAction.StepperAction(result_key, StepBackward)), + ~disabled=!Stepper.can_undo(~settings, stepper), + ~tooltip="Step Backwards", + ); + let hide_stepper = + Widgets.toggle(~tooltip="Show Stepper", "s", true, _ => + inject(UpdateAction.ToggleStepper(result_key)) + ); + let show_history = + Widgets.toggle(~tooltip="Show History", "h", settings.stepper_history, _ => + inject(Set(Evaluation(ShowRecord))) + ); + let eval_settings = + Widgets.button(Icons.gear, _ => + inject(Set(Evaluation(ShowSettings))) + ); + let current = + div( + ~attr=Attr.classes(["cell-result"]), + read_only + ? [ + div(~attr=Attr.class_("equiv"), [Node.text("≡")]), + step_dh_code(~next_steps=[], hd), + ] + : [ + div(~attr=Attr.class_("equiv"), [Node.text("≡")]), + step_dh_code(~next_steps=Stepper.get_next_steps(stepper), hd), + button_back, + eval_settings, + show_history, + hide_stepper, + ], + ); + let dh_code_previous = step_dh_code; + let previous_step = (step: Stepper.step_info) => { div( ~attr=Attr.classes(["cell-result"]), [ div(~attr=Attr.class_("equiv"), [Node.text("≡")]), - dh_code_current(d), - button_back, - eval_settings, - show_history, - hide_stepper, + dh_code_previous(~next_steps=[], step), + div( + ~attr=Attr.classes(["stepper-justification"]), + step.chosen_step + |> Option.map((chosen_step: EvaluatorStep.step) => + chosen_step.knd |> Stepper.get_justification |> Node.text + ) + |> Option.to_list, + ), ], - ) - // TODO[Matt]: show errors and waiting - | StepperError(_) - | StepTimeout(_) - | StepPending(_, _, _) => div([]) + ); }; - - let previous_step = (step: Stepper.step_with_previous) => { - div( - ~attr=Attr.classes(["cell-result"]), - [ - div(~attr=Attr.class_("equiv"), [Node.text("≡")]), - dh_code_previous(step), - div( - ~attr=Attr.classes(["stepper-justification"]), - [Node.text(Stepper.get_justification(step.step.knd))], - ), - ], - ); + List.map(previous_step, tl) |> List.rev_append(_, [current]); }; - let nodes_previous = List.map(previous_step, previous); - List.fold_left((x, y) => List.cons(y, x), [current], nodes_previous); }; diff --git a/src/haz3lweb/view/dhcode/DHCode.re b/src/haz3lweb/view/dhcode/DHCode.re index be2cfa5745..fe1adf1715 100644 --- a/src/haz3lweb/view/dhcode/DHCode.re +++ b/src/haz3lweb/view/dhcode/DHCode.re @@ -140,8 +140,8 @@ let view = ~font_metrics: FontMetrics.t, ~width: int, ~pos=0, - ~previous_step: option(EvaluatorStep.step)=None, // The step that will be displayed above this one - ~hidden_steps: list(EvaluatorStep.step)=[], // The hidden steps between the above and the current one + ~previous_step: option((EvaluatorStep.step, Id.t))=None, // The step that will be displayed above this one + ~hidden_steps: list((EvaluatorStep.step, Id.t))=[], // The hidden steps between the above and the current one ~chosen_step: option(EvaluatorStep.step)=None, // The step that will be taken next ~next_steps: list(EvaluatorStep.EvalObj.t)=[], ~result_key: string, diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index 81e6a917ed..5e5cc78560 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -104,8 +104,8 @@ let mk = ~enforce_inline: bool, ~selected_hole_instance: option(HoleInstance.t), // The next four are used when drawing the stepper to track where we can annotate changes - ~previous_step: option(step), // The step that will be displayed above this one - ~hidden_steps: list(step), // The hidden steps between the above and the current one + ~previous_step: option((step, Id.t)), // The step that will be displayed above this one (an Id in included because it may have changed since the step was taken) + ~hidden_steps: list((step, Id.t)), // The hidden steps between the above and the current one (an Id in included because it may have changed since the step was taken) ~chosen_step: option(step), // The step that will be taken next ~next_steps: list(EvalObj.t), // The options for the next step, if it hasn't been chosen yet ~env: ClosureEnvironment.t, @@ -118,10 +118,6 @@ let mk = d: DHExp.t, env: ClosureEnvironment.t, enforce_inline: bool, - previous_step: option(step), - hidden_steps: list(step), - chosen_step: option(step), - next_steps: list((EvalCtx.t, EvalObj.t)), recent_subst: list(Var.t), recursive_calls: list(Var.t), ) @@ -129,7 +125,7 @@ let mk = open Doc; let recent_subst = switch (previous_step) { - | Some(ps) when ps.ctx == Mark => + | Some((ps, id)) when id == DHExp.rep_id(d) => switch (ps.knd, DHExp.term_of(ps.d_loc)) { | (FunAp, Ap(d2, _)) => switch (DHExp.term_of(d2)) { @@ -171,30 +167,8 @@ let mk = ~recent_subst=recent_subst, ~recursive_calls=recursive_calls, d, - ctx, ) => { - go( - d, - env, - enforce_inline, - Option.join( - Option.map(EvaluatorStep.unwrap(_, ctx), previous_step), - ), - hidden_steps - |> List.filter(s => !EvalCtx.fuzzy_mark(s.ctx)) - |> List.filter_map(EvaluatorStep.unwrap(_, ctx)), - Option.join(Option.map(EvaluatorStep.unwrap(_, ctx), chosen_step)), - List.filter_map( - ((x, y)) => - switch (EvalCtx.unwrap(x, ctx)) { - | None => None - | Some(x') => Some((x', y)) - }, - next_steps, - ), - recent_subst, - recursive_calls, - ); + go(d, env, enforce_inline, recent_subst, recursive_calls); }; let parenthesize = (b, doc) => if (b) { @@ -206,16 +180,15 @@ let mk = } else { doc(~enforce_inline); }; - let go_case_rule = (rule_idx: int, (dp, dclause)): DHDoc.t => { - let kind: EvalCtx.cls = MatchRule(rule_idx); + let go_case_rule = ((dp, dclause)): DHDoc.t => { let hidden_clause = annot(DHAnnot.Collapsed, text(Unicode.ellipsis)); let clause_doc = settings.show_case_clauses ? choices([ - hcats([space(), go'(~enforce_inline=true, dclause, kind)]), + hcats([space(), go'(~enforce_inline=true, dclause)]), hcats([ linebreak(), - indent_and_align(go'(~enforce_inline=false, dclause, kind)), + indent_and_align(go'(~enforce_inline=false, dclause)), ]), ]) : hcat(space(), hidden_clause); @@ -236,40 +209,38 @@ let mk = } else { let scrut_doc = choices([ - hcats([space(), go'(~enforce_inline=true, dscrut, MatchScrut)]), + hcats([space(), go'(~enforce_inline=true, dscrut)]), hcats([ linebreak(), - indent_and_align( - go'(~enforce_inline=false, dscrut, MatchScrut), - ), + indent_and_align(go'(~enforce_inline=false, dscrut)), ]), ]); vseps( List.concat([ [hcat(DHDoc_common.Delim.open_Case, scrut_doc)], - drs |> List.mapi(go_case_rule), + drs |> List.map(go_case_rule), [DHDoc_common.Delim.close_Case], ]), ); }; let go_formattable = (~enforce_inline) => go'(~enforce_inline); - let mk_left_associative_operands = (precedence_op, (d1, l), (d2, r)) => ( - go_formattable(d1, l) |> parenthesize(precedence(d1) > precedence_op), - go_formattable(d2, r) |> parenthesize(precedence(d2) >= precedence_op), + let mk_left_associative_operands = (precedence_op, d1, d2) => ( + go_formattable(d1) |> parenthesize(precedence(d1) > precedence_op), + go_formattable(d2) |> parenthesize(precedence(d2) >= precedence_op), ); - let mk_right_associative_operands = (precedence_op, (d1, l), (d2, r)) => ( - go_formattable(d1, l) |> parenthesize(precedence(d1) >= precedence_op), - go_formattable(d2, r) |> parenthesize(precedence(d2) > precedence_op), + let mk_right_associative_operands = (precedence_op, d1, d2) => ( + go_formattable(d1) |> parenthesize(precedence(d1) >= precedence_op), + go_formattable(d2) |> parenthesize(precedence(d2) > precedence_op), ); let doc = { switch (DHExp.term_of(d)) { - | Closure(env', d') => go'(d', Closure, ~env=env') + | Closure(env', d') => go'(d', ~env=env') | Filter(flt, d') => if (settings.show_stepper_filters) { switch (flt) { | Filter({pat, act}) => let keyword = FilterAction.string_of_t(act); - let flt_doc = go_formattable(pat, FilterPattern); + let flt_doc = go_formattable(pat); vseps([ hcats([ DHDoc_common.Delim.mk(keyword), @@ -280,16 +251,16 @@ let mk = ), DHDoc_common.Delim.mk("in"), ]), - go'(d', Filter), + go'(d'), ]); | Residue(_, act) => let keyword = FilterAction.string_of_t(act); - vseps([DHDoc_common.Delim.mk(keyword), go'(d', Filter)]); + vseps([DHDoc_common.Delim.mk(keyword), go'(d')]); }; } else { switch (flt) { - | Residue(_) => go'(d', Filter) - | Filter(_) => go'(d', Filter) + | Residue(_) => go'(d') + | Filter(_) => go'(d') }; } @@ -303,8 +274,7 @@ let mk = }; DHDoc_common.mk_EmptyHole(~selected, (u, i)); | NonEmptyHole(reason, u, i, d') => - go'(d', NonEmptyHole) - |> annot(DHAnnot.NonEmptyHole(reason, (u, i))) + go'(d') |> annot(DHAnnot.NonEmptyHole(reason, (u, i))) | ExpandingKeyword(u, i, k) => DHDoc_common.mk_ExpandingKeyword((u, i), k) | FreeVar(u, i, x) => @@ -320,12 +290,12 @@ let mk = | Some(d') => if (List.mem(x, recent_subst)) { hcats([ - go'(~env=ClosureEnvironment.empty, d, BoundVar) + go'(~env=ClosureEnvironment.empty, d) |> annot(DHAnnot.Substituted), - go'(~env=ClosureEnvironment.empty, d', BoundVar), + go'(~env=ClosureEnvironment.empty, d'), ]); } else { - go'(~env=ClosureEnvironment.empty, d', BoundVar); + go'(~env=ClosureEnvironment.empty, d'); } } | BuiltinFun(f) => text(f) @@ -334,85 +304,60 @@ let mk = | Int(n) => DHDoc_common.mk_IntLit(n) | Float(f) => DHDoc_common.mk_FloatLit(f) | String(s) => DHDoc_common.mk_StringLit(s) - | Test(_, d) => DHDoc_common.mk_Test(go'(d, Test)) + | Test(_, d) => DHDoc_common.mk_Test(go'(d)) | Seq(d1, d2) => - let (doc1, doc2) = (go'(d1, Seq1), go'(d2, Seq2)); + let (doc1, doc2) = (go'(d1), go'(d2)); DHDoc_common.mk_Sequence(doc1, doc2); | ListLit(_, _, _, d_list) => - let ol = d_list |> List.mapi((i, d) => go'(d, ListLit(i))); + let ol = d_list |> List.map(d => go'(d)); DHDoc_common.mk_ListLit(ol); | Ap(d1, d2) => let (doc1, doc2) = ( - go_formattable(d1, Ap1) + go_formattable(d1) |> parenthesize(precedence(d1) > DHDoc_common.precedence_Ap), - go'(d2, Ap2), + go'(d2), ); DHDoc_common.mk_Ap(doc1, doc2); | ApBuiltin(ident, d) => DHDoc_common.mk_Ap( text(ident), - go_formattable(d, ApBuiltin) + go_formattable(d) |> parenthesize(precedence(d) > DHDoc_common.precedence_Ap), ) | BinOp(Int(op), d1, d2) => // TODO assumes all bin int ops are left associative let (doc1, doc2) = - mk_left_associative_operands( - precedence_bin_int_op(op), - (d1, BinOp1), - (d2, BinOp2), - ); + mk_left_associative_operands(precedence_bin_int_op(op), d1, d2); hseps([doc1, mk_bin_int_op(op), doc2]); | BinOp(Float(op), d1, d2) => // TODO assumes all bin float ops are left associative let (doc1, doc2) = - mk_left_associative_operands( - precedence_bin_float_op(op), - (d1, BinOp1), - (d2, BinOp2), - ); + mk_left_associative_operands(precedence_bin_float_op(op), d1, d2); hseps([doc1, mk_bin_float_op(op), doc2]); | BinOp(String(op), d1, d2) => // TODO assumes all bin string ops are left associative let (doc1, doc2) = - mk_left_associative_operands( - precedence_bin_string_op(op), - (d1, BinOp1), - (d2, BinOp2), - ); + mk_left_associative_operands(precedence_bin_string_op(op), d1, d2); hseps([doc1, mk_bin_string_op(op), doc2]); | Cons(d1, d2) => let (doc1, doc2) = - mk_right_associative_operands( - DHDoc_common.precedence_Cons, - (d1, Cons1), - (d2, Cons2), - ); + mk_right_associative_operands(DHDoc_common.precedence_Cons, d1, d2); DHDoc_common.mk_Cons(doc1, doc2); | ListConcat(d1, d2) => let (doc1, doc2) = - mk_right_associative_operands( - DHDoc_common.precedence_Plus, - (d1, ListConcat1), - (d2, ListConcat2), - ); + mk_right_associative_operands(DHDoc_common.precedence_Plus, d1, d2); DHDoc_common.mk_ListConcat(doc1, doc2); | BinOp(Bool(op), d1, d2) => let (doc1, doc2) = - mk_right_associative_operands( - precedence_bin_bool_op(op), - (d1, BinOp1), - (d2, BinOp2), - ); + mk_right_associative_operands(precedence_bin_bool_op(op), d1, d2); hseps([doc1, mk_bin_bool_op(op), doc2]); | Tuple([]) => DHDoc_common.Delim.triv - | Tuple(ds) => - DHDoc_common.mk_Tuple(ds |> List.mapi((i, d) => go'(d, Tuple(i)))) - | Prj(d, n) => DHDoc_common.mk_Prj(go'(d, Prj), n) + | Tuple(ds) => DHDoc_common.mk_Tuple(ds |> List.map(d => go'(d))) + | Prj(d, n) => DHDoc_common.mk_Prj(go'(d), n) | Match(Consistent, dscrut, drs) => go_case(dscrut, drs) | Cast(d, _, ty) when settings.show_casts => // TODO[Matt]: Roll multiple casts into one cast - let doc = go'(d, Cast); + let doc = go'(d); Doc.( hcat( doc, @@ -423,14 +368,14 @@ let mk = ) ); | Cast(d, _, _) => - let doc = go'(d, Cast); + let doc = go'(d); doc; | Let(dp, ddef, dbody) => if (enforce_inline) { fail(); } else { let bindings = DHPat.bound_vars(dp); - let def_doc = go_formattable(ddef, Let1); + let def_doc = go_formattable(ddef); vseps([ hcats([ DHDoc_common.Delim.mk("let"), @@ -453,14 +398,13 @@ let mk = ~recent_subst= List.filter(x => !List.mem(x, bindings), recent_subst), dbody, - Let2, ), ]); } | FailedCast(d1, ty2', ty3) => switch (DHExp.term_of(d1)) { | Cast(d, ty1, ty2) when Typ.eq(ty2, ty2') => - let d_doc = go'(d, FailedCastCast); + let d_doc = go'(d); let cast_decoration = hcats([ DHDoc_common.Delim.open_FailedCast, @@ -476,16 +420,16 @@ let mk = | _ => failwith("unexpected FailedCast without inner cast") } | InvalidOperation(d, err) => - let d_doc = go'(d, InvalidOperation); + let d_doc = go'(d); let decoration = Doc.text(InvalidOperationError.err_msg(err)) |> annot(DHAnnot.OperationError(err)); hcats([d_doc, decoration]); | If(_, c, d1, d2) => - let c_doc = go_formattable(c, If1); - let d1_doc = go_formattable(d1, If2); - let d2_doc = go_formattable(d2, If3); + let c_doc = go_formattable(c); + let d1_doc = go_formattable(d1); + let d2_doc = go_formattable(d2); hcats([ DHDoc_common.Delim.mk("("), DHDoc_common.Delim.mk("if"), @@ -525,7 +469,6 @@ let mk = ), ~recent_subst= List.filter(x => !List.mem(x, bindings), recent_subst), - Fun, ); hcats( [ @@ -568,7 +511,6 @@ let mk = ~recent_subst= List.filter(x => !List.mem(x, bindings), recent_subst), ~recursive_calls=Option.to_list(s) @ recursive_calls, - Fun, ); hcats( [ @@ -606,7 +548,6 @@ let mk = go_formattable( dbody, ~env=ClosureEnvironment.without_keys([x], env), - FixF, ); hcats( [DHDoc_common.Delim.fix_FixF, space(), text(x)] @@ -627,25 +568,28 @@ let mk = ], ); | FixF(x, _, d) => - go'(~env=ClosureEnvironment.without_keys([x], env), d, FixF) + go'(~env=ClosureEnvironment.without_keys([x], env), d) }; }; let steppable = - next_steps |> List.find_opt(((ctx, _)) => ctx == EvalCtx.Mark); + next_steps + |> List.find_opt((eo: EvalObj.t) => + DHExp.rep_id(eo.d_loc) == DHExp.rep_id(d) + ); let stepped = chosen_step - |> Option.map(x => x.ctx == Mark) + |> Option.map(x => DHExp.rep_id(x.d_loc) == DHExp.rep_id(d)) |> Option.value(~default=false); let substitution = hidden_steps - |> List.find_opt(step => + |> List.find_opt(((step, id)) => step.knd == VarLookup // HACK[Matt]: to prevent substitutions hiding inside casts - && EvalCtx.fuzzy_mark(step.ctx) + && id == DHExp.rep_id(d) ); let doc = switch (substitution) { - | Some(step) => + | Some((step, _)) => switch (DHExp.term_of(step.d_loc)) { | Var(v) when List.mem(v, recent_subst) => hcats([text(v) |> annot(DHAnnot.Substituted), doc]) @@ -658,21 +602,11 @@ let mk = annot(DHAnnot.Stepped, doc); } else { switch (steppable) { - | Some((_, full)) => annot(DHAnnot.Steppable(full), doc) + | Some(eo) => annot(DHAnnot.Steppable(eo), doc) | None => doc }; }; doc; }; - go( - d, - env, - enforce_inline, - previous_step, - hidden_steps, - chosen_step, - List.map((x: EvalObj.t) => (x.ctx, x), next_steps), - [], - [], - ); + go(d, env, enforce_inline, [], []); }; diff --git a/src/util/Aba.re b/src/util/Aba.re index bf03b9899d..39c2e9db0d 100644 --- a/src/util/Aba.re +++ b/src/util/Aba.re @@ -47,6 +47,19 @@ let rec aba_triples = (aba: t('a, 'b)): list(('a, 'b, 'a)) => ] | _ => [] }; +let rec bab_triples' = + (b1: option('b), aba: t('a, 'b)) + : list((option('b), 'a, option('b))) => + switch (aba) { + | ([a, ...as_], [b2, ...bs]) => [ + (b1, a, Some(b2)), + ...bab_triples'(Some(b2), (as_, bs)), + ] + | ([a], []) => [(b1, a, None)] + | _ => [] + }; +let bab_triples: t('a, 'b) => list((option('b), 'a, option('b))) = + aba => bab_triples'(None, aba); let map_a = (f_a: 'a => 'c, (as_, bs): t('a, 'b)): t('c, 'b) => ( List.map(f_a, as_), @@ -61,6 +74,10 @@ let map_abas = as_, List.map(f_aba, aba_triples(aba)), ); +let map_hd = (f_a: 'a => 'a, (as_, bs): t('a, 'b)): t('a, 'b) => ( + [as_ |> List.hd |> f_a, ...as_ |> List.tl], + bs, +); let trim = ((as_, bs): t('a, 'b)): option(('a, t('b, 'a), 'a)) => switch (bs) { From 720ae55e2107b59874accdc29e2a9e2c0e61676e Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Tue, 6 Feb 2024 16:24:06 -0500 Subject: [PATCH 006/103] Update comments from meeting with Andrew --- src/haz3lcore/dynamics/DH.re | 24 ++++++++++++------------ src/haz3lcore/statics/TermBase.re | 1 + 2 files changed, 13 insertions(+), 12 deletions(-) diff --git a/src/haz3lcore/dynamics/DH.re b/src/haz3lcore/dynamics/DH.re index 43322a0f1f..1ed7c72e70 100644 --- a/src/haz3lcore/dynamics/DH.re +++ b/src/haz3lcore/dynamics/DH.re @@ -15,22 +15,22 @@ module rec DHExp: { Parens */ // TODO: Work out how to reconcile the invalids - | EmptyHole(MetaVar.t, HoleInstanceId.t) - | NonEmptyHole(ErrStatus.HoleReason.t, MetaVar.t, HoleInstanceId.t, t) - | ExpandingKeyword(MetaVar.t, HoleInstanceId.t, ExpandingKeyword.t) - | FreeVar(MetaVar.t, HoleInstanceId.t, Var.t) - | InvalidText(MetaVar.t, HoleInstanceId.t, string) - | InvalidOperation(t, InvalidOperationError.t) + | EmptyHole(MetaVar.t, HoleInstanceId.t) // TODO: Remove metavar/Holeinstanceid, for now? + | NonEmptyHole(ErrStatus.HoleReason.t, MetaVar.t, HoleInstanceId.t, t) // TODO: Remove, use infomap + | ExpandingKeyword(MetaVar.t, HoleInstanceId.t, ExpandingKeyword.t) // TODO: Remove, use infomap + | FreeVar(MetaVar.t, HoleInstanceId.t, Var.t) // TODO: Remove, use infomap + | InvalidText(MetaVar.t, HoleInstanceId.t, string) // DONE [ALREADY] + | InvalidOperation(t, InvalidOperationError.t) // Warning will robinson | FailedCast(t, Typ.t, Typ.t) | Closure([@show.opaque] ClosureEnvironment.t, t) // > UEXP | Filter(DHFilter.t, t) // DONE [UEXP TO BE CHANGED] | Var(Var.t) // DONE [ALREADY] | Seq(t, t) // DONE [ALREADY] | Let(DHPat.t, t, t) // DONE [ALREADY] - | FixF(Var.t, Typ.t, t) // TODO: ! REMOVE, LEAVE AS LETS? - | Fun(DHPat.t, Typ.t, t, option(ClosureEnvironment.t), option(Var.t)) // TODO: Move type into pattern?; name > UEXP + | FixF(Var.t, Typ.t, t) // TODO: surface fix + | Fun(DHPat.t, Typ.t, t, option(ClosureEnvironment.t), option(Var.t)) // TODO: Use infomap for Typ.t | Ap(t, t) // TODO: Add reverse application - | ApBuiltin(string, t) // DONE [TO ADD TO UEXP] + | ApBuiltin(string, t) // DONE [TO ADD TO UEXP] TODO: Add a loooong comment here | BuiltinFun(string) // DONE [TO ADD TO UEXP] | Test(KeywordID.t, t) // TODO: ! ID | Bool(bool) // DONE @@ -38,16 +38,16 @@ module rec DHExp: { | Float(float) // DONE | String(string) // DONE | BinOp(TermBase.UExp.op_bin, t, t) // DONE - | ListLit(MetaVar.t, MetaVarInst.t, Typ.t, list(t)) // TODO: afaict the first three arguments here are never used? + | ListLit(MetaVar.t, MetaVarInst.t, Typ.t, list(t)) // TODO: afaict the first three arguments here are never used? 3rd one might be infomap | Cons(t, t) // DONE [ALREADY] | ListConcat(t, t) // DONE [ALREADY] | Tuple(list(t)) // DONE [ALREADY] - | Prj(t, int) // TODO: ! REMOVE, LEAVE AS LETS? + | Prj(t, int) // TODO: Add to uexp | Constructor(string) // DONE [ALREADY] | Match(consistency, t, list((DHPat.t, t))) | Cast(t, Typ.t, Typ.t) // TODO: Add to uexp or remove | If(consistency, t, t, t) - and t; // TODO: CONSISTENCY? use bool tag to track if branches are consistent + and t; // TODO: CONSISTENCY? from statics let rep_id: t => Id.t; let term_of: t => term; diff --git a/src/haz3lcore/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index daa72d7cd2..e0ce064543 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -267,6 +267,7 @@ and UExp: { Filter() ApBuiltin(string, t) // These two are different to `var` to allow shadowing of builtins BuiltinFun(string) + FixF() */ | Invalid(string) // TODO: Reconcile the invalids | EmptyHole // DONE From 7dd9a780282cff842bed621ae29c0358d09af5cb Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Tue, 6 Feb 2024 16:50:34 -0500 Subject: [PATCH 007/103] Fix up ids to make them unique after evaluation --- src/haz3lcore/dynamics/DH.re | 60 +++++++++++++++++++++++++++++ src/haz3lcore/dynamics/Evaluator.re | 6 +-- src/haz3lcore/dynamics/Stepper.re | 15 ++------ 3 files changed, 66 insertions(+), 15 deletions(-) diff --git a/src/haz3lcore/dynamics/DH.re b/src/haz3lcore/dynamics/DH.re index 1ed7c72e70..a73e6a5585 100644 --- a/src/haz3lcore/dynamics/DH.re +++ b/src/haz3lcore/dynamics/DH.re @@ -64,6 +64,8 @@ module rec DHExp: { let apply_casts: (t, list((Typ.t, Typ.t))) => t; let strip_casts: t => t; + let repair_ids: t => t; + let fast_equal: (t, t) => bool; } = { [@deriving (show({with_path: false}), sexp, yojson)] @@ -179,6 +181,64 @@ module rec DHExp: { let apply_casts = (d: t, casts: list((Typ.t, Typ.t))): t => List.fold_left((d, (ty1, ty2)) => fresh_cast(d, ty1, ty2), d, casts); + // preorder traversal + let rec repair_ids = (require: bool, d: t) => { + let child_require = require || !d.ids_are_unique; + let repair_ids = repair_ids(child_require); + let term = term_of(d); + let rewrap = term => { + ids: require ? [Id.mk()] : d.ids, + ids_are_unique: true, + term, + }; + ( + switch (term) { + | EmptyHole(_) + | ExpandingKeyword(_) + | FreeVar(_) + | InvalidText(_) + | Var(_) + | BuiltinFun(_) + | Bool(_) + | Int(_) + | Float(_) + | String(_) + | Constructor(_) => term + | NonEmptyHole(x, y, z, d1) => NonEmptyHole(x, y, z, repair_ids(d1)) + | InvalidOperation(d1, x) => InvalidOperation(repair_ids(d1), x) + | FailedCast(d1, t1, t2) => FailedCast(repair_ids(d1), t1, t2) + | Closure(env, d1) => Closure(env, repair_ids(d1)) + | Filter(flt, d1) => Filter(flt, repair_ids(d1)) + | Seq(d1, d2) => Seq(repair_ids(d1), repair_ids(d2)) + | Let(dp, d1, d2) => Let(dp, repair_ids(d1), repair_ids(d2)) + | FixF(f, t, d1) => FixF(f, t, repair_ids(d1)) + | Fun(dp, t, d1, env, f) => Fun(dp, t, repair_ids(d1), env, f) + | Ap(d1, d2) => Ap(repair_ids(d1), repair_ids(d2)) + | ApBuiltin(s, d1) => ApBuiltin(s, repair_ids(d1)) + | Test(id, d1) => Test(id, repair_ids(d1)) + | BinOp(op, d1, d2) => BinOp(op, repair_ids(d1), repair_ids(d2)) + | ListLit(mv, mvi, t, ds) => + ListLit(mv, mvi, t, List.map(repair_ids, ds)) + | Cons(d1, d2) => Cons(repair_ids(d1), repair_ids(d2)) + | ListConcat(d1, d2) => ListConcat(repair_ids(d1), repair_ids(d2)) + | Tuple(ds) => Tuple(List.map(repair_ids, ds)) + | Prj(d1, i) => Prj(repair_ids(d1), i) + | Match(c, d1, rls) => + Match( + c, + repair_ids(d1), + List.map(((p, d)) => (p, repair_ids(d)), rls), + ) + | Cast(d1, t1, t2) => Cast(repair_ids(d1), t1, t2) + | If(c, d1, d2, d3) => + If(c, repair_ids(d1), repair_ids(d2), repair_ids(d3)) + } + ) + |> rewrap; + }; + + let repair_ids = repair_ids(false); + let rec strip_casts = d => { let (term, rewrap) = unwrap(d); switch (term) { diff --git a/src/haz3lcore/dynamics/Evaluator.re b/src/haz3lcore/dynamics/Evaluator.re index 5395627ff3..29481365b1 100644 --- a/src/haz3lcore/dynamics/Evaluator.re +++ b/src/haz3lcore/dynamics/Evaluator.re @@ -112,9 +112,9 @@ let evaluate = (env, d): (EvaluatorState.t, EvaluatorResult.t) => { let result = evaluate(state, env, d); let result = switch (result) { - | BoxedValue(x) => BoxedValue(x) - | Indet(x) => Indet(x) - | Uneval(x) => Indet(x) + | BoxedValue(x) => BoxedValue(x |> DHExp.repair_ids) + | Indet(x) => Indet(x |> DHExp.repair_ids) + | Uneval(x) => Indet(x |> DHExp.repair_ids) }; (state^, result); }; diff --git a/src/haz3lcore/dynamics/Stepper.re b/src/haz3lcore/dynamics/Stepper.re index b6f34fc0ec..6c64ed16d1 100644 --- a/src/haz3lcore/dynamics/Stepper.re +++ b/src/haz3lcore/dynamics/Stepper.re @@ -224,6 +224,7 @@ let rec evaluate_pending = (~settings, s: t) => { | None => raise(Exception) }; let d' = compose(eo.ctx, d_loc'); + let d' = DHExp.repair_ids(d'); let new_step = { d, d_loc: eo.d_loc, @@ -331,24 +332,17 @@ type step_info = { let get_history = (~settings, stepper) => { let should_skip_step = step => step |> should_hide_step(~settings) |> fst == Eval; - let _ = print_int(List.length(fst(stepper.history))); let grouped_steps = stepper.history |> Aba.fold_right( - ((d, _), step, result) => { - print_string("e"); - print_int(result |> fst |> List.length); - print_int(result |> snd |> List.length); + ((d, _), step, result) => if (should_skip_step(step)) { Aba.map_hd(((_, hs)) => (d, [step, ...hs]), result); } else { Aba.cons((d, []), step, result); - }; - }, + }, ((d, _)) => Aba.singleton((d, [])), ); - let _ = print_int(List.length(fst(grouped_steps))); - let _ = print_int(List.length(snd(grouped_steps))); let replace_id = (x, y, (s, z)) => (s, x == z ? y : z); let track_ids = ( @@ -374,10 +368,7 @@ let get_history = (~settings, stepper) => { {d, previous_step, hidden_steps, chosen_step}; }; let padded = grouped_steps |> Aba.bab_triples; - let _ = print_int(List.length(padded)); let result = padded |> List.map(track_ids); - let _ = print_int(List.length(result)); - print_endline(""); result; //grouped_steps |> Aba.bab_triples |> List.map(track_ids); }; From bdf0310d41a86af93d18b16202efecb149c9690e Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 8 Feb 2024 13:19:24 -0500 Subject: [PATCH 008/103] Remove hole instance identifiers, postprocessing --- src/haz3lcore/dynamics/DH.re | 16 +- src/haz3lcore/dynamics/Elaborator.re | 8 +- src/haz3lcore/dynamics/EvaluatorPost.re | 592 ------------------ src/haz3lcore/dynamics/EvaluatorPost.rei | 71 --- src/haz3lcore/dynamics/FilterMatcher.re | 4 +- src/haz3lcore/dynamics/PatternMatch.re | 8 +- src/haz3lcore/dynamics/Substitution.re | 2 +- src/haz3lcore/dynamics/Transition.re | 2 +- src/haz3lcore/prog/Interface.re | 45 +- src/haz3lweb/view/dhcode/DHCode.re | 2 +- src/haz3lweb/view/dhcode/layout/DHAnnot.re | 2 +- src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 16 +- src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re | 2 +- src/haz3lweb/view/dhcode/layout/DHDoc_Util.re | 10 +- .../view/dhcode/layout/DHDoc_common.re | 6 +- .../view/dhcode/layout/DHDoc_common.rei | 4 +- 16 files changed, 40 insertions(+), 750 deletions(-) delete mode 100644 src/haz3lcore/dynamics/EvaluatorPost.re delete mode 100644 src/haz3lcore/dynamics/EvaluatorPost.rei diff --git a/src/haz3lcore/dynamics/DH.re b/src/haz3lcore/dynamics/DH.re index a73e6a5585..12eccee0ca 100644 --- a/src/haz3lcore/dynamics/DH.re +++ b/src/haz3lcore/dynamics/DH.re @@ -15,13 +15,13 @@ module rec DHExp: { Parens */ // TODO: Work out how to reconcile the invalids - | EmptyHole(MetaVar.t, HoleInstanceId.t) // TODO: Remove metavar/Holeinstanceid, for now? + | EmptyHole | NonEmptyHole(ErrStatus.HoleReason.t, MetaVar.t, HoleInstanceId.t, t) // TODO: Remove, use infomap | ExpandingKeyword(MetaVar.t, HoleInstanceId.t, ExpandingKeyword.t) // TODO: Remove, use infomap | FreeVar(MetaVar.t, HoleInstanceId.t, Var.t) // TODO: Remove, use infomap | InvalidText(MetaVar.t, HoleInstanceId.t, string) // DONE [ALREADY] | InvalidOperation(t, InvalidOperationError.t) // Warning will robinson - | FailedCast(t, Typ.t, Typ.t) + | FailedCast(t, Typ.t, Typ.t) // TODO: Add to TermBase | Closure([@show.opaque] ClosureEnvironment.t, t) // > UEXP | Filter(DHFilter.t, t) // DONE [UEXP TO BE CHANGED] | Var(Var.t) // DONE [ALREADY] @@ -71,7 +71,7 @@ module rec DHExp: { [@deriving (show({with_path: false}), sexp, yojson)] type term = /* Hole types */ - | EmptyHole(MetaVar.t, HoleInstanceId.t) + | EmptyHole | NonEmptyHole(ErrStatus.HoleReason.t, MetaVar.t, HoleInstanceId.t, t) | ExpandingKeyword(MetaVar.t, HoleInstanceId.t, ExpandingKeyword.t) | FreeVar(MetaVar.t, HoleInstanceId.t, Var.t) @@ -136,7 +136,7 @@ module rec DHExp: { let constructor_string = ({term: d, _}: t): string => switch (d) { - | EmptyHole(_, _) => "EmptyHole" + | EmptyHole => "EmptyHole" | NonEmptyHole(_, _, _, _) => "NonEmptyHole" | ExpandingKeyword(_, _, _) => "ExpandingKeyword" | FreeVar(_, _, _) => "FreeVar" @@ -193,7 +193,7 @@ module rec DHExp: { }; ( switch (term) { - | EmptyHole(_) + | EmptyHole | ExpandingKeyword(_) | FreeVar(_) | InvalidText(_) @@ -272,7 +272,7 @@ module rec DHExp: { List.map(((k, v)) => (k, strip_casts(v)), rules), ) |> rewrap - | EmptyHole(_) as d + | EmptyHole as d | ExpandingKeyword(_) as d | FreeVar(_) as d | InvalidText(_) as d @@ -384,7 +384,7 @@ module rec DHExp: { environment ID's are equal, don't check structural equality. (This resolves a performance issue with many nested holes.) */ - | (EmptyHole(u1, i1), EmptyHole(u2, i2)) => u1 == u2 && i1 == i2 + | (EmptyHole, EmptyHole) => true | (NonEmptyHole(reason1, u1, i1, d1), NonEmptyHole(reason2, u2, i2, d2)) => reason1 == reason2 && u1 == u2 && i1 == i2 && fast_equal(d1, d2) | (ExpandingKeyword(u1, i1, kw1), ExpandingKeyword(u2, i2, kw2)) => @@ -395,7 +395,7 @@ module rec DHExp: { u1 == u2 && i1 == i2 && text1 == text2 | (Closure(sigma1, d1), Closure(sigma2, d2)) => ClosureEnvironment.id_equal(sigma1, sigma2) && fast_equal(d1, d2) - | (EmptyHole(_), _) + | (EmptyHole, _) | (NonEmptyHole(_), _) | (ExpandingKeyword(_), _) | (FreeVar(_), _) diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index faaffe4fde..8cfc7601bf 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -86,7 +86,7 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => | InvalidText(_) | FreeVar(_) | ExpandingKeyword(_) - | EmptyHole(_) + | EmptyHole | NonEmptyHole(_) => d /* DHExp-specific forms: Don't cast */ | Cast(_) @@ -136,12 +136,12 @@ let rec dhexp_of_uexp = let+ d: DHExp.t = switch (uexp.term) { | Invalid(t) => Some(DHExp.InvalidText(id, 0, t) |> rewrap) - | EmptyHole => Some(DHExp.EmptyHole(id, 0) |> rewrap) + | EmptyHole => Some(DHExp.EmptyHole |> rewrap) | MultiHole(_tms) => /* TODO: add a dhexp case and eval logic for multiholes. Make sure new dhexp form is properly considered Indet to avoid casting issues. */ - Some(EmptyHole(id, 0) |> rewrap) + Some(EmptyHole |> rewrap) | Triv => Some(Tuple([]) |> rewrap) | Bool(b) => Some(Bool(b) |> rewrap) | Int(n) => Some(Int(n) |> rewrap) @@ -172,7 +172,7 @@ let rec dhexp_of_uexp = switch (e.term) { | Var("e") when in_filter => Some(Constructor("$e") |> DHExp.fresh) | Var("v") when in_filter => Some(Constructor("$v") |> DHExp.fresh) - | _ => Some(DHExp.EmptyHole(id, 0) |> rewrap) + | _ => Some(DHExp.EmptyHole |> rewrap) } | UnOp(Int(Minus), e) => let+ dc = dhexp_of_uexp(m, e); diff --git a/src/haz3lcore/dynamics/EvaluatorPost.re b/src/haz3lcore/dynamics/EvaluatorPost.re deleted file mode 100644 index d51a9b4b96..0000000000 --- a/src/haz3lcore/dynamics/EvaluatorPost.re +++ /dev/null @@ -1,592 +0,0 @@ -module PpMonad = { - include Util.StateMonad.Make({ - [@deriving sexp] - type t = (EnvironmentIdMap.t(ClosureEnvironment.t), HoleInstanceInfo_.t); - }); - - open Syntax; - - let get_pe = get >>| (((pe, _)) => pe); - let pe_add = (ei, env) => - modify(((pe, hii)) => (pe |> EnvironmentIdMap.add(ei, env), hii)); - - let hii_add_instance = (u, env) => - modify'(((pe, hii)) => { - let (hii, i) = HoleInstanceInfo_.add_instance(hii, u, env); - (i, (pe, hii)); - }); -}; - -open PpMonad; -open PpMonad.Syntax; -open DHExp; - -type m('a) = PpMonad.t('a); - -[@deriving sexp] -type error = - | ClosureInsideClosure - | FixFOutsideClosureEnv - | UnevalOutsideClosure - | InvalidClosureBody - | PostprocessedNonHoleInClosure - | PostprocessedHoleOutsideClosure; - -[@deriving sexp] -exception Exception(error); - -/** - Postprocess inside evaluation boundary. - */ -let rec pp_eval = (d: DHExp.t): m(DHExp.t) => { - let (term, rewrap) = DHExp.unwrap(d); - switch (term) { - /* Non-hole expressions: recurse through subexpressions */ - | Test(_) - | Bool(_) - | Int(_) - | Float(_) - | String(_) - | Constructor(_) => d |> return - - | Seq(d1, d2) => - let* d1' = pp_eval(d1); - let+ d2' = pp_eval(d2); - Seq(d1', d2') |> rewrap; - - | Filter(f, dbody) => - let+ dbody' = pp_eval(dbody); - Filter(f, dbody') |> rewrap; - - | Ap(d1, d2) => - let* d1' = pp_eval(d1); - let* d2' = pp_eval(d2); - Ap(d1', d2') |> rewrap |> return; - - | ApBuiltin(f, d1) => - let* d1' = pp_eval(d1); - ApBuiltin(f, d1') |> rewrap |> return; - - | BinOp(op, d1, d2) => - let* d1' = pp_eval(d1); - let* d2' = pp_eval(d2); - BinOp(op, d1', d2') |> rewrap |> return; - - | BuiltinFun(f) => BuiltinFun(f) |> rewrap |> return - - | Cons(d1, d2) => - let* d1' = pp_eval(d1); - let* d2' = pp_eval(d2); - Cons(d1', d2') |> rewrap |> return; - - | ListConcat(d1, d2) => - let* d1' = pp_eval(d1); - let* d2' = pp_eval(d2); - ListConcat(d1', d2') |> rewrap |> return; - - | ListLit(a, b, c, ds) => - let+ ds = - ds - |> List.fold_left( - (ds, d) => { - let* ds = ds; - let+ d = pp_eval(d); - ds @ [d]; - }, - return([]), - ); - ListLit(a, b, c, ds) |> rewrap; - - | Tuple(ds) => - let+ ds = - ds - |> List.fold_left( - (ds, d) => { - let* ds = ds; - let+ d = pp_eval(d); - ds @ [d]; - }, - return([]), - ); - Tuple(ds) |> rewrap; - - | Prj(d, n) => - let+ d = pp_eval(d); - Prj(d, n) |> rewrap; - - | Cast(d', ty1, ty2) => - let* d'' = pp_eval(d'); - Cast(d'', ty1, ty2) |> rewrap |> return; - - | FailedCast(d', ty1, ty2) => - let* d'' = pp_eval(d'); - FailedCast(d'', ty1, ty2) |> rewrap |> return; - - | InvalidOperation(d', reason) => - let* d'' = pp_eval(d'); - InvalidOperation(d'', reason) |> rewrap |> return; - - | If(consistent, c, d1, d2) => - let* c' = pp_eval(c); - let* d1' = pp_eval(d1); - let* d2' = pp_eval(d2); - If(consistent, c', d1', d2') |> rewrap |> return; - - // TODO: Add consistent case - - /* These expression forms should not exist outside closure in evaluated result */ - | Var(_) - | Let(_) - | Fun(_, _, _, None, _) - | Match(_) - | EmptyHole(_) - | NonEmptyHole(_) - | ExpandingKeyword(_) - | FreeVar(_) - | InvalidText(_) => raise(Exception(UnevalOutsideClosure)) - - | FixF(_) => raise(Exception(FixFOutsideClosureEnv)) - - /* Closure: postprocess environment, then postprocess `d'`. - - Some parts of `d'` may lie inside and outside the evaluation boundary, - use `pp_eval` and `pp_uneval` as necessary. - */ - | Fun(dp, ty, d, Some(env), s) => - let* env = - Util.TimeUtil.measure_time("pp_eval_env/FunClosure", true, () => - pp_eval_env(env) - ); - let* d = pp_uneval(env, d); - Fun(dp, ty, d, Some(env), s) |> rewrap |> return; - - | Closure(env, d) => - let* env = - Util.TimeUtil.measure_time("pp_eval_env/Closure", true, () => - pp_eval_env(env) - ); - let (term, rewrap) = DHExp.unwrap(d); - switch (term) { - /* Non-hole constructs inside closures. */ - | Let(dp, d1, d2) => - /* d1 should already be evaluated, d2 is not */ - let* d1 = pp_eval(d1); - let* d2 = pp_uneval(env, d2); - Let(dp, d1, d2) |> rewrap |> return; - - | Match(Consistent, scrut, rules) => - /* scrut should already be evaluated, rule bodies are not */ - let* scrut = - Util.TimeUtil.measure_time("pp_eval(scrut)", true, () => - pp_eval(scrut) - ); - let* rules = - Util.TimeUtil.measure_time("pp_uneval_rules", true, () => - pp_uneval_rules(env, rules) - ); - Match(Consistent, scrut, rules) |> rewrap |> return; - - /* Hole constructs inside closures. - - `NonEmptyHole` and `InconsistentBranches` have subexpressions that - lie inside the evaluation boundary, and need to be handled differently - than in `pp_uneval`. The other hole types don't have any evaluated - subexpressions and we can use `pp_uneval`. - */ - | NonEmptyHole(reason, u, _, d) => - let* d = pp_eval(d); - let* i = hii_add_instance(u, env); - Closure(env, NonEmptyHole(reason, u, i, d) |> rewrap) - |> fresh - |> return; - - | Match(Inconsistent(u, _), scrut, rules) => - let* scrut = pp_eval(scrut); - let* i = hii_add_instance(u, env); - Closure(env, Match(Inconsistent(u, i), scrut, rules) |> rewrap) - |> fresh - |> return; - - | EmptyHole(_) - | ExpandingKeyword(_) - | FreeVar(_) - | InvalidText(_) => pp_uneval(env, d) - - /* Other expression forms cannot be directly in a closure. */ - | _ => raise(Exception(InvalidClosureBody)) - }; - }; -} - -/* Recurse through environments, using memoized result if available. */ -and pp_eval_env = (env: ClosureEnvironment.t): m(ClosureEnvironment.t) => { - let ei = env |> ClosureEnvironment.id_of; - - let* pe = get_pe; - switch (pe |> EnvironmentIdMap.find_opt(ei)) { - | Some(env) => env |> return - | None => - let* env = - env - |> ClosureEnvironment.fold( - ((x, d), env') => { - let* env' = env'; - let* d' = { - let (term, rewrap) = DHExp.unwrap(d); - switch (term) { - | FixF(f, ty, d1) => - let+ d1 = pp_uneval(env', d1); - FixF(f, ty, d1) |> rewrap; - | _ => pp_eval(d) - }; - }; - ClosureEnvironment.extend(env', (x, d')) |> return; - }, - Environment.empty |> ClosureEnvironment.wrap(ei) |> return, - ); - - let* () = pe_add(ei, env); - env |> return; - }; -} - -/** - Postprocess inside evaluation boundary. Environment should already be - postprocessed. - */ -and pp_uneval = (env: ClosureEnvironment.t, d: DHExp.t): m(DHExp.t) => { - let (term, rewrap) = DHExp.unwrap(d); - switch (term) { - /* Bound variables should be looked up within the closure - environment. If lookup fails, then variable is not bound. */ - | Var(x) => - switch (ClosureEnvironment.lookup(env, x)) { - | Some(d') => d' |> return - | None => d |> return - } - - /* Non-hole expressions: expand recursively */ - | Bool(_) - | Int(_) - | Float(_) - | String(_) - | Constructor(_) => d |> return - - | Test(id, d1) => - let+ d1' = pp_uneval(env, d1); - Test(id, d1') |> rewrap; - - | Seq(d1, d2) => - let* d1' = pp_uneval(env, d1); - let+ d2' = pp_uneval(env, d2); - Seq(d1', d2') |> rewrap; - - | Filter(flt, dbody) => - let+ dbody' = pp_uneval(env, dbody); - Filter(flt, dbody') |> rewrap; - | Let(dp, d1, d2) => - let* d1' = pp_uneval(env, d1); - let* d2' = pp_uneval(env, d2); - Let(dp, d1', d2') |> rewrap |> return; - - | FixF(f, ty, d1) => - let* d1' = pp_uneval(env, d1); - FixF(f, ty, d1') |> rewrap |> return; - - | Fun(dp, ty, d', None, s) => - let* d'' = pp_uneval(env, d'); - Fun(dp, ty, d'', None, s) |> rewrap |> return; - - | Ap(d1, d2) => - let* d1' = pp_uneval(env, d1); - let* d2' = pp_uneval(env, d2); - Ap(d1', d2') |> rewrap |> return; - - | ApBuiltin(f, d1) => - let* d1' = pp_uneval(env, d1); - ApBuiltin(f, d1') |> rewrap |> return; - | BuiltinFun(f) => BuiltinFun(f) |> rewrap |> return - - | BinOp(op, d1, d2) => - let* d1' = pp_uneval(env, d1); - let* d2' = pp_uneval(env, d2); - BinOp(op, d1', d2') |> rewrap |> return; - - | If(consistent, c, d1, d2) => - let* c' = pp_uneval(env, c); - let* d1' = pp_uneval(env, d1); - let* d2' = pp_uneval(env, d2); - If(consistent, c', d1', d2') |> rewrap |> return; - - | Cons(d1, d2) => - let* d1' = pp_uneval(env, d1); - let* d2' = pp_uneval(env, d2); - Cons(d1', d2') |> rewrap |> return; - - | ListConcat(d1, d2) => - let* d1' = pp_uneval(env, d1); - let* d2' = pp_uneval(env, d2); - ListConcat(d1', d2') |> rewrap |> return; - - | ListLit(a, b, c, ds) => - let+ ds = - ds - |> List.fold_left( - (ds, d) => { - let* ds = ds; - let+ d = pp_uneval(env, d); - ds @ [d]; - }, - return([]), - ); - ListLit(a, b, c, ds) |> rewrap; - - | Tuple(ds) => - let+ ds = - ds - |> List.fold_left( - (ds, d) => { - let* ds = ds; - let+ d = pp_uneval(env, d); - ds @ [d]; - }, - return([]), - ); - Tuple(ds) |> rewrap; - - | Prj(d, n) => - let+ d = pp_uneval(env, d); - Prj(d, n) |> rewrap; - - | Cast(d', ty1, ty2) => - let* d'' = pp_uneval(env, d'); - Cast(d'', ty1, ty2) |> rewrap |> return; - - | FailedCast(d', ty1, ty2) => - let* d'' = pp_uneval(env, d'); - FailedCast(d'', ty1, ty2) |> rewrap |> return; - - | InvalidOperation(d', reason) => - let* d'' = pp_uneval(env, d'); - InvalidOperation(d'', reason) |> rewrap |> return; - - | Match(Consistent, scrut, rules) => - let* scrut' = pp_uneval(env, scrut); - let* rules' = pp_uneval_rules(env, rules); - Match(Consistent, scrut', rules') |> rewrap |> return; - - /* Closures shouldn't exist inside other closures */ - | Fun(_, _, _, Some(_), _) - | Closure(_) => raise(Exception(ClosureInsideClosure)) - - /* Hole expressions: - - Use the closure environment as the hole environment. - - Number the hole instance appropriately. - - Recurse through inner expression (if any). - */ - | EmptyHole(u, _) => - let* i = hii_add_instance(u, env); - Closure(env, EmptyHole(u, i) |> rewrap) |> fresh |> return; - - | NonEmptyHole(reason, u, _, d') => - let* d' = pp_uneval(env, d'); - let* i = hii_add_instance(u, env); - Closure(env, NonEmptyHole(reason, u, i, d') |> rewrap) |> fresh |> return; - - | ExpandingKeyword(u, _, kw) => - let* i = hii_add_instance(u, env); - Closure(env, ExpandingKeyword(u, i, kw) |> rewrap) |> fresh |> return; - - | FreeVar(u, _, x) => - let* i = hii_add_instance(u, env); - Closure(env, FreeVar(u, i, x) |> rewrap) |> fresh |> return; - - | InvalidText(u, _, text) => - let* i = hii_add_instance(u, env); - Closure(env, InvalidText(u, i, text) |> rewrap) |> fresh |> return; - - | Match(Inconsistent(u, _), scrut, rules) => - let* scrut = pp_uneval(env, scrut); - let* rules = pp_uneval_rules(env, rules); - let* i = hii_add_instance(u, env); - Closure(env, Match(Inconsistent(u, i), scrut, rules) |> rewrap) - |> fresh - |> return; - }; -} - -and pp_uneval_rules = - (env: ClosureEnvironment.t, rules: list((DHPat.t, DHExp.t))) - : m(list((DHPat.t, DHExp.t))) => { - rules - |> List.map(((dp, d)) => { - let* d' = pp_uneval(env, d); - (dp, d') |> return; - }) - |> sequence; -}; - -/** - Tracking children of hole instances. A hole instance is a child of another hole - instance if it exists in the hole environment of the parent. - - This is the second stage of postprocessing, separate from hole numbering and - substitution, since memoization becomes much more convoluted if these two - stages are combined. - - This works by simply iterating over all the (postprocessed) hole instance - environments in the HoleInstanceInfo_.t and looking for "child" holes. - */ -let rec track_children_of_hole = - (hii: HoleInstanceInfo.t, parent: HoleInstanceParents.t_, d: DHExp.t) - : HoleInstanceInfo.t => - switch (DHExp.term_of(d)) { - | Constructor(_) - | Bool(_) - | Int(_) - | Float(_) - | String(_) - | BuiltinFun(_) - | Var(_) => hii - | Test(_, d) - | FixF(_, _, d) - | Fun(_, _, d, _, _) - | Prj(d, _) - | Cast(d, _, _) - | FailedCast(d, _, _) - | InvalidOperation(d, _) => track_children_of_hole(hii, parent, d) - | Seq(d1, d2) - | Let(_, d1, d2) - | Ap(d1, d2) - | BinOp(_, d1, d2) - | Cons(d1, d2) => - let hii = track_children_of_hole(hii, parent, d1); - track_children_of_hole(hii, parent, d2); - | ListConcat(d1, d2) => - let hii = track_children_of_hole(hii, parent, d1); - track_children_of_hole(hii, parent, d2); - - | ListLit(_, _, _, ds) => - List.fold_right( - (d, hii) => track_children_of_hole(hii, parent, d), - ds, - hii, - ) - - | Tuple(ds) => - List.fold_right( - (d, hii) => track_children_of_hole(hii, parent, d), - ds, - hii, - ) - | If(_, c, d1, d2) => - let hii = track_children_of_hole(hii, parent, c); - let hii = track_children_of_hole(hii, parent, d1); - track_children_of_hole(hii, parent, d2); - - | Match(Consistent, scrut, rules) => - let hii = - Util.TimeUtil.measure_time("track_children_of_hole(scrut)", true, () => - track_children_of_hole(hii, parent, scrut) - ); - Util.TimeUtil.measure_time("track_children_of_hole_rules", true, () => - track_children_of_hole_rules(hii, parent, rules) - ); - - | ApBuiltin(_, d) => track_children_of_hole(hii, parent, d) - - /* Hole types */ - | NonEmptyHole(_, u, i, d) => - let hii = track_children_of_hole(hii, parent, d); - hii |> HoleInstanceInfo.add_parent((u, i), parent); - | Match(Inconsistent(u, i), scrut, rules) => - let hii = track_children_of_hole(hii, parent, scrut); - let hii = track_children_of_hole_rules(hii, parent, rules); - hii |> HoleInstanceInfo.add_parent((u, i), parent); - | EmptyHole(u, i) - | ExpandingKeyword(u, i, _) - | FreeVar(u, i, _) - | InvalidText(u, i, _) => - hii |> HoleInstanceInfo.add_parent((u, i), parent) - - /* The only thing that should exist in closures at this point - are holes. Ignore the hole environment, not necessary for - parent tracking. */ - | Filter(_, d) - | Closure(_, d) => track_children_of_hole(hii, parent, d) - } - -and track_children_of_hole_rules = - ( - hii: HoleInstanceInfo.t, - parent: HoleInstanceParents.t_, - rules: list((DHPat.t, DHExp.t)), - ) - : HoleInstanceInfo.t => - List.fold_right( - ((_, d), hii) => track_children_of_hole(hii, parent, d), - rules, - hii, - ); - -/** - Driver for hole parent tracking; iterate through all hole instances in the - [HoleInstanceInfo.t], and call [track_children_of_hole] on them. - */ -let track_children = (hii: HoleInstanceInfo.t): HoleInstanceInfo.t => - MetaVarMap.fold( - (u, his, hii) => - List.fold_right( - ((i, (env, _)), hii) => - Environment.foldo( - ((x, d), hii) => track_children_of_hole(hii, (x, (u, i)), d), - hii, - env |> ClosureEnvironment.map_of, - ), - his |> List.mapi((i, hc) => (i, hc)), - hii, - ), - hii, - hii, - ); - -let postprocess = (d: DHExp.t): (HoleInstanceInfo.t, DHExp.t) => { - /* Substitution and hole numbering postprocessing */ - let ((_, hii), d) = - Util.TimeUtil.measure_time("pp_eval", true, () => - pp_eval(d, (EnvironmentIdMap.empty, HoleInstanceInfo_.empty)) - ); - - /* Build hole instance info. */ - let hii = - Util.TimeUtil.measure_time("to_hii", true, () => - hii |> HoleInstanceInfo_.to_hole_instance_info - ); - - /* Add special hole acting as top-level expression (to act as parent - for holes directly in the result) */ - /* FIXME: Better way to do this? */ - let (u_result, _) = HoleInstance.result; - let hii = - MetaVarMap.add( - u_result, - [ - ( - ClosureEnvironment.wrap( - EnvironmentId.invalid, - Environment.singleton(("", d)), - ), - [], - ), - ], - hii, - ); - - let hii = - Util.TimeUtil.measure_time("track_children", true, () => - hii |> track_children - ); - - /* Perform hole parent tracking. */ - (hii, d); -}; diff --git a/src/haz3lcore/dynamics/EvaluatorPost.rei b/src/haz3lcore/dynamics/EvaluatorPost.rei deleted file mode 100644 index 97df603897..0000000000 --- a/src/haz3lcore/dynamics/EvaluatorPost.rei +++ /dev/null @@ -1,71 +0,0 @@ -/** - Postprocessing of the evaluation result. - - NOTE: Currently disabled due to exponential blow-up in certain situations, but - leaving here for now until we can fully investigate. - - This has two functions: - - Match the evaluation result generated by evaluation with substitution. - This means to continue evaluation within expressions for which evaluation - has not reached (e.g., lambda expression bodies, unmatched case and let - expression bodies), by looking up bound variables and assigning hole - environments. - - Number holes and generate a HoleInstanceInfo.t that holds information - about all unique hole instances in the result. - - The postprocessing steps are partially memoized by environments. (Only - memoized among hole instances which share the same environment.) - - Algorithmically, this algorithm begins in the evaluated region of the - evaluation result inside the "evaluation boundary" (pp_eval), and continues - to the region outside the evaluation boundary (pp_uneval). - */ - -/** - Errors related to EvalPostprocess.postprocess - - Postprocessing invalid cases: Evaluation boundary is abbreviated as "EB". "In - closure" and "outside closure" correspond to "outside the EB" and "inside the - EB," respectively. - - The following errors are used to indicate an invalid case DURING - postprocessing: - - - ClosureInsideClosure: an evaluated expression outside the EB - - BoundVarOutsideClosure: an un-looked-up (unevaluated) variable inside the EB - - UnevalOutsideClosure: non-variable unevaluated expression inside the EB - - InvalidClosureBody: closures currently only make sense storing the - following expression types: - - Hole expressions - - Lambda abstractions - - Let/case with a pattern match failure - - The following errors are used to indicate an invalid case AFTER postprocessing. - After postprocessing, closures around lambda abstractions, let expressions, and - case expressions should be removed, and all hole expressions should be wrapped - in a closure. - - - PostprocessedNoneHoleInClosure - - PostprocessedHoleOutsideClosure - */ -[@deriving sexp] -type error = - | ClosureInsideClosure - | FixFOutsideClosureEnv - | UnevalOutsideClosure - | InvalidClosureBody - | PostprocessedNonHoleInClosure - | PostprocessedHoleOutsideClosure; - -[@deriving sexp] -exception Exception(error); - -/** - Postprocessing driver. - - Note: The top-level expression is wrapped in a non-empty hole, this is a - clean way of noting holes that lie directly in the result. - - See also HoleInstanceInfo.rei/HoleInstanceInfo_.rei. - */ -let postprocess: DHExp.t => (HoleInstanceInfo.t, DHExp.t); diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index 554fb63ad1..cdd8ff0e62 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -33,7 +33,7 @@ let rec matches_exp = | Expr => false } - | (_, EmptyHole(_)) + | (_, EmptyHole) | (_, Constructor("$e")) => true | (_, Closure(env, f)) => matches_exp(env, d, f) @@ -59,7 +59,7 @@ let rec matches_exp = | None => false } - | (EmptyHole(_), _) => false + | (EmptyHole, _) => false | (Filter(df, dd), Filter(ff, fd)) => DH.DHFilter.fast_equal(df, ff) && matches_exp(env, dd, fd) diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index 78d7881a4b..9e6835f895 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -40,7 +40,7 @@ let rec matches = (dp: DHPat.t, d: DHExp.t): match_result => | (Var(x), _) => let env = Environment.extend(Environment.empty, (x, d)); Matches(env); - | (_, EmptyHole(_)) => IndetMatch + | (_, EmptyHole) => IndetMatch | (_, NonEmptyHole(_)) => IndetMatch | (_, FailedCast(_)) => IndetMatch | (_, InvalidOperation(_)) => IndetMatch @@ -246,7 +246,7 @@ and matches_cast_Sum = | Let(_) | ApBuiltin(_) | BinOp(_) - | EmptyHole(_) + | EmptyHole | NonEmptyHole(_) | FailedCast(_, _, _) | Test(_) @@ -352,7 +352,7 @@ and matches_cast_Tuple = | Prj(_) => IndetMatch | Constructor(_) => DoesNotMatch | Match(_) => IndetMatch - | EmptyHole(_) => IndetMatch + | EmptyHole => IndetMatch | NonEmptyHole(_) => IndetMatch | FailedCast(_, _, _) => IndetMatch | InvalidOperation(_) => IndetMatch @@ -486,7 +486,7 @@ and matches_cast_Cons = | Prj(_) => IndetMatch | Constructor(_) => DoesNotMatch | Match(_) => IndetMatch - | EmptyHole(_) => IndetMatch + | EmptyHole => IndetMatch | NonEmptyHole(_) => IndetMatch | FailedCast(_, _, _) => IndetMatch | InvalidOperation(_) => IndetMatch diff --git a/src/haz3lcore/dynamics/Substitution.re b/src/haz3lcore/dynamics/Substitution.re index ad9b94bf97..f66b3d07dd 100644 --- a/src/haz3lcore/dynamics/Substitution.re +++ b/src/haz3lcore/dynamics/Substitution.re @@ -95,7 +95,7 @@ let rec subst_var = (d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => { rules, ); Match(c, ds, rules) |> rewrap; - | EmptyHole(u, i) => EmptyHole(u, i) |> rewrap + | EmptyHole => EmptyHole |> rewrap | NonEmptyHole(reason, u, i, d3) => let d3' = subst_var(d1, x, d3); NonEmptyHole(reason, u, i, d3') |> rewrap; diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index 4678084073..76b433fb0e 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -598,7 +598,7 @@ module Transition = (EV: EV_MODE) => { d1, ); Indet; - | EmptyHole(_) + | EmptyHole | FreeVar(_) | InvalidText(_) | InvalidOperation(_) diff --git a/src/haz3lcore/prog/Interface.re b/src/haz3lcore/prog/Interface.re index 24d5978a5c..2992db0e27 100644 --- a/src/haz3lcore/prog/Interface.re +++ b/src/haz3lcore/prog/Interface.re @@ -57,46 +57,6 @@ let elaborate_editor = }; exception EvalError(EvaluatorError.t); -exception PostprocessError(EvaluatorPost.error); - -// let postprocess = (es: EvaluatorState.t, d: DHExp.t) => { -// let ((d, hii), es) = -// es -// |> EvaluatorState.with_eig(eig => { -// let ((hii, d), eig) = -// switch (EvaluatorPost.postprocess(d, eig)) { -// | d => d -// | exception (EvaluatorPost.Exception(reason)) => -// raise(PostprocessError(reason)) -// }; -// ((d, hii), eig); -// }); -// let (tests, es) = -// es -// |> EvaluatorState.with_eig(eig => { -// let (eig, tests) = -// EvaluatorState.get_tests(es) -// |> List.fold_left_map( -// (eig, (k, instance_reports)) => { -// let (eig, instance_reports) = -// instance_reports -// |> List.fold_left_map( -// (eig, (d, status)) => -// switch (EvaluatorPost.postprocess(d, eig)) { -// | ((_, d), eig) => (eig, (d, status)) -// | exception (EvaluatorPost.Exception(reason)) => -// raise(PostprocessError(reason)) -// }, -// eig, -// ); -// (eig, (k, instance_reports)); -// }, -// eig, -// ); -// (tests, eig); -// }); -// ((d, hii), EvaluatorState.put_tests(tests, es)); -// }; let evaluate = (~settings: CoreSettings.t, ~env=Builtins.env_init, d: DHExp.t) @@ -118,12 +78,9 @@ let evaluate = | exn => err_wrap("System exception: " ++ Printexc.to_string(exn)) } }; - // TODO(cyrus): disabling post-processing for now, it has bad performance characteristics when you have deeply nested indet cases (and probably other situations) and we aren't using it in the UI for anything switch (result) { | (es, BoxedValue(_) as r) - | (es, Indet(_) as r) => - // let ((d, hii), es) = postprocess(es, d); - (r, es) + | (es, Indet(_) as r) => (r, es) }; }; diff --git a/src/haz3lweb/view/dhcode/DHCode.re b/src/haz3lweb/view/dhcode/DHCode.re index fe1adf1715..245a666cee 100644 --- a/src/haz3lweb/view/dhcode/DHCode.re +++ b/src/haz3lweb/view/dhcode/DHCode.re @@ -136,7 +136,7 @@ let view = ( ~inject, ~settings: CoreSettings.Evaluation.t, - ~selected_hole_instance: option(HoleInstance.t), + ~selected_hole_instance: option(Id.t), ~font_metrics: FontMetrics.t, ~width: int, ~pos=0, diff --git a/src/haz3lweb/view/dhcode/layout/DHAnnot.re b/src/haz3lweb/view/dhcode/layout/DHAnnot.re index 339a672d32..c26f2a3cd1 100644 --- a/src/haz3lweb/view/dhcode/layout/DHAnnot.re +++ b/src/haz3lweb/view/dhcode/layout/DHAnnot.re @@ -8,7 +8,7 @@ type t = | Term | HoleLabel | Delim - | EmptyHole(bool, HoleInstance.t) + | EmptyHole(bool, ClosureEnvironment.t) | NonEmptyHole(ErrStatus.HoleReason.t, HoleInstance.t) | VarHole(VarErrStatus.HoleReason.t, HoleInstance.t) | InconsistentBranches(HoleInstance.t) diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index 5e5cc78560..4acf9d4fb2 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -57,7 +57,7 @@ let rec precedence = (~show_casts: bool, d: DHExp.t) => { | String(_) | ListLit(_) | Prj(_) - | EmptyHole(_) + | EmptyHole | Constructor(_) | FailedCast(_) | InvalidOperation(_) @@ -102,7 +102,7 @@ let mk = ( ~settings: CoreSettings.Evaluation.t, ~enforce_inline: bool, - ~selected_hole_instance: option(HoleInstance.t), + ~selected_hole_instance: option(Id.t), // The next four are used when drawing the stepper to track where we can annotate changes ~previous_step: option((step, Id.t)), // The step that will be displayed above this one (an Id in included because it may have changed since the step was taken) ~hidden_steps: list((step, Id.t)), // The hidden steps between the above and the current one (an Id in included because it may have changed since the step was taken) @@ -266,13 +266,11 @@ let mk = /* Hole expressions must appear within a closure in the postprocessed result */ - | EmptyHole(u, i) => - let selected = - switch (selected_hole_instance) { - | None => false - | Some((u', i')) => u == u' && i == i' - }; - DHDoc_common.mk_EmptyHole(~selected, (u, i)); + | EmptyHole => + DHDoc_common.mk_EmptyHole( + ~selected=Some(DHExp.rep_id(d)) == selected_hole_instance, + env, + ) | NonEmptyHole(reason, u, i, d') => go'(d') |> annot(DHAnnot.NonEmptyHole(reason, (u, i))) | ExpandingKeyword(u, i, k) => diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re index af3e8b6760..1a3357e90e 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re @@ -34,7 +34,7 @@ let rec mk = ); let doc = switch (dp) { - | EmptyHole(u, i) => DHDoc_common.mk_EmptyHole((u, i)) + | EmptyHole(_, _) => DHDoc_common.mk_EmptyHole(ClosureEnvironment.empty) | NonEmptyHole(reason, u, i, dp) => mk'(dp) |> Doc.annot(DHAnnot.NonEmptyHole(reason, (u, i))) | ExpandingKeyword(u, i, k) => diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Util.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Util.re index cf69aa856d..f4ae24947b 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Util.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Util.re @@ -1,4 +1,3 @@ -open Util; open Haz3lcore; module Doc = Pretty.Doc; @@ -46,8 +45,8 @@ module Delim = { let mk = (delim_text: string): t => Doc.text(delim_text) |> Doc.annot(DHAnnot.Delim); - let empty_hole = ((u, i): HoleInstance.t): t => { - let lbl = StringUtil.cat([Id.to_string(u), ":", string_of_int(i + 1)]); + let empty_hole = (_env: ClosureEnvironment.t): t => { + let lbl = "-"; Doc.text(lbl) |> Doc.annot(DHAnnot.HoleLabel) |> Doc.annot(DHAnnot.Delim); @@ -85,9 +84,8 @@ module Delim = { let close_FailedCast = close_Cast |> Doc.annot(DHAnnot.FailedCastDelim); }; -let mk_EmptyHole = (~selected=false, (u, i)) => - Delim.empty_hole((u, i)) - |> Doc.annot(DHAnnot.EmptyHole(selected, (u, i))); +let mk_EmptyHole = (~selected=false, env) => + Delim.empty_hole(env) |> Doc.annot(DHAnnot.EmptyHole(selected, env)); let mk_Keyword = (u, i, k) => Doc.text(ExpandingKeyword.to_string(k)) diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_common.re b/src/haz3lweb/view/dhcode/layout/DHDoc_common.re index 4ccc57da62..1d184c4f82 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_common.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_common.re @@ -45,7 +45,7 @@ module Delim = { let mk = (delim_text: string): t => Doc.text(delim_text) |> Doc.annot(DHAnnot.Delim); - let empty_hole = ((_u, _i): HoleInstance.t): t => { + let empty_hole = (_env: ClosureEnvironment.t): t => { let lbl = //StringUtil.cat([string_of_int(u + 1), ":", string_of_int(i + 1)]); "?"; @@ -88,8 +88,8 @@ module Delim = { let close_FailedCast = close_Cast |> Doc.annot(DHAnnot.FailedCastDelim); }; -let mk_EmptyHole = (~selected=false, hc: HoleInstance.t) => - Delim.empty_hole(hc) |> Doc.annot(DHAnnot.EmptyHole(selected, hc)); +let mk_EmptyHole = (~selected=false, env: ClosureEnvironment.t) => + Delim.empty_hole(env) |> Doc.annot(DHAnnot.EmptyHole(selected, env)); let mk_ExpandingKeyword = (hc, k) => Doc.text(ExpandingKeyword.to_string(k)) diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_common.rei b/src/haz3lweb/view/dhcode/layout/DHDoc_common.rei index b3b9e2e264..af3ce0dec5 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_common.rei +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_common.rei @@ -29,7 +29,7 @@ let pad_child: module Delim: { let mk: string => DHDoc.t; - let empty_hole: HoleInstance.t => DHDoc.t; + let empty_hole: ClosureEnvironment.t => DHDoc.t; let list_nil: DHDoc.t; let triv: DHDoc.t; @@ -62,7 +62,7 @@ module Delim: { }; let mk_EmptyHole: - (~selected: bool=?, HoleInstance.t) => Pretty.Doc.t(DHAnnot.t); + (~selected: bool=?, ClosureEnvironment.t) => Pretty.Doc.t(DHAnnot.t); let mk_ExpandingKeyword: (HoleInstance.t, ExpandingKeyword.t) => Pretty.Doc.t(DHAnnot.t); From 34204aab663c90fc38939e5236d2904f691dead8 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Fri, 9 Feb 2024 09:43:05 -0500 Subject: [PATCH 009/103] Change how IDs are copied --- src/haz3lcore/dynamics/DH.re | 37 ++++++++++++++++++------------- src/haz3lcore/dynamics/Stepper.re | 20 +++++++++-------- 2 files changed, 32 insertions(+), 25 deletions(-) diff --git a/src/haz3lcore/dynamics/DH.re b/src/haz3lcore/dynamics/DH.re index 12eccee0ca..74e3d879fc 100644 --- a/src/haz3lcore/dynamics/DH.re +++ b/src/haz3lcore/dynamics/DH.re @@ -108,30 +108,27 @@ module rec DHExp: { and t = { /* invariant: nonempty, TODO: what happens to later ids in DHExp */ ids: list(Id.t), - /*TODO: Verify: Always true in UExp, not necessarily in DHExp - if some id is not unique, then one of its parents will be flagged false */ - ids_are_unique: bool, + /*TODO: Verify: Always false in UExp, if an expression has been copied as part of + evaluation (e.g. fun x -> x + x), then this will be flagged as true. This means + the ids should be replaced after evaluation. */ + copied: bool, term, }; let rep_id = ({ids, _}) => List.hd(ids); let term_of = ({term, _}) => term; - let fast_copy = (id, {term, _}) => { - ids: [id], - term, - ids_are_unique: false, - }; + let fast_copy = (id, {term, _}) => {ids: [id], term, copied: true}; // All children of term must have expression-unique ids. let fresh = term => { - {ids: [Id.mk()], ids_are_unique: true, term}; + {ids: [Id.mk()], copied: false, term}; }; - let unwrap = ({ids, term, ids_are_unique}) => ( + let unwrap = ({ids, term, copied}) => ( term, - term => {ids, term, ids_are_unique}, + term => {ids, term, copied}, ); let mk = (ids, term) => { - {ids, ids_are_unique: true, term}; + {ids, copied: true, term}; }; let constructor_string = ({term: d, _}: t): string => @@ -181,14 +178,22 @@ module rec DHExp: { let apply_casts = (d: t, casts: list((Typ.t, Typ.t))): t => List.fold_left((d, (ty1, ty2)) => fresh_cast(d, ty1, ty2), d, casts); - // preorder traversal let rec repair_ids = (require: bool, d: t) => { - let child_require = require || !d.ids_are_unique; + let child_require = require || d.copied; let repair_ids = repair_ids(child_require); let term = term_of(d); let rewrap = term => { - ids: require ? [Id.mk()] : d.ids, - ids_are_unique: true, + ids: + child_require + ? { + print_endline("copied!"); + let id = Id.mk(); + print_endline(Id.show(id)); + print_endline(Id.show(List.hd(d.ids))); + [id]; + } + : d.ids, + copied: false, term, }; ( diff --git a/src/haz3lcore/dynamics/Stepper.re b/src/haz3lcore/dynamics/Stepper.re index 6c64ed16d1..ae1e8b0917 100644 --- a/src/haz3lcore/dynamics/Stepper.re +++ b/src/haz3lcore/dynamics/Stepper.re @@ -33,7 +33,7 @@ let rec matches = idx: int, ) : (FilterAction.t, int, EvalCtx.t) => { - let composed = compose(ctx, exp); + let composed = EvalCtx.compose(ctx, exp); let (pact, pidx) = (act, idx); let (mact, midx) = FilterMatcher.matches(~env, ~exp=composed, ~act, flt); let (act, idx) = @@ -219,12 +219,14 @@ let rec evaluate_pending = (~settings, s: t) => { let (d, state) = Aba.hd(s.history); let state_ref = ref(state); let d_loc' = - switch (take_step(state_ref, eo.env, eo.d_loc)) { - | Some(d) => d - | None => raise(Exception) - }; - let d' = compose(eo.ctx, d_loc'); - let d' = DHExp.repair_ids(d'); + ( + switch (take_step(state_ref, eo.env, eo.d_loc)) { + | Some(d) => d + | None => raise(Exception) + } + ) + |> DHExp.repair_ids; + let d' = EvalCtx.compose(eo.ctx, d_loc'); let new_step = { d, d_loc: eo.d_loc, @@ -324,9 +326,9 @@ let get_justification: step_kind => string = type step_info = { d: DHExp.t, - previous_step: option((step, Id.t)), // The step that will be displayed above this one (an Id in included because it may have changed since the step was taken) + chosen_step: option(step), // The step that was taken next hidden_steps: list((step, Id.t)), // The hidden steps between previous_step and the current one (an Id in included because it may have changed since the step was taken) - chosen_step: option(step) // The step that was taken next + previous_step: option((step, Id.t)) // The step that will be displayed above this one (an Id in included because it may have changed since the step was taken) }; let get_history = (~settings, stepper) => { From d74d432316386adcfef470d6490e8a62f90ff1f9 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Fri, 9 Feb 2024 09:43:31 -0500 Subject: [PATCH 010/103] Move compose function --- src/haz3lcore/dynamics/EvalCtx.re | 99 ++++++++++++++++++++++ src/haz3lcore/dynamics/EvaluatorStep.re | 108 +----------------------- src/util/ListUtil.re | 8 ++ 3 files changed, 108 insertions(+), 107 deletions(-) diff --git a/src/haz3lcore/dynamics/EvalCtx.re b/src/haz3lcore/dynamics/EvalCtx.re index aba9a650da..3747915ce9 100644 --- a/src/haz3lcore/dynamics/EvalCtx.re +++ b/src/haz3lcore/dynamics/EvalCtx.re @@ -1,4 +1,5 @@ open Sexplib.Std; +open Util; open DH; [@deriving (show({with_path: false}), sexp, yojson)] @@ -46,3 +47,101 @@ type t = t, (list((DHPat.t, DHExp.t)), list((DHPat.t, DHExp.t))), ); + +let rec compose = (ctx: t, d: DHExp.t): DHExp.t => { + DHExp.( + switch (ctx) { + | Mark => d + | Closure(env, ctx) => + let d = compose(ctx, d); + Closure(env, d) |> fresh; + | Filter(flt, ctx) => + let d = compose(ctx, d); + Filter(flt, d) |> fresh; + | Seq1(ctx, d2) => + let d1 = compose(ctx, d); + Seq(d1, d2) |> fresh; + | Seq2(d1, ctx) => + let d2 = compose(ctx, d); + Seq(d1, d2) |> fresh; + | Ap1(ctx, d2) => + let d1 = compose(ctx, d); + Ap(d1, d2) |> fresh; + | Ap2(d1, ctx) => + let d2 = compose(ctx, d); + Ap(d1, d2) |> fresh; + | ApBuiltin(s, ctx) => + let d' = compose(ctx, d); + ApBuiltin(s, d') |> fresh; + | If1(c, ctx, d2, d3) => + let d' = compose(ctx, d); + If(c, d', d2, d3) |> fresh; + | If2(c, d1, ctx, d3) => + let d' = compose(ctx, d); + If(c, d1, d', d3) |> fresh; + | If3(c, d1, d2, ctx) => + let d' = compose(ctx, d); + If(c, d1, d2, d') |> fresh; + | Test(lit, ctx) => + let d1 = compose(ctx, d); + Test(lit, d1) |> fresh; + | BinOp1(op, ctx, d2) => + let d1 = compose(ctx, d); + BinOp(op, d1, d2) |> fresh; + | BinOp2(op, d1, ctx) => + let d2 = compose(ctx, d); + BinOp(op, d1, d2) |> fresh; + | Cons1(ctx, d2) => + let d1 = compose(ctx, d); + Cons(d1, d2) |> fresh; + | Cons2(d1, ctx) => + let d2 = compose(ctx, d); + Cons(d1, d2) |> fresh; + | ListConcat1(ctx, d2) => + let d1 = compose(ctx, d); + ListConcat(d1, d2) |> fresh; + | ListConcat2(d1, ctx) => + let d2 = compose(ctx, d); + ListConcat(d1, d2) |> fresh; + | Tuple(ctx, (ld, rd)) => + let d = compose(ctx, d); + Tuple(ListUtil.rev_concat(ld, [d, ...rd])) |> fresh; + | ListLit(m, i, t, ctx, (ld, rd)) => + let d = compose(ctx, d); + ListLit(m, i, t, ListUtil.rev_concat(ld, [d, ...rd])) |> fresh; + | Let1(dp, ctx, d2) => + let d = compose(ctx, d); + Let(dp, d, d2) |> fresh; + | Let2(dp, d1, ctx) => + let d = compose(ctx, d); + Let(dp, d1, d) |> fresh; + | Fun(dp, t, ctx, env, v) => + let d = compose(ctx, d); + Fun(dp, t, d, env, v) |> fresh; + | FixF(v, t, ctx) => + let d = compose(ctx, d); + FixF(v, t, d) |> fresh; + | Prj(ctx, n) => + let d = compose(ctx, d); + Prj(d, n) |> fresh; + | Cast(ctx, ty1, ty2) => + let d = compose(ctx, d); + Cast(d, ty1, ty2) |> fresh; + | FailedCast(ctx, ty1, ty2) => + let d = compose(ctx, d); + FailedCast(d, ty1, ty2) |> fresh; + | InvalidOperation(ctx, err) => + let d = compose(ctx, d); + InvalidOperation(d, err) |> fresh; + | NonEmptyHole(reason, u, i, ctx) => + let d = compose(ctx, d); + NonEmptyHole(reason, u, i, d) |> fresh; + | MatchScrut(c, ctx, rules) => + let d = compose(ctx, d); + Match(c, d, rules) |> fresh; + | MatchRule(c, scr, p, ctx, (lr, rr)) => + let d = compose(ctx, d); + Match(c, scr, ListUtil.rev_concat(lr, [(p, d), ...rr])) |> fresh; + } + ); +}; diff --git a/src/haz3lcore/dynamics/EvaluatorStep.re b/src/haz3lcore/dynamics/EvaluatorStep.re index 1dbfeb76be..2871e191eb 100644 --- a/src/haz3lcore/dynamics/EvaluatorStep.re +++ b/src/haz3lcore/dynamics/EvaluatorStep.re @@ -200,112 +200,6 @@ module TakeStep = { let take_step = TakeStep.take_step; -let rec rev_concat: (list('a), list('a)) => list('a) = - (ls, rs) => { - switch (ls) { - | [] => rs - | [hd, ...tl] => rev_concat(tl, [hd, ...rs]) - }; - }; - -let rec compose = (ctx: EvalCtx.t, d: DHExp.t): DHExp.t => { - DHExp.( - switch (ctx) { - | Mark => d - | Closure(env, ctx) => - let d = compose(ctx, d); - Closure(env, d) |> fresh; - | Filter(flt, ctx) => - let d = compose(ctx, d); - Filter(flt, d) |> fresh; - | Seq1(ctx, d2) => - let d1 = compose(ctx, d); - Seq(d1, d2) |> fresh; - | Seq2(d1, ctx) => - let d2 = compose(ctx, d); - Seq(d1, d2) |> fresh; - | Ap1(ctx, d2) => - let d1 = compose(ctx, d); - Ap(d1, d2) |> fresh; - | Ap2(d1, ctx) => - let d2 = compose(ctx, d); - Ap(d1, d2) |> fresh; - | ApBuiltin(s, ctx) => - let d' = compose(ctx, d); - ApBuiltin(s, d') |> fresh; - | If1(c, ctx, d2, d3) => - let d' = compose(ctx, d); - If(c, d', d2, d3) |> fresh; - | If2(c, d1, ctx, d3) => - let d' = compose(ctx, d); - If(c, d1, d', d3) |> fresh; - | If3(c, d1, d2, ctx) => - let d' = compose(ctx, d); - If(c, d1, d2, d') |> fresh; - | Test(lit, ctx) => - let d1 = compose(ctx, d); - Test(lit, d1) |> fresh; - | BinOp1(op, ctx, d2) => - let d1 = compose(ctx, d); - BinOp(op, d1, d2) |> fresh; - | BinOp2(op, d1, ctx) => - let d2 = compose(ctx, d); - BinOp(op, d1, d2) |> fresh; - | Cons1(ctx, d2) => - let d1 = compose(ctx, d); - Cons(d1, d2) |> fresh; - | Cons2(d1, ctx) => - let d2 = compose(ctx, d); - Cons(d1, d2) |> fresh; - | ListConcat1(ctx, d2) => - let d1 = compose(ctx, d); - ListConcat(d1, d2) |> fresh; - | ListConcat2(d1, ctx) => - let d2 = compose(ctx, d); - ListConcat(d1, d2) |> fresh; - | Tuple(ctx, (ld, rd)) => - let d = compose(ctx, d); - Tuple(rev_concat(ld, [d, ...rd])) |> fresh; - | ListLit(m, i, t, ctx, (ld, rd)) => - let d = compose(ctx, d); - ListLit(m, i, t, rev_concat(ld, [d, ...rd])) |> fresh; - | Let1(dp, ctx, d2) => - let d = compose(ctx, d); - Let(dp, d, d2) |> fresh; - | Let2(dp, d1, ctx) => - let d = compose(ctx, d); - Let(dp, d1, d) |> fresh; - | Fun(dp, t, ctx, env, v) => - let d = compose(ctx, d); - Fun(dp, t, d, env, v) |> fresh; - | FixF(v, t, ctx) => - let d = compose(ctx, d); - FixF(v, t, d) |> fresh; - | Prj(ctx, n) => - let d = compose(ctx, d); - Prj(d, n) |> fresh; - | Cast(ctx, ty1, ty2) => - let d = compose(ctx, d); - Cast(d, ty1, ty2) |> fresh; - | FailedCast(ctx, ty1, ty2) => - let d = compose(ctx, d); - FailedCast(d, ty1, ty2) |> fresh; - | InvalidOperation(ctx, err) => - let d = compose(ctx, d); - InvalidOperation(d, err) |> fresh; - | NonEmptyHole(reason, u, i, ctx) => - let d = compose(ctx, d); - NonEmptyHole(reason, u, i, d) |> fresh; - | MatchScrut(c, ctx, rules) => - let d = compose(ctx, d); - Match(c, d, rules) |> fresh; - | MatchRule(c, scr, p, ctx, (lr, rr)) => - let d = compose(ctx, d); - Match(c, scr, rev_concat(lr, [(p, d), ...rr])) |> fresh; - } - ); -}; - let decompose = (d: DHExp.t) => { let es = EvaluatorState.init; let env = ClosureEnvironment.of_environment(Builtins.env_init); @@ -322,7 +216,7 @@ let evaluate_with_history = d => { switch (take_step(state, x.env, x.d_loc)) { | None => [] | Some(d) => - let next = compose(x.ctx, d); + let next = EvalCtx.compose(x.ctx, d); [next, ...go(next)]; } }; diff --git a/src/util/ListUtil.re b/src/util/ListUtil.re index 20195c8a84..69cf5d2577 100644 --- a/src/util/ListUtil.re +++ b/src/util/ListUtil.re @@ -480,3 +480,11 @@ let first_and_last = (xss: list(list('a))): list(('a, 'a)) => | [x] => Some((x, x)) | [x, ...xs] => Some((x, last(xs))), ); + +let rec rev_concat: (list('a), list('a)) => list('a) = + (ls, rs) => { + switch (ls) { + | [] => rs + | [hd, ...tl] => rev_concat(tl, [hd, ...rs]) + }; + }; From 84287cd3cb9df970954f5f3db97a3aa0209886c1 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Sat, 10 Feb 2024 16:17:08 -0500 Subject: [PATCH 011/103] Combine forward and reverse application --- src/haz3lcore/dynamics/Builtins.re | 5 +- src/haz3lcore/dynamics/DH.re | 49 +++---------------- src/haz3lcore/dynamics/Elaborator.re | 7 ++- src/haz3lcore/dynamics/EvalCtx.re | 12 ++--- src/haz3lcore/dynamics/FilterMatcher.re | 5 +- src/haz3lcore/dynamics/PatternMatch.re | 8 +-- src/haz3lcore/dynamics/Stepper.re | 8 +-- src/haz3lcore/dynamics/Substitution.re | 4 +- src/haz3lcore/dynamics/Transition.re | 14 ++++-- src/haz3lcore/statics/MakeTerm.re | 6 +-- src/haz3lcore/statics/Statics.re | 3 +- src/haz3lcore/statics/Term.re | 3 -- src/haz3lcore/statics/TermBase.re | 21 +++++--- src/haz3lcore/zipper/EditorUtil.re | 1 - src/haz3lschool/SyntaxTest.re | 18 ++----- src/haz3lweb/view/ExplainThis.re | 4 +- src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 11 ++++- .../view/dhcode/layout/DHDoc_common.re | 2 + .../view/dhcode/layout/DHDoc_common.rei | 2 + 19 files changed, 79 insertions(+), 104 deletions(-) diff --git a/src/haz3lcore/dynamics/Builtins.re b/src/haz3lcore/dynamics/Builtins.re index d3c08ae0b4..bfd8b36f82 100644 --- a/src/haz3lcore/dynamics/Builtins.re +++ b/src/haz3lcore/dynamics/Builtins.re @@ -172,7 +172,7 @@ module Pervasives = { | Some(n) => Ok(wrap(n)) | None => let d' = DHExp.BuiltinFun(name) |> DHExp.fresh; - let d' = DHExp.Ap(d', d) |> DHExp.fresh; + let d' = DHExp.Ap(Forward, d', d) |> DHExp.fresh; let d' = InvalidOperation(d', InvalidOfString) |> DHExp.fresh; Ok(d'); } @@ -195,7 +195,8 @@ module Pervasives = { Ok( fresh( InvalidOperation( - DHExp.Ap(DHExp.BuiltinFun(name) |> fresh, d1) |> fresh, + DHExp.Ap(Forward, DHExp.BuiltinFun(name) |> fresh, d1) + |> fresh, DivideByZero, ), ), diff --git a/src/haz3lcore/dynamics/DH.re b/src/haz3lcore/dynamics/DH.re index 74e3d879fc..f51cd96747 100644 --- a/src/haz3lcore/dynamics/DH.re +++ b/src/haz3lcore/dynamics/DH.re @@ -29,7 +29,7 @@ module rec DHExp: { | Let(DHPat.t, t, t) // DONE [ALREADY] | FixF(Var.t, Typ.t, t) // TODO: surface fix | Fun(DHPat.t, Typ.t, t, option(ClosureEnvironment.t), option(Var.t)) // TODO: Use infomap for Typ.t - | Ap(t, t) // TODO: Add reverse application + | Ap(TermBase.UExp.ap_direction, t, t) // TODO: Add reverse application | ApBuiltin(string, t) // DONE [TO ADD TO UEXP] TODO: Add a loooong comment here | BuiltinFun(string) // DONE [TO ADD TO UEXP] | Test(KeywordID.t, t) // TODO: ! ID @@ -57,8 +57,6 @@ module rec DHExp: { let mk: (list(Id.t), term) => t; let unwrap: t => (term, term => t); - let constructor_string: t => string; - let fresh_cast: (t, Typ.t, Typ.t) => t; let apply_casts: (t, list((Typ.t, Typ.t))) => t; @@ -87,7 +85,7 @@ module rec DHExp: { | Let(DHPat.t, t, t) | FixF(Var.t, Typ.t, t) | Fun(DHPat.t, Typ.t, t, option(ClosureEnvironment.t), option(Var.t)) - | Ap(t, t) + | Ap(TermBase.UExp.ap_direction, t, t) | ApBuiltin(string, t) | BuiltinFun(string) | Test(KeywordID.t, t) @@ -131,42 +129,6 @@ module rec DHExp: { {ids, copied: true, term}; }; - let constructor_string = ({term: d, _}: t): string => - switch (d) { - | EmptyHole => "EmptyHole" - | NonEmptyHole(_, _, _, _) => "NonEmptyHole" - | ExpandingKeyword(_, _, _) => "ExpandingKeyword" - | FreeVar(_, _, _) => "FreeVar" - | InvalidText(_) => "InvalidText" - | Var(_) => "Var" - | Seq(_, _) => "Seq" - | Filter(_, _) => "Filter" - | Let(_, _, _) => "Let" - | FixF(_, _, _) => "FixF" - | Fun(_, _, _, _, _) => "Fun" - | Closure(_, _) => "Closure" - | Ap(_, _) => "Ap" - | ApBuiltin(_, _) => "ApBuiltin" - | BuiltinFun(_) => "BuiltinFun" - | Test(_) => "Test" - | Bool(_) => "Bool" - | Int(_) => "Int" - | Float(_) => "Float" - | String(_) => "String" - | BinOp(_, _, _) => "BinOp" - | ListLit(_) => "ListLit" - | Cons(_, _) => "Cons" - | ListConcat(_, _) => "ListConcat" - | Tuple(_) => "Tuple" - | Prj(_) => "Prj" - | Constructor(_) => "Constructor" - | Match(_) => "Match" - | Cast(_, _, _) => "Cast" - | FailedCast(_, _, _) => "FailedCast" - | InvalidOperation(_) => "InvalidOperation" - | If(_, _, _, _) => "If" - }; - // All children of d must have expression-unique ids. let fresh_cast = (d: t, t1: Typ.t, t2: Typ.t): t => if (Typ.eq(t1, t2) || t2 == Unknown(SynSwitch)) { @@ -218,7 +180,7 @@ module rec DHExp: { | Let(dp, d1, d2) => Let(dp, repair_ids(d1), repair_ids(d2)) | FixF(f, t, d1) => FixF(f, t, repair_ids(d1)) | Fun(dp, t, d1, env, f) => Fun(dp, t, repair_ids(d1), env, f) - | Ap(d1, d2) => Ap(repair_ids(d1), repair_ids(d2)) + | Ap(dir, d1, d2) => Ap(dir, repair_ids(d1), repair_ids(d2)) | ApBuiltin(s, d1) => ApBuiltin(s, repair_ids(d1)) | Test(id, d1) => Test(id, repair_ids(d1)) | BinOp(op, d1, d2) => BinOp(op, repair_ids(d1), repair_ids(d2)) @@ -265,7 +227,7 @@ module rec DHExp: { | Let(dp, b, c) => Let(dp, strip_casts(b), strip_casts(c)) |> rewrap | FixF(a, b, c) => FixF(a, b, strip_casts(c)) |> rewrap | Fun(a, b, c, e, d) => Fun(a, b, strip_casts(c), e, d) |> rewrap - | Ap(a, b) => Ap(strip_casts(a), strip_casts(b)) |> rewrap + | Ap(dir, a, b) => Ap(dir, strip_casts(a), strip_casts(b)) |> rewrap | Test(id, a) => Test(id, strip_casts(a)) |> rewrap | ApBuiltin(fn, args) => ApBuiltin(fn, strip_casts(args)) |> rewrap | BuiltinFun(fn) => BuiltinFun(fn) |> rewrap @@ -327,7 +289,8 @@ module rec DHExp: { && fast_equal(d1, d2) && ClosureEnvironment.id_equal(env1, env2) && s1 == s2 - | (Ap(d11, d21), Ap(d12, d22)) + | (Ap(dir1, d11, d21), Ap(dir2, d12, d22)) => + dir1 == dir2 && fast_equal(d11, d12) && fast_equal(d21, d22) | (Cons(d11, d21), Cons(d12, d22)) => fast_equal(d11, d12) && fast_equal(d21, d22) | (ListConcat(d11, d21), ListConcat(d12, d22)) => diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 8cfc7601bf..2cac287788 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -65,7 +65,7 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => DHExp.fresh_cast(d, self_ty, Unknown(prov)) | _ => d } - | Ap(f, _) => + | Ap(_, f, _) => switch (DHExp.term_of(f)) { | Constructor(_) => switch (ana_ty, self_ty) { @@ -274,11 +274,10 @@ let rec dhexp_of_uexp = Let(dp, FixF(self_id, ty, substituted_def) |> DHExp.fresh, dbody) |> rewrap; }; - | Ap(fn, arg) - | Pipeline(arg, fn) => + | Ap(dir, fn, arg) => let* c_fn = dhexp_of_uexp(m, fn); let+ c_arg = dhexp_of_uexp(m, arg); - DHExp.Ap(c_fn, c_arg) |> rewrap; + DHExp.Ap(dir, c_fn, c_arg) |> rewrap; | If(c, e1, e2) => let* c' = dhexp_of_uexp(m, c); let* d1 = dhexp_of_uexp(m, e1); diff --git a/src/haz3lcore/dynamics/EvalCtx.re b/src/haz3lcore/dynamics/EvalCtx.re index 3747915ce9..873202bf99 100644 --- a/src/haz3lcore/dynamics/EvalCtx.re +++ b/src/haz3lcore/dynamics/EvalCtx.re @@ -13,8 +13,8 @@ type t = | Let2(DHPat.t, DHExp.t, t) | Fun(DHPat.t, Typ.t, t, option(ClosureEnvironment.t), option(Var.t)) | FixF(Var.t, Typ.t, t) - | Ap1(t, DHExp.t) - | Ap2(DHExp.t, t) + | Ap1(TermBase.UExp.ap_direction, t, DHExp.t) + | Ap2(TermBase.UExp.ap_direction, DHExp.t, t) | If1(consistency, t, DHExp.t, DHExp.t) | If2(consistency, DHExp.t, t, DHExp.t) | If3(consistency, DHExp.t, DHExp.t, t) @@ -64,12 +64,12 @@ let rec compose = (ctx: t, d: DHExp.t): DHExp.t => { | Seq2(d1, ctx) => let d2 = compose(ctx, d); Seq(d1, d2) |> fresh; - | Ap1(ctx, d2) => + | Ap1(dir, ctx, d2) => let d1 = compose(ctx, d); - Ap(d1, d2) |> fresh; - | Ap2(d1, ctx) => + Ap(dir, d1, d2) |> fresh; + | Ap2(dir, d1, ctx) => let d2 = compose(ctx, d); - Ap(d1, d2) |> fresh; + Ap(dir, d1, d2) |> fresh; | ApBuiltin(s, ctx) => let d' = compose(ctx, d); ApBuiltin(s, d') |> fresh; diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index cdd8ff0e62..bcda716134 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -77,7 +77,7 @@ let rec matches_exp = | (String(dv), String(fv)) => dv == fv | (String(_), _) => false - | (Constructor(_), Ap(d1, d2)) => + | (Constructor(_), Ap(_, d1, d2)) => switch (DHExp.term_of(d1), DHExp.term_of(d2)) { | (Constructor("~MVal"), Tuple([])) => true | _ => false @@ -106,7 +106,8 @@ let rec matches_exp = && matches_exp(env, d2, f2) | (Let(_), _) => false - | (Ap(d1, d2), Ap(f1, f2)) => + // TODO: do we want f(x) to match x |> f ??? + | (Ap(_, d1, d2), Ap(_, f1, f2)) => matches_exp(env, d1, f1) && matches_exp(env, d2, f2) | (Ap(_), _) => false diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index 9e6835f895..54337c34ce 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -93,7 +93,7 @@ let rec matches = (dp: DHPat.t, d: DHExp.t): match_result => | (String(_), Cast(d, Unknown(_), String)) => matches(dp, d) | (String(_), _) => DoesNotMatch - | (Ap(dp1, dp2), Ap(d1, d2)) => + | (Ap(dp1, dp2), Ap(_, d1, d2)) => switch (matches(dp1, d1)) { | DoesNotMatch => DoesNotMatch | IndetMatch => @@ -217,7 +217,7 @@ and matches_cast_Sum = ctr == ctr' ? Matches(Environment.empty) : DoesNotMatch | _ => DoesNotMatch } - | Ap(d1, d2) => + | Ap(_, d1, d2) => switch (DHExp.term_of(d1)) { | Constructor(ctr') => switch ( @@ -336,7 +336,7 @@ and matches_cast_Tuple = | Fun(_, _, _, _, _) => DoesNotMatch | Closure(_, _) => IndetMatch | Filter(_, _) => IndetMatch - | Ap(_, _) => IndetMatch + | Ap(_, _, _) => IndetMatch | ApBuiltin(_, _) => IndetMatch | BinOp(_, _, _) | Bool(_) => DoesNotMatch @@ -471,7 +471,7 @@ and matches_cast_Cons = | Fun(_, _, _, _, _) => DoesNotMatch | Closure(_, d') => matches_cast_Cons(dp, d', elt_casts) | Filter(_, d') => matches_cast_Cons(dp, d', elt_casts) - | Ap(_, _) => IndetMatch + | Ap(_, _, _) => IndetMatch | ApBuiltin(_, _) => IndetMatch | BinOp(_, _, _) | ListConcat(_) diff --git a/src/haz3lcore/dynamics/Stepper.re b/src/haz3lcore/dynamics/Stepper.re index ae1e8b0917..a003d492a4 100644 --- a/src/haz3lcore/dynamics/Stepper.re +++ b/src/haz3lcore/dynamics/Stepper.re @@ -81,12 +81,12 @@ let rec matches = | FixF(name, ty, ctx) => let+ ctx = matches(env, flt, ctx, exp, act, idx); FixF(name, ty, ctx); - | Ap1(ctx, d2) => + | Ap1(dir, ctx, d2) => let+ ctx = matches(env, flt, ctx, exp, act, idx); - Ap1(ctx, d2); - | Ap2(d1, ctx) => + Ap1(dir, ctx, d2); + | Ap2(dir, d1, ctx) => let+ ctx = matches(env, flt, ctx, exp, act, idx); - Ap2(d1, ctx); + Ap2(dir, d1, ctx); | If1(c, ctx, d2, d3) => let+ ctx = matches(env, flt, ctx, exp, act, idx); If1(c, ctx, d2, d3); diff --git a/src/haz3lcore/dynamics/Substitution.re b/src/haz3lcore/dynamics/Substitution.re index f66b3d07dd..8f3f43cbbb 100644 --- a/src/haz3lcore/dynamics/Substitution.re +++ b/src/haz3lcore/dynamics/Substitution.re @@ -52,10 +52,10 @@ let rec subst_var = (d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => { let env' = subst_var_env(d1, x, env); let d3' = subst_var(d1, x, d3); Closure(env', d3') |> rewrap; - | Ap(d3, d4) => + | Ap(dir, d3, d4) => let d3 = subst_var(d1, x, d3); let d4 = subst_var(d1, x, d4); - Ap(d3, d4) |> rewrap; + Ap(dir, d3, d4) |> rewrap; | ApBuiltin(ident, d1) => let d2 = subst_var(d1, x, d1); ApBuiltin(ident, d2) |> rewrap; diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index 76b433fb0e..f1bdf38019 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -269,10 +269,10 @@ module Transition = (EV: EV_MODE) => { kind: UpdateTest, value: true, }); - | Ap(d1, d2) => - let. _ = otherwise(env, (d1, d2) => Ap(d1, d2) |> rewrap) - and. d1' = req_value(req(state, env), d1 => Ap1(d1, d2), d1) - and. d2' = req_final(req(state, env), d2 => Ap2(d1, d2), d2); + | Ap(dir, d1, d2) => + let. _ = otherwise(env, (d1, d2) => Ap(dir, d1, d2) |> rewrap) + and. d1' = req_value(req(state, env), d1 => Ap1(dir, d1, d2), d1) + and. d2' = req_final(req(state, env), d2 => Ap2(dir, d1, d2), d2); switch (DHExp.term_of(d1')) { | Constructor(_) => Constructor | Fun(dp, _, d3, Some(env'), _) => @@ -285,7 +285,11 @@ module Transition = (EV: EV_MODE) => { | Cast(d3', Arrow(ty1, ty2), Arrow(ty1', ty2')) => Step({ apply: () => - Cast(Ap(d3', Cast(d2', ty1', ty1) |> fresh) |> fresh, ty2, ty2') + Cast( + Ap(dir, d3', Cast(d2', ty1', ty1) |> fresh) |> fresh, + ty2, + ty2', + ) |> fresh, kind: CastAp, value: false, diff --git a/src/haz3lcore/statics/MakeTerm.re b/src/haz3lcore/statics/MakeTerm.re index 8fe8174dde..cf0da62c9b 100644 --- a/src/haz3lcore/statics/MakeTerm.re +++ b/src/haz3lcore/statics/MakeTerm.re @@ -207,8 +207,8 @@ and exp_term: unsorted => (UExp.term, list(Id.t)) = { | ([(_id, t)], []) => switch (t) { | (["()"], []) => - ret(Ap(l, {ids: [Id.nullary_ap_flag], term: Triv})) - | (["(", ")"], [Exp(arg)]) => ret(Ap(l, arg)) + ret(Ap(Forward, l, {ids: [Id.nullary_ap_flag], term: Triv})) + | (["(", ")"], [Exp(arg)]) => ret(Ap(Forward, l, arg)) | _ => ret(hole(tm)) } | _ => ret(hole(tm)) @@ -249,7 +249,7 @@ and exp_term: unsorted => (UExp.term, list(Id.t)) = { | ([";"], []) => Seq(l, r) | (["++"], []) => BinOp(String(Concat), l, r) | (["$=="], []) => BinOp(String(Equals), l, r) - | (["|>"], []) => Pipeline(l, r) + | (["|>"], []) => Ap(Reverse, l, r) | (["@"], []) => ListConcat(l, r) | _ => hole(tm) }, diff --git a/src/haz3lcore/statics/Statics.re b/src/haz3lcore/statics/Statics.re index 11d68ff1f4..721c3cf58d 100644 --- a/src/haz3lcore/statics/Statics.re +++ b/src/haz3lcore/statics/Statics.re @@ -270,8 +270,7 @@ and uexp_to_info_map = let (e2, m) = go(~mode, e2, m); add(~self=Just(e2.ty), ~co_ctx=CoCtx.union([e1.co_ctx, e2.co_ctx]), m); | Constructor(ctr) => atomic(Self.of_ctr(ctx, ctr)) - | Ap(fn, arg) - | Pipeline(arg, fn) => + | Ap(_, fn, arg) => let fn_mode = Mode.of_ap(ctx, mode, UExp.ctr_name(fn)); let (fn, m) = go(~mode=fn_mode, fn, m); let (ty_in, ty_out) = Typ.matched_arrow(ctx, fn.ty); diff --git a/src/haz3lcore/statics/Term.re b/src/haz3lcore/statics/Term.re index 0661e2ce90..d5eaf21548 100644 --- a/src/haz3lcore/statics/Term.re +++ b/src/haz3lcore/statics/Term.re @@ -478,7 +478,6 @@ module UExp = { | Let(_) => Let | TyAlias(_) => TyAlias | Ap(_) => Ap - | Pipeline(_) => Pipeline | If(_) => If | Seq(_) => Seq | Test(_) => Test @@ -602,7 +601,6 @@ module UExp = { | Let(_) | TyAlias(_) | Ap(_) - | Pipeline(_) | If(_) | Seq(_) | Test(_) @@ -636,7 +634,6 @@ module UExp = { | Let(_) | TyAlias(_) | Ap(_) - | Pipeline(_) | If(_) | Seq(_) | Test(_) diff --git a/src/haz3lcore/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index e0ce064543..f280bd5e40 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -102,6 +102,11 @@ and UExp: { | Bool(op_bin_bool) | String(op_bin_string); + [@deriving (show({with_path: false}), sexp, yojson)] + type ap_direction = + | Forward + | Reverse; + [@deriving (show({with_path: false}), sexp, yojson)] type cls = | Invalid @@ -118,7 +123,7 @@ and UExp: { | Tuple | Var | Let - | Ap + | Ap(ap_direction) | If | Seq | Test @@ -147,8 +152,7 @@ and UExp: { | Var(Var.t) | Let(UPat.t, t, t) | TyAlias(UTPat.t, UTyp.t, t) - | Ap(t, t) - | Pipeline(t, t) + | Ap(ap_direction, t, t) | If(t, t, t) | Seq(t, t) | Test(t) @@ -233,6 +237,11 @@ and UExp: { | Bool(op_bin_bool) | String(op_bin_string); + [@deriving (show({with_path: false}), sexp, yojson)] + type ap_direction = + | Forward + | Reverse; + [@deriving (show({with_path: false}), sexp, yojson)] type cls = | Invalid @@ -249,7 +258,7 @@ and UExp: { | Tuple | Var | Let - | Ap + | Ap(ap_direction) | If | Seq | Test @@ -284,8 +293,8 @@ and UExp: { | Var(Var.t) // DONE [ALREADY] | Let(UPat.t, t, t) // DONE [ALREADY] | TyAlias(UTPat.t, UTyp.t, t) // [TO ADD TO DHEXP] - | Ap(t, t) // TODO: Combine Ap and Pipeline? [alt: add pipeline to dhexp] - | Pipeline(t, t) // TODO: Above + // note: function is always first then argument; even in reverse + | Ap(ap_direction, t, t) // TODO: Combine Ap and Pipeline? [alt: add pipeline to dhexp] | If(t, t, t) // TODO: What to do about consistency? | Seq(t, t) // DONE [ALREADY] | Test(t) // [DHEXP TO CHANGE] diff --git a/src/haz3lcore/zipper/EditorUtil.re b/src/haz3lcore/zipper/EditorUtil.re index 0f4d093980..83492f17f6 100644 --- a/src/haz3lcore/zipper/EditorUtil.re +++ b/src/haz3lcore/zipper/EditorUtil.re @@ -57,7 +57,6 @@ let rec append_exp = (e1: TermBase.UExp.t, e2: TermBase.UExp.t) => { | Tuple(_) | Var(_) | Ap(_) - | Pipeline(_) | If(_) | Test(_) | Parens(_) diff --git a/src/haz3lschool/SyntaxTest.re b/src/haz3lschool/SyntaxTest.re index 110e1c1051..e81b7b37a9 100644 --- a/src/haz3lschool/SyntaxTest.re +++ b/src/haz3lschool/SyntaxTest.re @@ -55,8 +55,7 @@ let rec var_mention = (name: string, uexp: Term.UExp.t): bool => { | UnOp(_, u) | TyAlias(_, _, u) | Filter(_, _, u) => var_mention(name, u) - | Ap(u1, u2) - | Pipeline(u1, u2) + | Ap(_, u1, u2) | Seq(u1, u2) | Cons(u1, u2) | ListConcat(u1, u2) @@ -101,16 +100,11 @@ let rec var_applied = (name: string, uexp: Term.UExp.t): bool => { | UnOp(_, u) | TyAlias(_, _, u) | Filter(_, _, u) => var_applied(name, u) - | Ap(u1, u2) => + | Ap(_, u1, u2) => switch (u1.term) { | Var(x) => x == name ? true : var_applied(name, u2) | _ => var_applied(name, u1) || var_applied(name, u2) } - | Pipeline(u1, u2) => - switch (u2.term) { - | Var(x) => x == name ? true : var_applied(name, u1) - | _ => var_applied(name, u1) || var_applied(name, u2) - } | Cons(u1, u2) | Seq(u1, u2) | ListConcat(u1, u2) @@ -190,8 +184,7 @@ let rec find_fn = | TyAlias(_, _, u1) | Test(u1) | Filter(_, _, u1) => l |> find_fn(name, u1) - | Ap(u1, u2) - | Pipeline(u1, u2) + | Ap(_, u1, u2) | Seq(u1, u2) | Cons(u1, u2) | ListConcat(u1, u2) @@ -241,8 +234,7 @@ let rec tail_check = (name: string, uexp: Term.UExp.t): bool => { | Float(_) | String(_) | Constructor(_) - | Var(_) - | Pipeline(_, _) => true + | Var(_) => true | Fun(args, body) => find_var_upat(name, args) ? false : tail_check(name, body) | Let(p, def, body) => @@ -257,7 +249,7 @@ let rec tail_check = (name: string, uexp: Term.UExp.t): bool => { | Filter(_, _, u) | Parens(u) => tail_check(name, u) | UnOp(_, u) => !var_mention(name, u) - | Ap(u1, u2) => var_mention(name, u2) ? false : tail_check(name, u1) + | Ap(_, u1, u2) => var_mention(name, u2) ? false : tail_check(name, u1) | Seq(u1, u2) => var_mention(name, u1) ? false : tail_check(name, u2) | Cons(u1, u2) | ListConcat(u1, u2) diff --git a/src/haz3lweb/view/ExplainThis.re b/src/haz3lweb/view/ExplainThis.re index 7206789fdd..53508ff040 100644 --- a/src/haz3lweb/view/ExplainThis.re +++ b/src/haz3lweb/view/ExplainThis.re @@ -1632,14 +1632,14 @@ let get_doc = | Parens(_) => default // Shouldn't get hit? | TypeAnn(_) => default // Shouldn't get hit? }; - | Pipeline(arg, fn) => + | Ap(Reverse, arg, fn) => message_single( PipelineExp.single( ~arg_id=Term.UExp.rep_id(arg), ~fn_id=Term.UExp.rep_id(fn), ), ) - | Ap(x, arg) => + | Ap(Forward, x, arg) => let x_id = List.nth(x.ids, 0); let arg_id = List.nth(arg.ids, 0); let basic = (group, format, coloring_ids) => { diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index 4acf9d4fb2..c42bb5684f 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -127,7 +127,7 @@ let mk = switch (previous_step) { | Some((ps, id)) when id == DHExp.rep_id(d) => switch (ps.knd, DHExp.term_of(ps.d_loc)) { - | (FunAp, Ap(d2, _)) => + | (FunAp, Ap(_, d2, _)) => switch (DHExp.term_of(d2)) { | Fun(p, _, _, _, _) => DHPat.bound_vars(p) | _ => [] @@ -309,13 +309,20 @@ let mk = | ListLit(_, _, _, d_list) => let ol = d_list |> List.map(d => go'(d)); DHDoc_common.mk_ListLit(ol); - | Ap(d1, d2) => + | Ap(Forward, d1, d2) => let (doc1, doc2) = ( go_formattable(d1) |> parenthesize(precedence(d1) > DHDoc_common.precedence_Ap), go'(d2), ); DHDoc_common.mk_Ap(doc1, doc2); + | Ap(Reverse, d1, d2) => + let (doc1, doc2) = ( + go_formattable(d1) + |> parenthesize(precedence(d1) > DHDoc_common.precedence_Ap), + go'(d2), + ); + DHDoc_common.mk_rev_Ap(doc2, doc1); | ApBuiltin(ident, d) => DHDoc_common.mk_Ap( text(ident), diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_common.re b/src/haz3lweb/view/dhcode/layout/DHDoc_common.re index 1d184c4f82..db8fec65d1 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_common.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_common.re @@ -139,5 +139,7 @@ let mk_Tuple = elts => mk_comma_seq("", "", elts); let mk_Ap = (doc1, doc2) => Doc.(hcats([doc1, text("("), doc2, text(")")])); +let mk_rev_Ap = (doc1, doc2) => Doc.(hcats([doc1, text(" |> "), doc2])); + let mk_Prj = (targ, n) => Doc.hcats([targ, Delim.projection_dot, Doc.text(string_of_int(n))]); diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_common.rei b/src/haz3lweb/view/dhcode/layout/DHDoc_common.rei index af3ce0dec5..92f9d5a835 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_common.rei +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_common.rei @@ -93,4 +93,6 @@ let mk_Tuple: list(Pretty.Doc.t('a)) => Pretty.Doc.t('a); let mk_Ap: (Pretty.Doc.t('a), Pretty.Doc.t('a)) => Pretty.Doc.t('a); +let mk_rev_Ap: (Pretty.Doc.t('a), Pretty.Doc.t('a)) => Pretty.Doc.t('a); + let mk_Prj: (Pretty.Doc.t(DHAnnot.t), int) => Pretty.Doc.t(DHAnnot.t); From 252bce2f7d057135207ff74d2887867c152a9c06 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Tue, 20 Feb 2024 14:27:17 -0500 Subject: [PATCH 012/103] Merge fixes --- src/haz3lcore/dynamics/Elaborator.re | 2 +- src/haz3lcore/dynamics/Stepper.re | 33 ++++----- src/haz3lcore/prog/Interface.re | 2 +- src/haz3lweb/view/Cell.re | 2 +- src/haz3lweb/view/StepperView.re | 10 ++- src/haz3lweb/view/dhcode/DHCode.re | 2 +- src/test/Test_Elaboration.re | 102 ++++++++++++++++++--------- 7 files changed, 96 insertions(+), 57 deletions(-) diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 54ec454f62..9b5fef94ba 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -83,7 +83,7 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => DHExp.fresh_cast(d, self_ty, Unknown(prov)) | _ => d } - _ => DHExp.fresh_cast(d, self_ty, ana_ty) + | _ => DHExp.fresh_cast(d, self_ty, ana_ty) } | _ => DHExp.fresh_cast(d, self_ty, ana_ty) } diff --git a/src/haz3lcore/dynamics/Stepper.re b/src/haz3lcore/dynamics/Stepper.re index fa192742f0..7927e015f9 100644 --- a/src/haz3lcore/dynamics/Stepper.re +++ b/src/haz3lcore/dynamics/Stepper.re @@ -7,7 +7,7 @@ exception Exception; [@deriving (show({with_path: false}), sexp, yojson)] type stepper_state = - | StepPending(EvalObj.t) + | StepPending(int) | StepperReady | StepperDone | StepTimeout(EvalObj.t); @@ -189,9 +189,9 @@ let get_next_steps = s => s.next_options; let current_expr = ({history, _}: t) => Aba.hd(history); -let step_pending = (eo: EvalObj.t, stepper: t) => { +let step_pending = (idx: int, stepper: t) => { ...stepper, - stepper_state: StepPending(eo), + stepper_state: StepPending(idx), }; let init = (elab: DHExp.t) => { @@ -205,16 +205,19 @@ let init = (elab: DHExp.t) => { let rec evaluate_pending = (~settings, s: t) => { switch (s.stepper_state) { | StepperDone - | StepperError(_) | StepTimeout(_) => s | StepperReady => let next' = s.next_options |> List.map(should_hide_eval_obj(~settings)); - switch (List.find_opt(((act, _)) => act == FilterAction.Eval, next')) { - | Some((_, eo)) => - {...s, stepper_state: StepPending(eo)} |> evaluate_pending(~settings) + let next'' = List.mapi((i, x) => (i, x), next'); + switch ( + List.find_opt(((_, (act, _))) => act == FilterAction.Eval, next'') + ) { + | Some((i, (_, _))) => + {...s, stepper_state: StepPending(i)} |> evaluate_pending(~settings) | None => {...s, stepper_state: StepperDone} }; - | StepPending(eo) => + | StepPending(i) => + let eo = List.nth(s.next_options, i); let (d, state) = Aba.hd(s.history); let state_ref = ref(state); let d_loc' = @@ -245,11 +248,9 @@ let rec evaluate_pending = (~settings, s: t) => { let rec evaluate_full = (~settings, s: t) => { switch (s.stepper_state) { - | StepperError(_) | StepTimeout(_) => s | StepperDone when s.next_options == [] => s - | StepperDone => - s |> step_pending(List.hd(s.next_options)) |> evaluate_full(~settings) + | StepperDone => s |> step_pending(0) |> evaluate_full(~settings) | StepperReady | StepPending(_) => evaluate_pending(~settings, s) |> evaluate_full(~settings) @@ -258,15 +259,11 @@ let rec evaluate_full = (~settings, s: t) => { let timeout = fun - | {stepper_state: StepPending(eo), _} as s => { + | {stepper_state: StepPending(idx), _} as s => { ...s, - stepper_state: StepTimeout(eo), + stepper_state: StepTimeout(List.nth(s.next_options, idx)), } - | { - stepper_state: - StepperError(_) | StepTimeout(_) | StepperReady | StepperDone, - _, - } as s => s; + | {stepper_state: StepTimeout(_) | StepperReady | StepperDone, _} as s => s; let rec truncate_history = (~settings) => fun diff --git a/src/haz3lcore/prog/Interface.re b/src/haz3lcore/prog/Interface.re index 59402676b4..d74fe46f62 100644 --- a/src/haz3lcore/prog/Interface.re +++ b/src/haz3lcore/prog/Interface.re @@ -32,7 +32,7 @@ module Statics = { core.statics ? mk_map_ctx(ctx, exp) : Id.Map.empty; }; -let dh_err = (error: string): DHExp.t => BoundVar(error) |> DHExp.fresh; +let dh_err = (error: string): DHExp.t => Var(error) |> DHExp.fresh; let elaborate = Core.Memo.general(~cache_size_bound=1000, Elaborator.uexp_elab); diff --git a/src/haz3lweb/view/Cell.re b/src/haz3lweb/view/Cell.re index 087ff13d65..a607256cbc 100644 --- a/src/haz3lweb/view/Cell.re +++ b/src/haz3lweb/view/Cell.re @@ -396,7 +396,7 @@ let locked = statics.info_map, editor.state.meta.view_term, ) - : DHExp.BoolLit(true); + : DHExp.Bool(true) |> DHExp.fresh; let result: ModelResult.t = settings.core.dynamics ? Evaluation({ diff --git a/src/haz3lweb/view/StepperView.re b/src/haz3lweb/view/StepperView.re index 846261621d..8ee266e476 100644 --- a/src/haz3lweb/view/StepperView.re +++ b/src/haz3lweb/view/StepperView.re @@ -145,7 +145,15 @@ let stepper_view = ] : [ div(~attr=Attr.class_("equiv"), [Node.text("≡")]), - step_dh_code(~next_steps=Stepper.get_next_steps(stepper), hd), + step_dh_code( + ~next_steps= + List.mapi( + (i, x: EvaluatorStep.EvalObj.t) => + (i, x.d_loc |> DHExp.rep_id), + Stepper.get_next_steps(stepper), + ), + hd, + ), button_back, eval_settings, show_history, diff --git a/src/haz3lweb/view/dhcode/DHCode.re b/src/haz3lweb/view/dhcode/DHCode.re index c594bb653b..385d74ecb0 100644 --- a/src/haz3lweb/view/dhcode/DHCode.re +++ b/src/haz3lweb/view/dhcode/DHCode.re @@ -144,7 +144,7 @@ let view = ~previous_step: option((EvaluatorStep.step, Id.t))=None, // The step that will be displayed above this one ~hidden_steps: list((EvaluatorStep.step, Id.t))=[], // The hidden steps between the above and the current one ~chosen_step: option(EvaluatorStep.step)=None, // The step that will be taken next - ~next_steps: list(EvaluatorStep.EvalObj.t)=[], + ~next_steps: list((int, Id.t))=[], ~result_key: string, d: DHExp.t, ) diff --git a/src/test/Test_Elaboration.re b/src/test/Test_Elaboration.re index 2e20c1e869..edf72953f0 100644 --- a/src/test/Test_Elaboration.re +++ b/src/test/Test_Elaboration.re @@ -1,5 +1,6 @@ open Alcotest; open Haz3lcore; +open DHExp; let dhexp_eq = (d1: option(DHExp.t), d2: option(DHExp.t)): bool => switch (d1, d2) { @@ -25,22 +26,28 @@ let alco_check = dhexp_typ |> Alcotest.check; let u1: Term.UExp.t = {ids: [id_at(0)], term: Int(8)}; let single_integer = () => - alco_check("Integer literal 8", Some(IntLit(8)), dhexp_of_uexp(u1)); + alco_check( + "Integer literal 8", + Some(Int(8) |> fresh), + dhexp_of_uexp(u1), + ); let u2: Term.UExp.t = {ids: [id_at(0)], term: EmptyHole}; let empty_hole = () => - alco_check( - "Empty hole", - Some(EmptyHole(id_at(0), 0)), - dhexp_of_uexp(u2), - ); + alco_check("Empty hole", Some(EmptyHole |> fresh), dhexp_of_uexp(u2)); let u3: Term.UExp.t = { ids: [id_at(0)], term: Parens({ids: [id_at(1)], term: Var("y")}), }; let d3: DHExp.t = - NonEmptyHole(TypeInconsistent, id_at(1), 0, FreeVar(id_at(1), 0, "y")); + NonEmptyHole( + TypeInconsistent, + id_at(1), + 0, + FreeVar(id_at(1), 0, "y") |> fresh, + ) + |> fresh; let free_var = () => alco_check( "Nonempty hole with free variable", @@ -82,9 +89,10 @@ let u4: Term.UExp.t = { let d4: DHExp.t = Let( Tuple([Var("a"), Var("b")]), - Tuple([IntLit(4), IntLit(6)]), - BinIntOp(Minus, BoundVar("a"), BoundVar("b")), - ); + Tuple([Int(4) |> fresh, Int(6) |> fresh]) |> fresh, + BinOp(Int(Minus), Var("a") |> fresh, Var("b") |> fresh) |> fresh, + ) + |> fresh; let let_exp = () => alco_check( "Let expression for tuple (a, b)", @@ -102,11 +110,19 @@ let u5: Term.UExp.t = { ), }; let d5: DHExp.t = - BinIntOp( - Plus, - NonEmptyHole(TypeInconsistent, id_at(1), 0, BoolLit(false)), - NonEmptyHole(TypeInconsistent, id_at(2), 0, FreeVar(id_at(2), 0, "y")), - ); + BinOp( + Int(Plus), + NonEmptyHole(TypeInconsistent, id_at(1), 0, Bool(false) |> fresh) + |> fresh, + NonEmptyHole( + TypeInconsistent, + id_at(2), + 0, + FreeVar(id_at(2), 0, "y") |> fresh, + ) + |> fresh, + ) + |> fresh; let bin_op = () => alco_check( "Inconsistent binary integer operation (plus)", @@ -124,7 +140,8 @@ let u6: Term.UExp.t = { ), }; let d6: DHExp.t = - IfThenElse(DH.ConsistentIf, BoolLit(false), IntLit(8), IntLit(6)); + If(DH.Consistent, Bool(false) |> fresh, Int(8) |> fresh, Int(6) |> fresh) + |> fresh; let consistent_if = () => alco_check( "Consistent case with rules (BoolLit(true), IntLit(8)) and (BoolLit(false), IntLit(6))", @@ -136,6 +153,7 @@ let u7: Term.UExp.t = { ids: [id_at(0)], term: Ap( + Forward, { ids: [id_at(1)], term: @@ -157,18 +175,29 @@ let u7: Term.UExp.t = { }; let d7: DHExp.t = Ap( + Forward, Fun( Var("x"), Unknown(Internal), - BinIntOp( - Plus, - IntLit(4), - Cast(BoundVar("x"), Unknown(Internal), Int), - ), + BinOp( + Int(Plus), + Int(4) |> fresh, + Cast(Var("x") |> fresh, Unknown(Internal), Int) |> fresh, + ) + |> fresh, None, - ), - NonEmptyHole(TypeInconsistent, id_at(6), 0, FreeVar(id_at(6), 0, "y")), - ); + None, + ) + |> fresh, + NonEmptyHole( + TypeInconsistent, + id_at(6), + 0, + FreeVar(id_at(6), 0, "y") |> fresh, + ) + |> fresh, + ) + |> fresh; let ap_fun = () => alco_check( "Application of a function of a free variable wrapped inside a nonempty hole constructor", @@ -201,15 +230,16 @@ let u8: Term.UExp.t = { ], ), }; -let d8scrut: DHExp.t = BinIntOp(Equals, IntLit(4), IntLit(3)); +let d8scrut: DHExp.t = + BinOp(Int(Equals), Int(4) |> fresh, Int(3) |> fresh) |> fresh; let d8rules = DHExp.[ - Rule(BoolLit(true), IntLit(24)), - Rule(BoolLit(false), BoolLit(false)), + (Bool(true): DHPat.t, Int(24) |> fresh), + (Bool(false): DHPat.t, Bool(false) |> fresh), ]; let d8a: DHExp.t = - InconsistentBranches(id_at(0), 0, Case(d8scrut, d8rules, 0)); -let d8: DHExp.t = NonEmptyHole(TypeInconsistent, id_at(0), 0, d8a); + Match(Inconsistent(id_at(0), 0), d8scrut, d8rules) |> fresh; +let d8: DHExp.t = NonEmptyHole(TypeInconsistent, id_at(0), 0, d8a) |> fresh; let inconsistent_case = () => alco_check( "Inconsistent branches where the first branch is an integer and second branch is a boolean", @@ -264,12 +294,16 @@ let d9: DHExp.t = Fun( Var("x"), Int, - BinIntOp(Plus, IntLit(1), BoundVar("x")), + BinOp(Int(Plus), Int(1) |> fresh, Var("x") |> fresh) |> fresh, + None, Some("f"), - ), - ), - IntLit(55), - ); + ) + |> fresh, + ) + |> fresh, + Int(55) |> fresh, + ) + |> fresh; let let_fun = () => alco_check( "Let expression for function which wraps a fix point constructor around the function", From 4e98c227c0b5ed3f53078d1bb1e69189624e02fd Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Tue, 20 Feb 2024 14:46:49 -0500 Subject: [PATCH 013/103] Change how ids are renamed --- src/haz3lcore/dynamics/DH.re | 16 +- src/haz3lcore/dynamics/EvalCtx.re | 205 +++++++++--------- src/haz3lcore/dynamics/EvaluatorStep.re | 7 +- src/haz3lcore/dynamics/Stepper.re | 208 ++++++++++--------- src/haz3lcore/dynamics/Transition.re | 126 ++++++++--- src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 13 ++ 6 files changed, 344 insertions(+), 231 deletions(-) diff --git a/src/haz3lcore/dynamics/DH.re b/src/haz3lcore/dynamics/DH.re index 3b909fddbf..3f63fff746 100644 --- a/src/haz3lcore/dynamics/DH.re +++ b/src/haz3lcore/dynamics/DH.re @@ -28,7 +28,13 @@ module rec DHExp: { | Seq(t, t) // DONE [ALREADY] | Let(DHPat.t, t, t) // DONE [ALREADY] | FixF(Var.t, Typ.t, t) // TODO: surface fix - | Fun(DHPat.t, Typ.t, t, option(ClosureEnvironment.t), option(Var.t)) // TODO: Use infomap for Typ.t + | Fun( + DHPat.t, + Typ.t, + t, + [@show.opaque] option(ClosureEnvironment.t), + option(Var.t), + ) // TODO: Use infomap for Typ.t | Ap(TermBase.UExp.ap_direction, t, t) // TODO: Add reverse application | ApBuiltin(string, t) // DONE [TO ADD TO UEXP] TODO: Add a loooong comment here | BuiltinFun(string) // DONE [TO ADD TO UEXP] @@ -84,7 +90,13 @@ module rec DHExp: { | Seq(t, t) | Let(DHPat.t, t, t) | FixF(Var.t, Typ.t, t) - | Fun(DHPat.t, Typ.t, t, option(ClosureEnvironment.t), option(Var.t)) + | Fun( + DHPat.t, + Typ.t, + t, + [@show.opaque] option(ClosureEnvironment.t), + option(Var.t), + ) | Ap(TermBase.UExp.ap_direction, t, t) | ApBuiltin(string, t) | BuiltinFun(string) diff --git a/src/haz3lcore/dynamics/EvalCtx.re b/src/haz3lcore/dynamics/EvalCtx.re index 873202bf99..df2dbf7441 100644 --- a/src/haz3lcore/dynamics/EvalCtx.re +++ b/src/haz3lcore/dynamics/EvalCtx.re @@ -3,8 +3,7 @@ open Util; open DH; [@deriving (show({with_path: false}), sexp, yojson)] -type t = - | Mark +type term = | Closure([@show.opaque] ClosureEnvironment.t, t) | Filter(DH.DHFilter.t, t) | Seq1(t, DHExp.t) @@ -46,102 +45,112 @@ type t = DHPat.t, t, (list((DHPat.t, DHExp.t)), list((DHPat.t, DHExp.t))), - ); + ) +and t = + | Mark + | Term({ + term, + ids: list(Id.t), + }); let rec compose = (ctx: t, d: DHExp.t): DHExp.t => { - DHExp.( - switch (ctx) { - | Mark => d - | Closure(env, ctx) => - let d = compose(ctx, d); - Closure(env, d) |> fresh; - | Filter(flt, ctx) => - let d = compose(ctx, d); - Filter(flt, d) |> fresh; - | Seq1(ctx, d2) => - let d1 = compose(ctx, d); - Seq(d1, d2) |> fresh; - | Seq2(d1, ctx) => - let d2 = compose(ctx, d); - Seq(d1, d2) |> fresh; - | Ap1(dir, ctx, d2) => - let d1 = compose(ctx, d); - Ap(dir, d1, d2) |> fresh; - | Ap2(dir, d1, ctx) => - let d2 = compose(ctx, d); - Ap(dir, d1, d2) |> fresh; - | ApBuiltin(s, ctx) => - let d' = compose(ctx, d); - ApBuiltin(s, d') |> fresh; - | If1(c, ctx, d2, d3) => - let d' = compose(ctx, d); - If(c, d', d2, d3) |> fresh; - | If2(c, d1, ctx, d3) => - let d' = compose(ctx, d); - If(c, d1, d', d3) |> fresh; - | If3(c, d1, d2, ctx) => - let d' = compose(ctx, d); - If(c, d1, d2, d') |> fresh; - | Test(lit, ctx) => - let d1 = compose(ctx, d); - Test(lit, d1) |> fresh; - | BinOp1(op, ctx, d2) => - let d1 = compose(ctx, d); - BinOp(op, d1, d2) |> fresh; - | BinOp2(op, d1, ctx) => - let d2 = compose(ctx, d); - BinOp(op, d1, d2) |> fresh; - | Cons1(ctx, d2) => - let d1 = compose(ctx, d); - Cons(d1, d2) |> fresh; - | Cons2(d1, ctx) => - let d2 = compose(ctx, d); - Cons(d1, d2) |> fresh; - | ListConcat1(ctx, d2) => - let d1 = compose(ctx, d); - ListConcat(d1, d2) |> fresh; - | ListConcat2(d1, ctx) => - let d2 = compose(ctx, d); - ListConcat(d1, d2) |> fresh; - | Tuple(ctx, (ld, rd)) => - let d = compose(ctx, d); - Tuple(ListUtil.rev_concat(ld, [d, ...rd])) |> fresh; - | ListLit(m, i, t, ctx, (ld, rd)) => - let d = compose(ctx, d); - ListLit(m, i, t, ListUtil.rev_concat(ld, [d, ...rd])) |> fresh; - | Let1(dp, ctx, d2) => - let d = compose(ctx, d); - Let(dp, d, d2) |> fresh; - | Let2(dp, d1, ctx) => - let d = compose(ctx, d); - Let(dp, d1, d) |> fresh; - | Fun(dp, t, ctx, env, v) => - let d = compose(ctx, d); - Fun(dp, t, d, env, v) |> fresh; - | FixF(v, t, ctx) => - let d = compose(ctx, d); - FixF(v, t, d) |> fresh; - | Prj(ctx, n) => - let d = compose(ctx, d); - Prj(d, n) |> fresh; - | Cast(ctx, ty1, ty2) => - let d = compose(ctx, d); - Cast(d, ty1, ty2) |> fresh; - | FailedCast(ctx, ty1, ty2) => - let d = compose(ctx, d); - FailedCast(d, ty1, ty2) |> fresh; - | InvalidOperation(ctx, err) => - let d = compose(ctx, d); - InvalidOperation(d, err) |> fresh; - | NonEmptyHole(reason, u, i, ctx) => - let d = compose(ctx, d); - NonEmptyHole(reason, u, i, d) |> fresh; - | MatchScrut(c, ctx, rules) => - let d = compose(ctx, d); - Match(c, d, rules) |> fresh; - | MatchRule(c, scr, p, ctx, (lr, rr)) => - let d = compose(ctx, d); - Match(c, scr, ListUtil.rev_concat(lr, [(p, d), ...rr])) |> fresh; - } - ); + switch (ctx) { + | Mark => d + | Term({term, ids}) => + let wrap = DHExp.mk(ids); + DHExp.( + switch (term) { + | Closure(env, ctx) => + let d = compose(ctx, d); + Closure(env, d) |> wrap; + | Filter(flt, ctx) => + let d = compose(ctx, d); + Filter(flt, d) |> wrap; + | Seq1(ctx, d2) => + let d1 = compose(ctx, d); + Seq(d1, d2) |> wrap; + | Seq2(d1, ctx) => + let d2 = compose(ctx, d); + Seq(d1, d2) |> wrap; + | Ap1(dir, ctx, d2) => + let d1 = compose(ctx, d); + Ap(dir, d1, d2) |> wrap; + | Ap2(dir, d1, ctx) => + let d2 = compose(ctx, d); + Ap(dir, d1, d2) |> wrap; + | ApBuiltin(s, ctx) => + let d' = compose(ctx, d); + ApBuiltin(s, d') |> wrap; + | If1(c, ctx, d2, d3) => + let d' = compose(ctx, d); + If(c, d', d2, d3) |> wrap; + | If2(c, d1, ctx, d3) => + let d' = compose(ctx, d); + If(c, d1, d', d3) |> wrap; + | If3(c, d1, d2, ctx) => + let d' = compose(ctx, d); + If(c, d1, d2, d') |> wrap; + | Test(lit, ctx) => + let d1 = compose(ctx, d); + Test(lit, d1) |> wrap; + | BinOp1(op, ctx, d2) => + let d1 = compose(ctx, d); + BinOp(op, d1, d2) |> wrap; + | BinOp2(op, d1, ctx) => + let d2 = compose(ctx, d); + BinOp(op, d1, d2) |> wrap; + | Cons1(ctx, d2) => + let d1 = compose(ctx, d); + Cons(d1, d2) |> wrap; + | Cons2(d1, ctx) => + let d2 = compose(ctx, d); + Cons(d1, d2) |> wrap; + | ListConcat1(ctx, d2) => + let d1 = compose(ctx, d); + ListConcat(d1, d2) |> wrap; + | ListConcat2(d1, ctx) => + let d2 = compose(ctx, d); + ListConcat(d1, d2) |> wrap; + | Tuple(ctx, (ld, rd)) => + let d = compose(ctx, d); + Tuple(ListUtil.rev_concat(ld, [d, ...rd])) |> wrap; + | ListLit(m, i, t, ctx, (ld, rd)) => + let d = compose(ctx, d); + ListLit(m, i, t, ListUtil.rev_concat(ld, [d, ...rd])) |> wrap; + | Let1(dp, ctx, d2) => + let d = compose(ctx, d); + Let(dp, d, d2) |> wrap; + | Let2(dp, d1, ctx) => + let d = compose(ctx, d); + Let(dp, d1, d) |> wrap; + | Fun(dp, t, ctx, env, v) => + let d = compose(ctx, d); + Fun(dp, t, d, env, v) |> wrap; + | FixF(v, t, ctx) => + let d = compose(ctx, d); + FixF(v, t, d) |> wrap; + | Prj(ctx, n) => + let d = compose(ctx, d); + Prj(d, n) |> wrap; + | Cast(ctx, ty1, ty2) => + let d = compose(ctx, d); + Cast(d, ty1, ty2) |> wrap; + | FailedCast(ctx, ty1, ty2) => + let d = compose(ctx, d); + FailedCast(d, ty1, ty2) |> wrap; + | InvalidOperation(ctx, err) => + let d = compose(ctx, d); + InvalidOperation(d, err) |> wrap; + | NonEmptyHole(reason, u, i, ctx) => + let d = compose(ctx, d); + NonEmptyHole(reason, u, i, d) |> wrap; + | MatchScrut(c, ctx, rules) => + let d = compose(ctx, d); + Match(c, d, rules) |> wrap; + | MatchRule(c, scr, p, ctx, (lr, rr)) => + let d = compose(ctx, d); + Match(c, scr, ListUtil.rev_concat(lr, [(p, d), ...rr])) |> wrap; + } + ); + }; }; diff --git a/src/haz3lcore/dynamics/EvaluatorStep.re b/src/haz3lcore/dynamics/EvaluatorStep.re index 2871e191eb..23d7934eea 100644 --- a/src/haz3lcore/dynamics/EvaluatorStep.re +++ b/src/haz3lcore/dynamics/EvaluatorStep.re @@ -151,7 +151,12 @@ module Decompose = { let. _ = otherwise(env, (d1) => (Filter(flt, d1) |> rewrap: DHExp.t)) and. d1 = - req_final(decompose(state, env), d1 => Filter(flt, d1), d1); + req_final( + decompose(state, env), + d1 => + Term({term: Filter(flt, d1), ids: [DHExp.rep_id(exp)]}), + d1, + ); Step({apply: () => d1, kind: CompleteFilter, value: true}); } ) diff --git a/src/haz3lcore/dynamics/Stepper.re b/src/haz3lcore/dynamics/Stepper.re index 7927e015f9..130a83e77d 100644 --- a/src/haz3lcore/dynamics/Stepper.re +++ b/src/haz3lcore/dynamics/Stepper.re @@ -37,122 +37,126 @@ let rec matches = let (mact, midx) = FilterMatcher.matches(~env, ~exp=composed, ~act, flt); let (act, idx) = switch (ctx) { - | Filter(_, _) => (pact, pidx) + | Term({term: Filter(_, _), _}) => (pact, pidx) | _ => midx > idx ? (mact, midx) : (pact, pidx) }; - let map = ((a, i, c), f: EvalCtx.t => EvalCtx.t) => { + let map = ((a, i, c), f) => { (a, i, f(c)); }; let (let+) = map; let (ract, ridx, rctx) = switch (ctx) { | Mark => (act, idx, EvalCtx.Mark) - | Closure(env, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Closure(env, ctx); - | Filter(Filter(flt'), ctx) => - let flt = flt |> FilterEnvironment.extends(flt'); - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Filter(Filter(flt'), ctx); - | Filter(Residue(idx, act), ctx) => - let (ract, ridx, rctx) = matches(env, flt, ctx, exp, act, idx); - if (ridx == idx && ract |> snd == All) { - (ract, ridx, Filter(Residue(idx, act), rctx)); - } else { - (ract, ridx, rctx); + | Term({term, ids}) => + let rewrap = term => EvalCtx.Term({term, ids}); + switch ((term: EvalCtx.term)) { + | Closure(env, ctx) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Closure(env, ctx) |> rewrap; + | Filter(Filter(flt'), ctx) => + let flt = flt |> FilterEnvironment.extends(flt'); + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Filter(Filter(flt'), ctx) |> rewrap; + | Filter(Residue(idx, act), ctx) => + let (ract, ridx, rctx) = matches(env, flt, ctx, exp, act, idx); + if (ridx == idx && ract |> snd == All) { + (ract, ridx, Filter(Residue(idx, act), rctx) |> rewrap); + } else { + (ract, ridx, rctx); + }; + | Seq1(ctx, d2) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Seq1(ctx, d2) |> rewrap; + | Seq2(d1, ctx) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Seq2(d1, ctx) |> rewrap; + | Let1(d1, ctx, d3) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Let1(d1, ctx, d3) |> rewrap; + | Let2(d1, d2, ctx) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Let2(d1, d2, ctx) |> rewrap; + | Fun(dp, ty, ctx, env', name) => + let+ ctx = + matches(Option.value(~default=env, env'), flt, ctx, exp, act, idx); + Fun(dp, ty, ctx, env', name) |> rewrap; + | FixF(name, ty, ctx) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + FixF(name, ty, ctx) |> rewrap; + | Ap1(dir, ctx, d2) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Ap1(dir, ctx, d2) |> rewrap; + | Ap2(dir, d1, ctx) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Ap2(dir, d1, ctx) |> rewrap; + | If1(c, ctx, d2, d3) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + If1(c, ctx, d2, d3) |> rewrap; + | If2(c, d1, ctx, d3) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + If2(c, d1, ctx, d3) |> rewrap; + | If3(c, d1, d2, ctx) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + If3(c, d1, d2, ctx) |> rewrap; + | BinOp1(op, ctx, d1) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + BinOp1(op, ctx, d1) |> rewrap; + | BinOp2(op, d1, ctx) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + BinOp2(op, d1, ctx) |> rewrap; + | Tuple(ctx, ds) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Tuple(ctx, ds) |> rewrap; + | ApBuiltin(name, ctx) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + ApBuiltin(name, ctx) |> rewrap; + | Test(id, ctx) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Test(id, ctx) |> rewrap; + | ListLit(u, i, ty, ctx, ds) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + ListLit(u, i, ty, ctx, ds) |> rewrap; + | Cons1(ctx, d2) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Cons1(ctx, d2) |> rewrap; + | Cons2(d1, ctx) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Cons2(d1, ctx) |> rewrap; + | ListConcat1(ctx, d2) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + ListConcat1(ctx, d2) |> rewrap; + | ListConcat2(d1, ctx) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + ListConcat2(d1, ctx) |> rewrap; + | Prj(ctx, n) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Prj(ctx, n) |> rewrap; + | NonEmptyHole(e, u, i, ctx) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + NonEmptyHole(e, u, i, ctx) |> rewrap; + | Cast(ctx, ty, ty') => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Cast(ctx, ty, ty') |> rewrap; + | FailedCast(ctx, ty, ty') => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + FailedCast(ctx, ty, ty') |> rewrap; + | InvalidOperation(ctx, error) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + InvalidOperation(ctx, error) |> rewrap; + | MatchScrut(c, ctx, rs) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + MatchScrut(c, ctx, rs) |> rewrap; + | MatchRule(c, scr, p, ctx, rs) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + MatchRule(c, scr, p, ctx, rs) |> rewrap; }; - | Seq1(ctx, d2) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Seq1(ctx, d2); - | Seq2(d1, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Seq2(d1, ctx); - | Let1(d1, ctx, d3) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Let1(d1, ctx, d3); - | Let2(d1, d2, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Let2(d1, d2, ctx); - | Fun(dp, ty, ctx, env', name) => - let+ ctx = - matches(Option.value(~default=env, env'), flt, ctx, exp, act, idx); - Fun(dp, ty, ctx, env', name); - | FixF(name, ty, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - FixF(name, ty, ctx); - | Ap1(dir, ctx, d2) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Ap1(dir, ctx, d2); - | Ap2(dir, d1, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Ap2(dir, d1, ctx); - | If1(c, ctx, d2, d3) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - If1(c, ctx, d2, d3); - | If2(c, d1, ctx, d3) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - If2(c, d1, ctx, d3); - | If3(c, d1, d2, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - If3(c, d1, d2, ctx); - | BinOp1(op, ctx, d1) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - BinOp1(op, ctx, d1); - | BinOp2(op, d1, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - BinOp2(op, d1, ctx); - | Tuple(ctx, ds) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Tuple(ctx, ds); - | ApBuiltin(name, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - ApBuiltin(name, ctx); - | Test(id, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Test(id, ctx); - | ListLit(u, i, ty, ctx, ds) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - ListLit(u, i, ty, ctx, ds); - | Cons1(ctx, d2) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Cons1(ctx, d2); - | Cons2(d1, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Cons2(d1, ctx); - | ListConcat1(ctx, d2) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - ListConcat1(ctx, d2); - | ListConcat2(d1, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - ListConcat2(d1, ctx); - | Prj(ctx, n) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Prj(ctx, n); - | NonEmptyHole(e, u, i, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - NonEmptyHole(e, u, i, ctx); - | Cast(ctx, ty, ty') => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Cast(ctx, ty, ty'); - | FailedCast(ctx, ty, ty') => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - FailedCast(ctx, ty, ty'); - | InvalidOperation(ctx, error) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - InvalidOperation(ctx, error); - | MatchScrut(c, ctx, rs) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - MatchScrut(c, ctx, rs); - | MatchRule(c, scr, p, ctx, rs) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - MatchRule(c, scr, p, ctx, rs); }; switch (ctx) { - | Filter(_) => (ract, ridx, rctx) + | Term({term: Filter(_), _}) => (ract, ridx, rctx) | _ when midx == ridx && midx > pidx && mact |> snd == All => ( ract, ridx, - Filter(Residue(midx, mact), rctx), + Term({term: Filter(Residue(midx, mact), rctx), ids: [Id.mk()]}), ) | _ => (ract, ridx, rctx) }; diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index f1bdf38019..8cf86f9065 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -198,6 +198,7 @@ module Transition = (EV: EV_MODE) => { let transition = (req, state, env, d): 'a => { let (term, rewrap) = DHExp.unwrap(d); + let wrap_ctx = (term): EvalCtx.t => Term({term, ids: [rep_id(d)]}); switch (term) { | Var(x) => let. _ = otherwise(env, Var(x) |> rewrap); @@ -216,11 +217,13 @@ module Transition = (EV: EV_MODE) => { }); | Seq(d1, d2) => let. _ = otherwise(env, d1 => Seq(d1, d2) |> rewrap) - and. _ = req_final(req(state, env), d1 => Seq1(d1, d2), d1); + and. _ = + req_final(req(state, env), d1 => Seq1(d1, d2) |> wrap_ctx, d1); Step({apply: () => d2, kind: Seq, value: false}); | Let(dp, d1, d2) => let. _ = otherwise(env, d1 => Let(dp, d1, d2) |> rewrap) - and. d1' = req_final(req(state, env), d1 => Let1(dp, d1, d2), d1); + and. d1' = + req_final(req(state, env), d1 => Let1(dp, d1, d2) |> wrap_ctx, d1); let.match env' = (env, matches(dp, d1')); Step({ apply: () => Closure(env', d2) |> fresh, @@ -251,7 +254,7 @@ module Transition = (EV: EV_MODE) => { }); | Test(id, d) => let. _ = otherwise(env, d => Test(id, d) |> rewrap) - and. d' = req_final(req(state, env), d => Test(id, d), d); + and. d' = req_final(req(state, env), d => Test(id, d) |> wrap_ctx, d); Step({ apply: () => switch (DHExp.term_of(d')) { @@ -271,8 +274,10 @@ module Transition = (EV: EV_MODE) => { }); | Ap(dir, d1, d2) => let. _ = otherwise(env, (d1, d2) => Ap(dir, d1, d2) |> rewrap) - and. d1' = req_value(req(state, env), d1 => Ap1(dir, d1, d2), d1) - and. d2' = req_final(req(state, env), d2 => Ap2(dir, d1, d2), d2); + and. d1' = + req_value(req(state, env), d1 => Ap1(dir, d1, d2) |> wrap_ctx, d1) + and. d2' = + req_final(req(state, env), d2 => Ap2(dir, d1, d2) |> wrap_ctx, d2); switch (DHExp.term_of(d1')) { | Constructor(_) => Constructor | Fun(dp, _, d3, Some(env'), _) => @@ -315,7 +320,11 @@ module Transition = (EV: EV_MODE) => { | ApBuiltin(ident, arg) => let. _ = otherwise(env, arg => ApBuiltin(ident, arg) |> rewrap) and. arg' = - req_value(req(state, env), arg => ApBuiltin(ident, arg), arg); + req_value( + req(state, env), + arg => ApBuiltin(ident, arg) |> wrap_ctx, + arg, + ); Step({ apply: () => { let builtin = @@ -339,7 +348,11 @@ module Transition = (EV: EV_MODE) => { | If(consistent, c, d1, d2) => let. _ = otherwise(env, c => If(consistent, c, d1, d2) |> rewrap) and. c' = - req_value(req(state, env), c => If1(consistent, c, d1, d2), c); + req_value( + req(state, env), + c => If1(consistent, c, d1, d2) |> wrap_ctx, + c, + ); switch (consistent, DHExp.term_of(c')) { | (Consistent, Bool(b)) => Step({ @@ -365,7 +378,11 @@ module Transition = (EV: EV_MODE) => { | BinOp(Bool(And), d1, d2) => let. _ = otherwise(env, d1 => BinOp(Bool(And), d1, d2) |> rewrap) and. d1' = - req_value(req(state, env), d1 => BinOp1(Bool(And), d1, d2), d1); + req_value( + req(state, env), + d1 => BinOp1(Bool(And), d1, d2) |> wrap_ctx, + d1, + ); Step({ apply: () => switch (DHExp.term_of(d1')) { @@ -379,7 +396,11 @@ module Transition = (EV: EV_MODE) => { | BinOp(Bool(Or), d1, d2) => let. _ = otherwise(env, d1 => BinOp(Bool(Or), d1, d2) |> rewrap) and. d1' = - req_value(req(state, env), d1 => BinOp1(Bool(Or), d1, d2), d1); + req_value( + req(state, env), + d1 => BinOp1(Bool(Or), d1, d2) |> wrap_ctx, + d1, + ); Step({ apply: () => switch (DHExp.term_of(d1')) { @@ -393,9 +414,17 @@ module Transition = (EV: EV_MODE) => { | BinOp(Int(op), d1, d2) => let. _ = otherwise(env, (d1, d2) => BinOp(Int(op), d1, d2) |> rewrap) and. d1' = - req_value(req(state, env), d1 => BinOp1(Int(op), d1, d2), d1) + req_value( + req(state, env), + d1 => BinOp1(Int(op), d1, d2) |> wrap_ctx, + d1, + ) and. d2' = - req_value(req(state, env), d2 => BinOp2(Int(op), d1, d2), d2); + req_value( + req(state, env), + d2 => BinOp2(Int(op), d1, d2) |> wrap_ctx, + d2, + ); Step({ apply: () => switch (DHExp.term_of(d1'), DHExp.term_of(d2')) { @@ -440,9 +469,17 @@ module Transition = (EV: EV_MODE) => { let. _ = otherwise(env, (d1, d2) => BinOp(Float(op), d1, d2) |> rewrap) and. d1' = - req_value(req(state, env), d1 => BinOp1(Float(op), d1, d2), d1) + req_value( + req(state, env), + d1 => BinOp1(Float(op), d1, d2) |> wrap_ctx, + d1, + ) and. d2' = - req_value(req(state, env), d2 => BinOp2(Float(op), d1, d2), d2); + req_value( + req(state, env), + d2 => BinOp2(Float(op), d1, d2) |> wrap_ctx, + d2, + ); Step({ apply: () => switch (DHExp.term_of(d1'), DHExp.term_of(d2')) { @@ -474,9 +511,17 @@ module Transition = (EV: EV_MODE) => { let. _ = otherwise(env, (d1, d2) => BinOp(String(op), d1, d2) |> rewrap) and. d1' = - req_value(req(state, env), d1 => BinOp1(String(op), d1, d2), d1) + req_value( + req(state, env), + d1 => BinOp1(String(op), d1, d2) |> wrap_ctx, + d1, + ) and. d2' = - req_value(req(state, env), d2 => BinOp2(String(op), d1, d2), d2); + req_value( + req(state, env), + d2 => BinOp2(String(op), d1, d2) |> wrap_ctx, + d2, + ); Step({ apply: () => switch (DHExp.term_of(d1'), DHExp.term_of(d2')) { @@ -495,11 +540,16 @@ module Transition = (EV: EV_MODE) => { | Tuple(ds) => let. _ = otherwise(env, ds => Tuple(ds) |> rewrap) and. _ = - req_all_final(req(state, env), (d1, ds) => Tuple(d1, ds), ds); + req_all_final( + req(state, env), + (d1, ds) => Tuple(d1, ds) |> wrap_ctx, + ds, + ); Constructor; | Prj(d1, n) => let. _ = otherwise(env, d1 => Prj(d1, n) |> rewrap) - and. d1' = req_final(req(state, env), d1 => Prj(d1, n), d1); + and. d1' = + req_final(req(state, env), d1 => Prj(d1, n) |> wrap_ctx, d1); Step({ apply: () => { switch (DHExp.term_of(d1')) { @@ -520,8 +570,10 @@ module Transition = (EV: EV_MODE) => { // TODO(Matt): Can we do something cleverer when the list structure is complete but the contents aren't? | Cons(d1, d2) => let. _ = otherwise(env, (d1, d2) => Cons(d1, d2) |> rewrap) - and. d1' = req_final(req(state, env), d1 => Cons1(d1, d2), d1) - and. d2' = req_value(req(state, env), d2 => Cons2(d1, d2), d2); + and. d1' = + req_final(req(state, env), d1 => Cons1(d1, d2) |> wrap_ctx, d1) + and. d2' = + req_value(req(state, env), d2 => Cons2(d1, d2) |> wrap_ctx, d2); Step({ apply: () => switch (term_of(d2')) { @@ -535,8 +587,18 @@ module Transition = (EV: EV_MODE) => { | ListConcat(d1, d2) => // TODO(Matt): Can we do something cleverer when the list structure is complete but the contents aren't? let. _ = otherwise(env, (d1, d2) => ListConcat(d1, d2) |> rewrap) - and. d1' = req_value(req(state, env), d1 => ListConcat1(d1, d2), d1) - and. d2' = req_value(req(state, env), d2 => ListConcat2(d1, d2), d2); + and. d1' = + req_value( + req(state, env), + d1 => ListConcat1(d1, d2) |> wrap_ctx, + d1, + ) + and. d2' = + req_value( + req(state, env), + d2 => ListConcat2(d1, d2) |> wrap_ctx, + d2, + ); Step({ apply: () => switch (term_of(d1'), term_of(d2')) { @@ -555,7 +617,7 @@ module Transition = (EV: EV_MODE) => { and. _ = req_all_final( req(state, env), - (d1, ds) => ListLit(u, i, ty, d1, ds), + (d1, ds) => ListLit(u, i, ty, d1, ds) |> wrap_ctx, ds, ); Constructor; @@ -564,7 +626,7 @@ module Transition = (EV: EV_MODE) => { and. d1 = req_final( req(state, env), - d1 => MatchScrut(Consistent, d1, rules), + d1 => MatchScrut(Consistent, d1, rules) |> wrap_ctx, d1, ); let rec next_rule = ( @@ -591,14 +653,15 @@ module Transition = (EV: EV_MODE) => { Indet; | Closure(env', d) => let. _ = otherwise(env, d => Closure(env', d) |> rewrap) - and. d' = req_value(req(state, env'), d1 => Closure(env', d1), d); + and. d' = + req_value(req(state, env'), d1 => Closure(env', d1) |> wrap_ctx, d); Step({apply: () => d', kind: CompleteClosure, value: true}); | NonEmptyHole(reason, u, i, d1) => let. _ = otherwise(env, d1 => NonEmptyHole(reason, u, i, d1) |> rewrap) and. _ = req_final( req(state, env), - d1 => NonEmptyHole(reason, u, i, d1), + d1 => NonEmptyHole(reason, u, i, d1) |> wrap_ctx, d1, ); Indet; @@ -613,7 +676,8 @@ module Transition = (EV: EV_MODE) => { open CastHelpers; /* Cast calculus */ let. _ = otherwise(env, d => Cast(d, t1, t2) |> rewrap) - and. d' = req_final(req(state, env), d => Cast(d, t1, t2), d); + and. d' = + req_final(req(state, env), d => Cast(d, t1, t2) |> wrap_ctx, d); switch (ground_cases_of(t1), ground_cases_of(t2)) { | (Hole, Hole) | (Ground, Ground) => @@ -669,11 +733,17 @@ module Transition = (EV: EV_MODE) => { }; | FailedCast(d1, t1, t2) => let. _ = otherwise(env, d1 => FailedCast(d1, t1, t2) |> rewrap) - and. _ = req_final(req(state, env), d1 => FailedCast(d1, t1, t2), d1); + and. _ = + req_final( + req(state, env), + d1 => FailedCast(d1, t1, t2) |> wrap_ctx, + d1, + ); Indet; | Filter(f1, d1) => let. _ = otherwise(env, d1 => Filter(f1, d1) |> rewrap) - and. d1 = req_final(req(state, env), d1 => Filter(f1, d1), d1); + and. d1 = + req_final(req(state, env), d1 => Filter(f1, d1) |> wrap_ctx, d1); Step({apply: () => d1, kind: CompleteFilter, value: true}); }; }; diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index b882e74827..24b16e324e 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -112,6 +112,19 @@ let mk = d: DHExp.t, ) : DHDoc.t => { + let _ = print_endline("[mmpp] New Expression"); + let _ = print_endline(DHExp.show(d)); + let _ = print_int(List.length(hidden_steps)); + print_endline(""); + let _ = + List.map( + ((x, y)) => { + print_endline(Id.show(y)); + print_endline(show_step_kind(x.knd)); + }, + hidden_steps, + ); + let _ = print_endline("============"); let precedence = precedence(~show_casts=settings.show_casts); let rec go = ( From f53fede8bd663ac45129c272a725179c582e8283 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Tue, 20 Feb 2024 16:03:47 -0500 Subject: [PATCH 014/103] Remove ExpandingKeyword from dhexp --- src/haz3lcore/dynamics/DH.re | 12 +++--------- src/haz3lcore/dynamics/Elaborator.re | 1 - src/haz3lcore/dynamics/FilterMatcher.re | 1 - src/haz3lcore/dynamics/PatternMatch.re | 3 --- src/haz3lcore/dynamics/Substitution.re | 1 - src/haz3lcore/dynamics/Transition.re | 3 +-- src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 3 --- 7 files changed, 4 insertions(+), 20 deletions(-) diff --git a/src/haz3lcore/dynamics/DH.re b/src/haz3lcore/dynamics/DH.re index 3f63fff746..78e7c1d15d 100644 --- a/src/haz3lcore/dynamics/DH.re +++ b/src/haz3lcore/dynamics/DH.re @@ -16,9 +16,8 @@ module rec DHExp: { */ // TODO: Work out how to reconcile the invalids | EmptyHole - | NonEmptyHole(ErrStatus.HoleReason.t, MetaVar.t, HoleInstanceId.t, t) // TODO: Remove, use infomap - | ExpandingKeyword(MetaVar.t, HoleInstanceId.t, ExpandingKeyword.t) // TODO: Remove, use infomap - | FreeVar(MetaVar.t, HoleInstanceId.t, Var.t) // TODO: Remove, use infomap + | NonEmptyHole(ErrStatus.HoleReason.t, MetaVar.t, HoleInstanceId.t, t) // TODO: Remove, use infomap /// -------------------------------------------------------------------------------------------------------- + | FreeVar(MetaVar.t, HoleInstanceId.t, Var.t) // TODO: Remove, use infomap /// -------------------------------------------------------------------------------------------------------- | InvalidText(MetaVar.t, HoleInstanceId.t, string) // DONE [ALREADY] | InvalidOperation(t, InvalidOperationError.t) // Warning will robinson | FailedCast(t, Typ.t, Typ.t) // TODO: Add to TermBase @@ -77,7 +76,6 @@ module rec DHExp: { /* Hole types */ | EmptyHole | NonEmptyHole(ErrStatus.HoleReason.t, MetaVar.t, HoleInstanceId.t, t) - | ExpandingKeyword(MetaVar.t, HoleInstanceId.t, ExpandingKeyword.t) | FreeVar(MetaVar.t, HoleInstanceId.t, Var.t) | InvalidText(MetaVar.t, HoleInstanceId.t, string) | InvalidOperation(t, InvalidOperationError.t) @@ -173,7 +171,6 @@ module rec DHExp: { ( switch (term) { | EmptyHole - | ExpandingKeyword(_) | FreeVar(_) | InvalidText(_) | Var(_) @@ -252,7 +249,6 @@ module rec DHExp: { ) |> rewrap | EmptyHole as d - | ExpandingKeyword(_) as d | FreeVar(_) as d | InvalidText(_) as d | Var(_) as d @@ -367,8 +363,7 @@ module rec DHExp: { | (EmptyHole, EmptyHole) => true | (NonEmptyHole(reason1, u1, i1, d1), NonEmptyHole(reason2, u2, i2, d2)) => reason1 == reason2 && u1 == u2 && i1 == i2 && fast_equal(d1, d2) - | (ExpandingKeyword(u1, i1, kw1), ExpandingKeyword(u2, i2, kw2)) => - u1 == u2 && i1 == i2 && kw1 == kw2 + | (FreeVar(u1, i1, x1), FreeVar(u2, i2, x2)) => u1 == u2 && i1 == i2 && x1 == x2 | (InvalidText(u1, i1, text1), InvalidText(u2, i2, text2)) => @@ -377,7 +372,6 @@ module rec DHExp: { ClosureEnvironment.id_equal(sigma1, sigma2) && fast_equal(d1, d2) | (EmptyHole, _) | (NonEmptyHole(_), _) - | (ExpandingKeyword(_), _) | (FreeVar(_), _) | (InvalidText(_), _) | (Closure(_), _) => false diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 9b5fef94ba..7fa45d1b53 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -96,7 +96,6 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => /* Hole-like forms: Don't cast */ | InvalidText(_) | FreeVar(_) - | ExpandingKeyword(_) | EmptyHole | NonEmptyHole(_) => d /* DHExp-specific forms: Don't cast */ diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index bcda716134..c74c0ca4d9 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -176,7 +176,6 @@ let rec matches_exp = | (Match(_), _) => false | (NonEmptyHole(_), _) => false - | (ExpandingKeyword(_), _) => false | (InvalidText(_), _) => false | (InvalidOperation(_), _) => false diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index 54337c34ce..dc94f754e7 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -241,7 +241,6 @@ and matches_cast_Sum = | Cast(d', Unknown(_), Sum(_) | Rec(_, Sum(_))) => matches_cast_Sum(ctr, dp, d', castmaps) | FreeVar(_) - | ExpandingKeyword(_) | InvalidText(_) | Let(_) | ApBuiltin(_) @@ -330,7 +329,6 @@ and matches_cast_Tuple = | Var(_) => DoesNotMatch | FreeVar(_) => IndetMatch | InvalidText(_) => IndetMatch - | ExpandingKeyword(_) => IndetMatch | Let(_, _, _) => IndetMatch | FixF(_, _, _) => DoesNotMatch | Fun(_, _, _, _, _) => DoesNotMatch @@ -465,7 +463,6 @@ and matches_cast_Cons = | Var(_) => DoesNotMatch | FreeVar(_) => IndetMatch | InvalidText(_) => IndetMatch - | ExpandingKeyword(_) => IndetMatch | Let(_, _, _) => IndetMatch | FixF(_, _, _) => DoesNotMatch | Fun(_, _, _, _, _) => DoesNotMatch diff --git a/src/haz3lcore/dynamics/Substitution.re b/src/haz3lcore/dynamics/Substitution.re index 8f3f43cbbb..cc0b486512 100644 --- a/src/haz3lcore/dynamics/Substitution.re +++ b/src/haz3lcore/dynamics/Substitution.re @@ -10,7 +10,6 @@ let rec subst_var = (d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => { } | FreeVar(_) => d2 | InvalidText(_) => d2 - | ExpandingKeyword(_) => d2 | Seq(d3, d4) => let d3 = subst_var(d1, x, d3); let d4 = subst_var(d1, x, d4); diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index 8cf86f9065..63759beed0 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -668,8 +668,7 @@ module Transition = (EV: EV_MODE) => { | EmptyHole | FreeVar(_) | InvalidText(_) - | InvalidOperation(_) - | ExpandingKeyword(_) => + | InvalidOperation(_) => let. _ = otherwise(env, d); Indet; | Cast(d, t1, t2) => diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index 24b16e324e..6da38ecf2f 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -48,7 +48,6 @@ let rec precedence = (~show_casts: bool, d: DHExp.t) => { | Var(_) | FreeVar(_) | InvalidText(_) - | ExpandingKeyword(_) | Bool(_) | Int(_) | Seq(_) @@ -286,8 +285,6 @@ let mk = ) | NonEmptyHole(reason, u, i, d') => go'(d') |> annot(DHAnnot.NonEmptyHole(reason, (u, i))) - | ExpandingKeyword(u, i, k) => - DHDoc_common.mk_ExpandingKeyword((u, i), k) | FreeVar(u, i, x) => text(x) |> annot(DHAnnot.VarHole(Free, (u, i))) | InvalidText(u, i, t) => DHDoc_common.mk_InvalidText(t, (u, i)) From a6be94f69b03c7a5106be896b27b98271dba7107 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 22 Feb 2024 11:05:43 -0500 Subject: [PATCH 015/103] thread info_map through dynamics --- src/haz3lcore/dynamics/DH.re | 11 +- src/haz3lcore/dynamics/Elaborator.re | 8 ++ src/haz3lcore/dynamics/Evaluator.re | 9 +- src/haz3lcore/dynamics/Evaluator.rei | 3 +- src/haz3lcore/dynamics/EvaluatorState.re | 11 +- src/haz3lcore/dynamics/EvaluatorState.rei | 6 +- src/haz3lcore/dynamics/EvaluatorStep.re | 17 ++- src/haz3lcore/dynamics/FilterMatcher.re | 29 ++-- src/haz3lcore/dynamics/Stepper.re | 135 ++++++++++++------- src/haz3lcore/dynamics/Transition.re | 20 +++ src/haz3lcore/dynamics/ValueChecker.re | 22 +-- src/haz3lcore/prog/Interface.re | 10 +- src/haz3lcore/prog/ModelResult.re | 6 +- src/haz3lcore/prog/ModelResults.re | 7 +- src/haz3lcore/prog/ProgramResult.re | 2 +- src/haz3lcore/statics/Statics.re | 17 +++ src/haz3lcore/zipper/action/Indicated.re | 2 +- src/haz3lschool/Exercise.re | 8 +- src/haz3lweb/Editors.re | 6 +- src/haz3lweb/view/Cell.re | 3 +- src/haz3lweb/view/Deco.re | 2 +- src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 23 ++-- 22 files changed, 245 insertions(+), 112 deletions(-) diff --git a/src/haz3lcore/dynamics/DH.re b/src/haz3lcore/dynamics/DH.re index 78e7c1d15d..ec03356d44 100644 --- a/src/haz3lcore/dynamics/DH.re +++ b/src/haz3lcore/dynamics/DH.re @@ -16,8 +16,8 @@ module rec DHExp: { */ // TODO: Work out how to reconcile the invalids | EmptyHole - | NonEmptyHole(ErrStatus.HoleReason.t, MetaVar.t, HoleInstanceId.t, t) // TODO: Remove, use infomap /// -------------------------------------------------------------------------------------------------------- - | FreeVar(MetaVar.t, HoleInstanceId.t, Var.t) // TODO: Remove, use infomap /// -------------------------------------------------------------------------------------------------------- + | NonEmptyHole(ErrStatus.HoleReason.t, MetaVar.t, HoleInstanceId.t, t) // TODO: Remove, use info_map /// -------------------------------------------------------------------------------------------------------- + | FreeVar(MetaVar.t, HoleInstanceId.t, Var.t) // TODO: Remove, use info_map /// -------------------------------------------------------------------------------------------------------- | InvalidText(MetaVar.t, HoleInstanceId.t, string) // DONE [ALREADY] | InvalidOperation(t, InvalidOperationError.t) // Warning will robinson | FailedCast(t, Typ.t, Typ.t) // TODO: Add to TermBase @@ -33,7 +33,7 @@ module rec DHExp: { t, [@show.opaque] option(ClosureEnvironment.t), option(Var.t), - ) // TODO: Use infomap for Typ.t + ) // TODO: Use info_map for Typ.t | Ap(TermBase.UExp.ap_direction, t, t) // TODO: Add reverse application | ApBuiltin(string, t) // DONE [TO ADD TO UEXP] TODO: Add a loooong comment here | BuiltinFun(string) // DONE [TO ADD TO UEXP] @@ -43,7 +43,7 @@ module rec DHExp: { | Float(float) // DONE | String(string) // DONE | BinOp(TermBase.UExp.op_bin, t, t) // DONE - | ListLit(MetaVar.t, MetaVarInst.t, Typ.t, list(t)) // TODO: afaict the first three arguments here are never used? 3rd one might be infomap + | ListLit(MetaVar.t, MetaVarInst.t, Typ.t, list(t)) // TODO: afaict the first three arguments here are never used? 3rd one might be info_map | Cons(t, t) // DONE [ALREADY] | ListConcat(t, t) // DONE [ALREADY] | Tuple(list(t)) // DONE [ALREADY] @@ -158,10 +158,7 @@ module rec DHExp: { ids: child_require ? { - print_endline("copied!"); let id = Id.mk(); - print_endline(Id.show(id)); - print_endline(Id.show(List.hd(d.ids))); [id]; } : d.ids, diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 7fa45d1b53..d434f82f54 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -1,6 +1,14 @@ open Util; open OptUtil.Syntax; +module Elaboration = { + [@deriving (show({with_path: false}), sexp, yojson)] + type t = { + d: DHExp.t, + info_map: Statics.Map.t, + }; +}; + module ElaborationResult = { [@deriving sexp] type t = diff --git a/src/haz3lcore/dynamics/Evaluator.re b/src/haz3lcore/dynamics/Evaluator.re index 29481365b1..d4da3132f4 100644 --- a/src/haz3lcore/dynamics/Evaluator.re +++ b/src/haz3lcore/dynamics/Evaluator.re @@ -34,6 +34,11 @@ module EvaluatorEVMode: { let update_test = (state, id, v) => state := EvaluatorState.add_test(state^, id, v); + let get_info_map = (state: state) => EvaluatorState.get_info_map(state^); + + let set_info_map = (info_map: Statics.Map.t, state: state) => + state := EvaluatorState.put_info_map(info_map, state^); + type result_unfinished = | BoxedValue(DHExp.t) | Indet(DHExp.t) @@ -106,8 +111,8 @@ let rec evaluate = (state, env, d) => { }; }; -let evaluate = (env, d): (EvaluatorState.t, EvaluatorResult.t) => { - let state = ref(EvaluatorState.init); +let evaluate = (env, {d, info_map}: Elaborator.Elaboration.t) => { + let state = ref(EvaluatorState.init(info_map)); let env = ClosureEnvironment.of_environment(env); let result = evaluate(state, env, d); let result = diff --git a/src/haz3lcore/dynamics/Evaluator.rei b/src/haz3lcore/dynamics/Evaluator.rei index 0589b7fe3f..e505c371af 100644 --- a/src/haz3lcore/dynamics/Evaluator.rei +++ b/src/haz3lcore/dynamics/Evaluator.rei @@ -6,7 +6,8 @@ open Transition; let evaluate: - (Environment.t, DHExp.t) => (EvaluatorState.t, EvaluatorResult.t); + (Environment.t, Elaborator.Elaboration.t) => + (EvaluatorState.t, EvaluatorResult.t); module EvaluatorEVMode: { type result_unfinished = diff --git a/src/haz3lcore/dynamics/EvaluatorState.re b/src/haz3lcore/dynamics/EvaluatorState.re index bb85612d05..0c83c0047c 100644 --- a/src/haz3lcore/dynamics/EvaluatorState.re +++ b/src/haz3lcore/dynamics/EvaluatorState.re @@ -2,9 +2,14 @@ type t = { stats: EvaluatorStats.t, tests: TestMap.t, + info_map: Statics.Map.t, }; -let init = {stats: EvaluatorStats.initial, tests: TestMap.empty}; +let init = info_map => { + stats: EvaluatorStats.initial, + tests: TestMap.empty, + info_map, +}; let take_step = ({stats, _} as es) => { ...es, @@ -23,3 +28,7 @@ let add_test = ({tests, _} as es, id, report) => { let get_tests = ({tests, _}) => tests; let put_tests = (tests, es) => {...es, tests}; + +let get_info_map = ({info_map, _}) => info_map; + +let put_info_map = (info_map, es) => {...es, info_map}; diff --git a/src/haz3lcore/dynamics/EvaluatorState.rei b/src/haz3lcore/dynamics/EvaluatorState.rei index e699190314..fc17591573 100644 --- a/src/haz3lcore/dynamics/EvaluatorState.rei +++ b/src/haz3lcore/dynamics/EvaluatorState.rei @@ -14,7 +14,7 @@ type t; /** [init] is the initial state. */ -let init: t; +let init: Statics.Map.t => t; /** [take_step es] is [es] with the updated step count. @@ -33,3 +33,7 @@ let add_test: (t, KeywordID.t, TestMap.instance_report) => t; let get_tests: t => TestMap.t; let put_tests: (TestMap.t, t) => t; + +let get_info_map: t => Statics.Map.t; + +let put_info_map: (Statics.Map.t, t) => t; diff --git a/src/haz3lcore/dynamics/EvaluatorStep.re b/src/haz3lcore/dynamics/EvaluatorStep.re index 23d7934eea..dac1118036 100644 --- a/src/haz3lcore/dynamics/EvaluatorStep.re +++ b/src/haz3lcore/dynamics/EvaluatorStep.re @@ -139,6 +139,10 @@ module Decompose = { let otherwise = (env, o) => (o, Result.BoxedValue, env, ()); let update_test = (state, id, v) => state := EvaluatorState.add_test(state^, id, v); + let get_info_map = (state: state) => EvaluatorState.get_info_map(state^); + + let set_info_map = (info_map: Statics.Map.t, state: state) => + state := EvaluatorState.put_info_map(info_map, state^); }; module Decomp = Transition(DecomposeEVMode); @@ -195,6 +199,10 @@ module TakeStep = { let update_test = (state, id, v) => state := EvaluatorState.add_test(state^, id, v); + let get_info_map = (state: state) => EvaluatorState.get_info_map(state^); + + let set_info_map = (info_map: Statics.Map.t, state: state) => + state := EvaluatorState.put_info_map(info_map, state^); }; module TakeStepEV = Transition(TakeStepEVMode); @@ -205,17 +213,16 @@ module TakeStep = { let take_step = TakeStep.take_step; -let decompose = (d: DHExp.t) => { - let es = EvaluatorState.init; +let decompose = (d: DHExp.t, es: EvaluatorState.t) => { let env = ClosureEnvironment.of_environment(Builtins.env_init); let rs = Decompose.decompose(ref(es), env, d); Decompose.Result.unbox(rs); }; -let evaluate_with_history = d => { - let state = ref(EvaluatorState.init); +let evaluate_with_history = (d, info_map) => { + let state = ref(EvaluatorState.init(info_map)); let rec go = d => - switch (decompose(d)) { + switch (decompose(d, state^)) { | [] => [] | [x, ..._] => switch (take_step(state, x.env, x.d_loc)) { diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index c74c0ca4d9..8c48bed566 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -1,5 +1,12 @@ let rec matches_exp = - (env: ClosureEnvironment.t, d: DHExp.t, f: DHExp.t): bool => { + ( + info_map: Statics.Map.t, + env: ClosureEnvironment.t, + d: DHExp.t, + f: DHExp.t, + ) + : bool => { + let matches_exp = matches_exp(info_map); switch (DHExp.term_of(d), DHExp.term_of(f)) { | (Constructor("$e"), _) => failwith("$e in matched expression") | (Constructor("$v"), _) => failwith("$v in matched expression") @@ -27,7 +34,7 @@ let rec matches_exp = ) | (_, Constructor("$v")) => - switch (ValueChecker.check_value(env, d)) { + switch (ValueChecker.check_value(info_map, env, d)) { | Indet | Value => true | Expr => false @@ -236,28 +243,34 @@ and matches_pat = (d: DHPat.t, f: DHPat.t): bool => { and matches_typ = (d: Typ.t, f: Typ.t) => { Typ.eq(d, f); } -and matches_rul = (env, (dp, d), (fp, f)) => { - matches_pat(dp, fp) && matches_exp(env, d, f); +and matches_rul = (info_map, env, (dp, d), (fp, f)) => { + matches_pat(dp, fp) && matches_exp(info_map, env, d, f); }; let matches = - (~env: ClosureEnvironment.t, ~exp: DHExp.t, ~flt: Filter.t) + (info_map, ~env: ClosureEnvironment.t, ~exp: DHExp.t, ~flt: Filter.t) : option(FilterAction.t) => - if (matches_exp(env, exp, flt.pat)) { + if (matches_exp(info_map, env, exp, flt.pat)) { Some(flt.act); } else { None; }; let matches = - (~env: ClosureEnvironment.t, ~exp: DHExp.t, ~act: FilterAction.t, flt_env) + ( + ~env: ClosureEnvironment.t, + ~exp: DHExp.t, + ~exp_info_map: Statics.Map.t, + ~act: FilterAction.t, + flt_env, + ) : (FilterAction.t, int) => { let len = List.length(flt_env); let rec matches' = (~env, ~exp, ~act, flt_env, idx) => { switch (flt_env) { | [] => (act, idx) | [hd, ...tl] => - switch (matches(~env, ~exp, ~flt=hd)) { + switch (matches(exp_info_map, ~env, ~exp, ~flt=hd)) { | Some(act) => (act, idx) | None => matches'(~env, ~exp, ~act, tl, idx + 1) } diff --git a/src/haz3lcore/dynamics/Stepper.re b/src/haz3lcore/dynamics/Stepper.re index 130a83e77d..c794bd72e8 100644 --- a/src/haz3lcore/dynamics/Stepper.re +++ b/src/haz3lcore/dynamics/Stepper.re @@ -28,13 +28,15 @@ let rec matches = flt: FilterEnvironment.t, ctx: EvalCtx.t, exp: DHExp.t, + exp_info_map: Statics.Map.t, act: FilterAction.t, idx: int, ) : (FilterAction.t, int, EvalCtx.t) => { let composed = EvalCtx.compose(ctx, exp); let (pact, pidx) = (act, idx); - let (mact, midx) = FilterMatcher.matches(~env, ~exp=composed, ~act, flt); + let (mact, midx) = + FilterMatcher.matches(~env, ~exp=composed, ~exp_info_map, ~act, flt); let (act, idx) = switch (ctx) { | Term({term: Filter(_, _), _}) => (pact, pidx) @@ -51,103 +53,112 @@ let rec matches = let rewrap = term => EvalCtx.Term({term, ids}); switch ((term: EvalCtx.term)) { | Closure(env, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); + let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); Closure(env, ctx) |> rewrap; | Filter(Filter(flt'), ctx) => let flt = flt |> FilterEnvironment.extends(flt'); - let+ ctx = matches(env, flt, ctx, exp, act, idx); + let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); Filter(Filter(flt'), ctx) |> rewrap; | Filter(Residue(idx, act), ctx) => - let (ract, ridx, rctx) = matches(env, flt, ctx, exp, act, idx); + let (ract, ridx, rctx) = + matches(env, flt, ctx, exp, exp_info_map, act, idx); if (ridx == idx && ract |> snd == All) { (ract, ridx, Filter(Residue(idx, act), rctx) |> rewrap); } else { (ract, ridx, rctx); }; | Seq1(ctx, d2) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); + let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); Seq1(ctx, d2) |> rewrap; | Seq2(d1, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); + let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); Seq2(d1, ctx) |> rewrap; | Let1(d1, ctx, d3) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); + let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); Let1(d1, ctx, d3) |> rewrap; | Let2(d1, d2, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); + let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); Let2(d1, d2, ctx) |> rewrap; | Fun(dp, ty, ctx, env', name) => let+ ctx = - matches(Option.value(~default=env, env'), flt, ctx, exp, act, idx); + matches( + Option.value(~default=env, env'), + flt, + ctx, + exp, + exp_info_map, + act, + idx, + ); Fun(dp, ty, ctx, env', name) |> rewrap; | FixF(name, ty, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); + let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); FixF(name, ty, ctx) |> rewrap; | Ap1(dir, ctx, d2) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); + let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); Ap1(dir, ctx, d2) |> rewrap; | Ap2(dir, d1, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); + let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); Ap2(dir, d1, ctx) |> rewrap; | If1(c, ctx, d2, d3) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); + let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); If1(c, ctx, d2, d3) |> rewrap; | If2(c, d1, ctx, d3) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); + let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); If2(c, d1, ctx, d3) |> rewrap; | If3(c, d1, d2, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); + let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); If3(c, d1, d2, ctx) |> rewrap; | BinOp1(op, ctx, d1) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); + let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); BinOp1(op, ctx, d1) |> rewrap; | BinOp2(op, d1, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); + let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); BinOp2(op, d1, ctx) |> rewrap; | Tuple(ctx, ds) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); + let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); Tuple(ctx, ds) |> rewrap; | ApBuiltin(name, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); + let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); ApBuiltin(name, ctx) |> rewrap; | Test(id, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); + let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); Test(id, ctx) |> rewrap; | ListLit(u, i, ty, ctx, ds) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); + let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); ListLit(u, i, ty, ctx, ds) |> rewrap; | Cons1(ctx, d2) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); + let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); Cons1(ctx, d2) |> rewrap; | Cons2(d1, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); + let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); Cons2(d1, ctx) |> rewrap; | ListConcat1(ctx, d2) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); + let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); ListConcat1(ctx, d2) |> rewrap; | ListConcat2(d1, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); + let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); ListConcat2(d1, ctx) |> rewrap; | Prj(ctx, n) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); + let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); Prj(ctx, n) |> rewrap; | NonEmptyHole(e, u, i, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); + let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); NonEmptyHole(e, u, i, ctx) |> rewrap; | Cast(ctx, ty, ty') => - let+ ctx = matches(env, flt, ctx, exp, act, idx); + let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); Cast(ctx, ty, ty') |> rewrap; | FailedCast(ctx, ty, ty') => - let+ ctx = matches(env, flt, ctx, exp, act, idx); + let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); FailedCast(ctx, ty, ty') |> rewrap; | InvalidOperation(ctx, error) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); + let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); InvalidOperation(ctx, error) |> rewrap; | MatchScrut(c, ctx, rs) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); + let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); MatchScrut(c, ctx, rs) |> rewrap; | MatchRule(c, scr, p, ctx, rs) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); + let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); MatchRule(c, scr, p, ctx, rs) |> rewrap; }; }; @@ -163,12 +174,20 @@ let rec matches = }; let should_hide_eval_obj = - (~settings, x: EvalObj.t): (FilterAction.action, EvalObj.t) => + (~settings, ~info_map, x: EvalObj.t): (FilterAction.action, EvalObj.t) => if (should_hide_step(~settings, x.knd)) { (Eval, x); } else { let (act, _, ctx) = - matches(ClosureEnvironment.empty, [], x.ctx, x.d_loc, (Step, One), 0); + matches( + ClosureEnvironment.empty, + [], + x.ctx, + x.d_loc, + info_map, + (Step, One), + 0, + ); switch (act) { | (Eval, _) => (Eval, {...x, ctx}) | (Step, _) => (Step, {...x, ctx}) @@ -180,28 +199,45 @@ let should_hide_step = (~settings, x: step): (FilterAction.action, step) => (Eval, x); } else { let (act, _, ctx) = - matches(ClosureEnvironment.empty, [], x.ctx, x.d_loc, (Step, One), 0); + matches( + ClosureEnvironment.empty, + [], + x.ctx, + x.d_loc, + EvaluatorState.get_info_map(x.state), + (Step, One), + 0, + ); switch (act) { | (Eval, _) => (Eval, {...x, ctx}) | (Step, _) => (Step, {...x, ctx}) }; }; -let get_elab = ({history, _}: t) => Aba.last_a(history) |> fst; +let get_elab = ({history, _}: t): Elaborator.Elaboration.t => { + let (d, st) = Aba.last_a(history); + {d, info_map: EvaluatorState.get_info_map(st)}; +}; + +let get_elab_info_map = ({history, _}: t) => + Aba.last_a(history) |> snd |> EvaluatorState.get_info_map; let get_next_steps = s => s.next_options; -let current_expr = ({history, _}: t) => Aba.hd(history); +let current_expr = ({history, _}: t) => Aba.hd(history) |> fst; + +let current_state = ({history, _}: t) => Aba.hd(history) |> snd; let step_pending = (idx: int, stepper: t) => { ...stepper, stepper_state: StepPending(idx), }; -let init = (elab: DHExp.t) => { +let init = ({d, info_map}: Elaborator.Elaboration.t) => { + let state = EvaluatorState.init(info_map); { - history: Aba.singleton((elab, EvaluatorState.init)), - next_options: decompose(elab), + history: Aba.singleton((d, state)), + next_options: decompose(d, state), stepper_state: StepperReady, }; }; @@ -211,7 +247,14 @@ let rec evaluate_pending = (~settings, s: t) => { | StepperDone | StepTimeout(_) => s | StepperReady => - let next' = s.next_options |> List.map(should_hide_eval_obj(~settings)); + let next' = + s.next_options + |> List.map( + should_hide_eval_obj( + ~settings, + ~info_map=EvaluatorState.get_info_map(current_state(s)), + ), + ); let next'' = List.mapi((i, x) => (i, x), next'); switch ( List.find_opt(((_, (act, _))) => act == FilterAction.Eval, next'') @@ -241,10 +284,11 @@ let rec evaluate_pending = (~settings, s: t) => { knd: eo.knd, state, }; + let new_state = state_ref^; { - history: s.history |> Aba.cons((d', state_ref^), new_step), + history: s.history |> Aba.cons((d', new_state), new_step), stepper_state: StepperReady, - next_options: decompose(d'), + next_options: decompose(d', new_state), } |> evaluate_pending(~settings); }; @@ -283,7 +327,7 @@ let step_backward = (~settings, s: t) => { |> Option.value(~default=s.history); { history: h', - next_options: decompose(Aba.hd(h') |> fst), + next_options: decompose(Aba.hd(h') |> fst, Aba.hd(h') |> snd), stepper_state: StepperDone, }; }; @@ -397,7 +441,8 @@ let from_persistent: persistent => t = ({history}) => { { history, - next_options: decompose(Aba.hd(history) |> fst), + next_options: + decompose(Aba.hd(history) |> fst, Aba.hd(history) |> snd), stepper_state: StepperDone, }; }; diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index 63759beed0..3f44aa1f27 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -180,6 +180,9 @@ module type EV_MODE = { let otherwise: (ClosureEnvironment.t, 'a) => requirements(unit, 'a); let update_test: (state, KeywordID.t, TestMap.instance_report) => unit; + + let get_info_map: state => Statics.Map.t; + let set_info_map: (Statics.Map.t, state) => unit; }; module Transition = (EV: EV_MODE) => { @@ -197,8 +200,25 @@ module Transition = (EV: EV_MODE) => { children change, we use rewrap */ let transition = (req, state, env, d): 'a => { + // If there is an error at this location, swap out the rule for indet. + let info_map = get_info_map(state); + let err_info = Statics.get_error_at(info_map, DHExp.rep_id(d)); + let (let.) = + switch (err_info) { + | Some(FreeVariable(_) | Common(NoType(_) | Inconsistent(_))) => ( + (x, _) => { + let. _ = x; + Indet; + } + ) + | None => (let.) + }; + + // Split DHExp into term and id information let (term, rewrap) = DHExp.unwrap(d); let wrap_ctx = (term): EvalCtx.t => Term({term, ids: [rep_id(d)]}); + + // Transition rules switch (term) { | Var(x) => let. _ = otherwise(env, Var(x) |> rewrap); diff --git a/src/haz3lcore/dynamics/ValueChecker.re b/src/haz3lcore/dynamics/ValueChecker.re index 8975c48bbe..b9feb99509 100644 --- a/src/haz3lcore/dynamics/ValueChecker.re +++ b/src/haz3lcore/dynamics/ValueChecker.re @@ -8,9 +8,9 @@ type t = | Expr; module ValueCheckerEVMode: { - include EV_MODE with type result = t and type state = unit; + include EV_MODE with type result = t and type state = Statics.Map.t; } = { - type state = unit; + type state = Statics.Map.t; type result = t; type requirement('a) = ('a, (result, bool)); @@ -71,20 +71,22 @@ module ValueCheckerEVMode: { ((v1, v2), combine(r1, r2)); }; - let update_test = ((), _, _) => (); + let update_test = (_, _, _) => (); + let get_info_map = (info_map: state) => info_map; + + let set_info_map = (_, _) => (); }; module CV = Transition(ValueCheckerEVMode); -let rec check_value = ((), env, d) => CV.transition(check_value, (), env, d); - -let check_value = check_value(); +let rec check_value = (state, env, d) => + CV.transition(check_value, state, env, d); -let rec check_value_mod_ctx = ((), env, d) => +let rec check_value_mod_ctx = (info_map: Statics.Map.t, env, d) => switch (DHExp.term_of(d)) { | Var(x) => check_value_mod_ctx( - (), + info_map, env, ClosureEnvironment.lookup(env, x) |> OptUtil.get(() => { @@ -92,7 +94,5 @@ let rec check_value_mod_ctx = ((), env, d) => raise(EvaluatorError.Exception(FreeInvalidVar(x))); }), ) - | _ => CV.transition(check_value_mod_ctx, (), env, d) + | _ => CV.transition(check_value_mod_ctx, info_map, env, d) }; - -let check_value_mod_ctx = check_value_mod_ctx(); diff --git a/src/haz3lcore/prog/Interface.re b/src/haz3lcore/prog/Interface.re index d74fe46f62..b47008640b 100644 --- a/src/haz3lcore/prog/Interface.re +++ b/src/haz3lcore/prog/Interface.re @@ -1,3 +1,5 @@ +module CoreStatics = Statics; + module Statics = { let mk_map' = Core.Memo.general(~cache_size_bound=1000, e => { @@ -51,7 +53,11 @@ let elaborate = (~settings: CoreSettings.t, map, term): DHExp.t => }; let evaluate = - (~settings: CoreSettings.t, ~env=Builtins.env_init, elab: DHExp.t) + ( + ~settings: CoreSettings.t, + ~env=Builtins.env_init, + elab: Elaborator.Elaboration.t, + ) : ProgramResult.t => switch () { | _ when !settings.dynamics => Off(elab) @@ -78,5 +84,5 @@ let eval_z = let (term, _) = MakeTerm.from_zip_for_sem(z); let info_map = Statics.mk_map_ctx(settings, ctx_init, term); let d = elaborate(~settings, info_map, term); - evaluate(~settings, ~env=env_init, d); + evaluate(~settings, ~env=env_init, {d, info_map}); }; diff --git a/src/haz3lcore/prog/ModelResult.re b/src/haz3lcore/prog/ModelResult.re index 13ce25714c..25cee41b13 100644 --- a/src/haz3lcore/prog/ModelResult.re +++ b/src/haz3lcore/prog/ModelResult.re @@ -1,6 +1,6 @@ [@deriving (show({with_path: false}), sexp, yojson)] type eval_result = { - elab: DHExp.t, + elab: Elaborator.Elaboration.t, evaluation: ProgramResult.t, previous: ProgramResult.t, }; @@ -11,7 +11,7 @@ type t = | Evaluation(eval_result) | Stepper(Stepper.t); -let init_eval = elab => +let init_eval = (elab: Elaborator.Elaboration.t) => Evaluation({elab, evaluation: ResultPending, previous: ResultPending}); let update_elab = elab => @@ -20,7 +20,7 @@ let update_elab = elab => Evaluation({elab, evaluation: ResultPending, previous: ResultPending}) | Evaluation({evaluation, _}) => Evaluation({elab, evaluation: ResultPending, previous: evaluation}) - | Stepper(s) as s' when DHExp.fast_equal(elab, Stepper.get_elab(s)) => s' + | Stepper(s) as s' when DHExp.fast_equal(elab.d, Stepper.get_elab(s).d) => s' | Stepper(_) => Stepper(Stepper.init(elab)); let update_stepper = f => diff --git a/src/haz3lcore/prog/ModelResults.re b/src/haz3lcore/prog/ModelResults.re index ae54a9729d..7cf914f8b9 100644 --- a/src/haz3lcore/prog/ModelResults.re +++ b/src/haz3lcore/prog/ModelResults.re @@ -19,7 +19,7 @@ include M; [@deriving (show({with_path: false}), sexp, yojson)] type t = M.t(ModelResult.t); -let init_eval = (ds: list((Key.t, DHExp.t))): t => +let init_eval = (ds: list((Key.t, Elaborator.Elaboration.t))): t => ds |> List.to_seq |> of_seq |> map(ModelResult.init_eval); let lookup = (results: t, key: Key.t) => find_opt(key, results); @@ -29,7 +29,7 @@ let run_pending = (~settings) => M.map(ModelResult.run_pending(~settings)); let timeout_all = map(ModelResult.timeout); let advance_evaluator_result = - (results: t, (key: Key.t, elab: DHExp.t)) + (results: t, (key: Key.t, elab: Elaborator.Elaboration.t)) : option((Key.t, ModelResult.t)) => switch (lookup(results, key)) { | Some(Stepper(_)) => None @@ -50,7 +50,8 @@ let stepper_result_opt = | _ => None }; -let to_evaluate = (results: t, elabs: list((Key.t, DHExp.t))): t => +let to_evaluate = + (results: t, elabs: list((Key.t, Elaborator.Elaboration.t))): t => elabs |> List.filter_map(advance_evaluator_result(results)) |> List.to_seq diff --git a/src/haz3lcore/prog/ProgramResult.re b/src/haz3lcore/prog/ProgramResult.re index a8e0eb4415..0b57d2558f 100644 --- a/src/haz3lcore/prog/ProgramResult.re +++ b/src/haz3lcore/prog/ProgramResult.re @@ -19,7 +19,7 @@ type error = [@deriving (show({with_path: false}), sexp, yojson)] type t = - | Off(DHExp.t) //elab + | Off(Elaborator.Elaboration.t) | ResultOk(inner) | ResultFail(error) | ResultPending; diff --git a/src/haz3lcore/statics/Statics.re b/src/haz3lcore/statics/Statics.re index 7334e2c42c..8080e39122 100644 --- a/src/haz3lcore/statics/Statics.re +++ b/src/haz3lcore/statics/Statics.re @@ -628,6 +628,23 @@ and variant_to_info_map = }; }; +let get_error_at = (info_map: Map.t, id: Id.t) => { + id + |> Id.Map.find_opt(_, info_map) + |> Option.bind( + _, + fun + | InfoExp(e) => Some(e) + | _ => None, + ) + |> Option.bind(_, e => + switch (e.status) { + | InHole(err_info) => Some(err_info) + | NotInHole(_) => None + } + ); +}; + let collect_errors = (map: Map.t): list((Id.t, Info.error)) => Id.Map.fold( (id, info: Info.t, acc) => diff --git a/src/haz3lcore/zipper/action/Indicated.re b/src/haz3lcore/zipper/action/Indicated.re index 3df1f3cb5c..6f36235746 100644 --- a/src/haz3lcore/zipper/action/Indicated.re +++ b/src/haz3lcore/zipper/action/Indicated.re @@ -95,7 +95,7 @@ let index = (z: Zipper.t): option(Id.t) => let ci_of = (z: Zipper.t, info_map: Statics.Map.t): option(Statics.Info.t) => /* This version takes into accounts Secondary, while accounting for the - * fact that Secondary is not currently added to the infomap. First we + * fact that Secondary is not currently added to the info_map. First we * try the basic indication function, specifying that we do not want * Secondary. But if this doesn't succeed, then we create a 'virtual' * info map entry representing the Secondary notation, which takes on diff --git a/src/haz3lschool/Exercise.re b/src/haz3lschool/Exercise.re index 86fdd4ce99..ab95b6ead2 100644 --- a/src/haz3lschool/Exercise.re +++ b/src/haz3lschool/Exercise.re @@ -704,7 +704,7 @@ module F = (ExerciseEnv: ExerciseEnv) => { let spliced_elabs = (settings: CoreSettings.t, state: state) - : list((ModelResults.key, DHExp.t)) => { + : list((ModelResults.key, Elaborator.Elaboration.t)) => { let { test_validation, user_impl, @@ -715,8 +715,10 @@ module F = (ExerciseEnv: ExerciseEnv) => { hidden_tests, } = stitch_static(settings, stitch_term(state)); - let elab = (s: CachedStatics.statics) => - Interface.elaborate(~settings, s.info_map, s.term); + let elab = (s: CachedStatics.statics): Elaborator.Elaboration.t => { + d: Interface.elaborate(~settings, s.info_map, s.term), + info_map: s.info_map, + }; [ (test_validation_key, elab(test_validation)), (user_impl_key, elab(user_impl)), diff --git a/src/haz3lweb/Editors.re b/src/haz3lweb/Editors.re index 95a1d81dbe..318e1c428f 100644 --- a/src/haz3lweb/Editors.re +++ b/src/haz3lweb/Editors.re @@ -98,20 +98,20 @@ let lookup_statics = Used in the Update module */ let get_spliced_elabs = (~settings: Settings.t, statics, editors: t) - : list((ModelResults.key, DHExp.t)) => + : list((ModelResults.key, Elaborator.Elaboration.t)) => switch (editors) { | Scratch(idx, _) => let key = ScratchSlide.scratch_key(idx |> string_of_int); let CachedStatics.{term, info_map, _} = lookup_statics(~settings, ~statics, editors); let d = Interface.elaborate(~settings=settings.core, info_map, term); - [(key, d)]; + [(key, {d, info_map})]; | Documentation(name, _) => let key = ScratchSlide.scratch_key(name); let CachedStatics.{term, info_map, _} = lookup_statics(~settings, ~statics, editors); let d = Interface.elaborate(~settings=settings.core, info_map, term); - [(key, d)]; + [(key, {d, info_map})]; | Exercises(_, _, exercise) => Exercise.spliced_elabs(settings.core, exercise) }; diff --git a/src/haz3lweb/view/Cell.re b/src/haz3lweb/view/Cell.re index a607256cbc..55f5e6f4bd 100644 --- a/src/haz3lweb/view/Cell.re +++ b/src/haz3lweb/view/Cell.re @@ -180,7 +180,7 @@ let live_eval = switch (result.evaluation, result.previous) { | (ResultOk(res), _) => ProgramResult.get_dhexp(res) | (ResultPending, ResultOk(res)) => ProgramResult.get_dhexp(res) - | _ => result.elab + | _ => result.elab.d }; let dhcode_view = DHCode.view( @@ -397,6 +397,7 @@ let locked = editor.state.meta.view_term, ) : DHExp.Bool(true) |> DHExp.fresh; + let elab: Elaborator.Elaboration.t = {d: elab, info_map: statics.info_map}; let result: ModelResult.t = settings.core.dynamics ? Evaluation({ diff --git a/src/haz3lweb/view/Deco.re b/src/haz3lweb/view/Deco.re index e5cfacc04d..0019dfa085 100644 --- a/src/haz3lweb/view/Deco.re +++ b/src/haz3lweb/view/Deco.re @@ -276,7 +276,7 @@ module Deco = ); }; - // faster infomap traversal + // faster info_map traversal let err_holes = (_z: Zipper.t) => List.map(term_highlight(~clss=["err-hole"]), M.error_ids); diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index 6da38ecf2f..fd4b7b9877 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -111,19 +111,16 @@ let mk = d: DHExp.t, ) : DHDoc.t => { - let _ = print_endline("[mmpp] New Expression"); - let _ = print_endline(DHExp.show(d)); - let _ = print_int(List.length(hidden_steps)); - print_endline(""); - let _ = - List.map( - ((x, y)) => { - print_endline(Id.show(y)); - print_endline(show_step_kind(x.knd)); - }, - hidden_steps, - ); - let _ = print_endline("============"); + // // print_endline(""); + // // let _ = + // // List.map( + // // ((x, y)) => { + // // print_endline(Id.show(y)); + // // print_endline(show_step_kind(x.knd)); + // // }, + // // hidden_steps, + // // ); + // let _ = print_endline("============"); let precedence = precedence(~show_casts=settings.show_casts); let rec go = ( From f55f55a9141104bc6e7931315d145b48492e76f8 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Fri, 23 Feb 2024 13:20:15 -0500 Subject: [PATCH 016/103] Add patterns to FixF DHExp, remove projection --- src/haz3lcore/dynamics/DH.re | 10 +- src/haz3lcore/dynamics/DHPat.re | 21 +++++ src/haz3lcore/dynamics/Elaborator.re | 38 +------- src/haz3lcore/dynamics/EvalCtx.re | 6 +- src/haz3lcore/dynamics/FilterMatcher.re | 30 +----- src/haz3lcore/dynamics/PatternMatch.re | 3 - src/haz3lcore/dynamics/Stepper.re | 10 +- src/haz3lcore/dynamics/Substitution.re | 3 +- src/haz3lcore/dynamics/Transition.re | 91 ++++++++++++------- src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 23 +++-- .../view/dhcode/layout/DHDoc_common.re | 5 - .../view/dhcode/layout/DHDoc_common.rei | 2 - src/test/Test_Elaboration.re | 52 +++++------ 13 files changed, 134 insertions(+), 160 deletions(-) diff --git a/src/haz3lcore/dynamics/DH.re b/src/haz3lcore/dynamics/DH.re index ec03356d44..a7150e327e 100644 --- a/src/haz3lcore/dynamics/DH.re +++ b/src/haz3lcore/dynamics/DH.re @@ -26,7 +26,7 @@ module rec DHExp: { | Var(Var.t) // DONE [ALREADY] | Seq(t, t) // DONE [ALREADY] | Let(DHPat.t, t, t) // DONE [ALREADY] - | FixF(Var.t, Typ.t, t) // TODO: surface fix + | FixF(DHPat.t, Typ.t, t) // TODO: surface fix | Fun( DHPat.t, Typ.t, @@ -47,7 +47,6 @@ module rec DHExp: { | Cons(t, t) // DONE [ALREADY] | ListConcat(t, t) // DONE [ALREADY] | Tuple(list(t)) // DONE [ALREADY] - | Prj(t, int) // TODO: Add to uexp | Constructor(string) // DONE [ALREADY] | Match(consistency, t, list((DHPat.t, t))) | Cast(t, Typ.t, Typ.t) // TODO: Add to uexp or remove @@ -87,7 +86,7 @@ module rec DHExp: { | Var(Var.t) | Seq(t, t) | Let(DHPat.t, t, t) - | FixF(Var.t, Typ.t, t) + | FixF(DHPat.t, Typ.t, t) | Fun( DHPat.t, Typ.t, @@ -108,7 +107,6 @@ module rec DHExp: { | Cons(t, t) | ListConcat(t, t) | Tuple(list(t)) - | Prj(t, int) | Constructor(string) | Match(consistency, t, list((DHPat.t, t))) | Cast(t, Typ.t, Typ.t) @@ -195,7 +193,6 @@ module rec DHExp: { | Cons(d1, d2) => Cons(repair_ids(d1), repair_ids(d2)) | ListConcat(d1, d2) => ListConcat(repair_ids(d1), repair_ids(d2)) | Tuple(ds) => Tuple(List.map(repair_ids, ds)) - | Prj(d1, i) => Prj(repair_ids(d1), i) | Match(c, d1, rls) => Match( c, @@ -219,7 +216,6 @@ module rec DHExp: { | Cast(d, _, _) => strip_casts(d) | FailedCast(d, _, _) => strip_casts(d) | Tuple(ds) => Tuple(ds |> List.map(strip_casts)) |> rewrap - | Prj(d, n) => Prj(strip_casts(d), n) |> rewrap | Cons(d1, d2) => Cons(strip_casts(d1), strip_casts(d2)) |> rewrap | ListConcat(d1, d2) => ListConcat(strip_casts(d1), strip_casts(d2)) |> rewrap @@ -303,7 +299,6 @@ module rec DHExp: { | (Tuple(ds1), Tuple(ds2)) => List.length(ds1) == List.length(ds2) && List.for_all2(fast_equal, ds1, ds2) - | (Prj(d1, n), Prj(d2, m)) => n == m && fast_equal(d1, d2) | (ApBuiltin(f1, d1), ApBuiltin(f2, d2)) => f1 == f2 && d1 == d2 | (BuiltinFun(f1), BuiltinFun(f2)) => f1 == f2 | (ListLit(_, _, _, ds1), ListLit(_, _, _, ds2)) => @@ -345,7 +340,6 @@ module rec DHExp: { | (ListConcat(_), _) | (ListLit(_), _) | (Tuple(_), _) - | (Prj(_), _) | (BinOp(_), _) | (Cast(_), _) | (FailedCast(_), _) diff --git a/src/haz3lcore/dynamics/DHPat.re b/src/haz3lcore/dynamics/DHPat.re index 271126defb..9b30cccb2d 100644 --- a/src/haz3lcore/dynamics/DHPat.re +++ b/src/haz3lcore/dynamics/DHPat.re @@ -66,3 +66,24 @@ let rec bound_vars = (dp: t): list(Var.t) => | ListLit(_, dps) => List.flatten(List.map(bound_vars, dps)) | Ap(_, dp1) => bound_vars(dp1) }; + +let get_var = (pat: t) => { + switch (pat) { + | Var(x) => Some(x) + | Wild + | Int(_) + | Float(_) + | Bool(_) + | String(_) + | ListLit(_) + | Cons(_, _) + | Tuple(_) + | Constructor(_) + | EmptyHole(_) + | NonEmptyHole(_) + | ExpandingKeyword(_) + | InvalidText(_) + | BadConstructor(_) + | Ap(_) => None + }; +}; diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index d434f82f54..704c004e1a 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -116,7 +116,6 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => | Var(_) | ApBuiltin(_) | BuiltinFun(_) - | Prj(_) | Bool(_) | Int(_) | Float(_) @@ -254,43 +253,14 @@ let rec dhexp_of_uexp = /* not recursive */ DHExp.Let(dp, add_name(Term.UPat.get_var(p), ddef), dbody) |> rewrap - | Some([f]) => - /* simple recursion */ - Let( + | Some(b) => + DHExp.Let( dp, - FixF(f, ty, add_name(Some(f), ddef)) |> DHExp.fresh, + FixF(dp, ty, add_name(Some(String.concat(",", b)), ddef)) + |> DHExp.fresh, dbody, ) |> rewrap - | Some(fs) => - /* mutual recursion */ - let ddef = - switch (DHExp.term_of(ddef)) { - | Tuple(a) => - DHExp.Tuple(List.map2(s => add_name(Some(s)), fs, a)) - |> DHExp.fresh - | _ => ddef - }; - let uniq_id = List.nth(def.ids, 0); - let self_id = "__mutual__" ++ Id.to_string(uniq_id); - // TODO: Re-use IDs here instead of using fresh - let self_var = DHExp.Var(self_id) |> DHExp.fresh; - let (_, substituted_def) = - fs - |> List.fold_left( - ((i, ddef), f) => { - let ddef = - Substitution.subst_var( - DHExp.Prj(self_var, i) |> DHExp.fresh, - f, - ddef, - ); - (i + 1, ddef); - }, - (0, ddef), - ); - Let(dp, FixF(self_id, ty, substituted_def) |> DHExp.fresh, dbody) - |> rewrap; }; | Ap(dir, fn, arg) => let* c_fn = dhexp_of_uexp(m, fn); diff --git a/src/haz3lcore/dynamics/EvalCtx.re b/src/haz3lcore/dynamics/EvalCtx.re index df2dbf7441..19d23d98d5 100644 --- a/src/haz3lcore/dynamics/EvalCtx.re +++ b/src/haz3lcore/dynamics/EvalCtx.re @@ -11,7 +11,7 @@ type term = | Let1(DHPat.t, t, DHExp.t) | Let2(DHPat.t, DHExp.t, t) | Fun(DHPat.t, Typ.t, t, option(ClosureEnvironment.t), option(Var.t)) - | FixF(Var.t, Typ.t, t) + | FixF(DHPat.t, Typ.t, t) | Ap1(TermBase.UExp.ap_direction, t, DHExp.t) | Ap2(TermBase.UExp.ap_direction, DHExp.t, t) | If1(consistency, t, DHExp.t, DHExp.t) @@ -33,7 +33,6 @@ type term = | Cons2(DHExp.t, t) | ListConcat1(t, DHExp.t) | ListConcat2(DHExp.t, t) - | Prj(t, int) | NonEmptyHole(ErrStatus.HoleReason.t, MetaVar.t, HoleInstanceId.t, t) | Cast(t, Typ.t, Typ.t) | FailedCast(t, Typ.t, Typ.t) @@ -129,9 +128,6 @@ let rec compose = (ctx: t, d: DHExp.t): DHExp.t => { | FixF(v, t, ctx) => let d = compose(ctx, d); FixF(v, t, d) |> wrap; - | Prj(ctx, n) => - let d = compose(ctx, d); - Prj(d, n) |> wrap; | Cast(ctx, ty1, ty2) => let d = compose(ctx, d); Cast(d, ty1, ty2) |> wrap; diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index 8c48bed566..ef7f270fb1 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -10,29 +10,6 @@ let rec matches_exp = switch (DHExp.term_of(d), DHExp.term_of(f)) { | (Constructor("$e"), _) => failwith("$e in matched expression") | (Constructor("$v"), _) => failwith("$v in matched expression") - - // HACK[Matt]: ignore fixpoints in comparison, to allow pausing on fixpoint steps - | (FixF(dp, _, dc), _) => - matches_exp( - env, - Closure( - Transition.evaluate_extend_env(Environment.singleton((dp, dc)), env), - dc, - ) - |> DHExp.fresh, - f, - ) - | (_, FixF(fp, _, fc)) => - matches_exp( - env, - d, - Closure( - Transition.evaluate_extend_env(Environment.singleton((fp, fc)), env), - fc, - ) - |> DHExp.fresh, - ) - | (_, Constructor("$v")) => switch (ValueChecker.check_value(info_map, env, d)) { | Indet @@ -103,6 +80,10 @@ let rec matches_exp = && dname1 == fname1 | (Fun(_), _) => false + | (FixF(dp, dt, d1), FixF(fp, ft, f1)) => + matches_pat(dp, fp) && dt == ft && matches_exp(env, d1, f1) + | (FixF(_), _) => false + | (FreeVar(du, di, dx), FreeVar(fu, fi, fx)) => du == fu && di == fi && dx == fx | (FreeVar(_), _) => false @@ -189,9 +170,6 @@ let rec matches_exp = | (ApBuiltin(dname, darg), ApBuiltin(fname, farg)) => dname == fname && matches_exp(env, darg, farg) | (ApBuiltin(_), _) => false - - | (Prj(dv, di), Prj(fv, fi)) => matches_exp(env, dv, fv) && di == fi - | (Prj(_), _) => false }; } and matches_pat = (d: DHPat.t, f: DHPat.t): bool => { diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index dc94f754e7..6a57476c42 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -251,7 +251,6 @@ and matches_cast_Sum = | Test(_) | InvalidOperation(_) | Match(_) - | Prj(_) | If(_) | BuiltinFun(_) => IndetMatch | Cast(_) @@ -347,7 +346,6 @@ and matches_cast_Tuple = | ListLit(_) => DoesNotMatch | Cons(_, _) => DoesNotMatch | ListConcat(_) => DoesNotMatch - | Prj(_) => IndetMatch | Constructor(_) => DoesNotMatch | Match(_) => IndetMatch | EmptyHole => IndetMatch @@ -480,7 +478,6 @@ and matches_cast_Cons = | Float(_) => DoesNotMatch | String(_) => DoesNotMatch | Tuple(_) => DoesNotMatch - | Prj(_) => IndetMatch | Constructor(_) => DoesNotMatch | Match(_) => IndetMatch | EmptyHole => IndetMatch diff --git a/src/haz3lcore/dynamics/Stepper.re b/src/haz3lcore/dynamics/Stepper.re index c794bd72e8..27559b93ee 100644 --- a/src/haz3lcore/dynamics/Stepper.re +++ b/src/haz3lcore/dynamics/Stepper.re @@ -139,9 +139,6 @@ let rec matches = | ListConcat2(d1, ctx) => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); ListConcat2(d1, ctx) |> rewrap; - | Prj(ctx, n) => - let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); - Prj(ctx, n) |> rewrap; | NonEmptyHole(e, u, i, ctx) => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); NonEmptyHole(e, u, i, ctx) |> rewrap; @@ -363,9 +360,10 @@ let get_justification: step_kind => string = | VarLookup => "variable lookup" | CastAp | Cast => "cast calculus" - | CompleteFilter => "unidentified step" - | CompleteClosure => "unidentified step" - | FunClosure => "unidentified step" + | FixClosure => "fixpoint closure" + | CompleteFilter => "complete filter" + | CompleteClosure => "complete closure" + | FunClosure => "function closure" | Skip => "skipped steps"; type step_info = { diff --git a/src/haz3lcore/dynamics/Substitution.re b/src/haz3lcore/dynamics/Substitution.re index cc0b486512..a26f7a54cc 100644 --- a/src/haz3lcore/dynamics/Substitution.re +++ b/src/haz3lcore/dynamics/Substitution.re @@ -29,7 +29,7 @@ let rec subst_var = (d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => { Let(dp, d3, d4) |> rewrap; | FixF(y, ty, d3) => let d3 = - if (Var.eq(x, y)) { + if (DHPat.binds_var(x, y)) { d3; } else { subst_var(d1, x, d3); @@ -76,7 +76,6 @@ let rec subst_var = (d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => { let d4 = subst_var(d1, x, d4); ListConcat(d3, d4) |> rewrap; | Tuple(ds) => Tuple(List.map(subst_var(d1, x), ds)) |> rewrap - | Prj(d, n) => Prj(subst_var(d1, x, d), n) |> rewrap | BinOp(op, d3, d4) => let d3 = subst_var(d1, x, d3); let d4 = subst_var(d1, x, d4); diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index 3f44aa1f27..06f44219b9 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -52,6 +52,7 @@ type step_kind = | LetBind | FunClosure | FixUnwrap + | FixClosure | UpdateTest | FunAp | CastAp @@ -260,18 +261,58 @@ module Transition = (EV: EV_MODE) => { kind: FunClosure, value: true, }); - | FixF(f, t, d1) => - let. _ = otherwise(env, FixF(f, t, d1) |> rewrap); - Step({ - apply: () => - Closure( - evaluate_extend_env(Environment.singleton((f, d1)), env), - d1, - ) - |> fresh, - kind: FixUnwrap, - value: false, - }); + | FixF(dp, t, d1) => + let (term1, rewrap1) = DHExp.unwrap(d1); + switch (term1, DHPat.get_var(dp)) { + // Simple Recursion case + | (Closure(env, d1), Some(f)) => + let. _ = otherwise(env, d); + let env'' = + evaluate_extend_env( + Environment.singleton(( + f, + FixF(dp, t, Closure(env, d1) |> rewrap1) |> rewrap, + )), + env, + ); + Step({ + apply: () => Closure(env'', d1) |> fresh, + kind: FixUnwrap, + value: false, + }); + // Mutual Recursion case + | (Closure(env, d1), None) => + let. _ = otherwise(env, d); + let bindings = DHPat.bound_vars(dp); + let substitutions = + List.map( + binding => + ( + binding, + Let( + dp, + FixF(dp, t, Closure(env, d1) |> rewrap1) |> rewrap, + Var(binding) |> fresh, + ) + |> fresh, + ), + bindings, + ); + let env'' = + evaluate_extend_env(Environment.of_list(substitutions), env); + Step({ + apply: () => Closure(env'', d1) |> fresh, + kind: FixUnwrap, + value: false, + }); + | _ => + let. _ = otherwise(env, FixF(dp, t, d1) |> rewrap); + Step({ + apply: () => FixF(dp, t, Closure(env, d1) |> fresh) |> rewrap, + kind: FixClosure, + value: false, + }); + }; | Test(id, d) => let. _ = otherwise(env, d => Test(id, d) |> rewrap) and. d' = req_final(req(state, env), d => Test(id, d) |> wrap_ctx, d); @@ -566,27 +607,6 @@ module Transition = (EV: EV_MODE) => { ds, ); Constructor; - | Prj(d1, n) => - let. _ = otherwise(env, d1 => Prj(d1, n) |> rewrap) - and. d1' = - req_final(req(state, env), d1 => Prj(d1, n) |> wrap_ctx, d1); - Step({ - apply: () => { - switch (DHExp.term_of(d1')) { - | Tuple(ds) when n < 0 || List.length(ds) <= n => - raise(EvaluatorError.Exception(InvalidProjection(n))) - | Tuple(ds) => List.nth(ds, n) - | Cast(_, Prod(ts), Prod(_)) when n < 0 || List.length(ts) <= n => - raise(EvaluatorError.Exception(InvalidProjection(n))) - | Cast(d2, Prod(ts1), Prod(ts2)) => - Cast(Prj(d2, n) |> rewrap, List.nth(ts1, n), List.nth(ts2, n)) - |> fresh - | _ => raise(EvaluatorError.Exception(InvalidProjection(n))) - }; - }, - kind: Projection, - value: false, - }); // TODO(Matt): Can we do something cleverer when the list structure is complete but the contents aren't? | Cons(d1, d2) => let. _ = otherwise(env, (d1, d2) => Cons(d1, d2) |> rewrap) @@ -789,8 +809,9 @@ let should_hide_step = (~settings: CoreSettings.Evaluation.t) => | VarLookup => !settings.show_lookup_steps | CastAp | Cast => !settings.show_casts + | FixUnwrap => !settings.show_fixpoints | CompleteClosure | CompleteFilter - | FixUnwrap | BuiltinWrap - | FunClosure => true; + | FunClosure + | FixClosure => true; diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index fd4b7b9877..d884e1e20b 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -55,7 +55,6 @@ let rec precedence = (~show_casts: bool, d: DHExp.t) => { | Float(_) | String(_) | ListLit(_) - | Prj(_) | EmptyHole | Constructor(_) | FailedCast(_) @@ -144,11 +143,13 @@ let mk = | (FunAp, _) => [] | (LetBind, Let(p, _, _)) => DHPat.bound_vars(p) | (LetBind, _) => [] - | (FixUnwrap, _) // TODO[Matt]: Could do something here? + | (FixUnwrap, FixF(p, _, _)) => DHPat.bound_vars(p) + | (FixUnwrap, _) => [] | (InvalidStep, _) | (VarLookup, _) | (Seq, _) | (FunClosure, _) + | (FixClosure, _) | (UpdateTest, _) | (CastAp, _) | (BuiltinWrap, _) @@ -365,7 +366,6 @@ let mk = hseps([doc1, mk_bin_bool_op(op), doc2]); | Tuple([]) => DHDoc_common.Delim.triv | Tuple(ds) => DHDoc_common.mk_Tuple(ds |> List.map(d => go'(d))) - | Prj(d, n) => DHDoc_common.mk_Prj(go'(d), n) | Match(Consistent, dscrut, drs) => go_case(dscrut, drs) | Cast(d, _, ty) when settings.show_casts => // TODO[Matt]: Roll multiple casts into one cast @@ -555,14 +555,18 @@ let mk = | Some(name) => annot(DHAnnot.Collapsed, text("<" ++ name ++ ">")) }; } - | FixF(x, ty, dbody) when settings.show_fixpoints => + | FixF(dp, ty, dbody) when settings.show_fixpoints => let doc_body = go_formattable( dbody, - ~env=ClosureEnvironment.without_keys([x], env), + ~env=ClosureEnvironment.without_keys(DHPat.bound_vars(dp), env), ); hcats( - [DHDoc_common.Delim.fix_FixF, space(), text(x)] + [ + DHDoc_common.Delim.fix_FixF, + space(), + DHDoc_Pat.mk(dp, ~enforce_inline=true), + ] @ ( settings.show_casts ? [ @@ -579,8 +583,11 @@ let mk = doc_body |> DHDoc_common.pad_child(~enforce_inline), ], ); - | FixF(x, _, d) => - go'(~env=ClosureEnvironment.without_keys([x], env), d) + | FixF(dp, _, d) => + go'( + ~env=ClosureEnvironment.without_keys(DHPat.bound_vars(dp), env), + d, + ) }; }; let steppable = diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_common.re b/src/haz3lweb/view/dhcode/layout/DHDoc_common.re index db8fec65d1..de5adcbd4f 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_common.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_common.re @@ -70,8 +70,6 @@ module Delim = { let arrow_FixF = mk("->"); let colon_FixF = mk(":"); - let projection_dot = mk("."); - let open_Case = mk("case"); let close_Case = mk("end"); @@ -140,6 +138,3 @@ let mk_Ap = (doc1, doc2) => Doc.(hcats([doc1, text("("), doc2, text(")")])); let mk_rev_Ap = (doc1, doc2) => Doc.(hcats([doc1, text(" |> "), doc2])); - -let mk_Prj = (targ, n) => - Doc.hcats([targ, Delim.projection_dot, Doc.text(string_of_int(n))]); diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_common.rei b/src/haz3lweb/view/dhcode/layout/DHDoc_common.rei index 92f9d5a835..dacaa16b30 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_common.rei +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_common.rei @@ -94,5 +94,3 @@ let mk_Tuple: list(Pretty.Doc.t('a)) => Pretty.Doc.t('a); let mk_Ap: (Pretty.Doc.t('a), Pretty.Doc.t('a)) => Pretty.Doc.t('a); let mk_rev_Ap: (Pretty.Doc.t('a), Pretty.Doc.t('a)) => Pretty.Doc.t('a); - -let mk_Prj: (Pretty.Doc.t(DHAnnot.t), int) => Pretty.Doc.t(DHAnnot.t); diff --git a/src/test/Test_Elaboration.re b/src/test/Test_Elaboration.re index edf72953f0..a52acee358 100644 --- a/src/test/Test_Elaboration.re +++ b/src/test/Test_Elaboration.re @@ -285,31 +285,31 @@ let u9: Term.UExp.t = { {ids: [id_at(11)], term: Int(55)}, ), }; -let d9: DHExp.t = - Let( - Var("f"), - FixF( - "f", - Arrow(Int, Int), - Fun( - Var("x"), - Int, - BinOp(Int(Plus), Int(1) |> fresh, Var("x") |> fresh) |> fresh, - None, - Some("f"), - ) - |> fresh, - ) - |> fresh, - Int(55) |> fresh, - ) - |> fresh; -let let_fun = () => - alco_check( - "Let expression for function which wraps a fix point constructor around the function", - Some(d9), - dhexp_of_uexp(u9), - ); +// let d9: DHExp.t = +// Let( +// Var("f"), +// FixF( +// "f", +// Arrow(Int, Int), +// Fun( +// Var("x"), +// Int, +// BinOp(Int(Plus), Int(1) |> fresh, Var("x") |> fresh) |> fresh, +// None, +// Some("f"), +// ) +// |> fresh, +// ) +// |> fresh, +// Int(55) |> fresh, +// ) +// |> fresh; +// let let_fun = () => +// alco_check( +// "Let expression for function which wraps a fix point constructor around the function", +// Some(d9), +// dhexp_of_uexp(u9), +// ); let elaboration_tests = [ test_case("Single integer", `Quick, single_integer), @@ -320,5 +320,5 @@ let elaboration_tests = [ test_case("Consistent if statement", `Quick, consistent_if), test_case("Application of function on free variable", `Quick, ap_fun), test_case("Inconsistent case statement", `Quick, inconsistent_case), - test_case("Let expression for a function", `Quick, let_fun), + // test_case("Let expression for a function", `Quick, let_fun), ]; From 5127854cf7729a533c8a59d42dff936f0c02f649 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Fri, 23 Feb 2024 14:27:20 -0500 Subject: [PATCH 017/103] Surface fix --- src/haz3lcore/dynamics/Elaborator.re | 5 ++ src/haz3lcore/lang/Form.re | 1 + src/haz3lcore/statics/MakeTerm.re | 1 + src/haz3lcore/statics/Statics.re | 11 ++++ src/haz3lcore/statics/Term.re | 5 ++ src/haz3lcore/statics/TermBase.re | 2 + src/haz3lcore/zipper/EditorUtil.re | 1 + src/haz3lschool/SyntaxTest.re | 4 ++ src/haz3lweb/explainthis/Example.re | 1 + src/haz3lweb/explainthis/ExplainThisForm.re | 4 ++ src/haz3lweb/explainthis/data/FixFExp.re | 57 +++++++++++++++++++++ src/haz3lweb/view/ExplainThis.re | 7 +++ 12 files changed, 99 insertions(+) create mode 100644 src/haz3lweb/explainthis/data/FixFExp.re diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 704c004e1a..6a6055ce44 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -262,6 +262,11 @@ let rec dhexp_of_uexp = ) |> rewrap }; + | FixF(p, e) => + let* dp = dhpat_of_upat(m, p); + let* de = dhexp_of_uexp(m, e); + let+ ty = fixed_pat_typ(m, p); + DHExp.FixF(dp, ty, de) |> rewrap; | Ap(dir, fn, arg) => let* c_fn = dhexp_of_uexp(m, fn); let+ c_arg = dhexp_of_uexp(m, arg); diff --git a/src/haz3lcore/lang/Form.re b/src/haz3lcore/lang/Form.re index b43de49332..023bd340de 100644 --- a/src/haz3lcore/lang/Form.re +++ b/src/haz3lcore/lang/Form.re @@ -301,6 +301,7 @@ let forms: list((string, t)) = [ ("case", mk(ds, ["case", "end"], mk_op(Exp, [Rul]))), ("test", mk(ds, ["test", "end"], mk_op(Exp, [Exp]))), ("fun_", mk(ds, ["fun", "->"], mk_pre(P.fun_, Exp, [Pat]))), + ("fix", mk(ds, ["fix", "->"], mk_pre(P.fun_, Exp, [Pat]))), ( "rule", mk(ds, ["|", "=>"], mk_bin'(P.rule_sep, Rul, Exp, [Pat], Exp)), diff --git a/src/haz3lcore/statics/MakeTerm.re b/src/haz3lcore/statics/MakeTerm.re index cf0da62c9b..78f025d3a0 100644 --- a/src/haz3lcore/statics/MakeTerm.re +++ b/src/haz3lcore/statics/MakeTerm.re @@ -184,6 +184,7 @@ and exp_term: unsorted => (UExp.term, list(Id.t)) = { | (["-"], []) => UnOp(Int(Minus), r) | (["!"], []) => UnOp(Bool(Not), r) | (["fun", "->"], [Pat(pat)]) => Fun(pat, r) + | (["fix", "->"], [Pat(pat)]) => FixF(pat, r) | (["let", "=", "in"], [Pat(pat), Exp(def)]) => Let(pat, def, r) | (["hide", "in"], [Exp(filter)]) => Filter((Eval, One), filter, r) diff --git a/src/haz3lcore/statics/Statics.re b/src/haz3lcore/statics/Statics.re index 8080e39122..c7bd47f12a 100644 --- a/src/haz3lcore/statics/Statics.re +++ b/src/haz3lcore/statics/Statics.re @@ -340,6 +340,17 @@ and uexp_to_info_map = CoCtx.union([def.co_ctx, CoCtx.mk(ctx, p_ana.ctx, body.co_ctx)]), m, ); + | FixF(p, e) => + let (p', _) = + go_pat(~is_synswitch=false, ~co_ctx=CoCtx.empty, ~mode, p, m); + let (e', m) = go'(~ctx=p'.ctx, ~mode=Ana(p'.ty), e, m); + let (p'', m) = + go_pat(~is_synswitch=false, ~co_ctx=e'.co_ctx, ~mode, p, m); + add( + ~self=Just(p'.ty), + ~co_ctx=CoCtx.union([CoCtx.mk(ctx, p''.ctx, e'.co_ctx)]), + m, + ); | If(e0, e1, e2) => let branch_ids = List.map(UExp.rep_id, [e1, e2]); let (cond, m) = go(~mode=Ana(Bool), e0, m); diff --git a/src/haz3lcore/statics/Term.re b/src/haz3lcore/statics/Term.re index ac788e9229..ff8decf0f0 100644 --- a/src/haz3lcore/statics/Term.re +++ b/src/haz3lcore/statics/Term.re @@ -435,6 +435,7 @@ module UExp = { | Var | MetaVar | Let + | FixF | TyAlias | Ap | Pipeline @@ -476,6 +477,7 @@ module UExp = { | Tuple(_) => Tuple | Var(_) => Var | Let(_) => Let + | FixF(_) => FixF | TyAlias(_) => TyAlias | Ap(_) => Ap | If(_) => If @@ -569,6 +571,7 @@ module UExp = { | Var => "Variable reference" | MetaVar => "Meta variable reference" | Let => "Let expression" + | FixF => "Fixpoint operator" | TyAlias => "Type Alias definition" | Ap => "Application" | Pipeline => "Pipeline expression" @@ -599,6 +602,7 @@ module UExp = { | Tuple(_) | Var(_) | Let(_) + | FixF(_) | TyAlias(_) | Ap(_) | If(_) @@ -632,6 +636,7 @@ module UExp = { | Fun(_) | Var(_) | Let(_) + | FixF(_) | TyAlias(_) | Ap(_) | If(_) diff --git a/src/haz3lcore/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index f280bd5e40..dad402eb87 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -151,6 +151,7 @@ and UExp: { | Tuple(list(t)) | Var(Var.t) | Let(UPat.t, t, t) + | FixF(UPat.t, t) | TyAlias(UTPat.t, UTyp.t, t) | Ap(ap_direction, t, t) | If(t, t, t) @@ -292,6 +293,7 @@ and UExp: { | Tuple(list(t)) // DONE [EXCEPT FOR TRIV] | Var(Var.t) // DONE [ALREADY] | Let(UPat.t, t, t) // DONE [ALREADY] + | FixF(UPat.t, t) // DONE [CHECK WITH SOMEONE THAT I GOT THE STATIC SEMANTICS RIGHT] | TyAlias(UTPat.t, UTyp.t, t) // [TO ADD TO DHEXP] // note: function is always first then argument; even in reverse | Ap(ap_direction, t, t) // TODO: Combine Ap and Pipeline? [alt: add pipeline to dhexp] diff --git a/src/haz3lcore/zipper/EditorUtil.re b/src/haz3lcore/zipper/EditorUtil.re index 719e4154d9..cfe30187a7 100644 --- a/src/haz3lcore/zipper/EditorUtil.re +++ b/src/haz3lcore/zipper/EditorUtil.re @@ -54,6 +54,7 @@ let rec append_exp = (e1: TermBase.UExp.t, e2: TermBase.UExp.t) => { | ListLit(_) | Constructor(_) | Fun(_) + | FixF(_) | Tuple(_) | Var(_) | Ap(_) diff --git a/src/haz3lschool/SyntaxTest.re b/src/haz3lschool/SyntaxTest.re index e81b7b37a9..2107825c6e 100644 --- a/src/haz3lschool/SyntaxTest.re +++ b/src/haz3lschool/SyntaxTest.re @@ -42,6 +42,7 @@ let rec var_mention = (name: string, uexp: Term.UExp.t): bool => { | Float(_) | String(_) | Constructor(_) => false + | FixF(args, body) | Fun(args, body) => find_var_upat(name, args) ? false : var_mention(name, body) | ListLit(l) @@ -87,6 +88,7 @@ let rec var_applied = (name: string, uexp: Term.UExp.t): bool => { | Float(_) | String(_) | Constructor(_) => false + | FixF(args, body) | Fun(args, body) => find_var_upat(name, args) ? false : var_applied(name, body) | ListLit(l) @@ -178,6 +180,7 @@ let rec find_fn = | ListLit(ul) | Tuple(ul) => List.fold_left((acc, u1) => {find_fn(name, u1, acc)}, l, ul) + | FixF(_, body) | Fun(_, body) => l |> find_fn(name, body) | Parens(u1) | UnOp(_, u1) @@ -235,6 +238,7 @@ let rec tail_check = (name: string, uexp: Term.UExp.t): bool => { | String(_) | Constructor(_) | Var(_) => true + | FixF(args, body) | Fun(args, body) => find_var_upat(name, args) ? false : tail_check(name, body) | Let(p, def, body) => diff --git a/src/haz3lweb/explainthis/Example.re b/src/haz3lweb/explainthis/Example.re index b1b84c7906..4a76d4a55d 100644 --- a/src/haz3lweb/explainthis/Example.re +++ b/src/haz3lweb/explainthis/Example.re @@ -113,6 +113,7 @@ let pipeline = () => mk_monotile(Form.get("pipeline")); let nil = () => exp("[]"); let typeann = () => mk_monotile(Form.get("typeann")); let mk_fun = mk_tile(Form.get("fun_")); +let mk_fix = mk_tile(Form.get("fix")); let mk_ap_exp = mk_tile(Form.get("ap_exp")); let mk_ap_pat = mk_tile(Form.get("ap_pat")); let mk_let = mk_tile(Form.get("let_")); diff --git a/src/haz3lweb/explainthis/ExplainThisForm.re b/src/haz3lweb/explainthis/ExplainThisForm.re index 3462fe09c8..527bedde4f 100644 --- a/src/haz3lweb/explainthis/ExplainThisForm.re +++ b/src/haz3lweb/explainthis/ExplainThisForm.re @@ -74,6 +74,8 @@ type numeric_bin_op_examples = type example_id = | List(list_examples) | Fun(fun_examples) + | Fix1 + | Fix2 | Tuple1 | Tuple2 | Let(let_examples) @@ -152,6 +154,7 @@ type form_id = | Tuple2Exp | Tuple3Exp | LetExp(pat_sub_form_id) + | FixExp(pat_sub_form_id) | FunApExp | ConApExp | IfExp @@ -237,6 +240,7 @@ type group_id = | Tuple2Exp | Tuple3Exp | LetExp(pat_sub_form_id) + | FixExp(pat_sub_form_id) | FunApExp | ConApExp | IfExp diff --git a/src/haz3lweb/explainthis/data/FixFExp.re b/src/haz3lweb/explainthis/data/FixFExp.re new file mode 100644 index 0000000000..b5693342ef --- /dev/null +++ b/src/haz3lweb/explainthis/data/FixFExp.re @@ -0,0 +1,57 @@ +open Haz3lcore; +open ExplainThisForm; +open Example; + +/* (A) Use this file as an example for adding a new form to ExplainThis. + * You should be able to copy-paste this file and modify it to add a new form */ + +let single = (~pat_id: Id.t, ~body_id: Id.t): Simple.t => { + /* (B) You'll need to add new cases to ExplainThisForm.re for the new form + * to represent a group_id and form_id. This Simple style is specialized + * to singleton groups. In general, the group_id needs to be unique, and + * form_ids need to be unique within a group. These ids are used to track + * ExplainThis persistent state. */ + group_id: FixExp(Base), + form_id: FixExp(Base), + /* (C) The abstract field defines an abstract example illustrating the + * new form. You'll need to provide pairs associating any representative + * subterms of the exemplar (e.g. "e_arg" and "e_fun" below) with the + * concrete subterms of the term the user has selected (here, arg_id + * and fn_id). You'll then need a function to construct a segment + * representing your abstract. This is done in this indirect way so + * as to associate representative and concrete subterms ids for + * syntax highlighting purposes. */ + abstract: + Simple.mk_2(("p", pat_id), ("e", body_id), (p, e) => + [mk_fix([[space(), p, space()]]), space(), e] + ), + /* (D) The explanation which will appear in the sidebar below the abstract */ + explanation: + Printf.sprintf( + "Recursively replaces all occurences of the [*pattern*](%s) inside the [*body*](%s) with the entire [*body*](%s) itself, effectively creating an infinite expression. Unless [*pattern*](%s) is a function, it is likely to evaluate forever.", + pat_id |> Id.to_string, + body_id |> Id.to_string, + body_id |> Id.to_string, + pat_id |> Id.to_string, + ), + /* (E) Additional more concrete examples and associated explanations */ + examples: [ + { + sub_id: Fix1, + term: mk_example("fix x -> x + 1"), + message: {| + Tries to create the infinite expression (((...) + 1) + 1) + 1 but times out + |}, + }, + { + sub_id: Fix2, + term: + mk_example( + "(fix f -> fun x -> \nif x == 0 then \n0 \nelse \nf(x-1) + 2\n) (5)", + ), + message: {| + A recursive function that doubles a given number. + |}, + }, + ], +}; diff --git a/src/haz3lweb/view/ExplainThis.re b/src/haz3lweb/view/ExplainThis.re index b42f52544e..2efd733067 100644 --- a/src/haz3lweb/view/ExplainThis.re +++ b/src/haz3lweb/view/ExplainThis.re @@ -1523,6 +1523,13 @@ let get_doc = | Parens(_) => default // Shouldn't get hit? | TypeAnn(_) => default // Shouldn't get hit? }; + | FixF(pat, body) => + message_single( + FixFExp.single( + ~pat_id=Term.UPat.rep_id(pat), + ~body_id=Term.UExp.rep_id(body), + ), + ) | Ap(Reverse, arg, fn) => message_single( PipelineExp.single( From f75a1d5b90e41d6976e0893740967db5a12930eb Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Fri, 23 Feb 2024 15:19:45 -0500 Subject: [PATCH 018/103] Remove Triv --- src/haz3lcore/dynamics/Elaborator.re | 1 - src/haz3lcore/prog/CachedStatics.re | 2 +- src/haz3lcore/statics/MakeTerm.re | 4 ++-- src/haz3lcore/statics/Statics.re | 1 - src/haz3lcore/statics/Term.re | 5 ----- src/haz3lcore/statics/TermBase.re | 2 -- src/haz3lcore/zipper/EditorUtil.re | 1 - src/haz3lschool/SyntaxTest.re | 4 ---- src/haz3lweb/view/ExplainThis.re | 2 +- 9 files changed, 4 insertions(+), 18 deletions(-) diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 6a6055ce44..157ab6f7fc 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -159,7 +159,6 @@ let rec dhexp_of_uexp = Make sure new dhexp form is properly considered Indet to avoid casting issues. */ Some(EmptyHole |> rewrap) - | Triv => Some(Tuple([]) |> rewrap) | Bool(b) => Some(Bool(b) |> rewrap) | Int(n) => Some(Int(n) |> rewrap) | Float(n) => Some(Float(n) |> rewrap) diff --git a/src/haz3lcore/prog/CachedStatics.re b/src/haz3lcore/prog/CachedStatics.re index 336d61f3a3..76cbc772c3 100644 --- a/src/haz3lcore/prog/CachedStatics.re +++ b/src/haz3lcore/prog/CachedStatics.re @@ -8,7 +8,7 @@ type statics = { }; let empty_statics: statics = { - term: Term.UExp.{ids: [Id.invalid], term: Triv}, + term: Term.UExp.{ids: [Id.invalid], term: Tuple([])}, info_map: Id.Map.empty, error_ids: [], }; diff --git a/src/haz3lcore/statics/MakeTerm.re b/src/haz3lcore/statics/MakeTerm.re index 78f025d3a0..cfa58652ab 100644 --- a/src/haz3lcore/statics/MakeTerm.re +++ b/src/haz3lcore/statics/MakeTerm.re @@ -149,7 +149,7 @@ and exp_term: unsorted => (UExp.term, list(Id.t)) = { // single-tile case | ([(_id, t)], []) => switch (t) { - | ([t], []) when Form.is_empty_tuple(t) => ret(Triv) + | ([t], []) when Form.is_empty_tuple(t) => ret(Tuple([])) | ([t], []) when Form.is_empty_list(t) => ret(ListLit([])) | ([t], []) when Form.is_bool(t) => ret(Bool(bool_of_string(t))) | ([t], []) when Form.is_int(t) => ret(Int(int_of_string(t))) @@ -208,7 +208,7 @@ and exp_term: unsorted => (UExp.term, list(Id.t)) = { | ([(_id, t)], []) => switch (t) { | (["()"], []) => - ret(Ap(Forward, l, {ids: [Id.nullary_ap_flag], term: Triv})) + ret(Ap(Forward, l, {ids: [Id.nullary_ap_flag], term: Tuple([])})) | (["(", ")"], [Exp(arg)]) => ret(Ap(Forward, l, arg)) | _ => ret(hole(tm)) } diff --git a/src/haz3lcore/statics/Statics.re b/src/haz3lcore/statics/Statics.re index c7bd47f12a..4de748e764 100644 --- a/src/haz3lcore/statics/Statics.re +++ b/src/haz3lcore/statics/Statics.re @@ -198,7 +198,6 @@ and uexp_to_info_map = add(~self=IsMulti, ~co_ctx=CoCtx.union(co_ctxs), m); | Invalid(token) => atomic(BadToken(token)) | EmptyHole => atomic(Just(Unknown(Internal))) - | Triv => atomic(Just(Prod([]))) | Bool(_) => atomic(Just(Bool)) | Int(_) => atomic(Just(Int)) | Float(_) => atomic(Just(Float)) diff --git a/src/haz3lcore/statics/Term.re b/src/haz3lcore/statics/Term.re index ff8decf0f0..ab1bdab24d 100644 --- a/src/haz3lcore/statics/Term.re +++ b/src/haz3lcore/statics/Term.re @@ -423,7 +423,6 @@ module UExp = { | Invalid | EmptyHole | MultiHole - | Triv | Bool | Int | Float @@ -466,7 +465,6 @@ module UExp = { | Invalid(_) => Invalid | EmptyHole => EmptyHole | MultiHole(_) => MultiHole - | Triv => Triv | Bool(_) => Bool | Int(_) => Int | Float(_) => Float @@ -559,7 +557,6 @@ module UExp = { | Invalid => "Invalid expression" | MultiHole => "Broken expression" | EmptyHole => "Empty expression hole" - | Triv => "Trivial literal" | Bool => "Boolean literal" | Int => "Integer literal" | Float => "Float literal" @@ -593,7 +590,6 @@ module UExp = { | Invalid(_) | EmptyHole | MultiHole(_) - | Triv | Bool(_) | Int(_) | Float(_) @@ -627,7 +623,6 @@ module UExp = { | Invalid(_) | EmptyHole | MultiHole(_) - | Triv | Bool(_) | Int(_) | Float(_) diff --git a/src/haz3lcore/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index dad402eb87..8d7dfd7dd5 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -140,7 +140,6 @@ and UExp: { | Invalid(string) | EmptyHole | MultiHole(list(Any.t)) - | Triv // TODO: Replace with empty tuple | Bool(bool) | Int(int) | Float(float) @@ -282,7 +281,6 @@ and UExp: { | Invalid(string) // TODO: Reconcile the invalids | EmptyHole // DONE | MultiHole(list(Any.t)) // TODO: Reconcile the invalids - | Triv // REMOVE, REPLACE WITH EMPTY TUPLE | Bool(bool) // DONE [DH CHANGED] | Int(int) // DONE [DH CHANGED] | Float(float) // DONE [DH CHANGED] diff --git a/src/haz3lcore/zipper/EditorUtil.re b/src/haz3lcore/zipper/EditorUtil.re index cfe30187a7..7d532520da 100644 --- a/src/haz3lcore/zipper/EditorUtil.re +++ b/src/haz3lcore/zipper/EditorUtil.re @@ -46,7 +46,6 @@ let rec append_exp = (e1: TermBase.UExp.t, e2: TermBase.UExp.t) => { | EmptyHole | Invalid(_) | MultiHole(_) - | Triv | Bool(_) | Int(_) | Float(_) diff --git a/src/haz3lschool/SyntaxTest.re b/src/haz3lschool/SyntaxTest.re index 2107825c6e..30eccfbb96 100644 --- a/src/haz3lschool/SyntaxTest.re +++ b/src/haz3lschool/SyntaxTest.re @@ -34,7 +34,6 @@ let rec var_mention = (name: string, uexp: Term.UExp.t): bool => { switch (uexp.term) { | Var(x) => x == name | EmptyHole - | Triv | Invalid(_) | MultiHole(_) | Bool(_) @@ -80,7 +79,6 @@ let rec var_applied = (name: string, uexp: Term.UExp.t): bool => { switch (uexp.term) { | Var(_) | EmptyHole - | Triv | Invalid(_) | MultiHole(_) | Bool(_) @@ -201,7 +199,6 @@ let rec find_fn = ul, ) | EmptyHole - | Triv | Invalid(_) | MultiHole(_) | Bool(_) @@ -229,7 +226,6 @@ let is_recursive = (name: string, uexp: Term.UExp.t): bool => { let rec tail_check = (name: string, uexp: Term.UExp.t): bool => { switch (uexp.term) { | EmptyHole - | Triv | Invalid(_) | MultiHole(_) | Bool(_) diff --git a/src/haz3lweb/view/ExplainThis.re b/src/haz3lweb/view/ExplainThis.re index 2efd733067..2356078ff1 100644 --- a/src/haz3lweb/view/ExplainThis.re +++ b/src/haz3lweb/view/ExplainThis.re @@ -541,7 +541,6 @@ let get_doc = ), TyAliasExp.tyalias_exps, ); - | Triv => get_message(TerminalExp.triv_exps) | Bool(b) => get_message(TerminalExp.bool_exps(b)) | Int(i) => get_message(TerminalExp.int_exps(i)) | Float(f) => get_message(TerminalExp.float_exps(f)) @@ -867,6 +866,7 @@ let get_doc = } else { basic(FunctionExp.functions_var); } + | Tuple([]) => get_message(TerminalExp.triv_exps) | Tuple(elements) => let pat_id = List.nth(pat.ids, 0); let body_id = List.nth(body.ids, 0); From b3639ef2ef628090b7755940131983665f5b015a Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Fri, 23 Feb 2024 15:30:22 -0500 Subject: [PATCH 019/103] Rename InvalidText to Invalid --- src/haz3lcore/dynamics/DH.re | 13 ++++++------- src/haz3lcore/dynamics/Elaborator.re | 4 ++-- src/haz3lcore/dynamics/FilterMatcher.re | 2 +- src/haz3lcore/dynamics/PatternMatch.re | 8 ++++---- src/haz3lcore/dynamics/Substitution.re | 2 +- src/haz3lcore/dynamics/Transition.re | 2 +- src/haz3lweb/view/dhcode/DHCode.re | 5 +---- src/haz3lweb/view/dhcode/layout/DHAnnot.re | 2 +- src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 4 ++-- src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re | 4 ++-- src/haz3lweb/view/dhcode/layout/DHDoc_common.re | 3 +-- src/haz3lweb/view/dhcode/layout/DHDoc_common.rei | 2 +- 12 files changed, 23 insertions(+), 28 deletions(-) diff --git a/src/haz3lcore/dynamics/DH.re b/src/haz3lcore/dynamics/DH.re index a7150e327e..385f04cbe2 100644 --- a/src/haz3lcore/dynamics/DH.re +++ b/src/haz3lcore/dynamics/DH.re @@ -15,10 +15,10 @@ module rec DHExp: { Parens */ // TODO: Work out how to reconcile the invalids + | Invalid(string) | EmptyHole | NonEmptyHole(ErrStatus.HoleReason.t, MetaVar.t, HoleInstanceId.t, t) // TODO: Remove, use info_map /// -------------------------------------------------------------------------------------------------------- | FreeVar(MetaVar.t, HoleInstanceId.t, Var.t) // TODO: Remove, use info_map /// -------------------------------------------------------------------------------------------------------- - | InvalidText(MetaVar.t, HoleInstanceId.t, string) // DONE [ALREADY] | InvalidOperation(t, InvalidOperationError.t) // Warning will robinson | FailedCast(t, Typ.t, Typ.t) // TODO: Add to TermBase | Closure([@show.opaque] ClosureEnvironment.t, t) // > UEXP @@ -73,10 +73,10 @@ module rec DHExp: { [@deriving (show({with_path: false}), sexp, yojson)] type term = /* Hole types */ + | Invalid(string) | EmptyHole | NonEmptyHole(ErrStatus.HoleReason.t, MetaVar.t, HoleInstanceId.t, t) | FreeVar(MetaVar.t, HoleInstanceId.t, Var.t) - | InvalidText(MetaVar.t, HoleInstanceId.t, string) | InvalidOperation(t, InvalidOperationError.t) | FailedCast(t, Typ.t, Typ.t) /* Generalized closures */ @@ -167,7 +167,7 @@ module rec DHExp: { switch (term) { | EmptyHole | FreeVar(_) - | InvalidText(_) + | Invalid(_) | Var(_) | BuiltinFun(_) | Bool(_) @@ -243,7 +243,7 @@ module rec DHExp: { |> rewrap | EmptyHole as d | FreeVar(_) as d - | InvalidText(_) as d + | Invalid(_) as d | Var(_) as d | Bool(_) as d | Int(_) as d @@ -357,14 +357,13 @@ module rec DHExp: { | (FreeVar(u1, i1, x1), FreeVar(u2, i2, x2)) => u1 == u2 && i1 == i2 && x1 == x2 - | (InvalidText(u1, i1, text1), InvalidText(u2, i2, text2)) => - u1 == u2 && i1 == i2 && text1 == text2 + | (Invalid(text1), Invalid(text2)) => text1 == text2 | (Closure(sigma1, d1), Closure(sigma2, d2)) => ClosureEnvironment.id_equal(sigma1, sigma2) && fast_equal(d1, d2) | (EmptyHole, _) | (NonEmptyHole(_), _) | (FreeVar(_), _) - | (InvalidText(_), _) + | (Invalid(_), _) | (Closure(_), _) => false }; }; diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 157ab6f7fc..84d653f629 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -102,7 +102,7 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => | Let(_) | FixF(_) => d /* Hole-like forms: Don't cast */ - | InvalidText(_) + | Invalid(_) | FreeVar(_) | EmptyHole | NonEmptyHole(_) => d @@ -152,7 +152,7 @@ let rec dhexp_of_uexp = let rewrap = DHExp.mk(uexp.ids); let+ d: DHExp.t = switch (uexp.term) { - | Invalid(t) => Some(DHExp.InvalidText(id, 0, t) |> rewrap) + | Invalid(t) => Some(DHExp.Invalid(t) |> rewrap) | EmptyHole => Some(DHExp.EmptyHole |> rewrap) | MultiHole(_tms) => /* TODO: add a dhexp case and eval logic for multiholes. diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index ef7f270fb1..5fb5f9b246 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -164,7 +164,7 @@ let rec matches_exp = | (Match(_), _) => false | (NonEmptyHole(_), _) => false - | (InvalidText(_), _) => false + | (Invalid(_), _) => false | (InvalidOperation(_), _) => false | (ApBuiltin(dname, darg), ApBuiltin(fname, farg)) => diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index 6a57476c42..719d385b62 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -45,7 +45,7 @@ let rec matches = (dp: DHPat.t, d: DHExp.t): match_result => | (_, FailedCast(_)) => IndetMatch | (_, InvalidOperation(_)) => IndetMatch | (_, FreeVar(_)) => IndetMatch - | (_, InvalidText(_)) => IndetMatch + | (_, Invalid(_)) => IndetMatch | (_, Let(_)) => IndetMatch | (_, FixF(_)) => DoesNotMatch | (_, Fun(_)) => DoesNotMatch @@ -241,7 +241,7 @@ and matches_cast_Sum = | Cast(d', Unknown(_), Sum(_) | Rec(_, Sum(_))) => matches_cast_Sum(ctr, dp, d', castmaps) | FreeVar(_) - | InvalidText(_) + | Invalid(_) | Let(_) | ApBuiltin(_) | BinOp(_) @@ -327,7 +327,7 @@ and matches_cast_Tuple = | Cast(_, _, _) => DoesNotMatch | Var(_) => DoesNotMatch | FreeVar(_) => IndetMatch - | InvalidText(_) => IndetMatch + | Invalid(_) => IndetMatch | Let(_, _, _) => IndetMatch | FixF(_, _, _) => DoesNotMatch | Fun(_, _, _, _, _) => DoesNotMatch @@ -460,7 +460,7 @@ and matches_cast_Cons = | Cast(_, _, _) => DoesNotMatch | Var(_) => DoesNotMatch | FreeVar(_) => IndetMatch - | InvalidText(_) => IndetMatch + | Invalid(_) => IndetMatch | Let(_, _, _) => IndetMatch | FixF(_, _, _) => DoesNotMatch | Fun(_, _, _, _, _) => DoesNotMatch diff --git a/src/haz3lcore/dynamics/Substitution.re b/src/haz3lcore/dynamics/Substitution.re index a26f7a54cc..622cd1278c 100644 --- a/src/haz3lcore/dynamics/Substitution.re +++ b/src/haz3lcore/dynamics/Substitution.re @@ -9,7 +9,7 @@ let rec subst_var = (d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => { d2; } | FreeVar(_) => d2 - | InvalidText(_) => d2 + | Invalid(_) => d2 | Seq(d3, d4) => let d3 = subst_var(d1, x, d3); let d4 = subst_var(d1, x, d4); diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index 06f44219b9..f7c3f91e27 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -707,7 +707,7 @@ module Transition = (EV: EV_MODE) => { Indet; | EmptyHole | FreeVar(_) - | InvalidText(_) + | Invalid(_) | InvalidOperation(_) => let. _ = otherwise(env, d); Indet; diff --git a/src/haz3lweb/view/dhcode/DHCode.re b/src/haz3lweb/view/dhcode/DHCode.re index 385d74ecb0..a049ea2b4b 100644 --- a/src/haz3lweb/view/dhcode/DHCode.re +++ b/src/haz3lweb/view/dhcode/DHCode.re @@ -105,12 +105,9 @@ let view_of_layout = ds, ) | VarHole(_) => ([with_cls("InVarHole", txt)], ds) - | Invalid((_, (-666))) => - /* Evaluation and Elaboration exceptions */ - ([with_cls("exception", txt)], ds) | NonEmptyHole(_) | InconsistentBranches(_) - | Invalid(_) => + | Invalid => let offset = start.col - indent; let decoration = Decoration_common.container( diff --git a/src/haz3lweb/view/dhcode/layout/DHAnnot.re b/src/haz3lweb/view/dhcode/layout/DHAnnot.re index 361fc3730e..3d13b7c96f 100644 --- a/src/haz3lweb/view/dhcode/layout/DHAnnot.re +++ b/src/haz3lweb/view/dhcode/layout/DHAnnot.re @@ -12,7 +12,7 @@ type t = | NonEmptyHole(ErrStatus.HoleReason.t, HoleInstance.t) | VarHole(VarErrStatus.HoleReason.t, HoleInstance.t) | InconsistentBranches(HoleInstance.t) - | Invalid(HoleInstance.t) + | Invalid | FailedCastDelim | FailedCastDecoration | CastDecoration diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index d884e1e20b..46efb6d055 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -47,7 +47,7 @@ let rec precedence = (~show_casts: bool, d: DHExp.t) => { switch (DHExp.term_of(d)) { | Var(_) | FreeVar(_) - | InvalidText(_) + | Invalid(_) | Bool(_) | Int(_) | Seq(_) @@ -285,7 +285,7 @@ let mk = go'(d') |> annot(DHAnnot.NonEmptyHole(reason, (u, i))) | FreeVar(u, i, x) => text(x) |> annot(DHAnnot.VarHole(Free, (u, i))) - | InvalidText(u, i, t) => DHDoc_common.mk_InvalidText(t, (u, i)) + | Invalid(t) => DHDoc_common.mk_InvalidText(t) | Match(Inconsistent(u, i), dscrut, drs) => go_case(dscrut, drs) |> annot(DHAnnot.InconsistentBranches((u, i))) | Var(x) when List.mem(x, recursive_calls) => text(x) diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re index 1a3357e90e..0cc7c2eedb 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re @@ -39,8 +39,8 @@ let rec mk = mk'(dp) |> Doc.annot(DHAnnot.NonEmptyHole(reason, (u, i))) | ExpandingKeyword(u, i, k) => DHDoc_common.mk_ExpandingKeyword((u, i), k) - | InvalidText(u, i, t) => DHDoc_common.mk_InvalidText(t, (u, i)) - | BadConstructor(u, i, t) => DHDoc_common.mk_InvalidText(t, (u, i)) + | InvalidText(_, _, t) => DHDoc_common.mk_InvalidText(t) + | BadConstructor(_, _, t) => DHDoc_common.mk_InvalidText(t) | Var(x) => Doc.text(x) | Wild => DHDoc_common.Delim.wild | Constructor(name) => DHDoc_common.mk_ConstructorLit(name) diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_common.re b/src/haz3lweb/view/dhcode/layout/DHDoc_common.re index de5adcbd4f..d777d72f35 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_common.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_common.re @@ -93,8 +93,7 @@ let mk_ExpandingKeyword = (hc, k) => Doc.text(ExpandingKeyword.to_string(k)) |> Doc.annot(DHAnnot.VarHole(ExpandingKeyword(k), hc)); -let mk_InvalidText = (t, hc) => - Doc.text(t) |> Doc.annot(DHAnnot.Invalid(hc)); +let mk_InvalidText = t => Doc.text(t) |> Doc.annot(DHAnnot.Invalid); let mk_Sequence = (doc1, doc2) => Doc.(hcats([doc1, linebreak(), doc2])); diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_common.rei b/src/haz3lweb/view/dhcode/layout/DHDoc_common.rei index dacaa16b30..ccb721c2b7 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_common.rei +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_common.rei @@ -67,7 +67,7 @@ let mk_EmptyHole: let mk_ExpandingKeyword: (HoleInstance.t, ExpandingKeyword.t) => Pretty.Doc.t(DHAnnot.t); -let mk_InvalidText: (string, HoleInstance.t) => Pretty.Doc.t(DHAnnot.t); +let mk_InvalidText: string => Pretty.Doc.t(DHAnnot.t); let mk_Sequence: (Pretty.Doc.t('a), Pretty.Doc.t('a)) => Pretty.Doc.t('a); From 19cd211fde0fd6d3abc8b289815ba3b75e62d34d Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Fri, 23 Feb 2024 16:31:11 -0500 Subject: [PATCH 020/103] Add MultiHole to DHexp --- src/haz3lcore/dynamics/DH.re | 9 +++++++- src/haz3lcore/dynamics/Elaborator.re | 24 ++++++++++++++++---- src/haz3lcore/dynamics/EvalCtx.re | 4 ++++ src/haz3lcore/dynamics/FilterMatcher.re | 3 ++- src/haz3lcore/dynamics/PatternMatch.re | 3 +++ src/haz3lcore/dynamics/Stepper.re | 3 +++ src/haz3lcore/dynamics/Substitution.re | 1 + src/haz3lcore/dynamics/Transition.re | 9 ++++++++ src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 2 ++ 9 files changed, 51 insertions(+), 7 deletions(-) diff --git a/src/haz3lcore/dynamics/DH.re b/src/haz3lcore/dynamics/DH.re index 385f04cbe2..6c97958f31 100644 --- a/src/haz3lcore/dynamics/DH.re +++ b/src/haz3lcore/dynamics/DH.re @@ -17,6 +17,7 @@ module rec DHExp: { // TODO: Work out how to reconcile the invalids | Invalid(string) | EmptyHole + | MultiHole(list(DHExp.t)) | NonEmptyHole(ErrStatus.HoleReason.t, MetaVar.t, HoleInstanceId.t, t) // TODO: Remove, use info_map /// -------------------------------------------------------------------------------------------------------- | FreeVar(MetaVar.t, HoleInstanceId.t, Var.t) // TODO: Remove, use info_map /// -------------------------------------------------------------------------------------------------------- | InvalidOperation(t, InvalidOperationError.t) // Warning will robinson @@ -75,6 +76,7 @@ module rec DHExp: { /* Hole types */ | Invalid(string) | EmptyHole + | MultiHole(list(DHExp.t)) | NonEmptyHole(ErrStatus.HoleReason.t, MetaVar.t, HoleInstanceId.t, t) | FreeVar(MetaVar.t, HoleInstanceId.t, Var.t) | InvalidOperation(t, InvalidOperationError.t) @@ -193,6 +195,7 @@ module rec DHExp: { | Cons(d1, d2) => Cons(repair_ids(d1), repair_ids(d2)) | ListConcat(d1, d2) => ListConcat(repair_ids(d1), repair_ids(d2)) | Tuple(ds) => Tuple(List.map(repair_ids, ds)) + | MultiHole(ds) => MultiHole(List.map(repair_ids, ds)) | Match(c, d1, rls) => Match( c, @@ -221,6 +224,7 @@ module rec DHExp: { ListConcat(strip_casts(d1), strip_casts(d2)) |> rewrap | ListLit(a, b, c, ds) => ListLit(a, b, c, List.map(strip_casts, ds)) |> rewrap + | MultiHole(ds) => MultiHole(List.map(strip_casts, ds)) |> rewrap | NonEmptyHole(err, u, i, d) => NonEmptyHole(err, u, i, strip_casts(d)) |> rewrap | Seq(a, b) => Seq(strip_casts(a), strip_casts(b)) |> rewrap @@ -352,15 +356,18 @@ module rec DHExp: { (This resolves a performance issue with many nested holes.) */ | (EmptyHole, EmptyHole) => true + | (MultiHole(ds1), MultiHole(ds2)) => + List.length(ds1) == List.length(ds2) + && List.for_all2(fast_equal, ds1, ds2) | (NonEmptyHole(reason1, u1, i1, d1), NonEmptyHole(reason2, u2, i2, d2)) => reason1 == reason2 && u1 == u2 && i1 == i2 && fast_equal(d1, d2) - | (FreeVar(u1, i1, x1), FreeVar(u2, i2, x2)) => u1 == u2 && i1 == i2 && x1 == x2 | (Invalid(text1), Invalid(text2)) => text1 == text2 | (Closure(sigma1, d1), Closure(sigma2, d2)) => ClosureEnvironment.id_equal(sigma1, sigma2) && fast_equal(d1, d2) | (EmptyHole, _) + | (MultiHole(_), _) | (NonEmptyHole(_), _) | (FreeVar(_), _) | (Invalid(_), _) diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 84d653f629..2053bf933b 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -105,6 +105,7 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => | Invalid(_) | FreeVar(_) | EmptyHole + | MultiHole(_) | NonEmptyHole(_) => d /* DHExp-specific forms: Don't cast */ | Cast(_) @@ -154,11 +155,24 @@ let rec dhexp_of_uexp = switch (uexp.term) { | Invalid(t) => Some(DHExp.Invalid(t) |> rewrap) | EmptyHole => Some(DHExp.EmptyHole |> rewrap) - | MultiHole(_tms) => - /* TODO: add a dhexp case and eval logic for multiholes. - Make sure new dhexp form is properly considered Indet - to avoid casting issues. */ - Some(EmptyHole |> rewrap) + | MultiHole(us: list(TermBase.Any.t)) => + switch ( + us + |> List.filter_map( + fun + | TermBase.Any.Exp(x) => Some(x) + | _ => None, + ) + ) { + | [] => Some(DHExp.EmptyHole |> rewrap) + | us => + let+ ds = us |> List.map(dhexp_of_uexp(m)) |> OptUtil.sequence; + DHExp.MultiHole(ds) |> rewrap; + } + + /* TODO: add a dhexp case and eval logic for multiholes. + Make sure new dhexp form is properly considered Indet + to avoid casting issues. */ | Bool(b) => Some(Bool(b) |> rewrap) | Int(n) => Some(Int(n) |> rewrap) | Float(n) => Some(Float(n) |> rewrap) diff --git a/src/haz3lcore/dynamics/EvalCtx.re b/src/haz3lcore/dynamics/EvalCtx.re index 19d23d98d5..3c52c8d052 100644 --- a/src/haz3lcore/dynamics/EvalCtx.re +++ b/src/haz3lcore/dynamics/EvalCtx.re @@ -29,6 +29,7 @@ type term = t, (list(DHExp.t), list(DHExp.t)), ) + | MultiHole(t, (list(DHExp.t), list(DHExp.t))) | Cons1(t, DHExp.t) | Cons2(DHExp.t, t) | ListConcat1(t, DHExp.t) @@ -116,6 +117,9 @@ let rec compose = (ctx: t, d: DHExp.t): DHExp.t => { | ListLit(m, i, t, ctx, (ld, rd)) => let d = compose(ctx, d); ListLit(m, i, t, ListUtil.rev_concat(ld, [d, ...rd])) |> wrap; + | MultiHole(ctx, (ld, rd)) => + let d = compose(ctx, d); + MultiHole(ListUtil.rev_concat(ld, [d, ...rd])) |> wrap; | Let1(dp, ctx, d2) => let d = compose(ctx, d); Let(dp, d, d2) |> wrap; diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index 5fb5f9b246..8c9bf4ad55 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -162,7 +162,8 @@ let rec matches_exp = } ) | (Match(_), _) => false - + // TODO: should these not default to false? + | (MultiHole(_), _) => false | (NonEmptyHole(_), _) => false | (Invalid(_), _) => false | (InvalidOperation(_), _) => false diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index 719d385b62..905ec495c4 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -246,6 +246,7 @@ and matches_cast_Sum = | ApBuiltin(_) | BinOp(_) | EmptyHole + | MultiHole(_) | NonEmptyHole(_) | FailedCast(_, _, _) | Test(_) @@ -349,6 +350,7 @@ and matches_cast_Tuple = | Constructor(_) => DoesNotMatch | Match(_) => IndetMatch | EmptyHole => IndetMatch + | MultiHole(_) => IndetMatch | NonEmptyHole(_) => IndetMatch | FailedCast(_, _, _) => IndetMatch | InvalidOperation(_) => IndetMatch @@ -481,6 +483,7 @@ and matches_cast_Cons = | Constructor(_) => DoesNotMatch | Match(_) => IndetMatch | EmptyHole => IndetMatch + | MultiHole(_) => IndetMatch | NonEmptyHole(_) => IndetMatch | FailedCast(_, _, _) => IndetMatch | InvalidOperation(_) => IndetMatch diff --git a/src/haz3lcore/dynamics/Stepper.re b/src/haz3lcore/dynamics/Stepper.re index 27559b93ee..9127e5b1c9 100644 --- a/src/haz3lcore/dynamics/Stepper.re +++ b/src/haz3lcore/dynamics/Stepper.re @@ -139,6 +139,9 @@ let rec matches = | ListConcat2(d1, ctx) => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); ListConcat2(d1, ctx) |> rewrap; + | MultiHole(ctx, (dl, dr)) => + let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); + MultiHole(ctx, (dl, dr)) |> rewrap; | NonEmptyHole(e, u, i, ctx) => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); NonEmptyHole(e, u, i, ctx) |> rewrap; diff --git a/src/haz3lcore/dynamics/Substitution.re b/src/haz3lcore/dynamics/Substitution.re index 622cd1278c..8c5bff860d 100644 --- a/src/haz3lcore/dynamics/Substitution.re +++ b/src/haz3lcore/dynamics/Substitution.re @@ -94,6 +94,7 @@ let rec subst_var = (d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => { ); Match(c, ds, rules) |> rewrap; | EmptyHole => EmptyHole |> rewrap + | MultiHole(ds) => MultiHole(List.map(subst_var(d1, x), ds)) |> rewrap | NonEmptyHole(reason, u, i, d3) => let d3' = subst_var(d1, x, d3); NonEmptyHole(reason, u, i, d3') |> rewrap; diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index f7c3f91e27..703250085d 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -705,6 +705,15 @@ module Transition = (EV: EV_MODE) => { d1, ); Indet; + | MultiHole(ds) => + let. _ = otherwise(env, ds => MultiHole(ds) |> rewrap) + and. _ = + req_all_final( + req(state, env), + (d1, ds) => MultiHole(d1, ds) |> wrap_ctx, + ds, + ); + Indet; | EmptyHole | FreeVar(_) | Invalid(_) diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index 46efb6d055..85332fc930 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -80,6 +80,7 @@ let rec precedence = (~show_casts: bool, d: DHExp.t) => { | BinOp(Float(op), _, _) => precedence_bin_float_op(op) | BinOp(String(op), _, _) => precedence_bin_string_op(op) + | MultiHole(_) => DHDoc_common.precedence_max | NonEmptyHole(_, _, _, d) => precedence'(d) }; }; @@ -281,6 +282,7 @@ let mk = ~selected=Some(DHExp.rep_id(d)) == selected_hole_instance, env, ) + | MultiHole(ds) => ds |> List.map(go') |> Doc.hcats | NonEmptyHole(reason, u, i, d') => go'(d') |> annot(DHAnnot.NonEmptyHole(reason, (u, i))) | FreeVar(u, i, x) => From 841207b178a973ee7e63fc224cab6bbef1958c11 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Mon, 26 Feb 2024 11:19:56 -0500 Subject: [PATCH 021/103] Remove set_info_map --- src/haz3lcore/dynamics/Evaluator.re | 3 --- src/haz3lcore/dynamics/EvaluatorStep.re | 6 ------ src/haz3lcore/dynamics/Transition.re | 1 - src/haz3lcore/dynamics/ValueChecker.re | 2 -- 4 files changed, 12 deletions(-) diff --git a/src/haz3lcore/dynamics/Evaluator.re b/src/haz3lcore/dynamics/Evaluator.re index d4da3132f4..eb7d628c81 100644 --- a/src/haz3lcore/dynamics/Evaluator.re +++ b/src/haz3lcore/dynamics/Evaluator.re @@ -36,9 +36,6 @@ module EvaluatorEVMode: { let get_info_map = (state: state) => EvaluatorState.get_info_map(state^); - let set_info_map = (info_map: Statics.Map.t, state: state) => - state := EvaluatorState.put_info_map(info_map, state^); - type result_unfinished = | BoxedValue(DHExp.t) | Indet(DHExp.t) diff --git a/src/haz3lcore/dynamics/EvaluatorStep.re b/src/haz3lcore/dynamics/EvaluatorStep.re index dac1118036..0205aa3c5b 100644 --- a/src/haz3lcore/dynamics/EvaluatorStep.re +++ b/src/haz3lcore/dynamics/EvaluatorStep.re @@ -140,9 +140,6 @@ module Decompose = { let update_test = (state, id, v) => state := EvaluatorState.add_test(state^, id, v); let get_info_map = (state: state) => EvaluatorState.get_info_map(state^); - - let set_info_map = (info_map: Statics.Map.t, state: state) => - state := EvaluatorState.put_info_map(info_map, state^); }; module Decomp = Transition(DecomposeEVMode); @@ -200,9 +197,6 @@ module TakeStep = { let update_test = (state, id, v) => state := EvaluatorState.add_test(state^, id, v); let get_info_map = (state: state) => EvaluatorState.get_info_map(state^); - - let set_info_map = (info_map: Statics.Map.t, state: state) => - state := EvaluatorState.put_info_map(info_map, state^); }; module TakeStepEV = Transition(TakeStepEVMode); diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index 703250085d..75e9a78436 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -183,7 +183,6 @@ module type EV_MODE = { let update_test: (state, KeywordID.t, TestMap.instance_report) => unit; let get_info_map: state => Statics.Map.t; - let set_info_map: (Statics.Map.t, state) => unit; }; module Transition = (EV: EV_MODE) => { diff --git a/src/haz3lcore/dynamics/ValueChecker.re b/src/haz3lcore/dynamics/ValueChecker.re index b9feb99509..4164634a99 100644 --- a/src/haz3lcore/dynamics/ValueChecker.re +++ b/src/haz3lcore/dynamics/ValueChecker.re @@ -73,8 +73,6 @@ module ValueCheckerEVMode: { let update_test = (_, _, _) => (); let get_info_map = (info_map: state) => info_map; - - let set_info_map = (_, _) => (); }; module CV = Transition(ValueCheckerEVMode); From f5feb7a15f7e0e8cd1c15ccab2dfc673adb549ba Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Mon, 26 Feb 2024 11:46:09 -0500 Subject: [PATCH 022/103] DHPat renamings --- src/haz3lcore/dynamics/DHPat.re | 64 ++++++++++++-------- src/haz3lcore/dynamics/Elaborator.re | 45 +++++++------- src/haz3lcore/dynamics/FilterMatcher.re | 12 ++-- src/haz3lcore/dynamics/PatternMatch.re | 26 ++++---- src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re | 14 ++--- src/test/Test_Elaboration.re | 8 +-- 6 files changed, 94 insertions(+), 75 deletions(-) diff --git a/src/haz3lcore/dynamics/DHPat.re b/src/haz3lcore/dynamics/DHPat.re index 9b30cccb2d..cb49d0573b 100644 --- a/src/haz3lcore/dynamics/DHPat.re +++ b/src/haz3lcore/dynamics/DHPat.re @@ -1,36 +1,52 @@ open Sexplib.Std; [@deriving (show({with_path: false}), sexp, yojson)] -type t = - | EmptyHole(MetaVar.t, MetaVarInst.t) - // TODO: Work out what to do with invalids - | NonEmptyHole(ErrStatus.HoleReason.t, MetaVar.t, MetaVarInst.t, t) - | ExpandingKeyword(MetaVar.t, MetaVarInst.t, ExpandingKeyword.t) - // Same +type term = + | Invalid(string) + | EmptyHole + // TODO: Multihole | Wild | Int(int) | Float(float) | Bool(bool) | String(string) - // TODO: - | InvalidText(MetaVar.t, MetaVarInst.t, string) - | BadConstructor(MetaVar.t, MetaVarInst.t, string) - | Var(Var.t) - | ListLit(Typ.t, list(t)) + // TODO: Remove Triv from UPat + | ListLit(list(t)) + | Constructor(string) | Cons(t, t) + | Var(Var.t) | Tuple(list(t)) - | Constructor(string) - | Ap(t, t); + // TODO: parens + | Ap(t, t) + // TODO: Add Type Annotations??? + // TODO: Work out what to do with invalids + | NonEmptyHole(ErrStatus.HoleReason.t, MetaVar.t, MetaVarInst.t, t) + | ExpandingKeyword(MetaVar.t, MetaVarInst.t, ExpandingKeyword.t) + | BadConstructor(MetaVar.t, MetaVarInst.t, string) +and t = { + ids: list(Id.t), + copied: bool, + term, +}; + +let rep_id = ({ids, _}) => List.hd(ids); +let term_of = ({term, _}) => term; +let fast_copy = (id, {term, _}) => {ids: [id], term, copied: true}; +// All children of term must have expression-unique ids. +let unwrap = ({ids, term, copied}) => (term, term => {ids, term, copied}); +let fresh = term => { + {ids: [Id.mk()], copied: false, term}; +}; /** * Whether dp contains the variable x outside of a hole. */ let rec binds_var = (x: Var.t, dp: t): bool => - switch (dp) { - | EmptyHole(_, _) + switch (dp |> term_of) { + | EmptyHole | NonEmptyHole(_, _, _, _) | Wild - | InvalidText(_) + | Invalid(_) | BadConstructor(_) | Int(_) | Float(_) @@ -41,18 +57,18 @@ let rec binds_var = (x: Var.t, dp: t): bool => | Var(y) => Var.eq(x, y) | Tuple(dps) => dps |> List.exists(binds_var(x)) | Cons(dp1, dp2) => binds_var(x, dp1) || binds_var(x, dp2) - | ListLit(_, d_list) => + | ListLit(d_list) => let new_list = List.map(binds_var(x), d_list); List.fold_left((||), false, new_list); | Ap(_, _) => false }; let rec bound_vars = (dp: t): list(Var.t) => - switch (dp) { - | EmptyHole(_, _) + switch (dp |> term_of) { + | EmptyHole | NonEmptyHole(_, _, _, _) | Wild - | InvalidText(_) + | Invalid(_) | BadConstructor(_) | Int(_) | Float(_) @@ -63,12 +79,12 @@ let rec bound_vars = (dp: t): list(Var.t) => | Var(y) => [y] | Tuple(dps) => List.flatten(List.map(bound_vars, dps)) | Cons(dp1, dp2) => bound_vars(dp1) @ bound_vars(dp2) - | ListLit(_, dps) => List.flatten(List.map(bound_vars, dps)) + | ListLit(dps) => List.flatten(List.map(bound_vars, dps)) | Ap(_, dp1) => bound_vars(dp1) }; let get_var = (pat: t) => { - switch (pat) { + switch (pat |> term_of) { | Var(x) => Some(x) | Wild | Int(_) @@ -79,10 +95,10 @@ let get_var = (pat: t) => { | Cons(_, _) | Tuple(_) | Constructor(_) - | EmptyHole(_) + | EmptyHole | NonEmptyHole(_) | ExpandingKeyword(_) - | InvalidText(_) + | Invalid(_) | BadConstructor(_) | Ap(_) => None }; diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 2053bf933b..5afe652c2f 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -210,8 +210,8 @@ let rec dhexp_of_uexp = | UnOp(Bool(Not), e) => let+ d_scrut = dhexp_of_uexp(m, e); let d_rules = [ - (DHPat.Bool(true), DHExp.(fresh(Bool(false)))), - (DHPat.Bool(false), DHExp.(fresh(Bool(true)))), + (DHPat.(fresh(Bool(true))), DHExp.(fresh(Bool(false)))), + (DHPat.(fresh(Bool(false))), DHExp.(fresh(Bool(true)))), ]; let d = DHExp.(fresh(Match(Consistent, d_scrut, d_rules))); /* Manually construct cast (case is not otherwise cast) */ @@ -334,43 +334,46 @@ and dhpat_of_upat = (m: Statics.Map.t, upat: Term.UPat.t): option(DHPat.t) => { let wrap = (d: DHPat.t): option(DHPat.t) => switch (maybe_reason) { | None => Some(d) - | Some(reason) => Some(NonEmptyHole(reason, u, 0, d)) + | Some(reason) => Some(NonEmptyHole(reason, u, 0, d) |> DHPat.fresh) }; - switch (upat.term) { - | Invalid(t) => Some(DHPat.InvalidText(u, 0, t)) - | EmptyHole => Some(EmptyHole(u, 0)) + let (pterm, prewrap) = ( + upat.term, + ((term) => ({ids: upat.ids, copied: false, term}: DHPat.t)), + ); + switch (pterm) { + | Invalid(t) => Some(DHPat.Invalid(t) |> prewrap) + | EmptyHole => Some(EmptyHole |> prewrap) | MultiHole(_) => // TODO: dhexp, eval for multiholes - Some(EmptyHole(u, 0)) - | Wild => wrap(Wild) - | Bool(b) => wrap(Bool(b)) - | Int(n) => wrap(Int(n)) - | Float(n) => wrap(Float(n)) - | String(s) => wrap(String(s)) - | Triv => wrap(Tuple([])) + Some(EmptyHole |> prewrap) + | Wild => wrap(Wild |> prewrap) + | Bool(b) => wrap(Bool(b) |> prewrap) + | Int(n) => wrap(Int(n) |> prewrap) + | Float(n) => wrap(Float(n) |> prewrap) + | String(s) => wrap(String(s) |> prewrap) + | Triv => wrap(Tuple([]) |> prewrap) | ListLit(ps) => let* ds = ps |> List.map(dhpat_of_upat(m)) |> OptUtil.sequence; - let* ty = fixed_pat_typ(m, upat); - wrap(ListLit(Typ.matched_list(ctx, ty), ds)); + wrap(ListLit(ds) |> prewrap); | Constructor(name) => switch (err_status) { | InHole(Common(NoType(FreeConstructor(_)))) => - Some(BadConstructor(u, 0, name)) - | _ => wrap(Constructor(name)) + Some(BadConstructor(u, 0, name) |> prewrap) + | _ => wrap(Constructor(name) |> prewrap) } | Cons(hd, tl) => let* d_hd = dhpat_of_upat(m, hd); let* d_tl = dhpat_of_upat(m, tl); - wrap(Cons(d_hd, d_tl)); + wrap(Cons(d_hd, d_tl) |> prewrap); | Tuple(ps) => let* ds = ps |> List.map(dhpat_of_upat(m)) |> OptUtil.sequence; - wrap(DHPat.Tuple(ds)); - | Var(name) => Some(Var(name)) + wrap(DHPat.Tuple(ds) |> prewrap); + | Var(name) => Some(Var(name) |> prewrap) | Parens(p) => dhpat_of_upat(m, p) | Ap(p1, p2) => let* d_p1 = dhpat_of_upat(m, p1); let* d_p2 = dhpat_of_upat(m, p2); - wrap(Ap(d_p1, d_p2)); + wrap(Ap(d_p1, d_p2) |> prewrap); | TypeAnn(p, _ty) => let* dp = dhpat_of_upat(m, p); wrap(dp); diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index 8c9bf4ad55..59a1459455 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -174,8 +174,8 @@ let rec matches_exp = }; } and matches_pat = (d: DHPat.t, f: DHPat.t): bool => { - switch (d, f) { - | (_, EmptyHole(_)) => true + switch (d |> DHPat.term_of, f |> DHPat.term_of) { + | (_, EmptyHole) => true | (Wild, Wild) => true | (Wild, _) => false | (Int(dv), Int(fv)) => dv == fv @@ -186,12 +186,12 @@ and matches_pat = (d: DHPat.t, f: DHPat.t): bool => { | (Bool(_), _) => false | (String(dv), String(fv)) => dv == fv | (String(_), _) => false - | (ListLit(dty1, dl), ListLit(fty1, fl)) => + | (ListLit(dl), ListLit(fl)) => switch ( List.fold_left2((res, d, f) => res && matches_pat(d, f), true, dl, fl) ) { | exception (Invalid_argument(_)) => false - | res => matches_typ(dty1, fty1) && res + | res => res } | (ListLit(_), _) => false | (Constructor(dt), Constructor(ft)) => dt == ft @@ -213,10 +213,10 @@ and matches_pat = (d: DHPat.t, f: DHPat.t): bool => { | (Cons(d1, d2), Cons(f1, f2)) => matches_pat(d1, f1) && matches_pat(d2, f2) | (Cons(_), _) => false - | (EmptyHole(_), _) => false + | (EmptyHole, _) => false | (NonEmptyHole(_), _) => false | (ExpandingKeyword(_), _) => false - | (InvalidText(_), _) => false + | (Invalid(_), _) => false }; } and matches_typ = (d: Typ.t, f: Typ.t) => { diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index 905ec495c4..a1718c328a 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -29,13 +29,13 @@ let cast_sum_maps = }; let rec matches = (dp: DHPat.t, d: DHExp.t): match_result => - switch (dp, DHExp.term_of(d)) { + switch (DHPat.term_of(dp), DHExp.term_of(d)) { | (_, Var(_)) => DoesNotMatch - | (EmptyHole(_), _) + | (EmptyHole, _) | (NonEmptyHole(_), _) => IndetMatch | (Wild, _) => Matches(Environment.empty) | (ExpandingKeyword(_), _) => DoesNotMatch - | (InvalidText(_), _) => IndetMatch + | (Invalid(_), _) => IndetMatch | (BadConstructor(_), _) => IndetMatch | (Var(x), _) => let env = Environment.extend(Environment.empty, (x, d)); @@ -110,7 +110,7 @@ let rec matches = (dp: DHPat.t, d: DHExp.t): match_result => } } | ( - Ap(Constructor(ctr), dp_opt), + Ap({term: Constructor(ctr), _}, dp_opt), Cast(d, Sum(sm1) | Rec(_, Sum(sm1)), Sum(sm2) | Rec(_, Sum(sm2))), ) => switch (cast_sum_maps(sm1, sm2)) { @@ -194,7 +194,7 @@ let rec matches = (dp: DHPat.t, d: DHExp.t): match_result => | (Cons(_) | ListLit(_), Cast(d, List(ty1), Unknown(_))) => matches_cast_Cons(dp, d, [(ty1, Unknown(Internal))]) | (Cons(_, _), Cons(_, _)) - | (ListLit(_, _), Cons(_, _)) + | (ListLit(_), Cons(_, _)) | (Cons(_, _), ListLit(_)) | (ListLit(_), ListLit(_)) => matches_cast_Cons(dp, d, []) | (Cons(_) | ListLit(_), _) => DoesNotMatch @@ -360,12 +360,12 @@ and matches_cast_Cons = (dp: DHPat.t, d: DHExp.t, elt_casts: list((Typ.t, Typ.t))): match_result => switch (DHExp.term_of(d)) { | ListLit(_, _, _, []) => - switch (dp) { - | ListLit(_, []) => Matches(Environment.empty) + switch (DHPat.term_of(dp)) { + | ListLit([]) => Matches(Environment.empty) | _ => DoesNotMatch } | ListLit(u, i, ty, [dhd, ...dtl] as ds) => - switch (dp) { + switch (DHPat.term_of(dp)) { | Cons(dp1, dp2) => switch (matches(dp1, DHExp.apply_casts(dhd, elt_casts))) { | DoesNotMatch => DoesNotMatch @@ -386,7 +386,7 @@ and matches_cast_Cons = | Matches(env2) => Matches(Environment.union(env1, env2)) }; } - | ListLit(_, dps) => + | ListLit(dps) => switch (ListUtil.opt_zip(dps, ds)) { | None => DoesNotMatch | Some(lst) => @@ -410,7 +410,7 @@ and matches_cast_Cons = | _ => failwith("called matches_cast_Cons with non-list pattern") } | Cons(d1, d2) => - switch (dp) { + switch (DHPat.term_of(dp)) { | Cons(dp1, dp2) => switch (matches(dp1, DHExp.apply_casts(d1, elt_casts))) { | DoesNotMatch => DoesNotMatch @@ -430,8 +430,8 @@ and matches_cast_Cons = | Matches(env2) => Matches(Environment.union(env1, env2)) }; } - | ListLit(_, []) => DoesNotMatch - | ListLit(ty, [dphd, ...dptl]) => + | ListLit([]) => DoesNotMatch + | ListLit([dphd, ...dptl]) => switch (matches(dphd, DHExp.apply_casts(d1, elt_casts))) { | DoesNotMatch => DoesNotMatch | IndetMatch => IndetMatch @@ -444,7 +444,7 @@ and matches_cast_Cons = }, elt_casts, ); - let dp2 = DHPat.ListLit(ty, dptl); + let dp2 = DHPat.ListLit(dptl) |> DHPat.fresh; switch (matches(dp2, DHExp.apply_casts(d2, list_casts))) { | DoesNotMatch => DoesNotMatch | IndetMatch => IndetMatch diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re index 0cc7c2eedb..f006e73337 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re @@ -2,12 +2,12 @@ open Pretty; open Haz3lcore; let precedence = (dp: DHPat.t) => - switch (dp) { - | EmptyHole(_) + switch (DHPat.term_of(dp)) { + | EmptyHole | NonEmptyHole(_) | Wild | ExpandingKeyword(_) - | InvalidText(_) + | Invalid(_) | BadConstructor(_) | Var(_) | Int(_) @@ -33,13 +33,13 @@ let rec mk = mk'(~parenthesize=precedence(dp2) > precedence_op, dp2), ); let doc = - switch (dp) { - | EmptyHole(_, _) => DHDoc_common.mk_EmptyHole(ClosureEnvironment.empty) + switch (DHPat.term_of(dp)) { + | EmptyHole => DHDoc_common.mk_EmptyHole(ClosureEnvironment.empty) | NonEmptyHole(reason, u, i, dp) => mk'(dp) |> Doc.annot(DHAnnot.NonEmptyHole(reason, (u, i))) | ExpandingKeyword(u, i, k) => DHDoc_common.mk_ExpandingKeyword((u, i), k) - | InvalidText(_, _, t) => DHDoc_common.mk_InvalidText(t) + | Invalid(t) => DHDoc_common.mk_InvalidText(t) | BadConstructor(_, _, t) => DHDoc_common.mk_InvalidText(t) | Var(x) => Doc.text(x) | Wild => DHDoc_common.Delim.wild @@ -48,7 +48,7 @@ let rec mk = | Float(f) => DHDoc_common.mk_FloatLit(f) | Bool(b) => DHDoc_common.mk_BoolLit(b) | String(s) => DHDoc_common.mk_StringLit(s) - | ListLit(_, d_list) => + | ListLit(d_list) => let ol = List.map(mk', d_list); DHDoc_common.mk_ListLit(ol); | Cons(dp1, dp2) => diff --git a/src/test/Test_Elaboration.re b/src/test/Test_Elaboration.re index a52acee358..8406000451 100644 --- a/src/test/Test_Elaboration.re +++ b/src/test/Test_Elaboration.re @@ -88,7 +88,7 @@ let u4: Term.UExp.t = { }; let d4: DHExp.t = Let( - Tuple([Var("a"), Var("b")]), + Tuple([Var("a") |> DHPat.fresh, Var("b") |> DHPat.fresh]) |> DHPat.fresh, Tuple([Int(4) |> fresh, Int(6) |> fresh]) |> fresh, BinOp(Int(Minus), Var("a") |> fresh, Var("b") |> fresh) |> fresh, ) @@ -177,7 +177,7 @@ let d7: DHExp.t = Ap( Forward, Fun( - Var("x"), + Var("x") |> DHPat.fresh, Unknown(Internal), BinOp( Int(Plus), @@ -234,8 +234,8 @@ let d8scrut: DHExp.t = BinOp(Int(Equals), Int(4) |> fresh, Int(3) |> fresh) |> fresh; let d8rules = DHExp.[ - (Bool(true): DHPat.t, Int(24) |> fresh), - (Bool(false): DHPat.t, Bool(false) |> fresh), + (Bool(true) |> DHPat.fresh, Int(24) |> fresh), + (Bool(false) |> DHPat.fresh, Bool(false) |> fresh), ]; let d8a: DHExp.t = Match(Inconsistent(id_at(0), 0), d8scrut, d8rules) |> fresh; From 31482d6d59fee46dd22f7660630bdff50752e85b Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Mon, 26 Feb 2024 16:03:39 -0500 Subject: [PATCH 023/103] Remove Triv --- src/haz3lcore/dynamics/Elaborator.re | 1 - src/haz3lcore/statics/MakeTerm.re | 2 +- src/haz3lcore/statics/Statics.re | 1 - src/haz3lcore/statics/Term.re | 9 --------- src/haz3lcore/statics/TermBase.re | 4 ---- src/haz3lschool/SyntaxTest.re | 4 +--- src/haz3lweb/view/ExplainThis.re | 7 +++---- 7 files changed, 5 insertions(+), 23 deletions(-) diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 5afe652c2f..88027e112d 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -351,7 +351,6 @@ and dhpat_of_upat = (m: Statics.Map.t, upat: Term.UPat.t): option(DHPat.t) => { | Int(n) => wrap(Int(n) |> prewrap) | Float(n) => wrap(Float(n) |> prewrap) | String(s) => wrap(String(s) |> prewrap) - | Triv => wrap(Tuple([]) |> prewrap) | ListLit(ps) => let* ds = ps |> List.map(dhpat_of_upat(m)) |> OptUtil.sequence; wrap(ListLit(ds) |> prewrap); diff --git a/src/haz3lcore/statics/MakeTerm.re b/src/haz3lcore/statics/MakeTerm.re index cfa58652ab..a899a10ed2 100644 --- a/src/haz3lcore/statics/MakeTerm.re +++ b/src/haz3lcore/statics/MakeTerm.re @@ -275,7 +275,7 @@ and pat_term: unsorted => (UPat.term, list(Id.t)) = { | ([(_id, tile)], []) => ret( switch (tile) { - | ([t], []) when Form.is_empty_tuple(t) => Triv + | ([t], []) when Form.is_empty_tuple(t) => Tuple([]) | ([t], []) when Form.is_empty_list(t) => ListLit([]) | ([t], []) when Form.is_bool(t) => Bool(bool_of_string(t)) | ([t], []) when Form.is_float(t) => Float(float_of_string(t)) diff --git a/src/haz3lcore/statics/Statics.re b/src/haz3lcore/statics/Statics.re index 4de748e764..63dd4e9c4c 100644 --- a/src/haz3lcore/statics/Statics.re +++ b/src/haz3lcore/statics/Statics.re @@ -490,7 +490,6 @@ and upat_to_info_map = | EmptyHole => atomic(Just(unknown)) | Int(_) => atomic(Just(Int)) | Float(_) => atomic(Just(Float)) - | Triv => atomic(Just(Prod([]))) | Bool(_) => atomic(Just(Bool)) | String(_) => atomic(Just(String)) | ListLit(ps) => diff --git a/src/haz3lcore/statics/Term.re b/src/haz3lcore/statics/Term.re index ab1bdab24d..ff4c9cf7ed 100644 --- a/src/haz3lcore/statics/Term.re +++ b/src/haz3lcore/statics/Term.re @@ -196,7 +196,6 @@ module UPat = { | Float | Bool | String - | Triv | ListLit | Constructor | Cons @@ -229,7 +228,6 @@ module UPat = { | Float(_) => Float | Bool(_) => Bool | String(_) => String - | Triv => Triv | ListLit(_) => ListLit | Constructor(_) => Constructor | Cons(_) => Cons @@ -249,7 +247,6 @@ module UPat = { | Float => "Float literal" | Bool => "Boolean literal" | String => "String literal" - | Triv => "Trivial literal" | ListLit => "List literal" | Constructor => "Constructor" | Cons => "Cons" @@ -272,7 +269,6 @@ module UPat = { | Float(_) | Bool(_) | String(_) - | Triv | ListLit(_) | Cons(_, _) | Tuple(_) @@ -293,7 +289,6 @@ module UPat = { | Float(_) | Bool(_) | String(_) - | Triv | ListLit(_) | Cons(_, _) | Var(_) @@ -317,7 +312,6 @@ module UPat = { | Float(_) | Bool(_) | String(_) - | Triv | ListLit(_) | Cons(_, _) | Var(_) @@ -340,7 +334,6 @@ module UPat = { | Float(_) | Bool(_) | String(_) - | Triv | ListLit(_) | Cons(_, _) | Tuple(_) @@ -366,7 +359,6 @@ module UPat = { | Float(_) | Bool(_) | String(_) - | Triv | ListLit(_) | Cons(_, _) | Var(_) @@ -397,7 +389,6 @@ module UPat = { | Float(_) | Bool(_) | String(_) - | Triv | ListLit(_) | Cons(_, _) | Var(_) diff --git a/src/haz3lcore/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index 8d7dfd7dd5..3f3fc2fe12 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -112,7 +112,6 @@ and UExp: { | Invalid | EmptyHole | MultiHole - | Triv | Bool | Int | Float @@ -247,7 +246,6 @@ and UExp: { | Invalid | EmptyHole | MultiHole - | Triv | Bool | Int | Float @@ -368,7 +366,6 @@ and UPat: { | Float(float) | Bool(bool) | String(string) - | Triv | ListLit(list(t)) | Constructor(string) | Cons(t, t) @@ -392,7 +389,6 @@ and UPat: { | Float(float) | Bool(bool) | String(string) - | Triv | ListLit(list(t)) | Constructor(string) | Cons(t, t) diff --git a/src/haz3lschool/SyntaxTest.re b/src/haz3lschool/SyntaxTest.re index 30eccfbb96..a0ad4435a1 100644 --- a/src/haz3lschool/SyntaxTest.re +++ b/src/haz3lschool/SyntaxTest.re @@ -12,7 +12,6 @@ let rec find_var_upat = (name: string, upat: Term.UPat.t): bool => { | Var(x) => x == name | EmptyHole | Wild - | Triv | Invalid(_) | MultiHole(_) | Int(_) @@ -157,8 +156,7 @@ let rec find_in_let = | (Var(_), _) | (Tuple(_), _) | ( - EmptyHole | Wild | Triv | Invalid(_) | MultiHole(_) | Int(_) | Float(_) | - Bool(_) | + EmptyHole | Wild | Invalid(_) | MultiHole(_) | Int(_) | Float(_) | Bool(_) | String(_) | ListLit(_) | Constructor(_) | diff --git a/src/haz3lweb/view/ExplainThis.re b/src/haz3lweb/view/ExplainThis.re index 2356078ff1..618c377e8e 100644 --- a/src/haz3lweb/view/ExplainThis.re +++ b/src/haz3lweb/view/ExplainThis.re @@ -746,7 +746,7 @@ let get_doc = } else { basic(FunctionExp.functions_str); } - | Triv => + | Tuple([]) => if (FunctionExp.function_triv_exp.id == get_specificity_level(FunctionExp.functions_triv)) { get_message( @@ -866,7 +866,6 @@ let get_doc = } else { basic(FunctionExp.functions_var); } - | Tuple([]) => get_message(TerminalExp.triv_exps) | Tuple(elements) => let pat_id = List.nth(pat.ids, 0); let body_id = List.nth(body.ids, 0); @@ -1270,7 +1269,7 @@ let get_doc = LetExp.lets_str, ); } - | Triv => + | Tuple([]) => if (LetExp.let_triv_exp.id == get_specificity_level(LetExp.lets_triv)) { get_message( @@ -1840,7 +1839,7 @@ let get_doc = ), TerminalPat.strlit(s), ) - | Triv => get_message(TerminalPat.triv) + | Tuple([]) => get_message(TerminalPat.triv) | ListLit(elements) => if (List.length(elements) == 0) { get_message(ListPat.listnil); From 741f133814bd046bfdf9f4d9a4a05a7387e9bb25 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Tue, 27 Feb 2024 14:09:55 -0500 Subject: [PATCH 024/103] Rename NonEmptyHole to StaticErrorHole, and use it more sparingly --- src/haz3lcore/dynamics/DH.re | 17 ++++++------ src/haz3lcore/dynamics/Elaborator.re | 11 ++++++-- src/haz3lcore/dynamics/EvalCtx.re | 6 ++-- src/haz3lcore/dynamics/FilterMatcher.re | 2 +- src/haz3lcore/dynamics/PatternMatch.re | 8 +++--- src/haz3lcore/dynamics/Stepper.re | 4 +-- src/haz3lcore/dynamics/Substitution.re | 4 +-- src/haz3lcore/dynamics/Transition.re | 17 ++++++------ src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 6 ++-- src/test/Test_Elaboration.re | 29 ++++---------------- 10 files changed, 46 insertions(+), 58 deletions(-) diff --git a/src/haz3lcore/dynamics/DH.re b/src/haz3lcore/dynamics/DH.re index 6c97958f31..e679c12128 100644 --- a/src/haz3lcore/dynamics/DH.re +++ b/src/haz3lcore/dynamics/DH.re @@ -18,7 +18,7 @@ module rec DHExp: { | Invalid(string) | EmptyHole | MultiHole(list(DHExp.t)) - | NonEmptyHole(ErrStatus.HoleReason.t, MetaVar.t, HoleInstanceId.t, t) // TODO: Remove, use info_map /// -------------------------------------------------------------------------------------------------------- + | StaticErrorHole(Id.t, t) | FreeVar(MetaVar.t, HoleInstanceId.t, Var.t) // TODO: Remove, use info_map /// -------------------------------------------------------------------------------------------------------- | InvalidOperation(t, InvalidOperationError.t) // Warning will robinson | FailedCast(t, Typ.t, Typ.t) // TODO: Add to TermBase @@ -77,7 +77,7 @@ module rec DHExp: { | Invalid(string) | EmptyHole | MultiHole(list(DHExp.t)) - | NonEmptyHole(ErrStatus.HoleReason.t, MetaVar.t, HoleInstanceId.t, t) + | StaticErrorHole(Id.t, t) | FreeVar(MetaVar.t, HoleInstanceId.t, Var.t) | InvalidOperation(t, InvalidOperationError.t) | FailedCast(t, Typ.t, Typ.t) @@ -177,7 +177,8 @@ module rec DHExp: { | Float(_) | String(_) | Constructor(_) => term - | NonEmptyHole(x, y, z, d1) => NonEmptyHole(x, y, z, repair_ids(d1)) + | StaticErrorHole(static_id, d1) => + StaticErrorHole(static_id, repair_ids(d1)) | InvalidOperation(d1, x) => InvalidOperation(repair_ids(d1), x) | FailedCast(d1, t1, t2) => FailedCast(repair_ids(d1), t1, t2) | Closure(env, d1) => Closure(env, repair_ids(d1)) @@ -212,6 +213,7 @@ module rec DHExp: { let repair_ids = repair_ids(false); + // Also strips static error holes - kinda like unelaboration let rec strip_casts = d => { let (term, rewrap) = unwrap(d); switch (term) { @@ -225,8 +227,7 @@ module rec DHExp: { | ListLit(a, b, c, ds) => ListLit(a, b, c, List.map(strip_casts, ds)) |> rewrap | MultiHole(ds) => MultiHole(List.map(strip_casts, ds)) |> rewrap - | NonEmptyHole(err, u, i, d) => - NonEmptyHole(err, u, i, strip_casts(d)) |> rewrap + | StaticErrorHole(_, d) => strip_casts(d) | Seq(a, b) => Seq(strip_casts(a), strip_casts(b)) |> rewrap | Filter(f, b) => Filter(DHFilter.strip_casts(f), strip_casts(b)) |> rewrap @@ -359,8 +360,8 @@ module rec DHExp: { | (MultiHole(ds1), MultiHole(ds2)) => List.length(ds1) == List.length(ds2) && List.for_all2(fast_equal, ds1, ds2) - | (NonEmptyHole(reason1, u1, i1, d1), NonEmptyHole(reason2, u2, i2, d2)) => - reason1 == reason2 && u1 == u2 && i1 == i2 && fast_equal(d1, d2) + | (StaticErrorHole(sid1, d1), StaticErrorHole(sid2, d2)) => + sid1 == sid2 && d1 == d2 | (FreeVar(u1, i1, x1), FreeVar(u2, i2, x2)) => u1 == u2 && i1 == i2 && x1 == x2 | (Invalid(text1), Invalid(text2)) => text1 == text2 @@ -368,7 +369,7 @@ module rec DHExp: { ClosureEnvironment.id_equal(sigma1, sigma2) && fast_equal(d1, d2) | (EmptyHole, _) | (MultiHole(_), _) - | (NonEmptyHole(_), _) + | (StaticErrorHole(_), _) | (FreeVar(_), _) | (Invalid(_), _) | (Closure(_), _) => false diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 88027e112d..18d7b593f5 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -82,7 +82,7 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => DHExp.fresh_cast(d, self_ty, Unknown(prov)) | _ => d } - | NonEmptyHole(_, _, _, g) => + | StaticErrorHole(_, g) => switch (DHExp.term_of(g)) { | Constructor(_) => switch (ana_ty, self_ty) { @@ -106,7 +106,7 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => | FreeVar(_) | EmptyHole | MultiHole(_) - | NonEmptyHole(_) => d + | StaticErrorHole(_) => d /* DHExp-specific forms: Don't cast */ | Cast(_) | Closure(_) @@ -137,7 +137,12 @@ let wrap = (ctx: Ctx.t, u: Id.t, mode: Mode.t, self, d: DHExp.t): DHExp.t => | None => Unknown(Internal) }; cast(ctx, mode, self_ty, d); - | InHole(_) => DHExp.fresh(NonEmptyHole(TypeInconsistent, u, 0, d)) + | InHole( + FreeVariable(_) | Common(NoType(_)) | + Common(Inconsistent(Internal(_))), + ) => d + | InHole(Common(Inconsistent(Expectation(_) | WithArrow(_)))) => + DHExp.fresh(StaticErrorHole(u, d)) }; let rec dhexp_of_uexp = diff --git a/src/haz3lcore/dynamics/EvalCtx.re b/src/haz3lcore/dynamics/EvalCtx.re index 3c52c8d052..5dfd5becee 100644 --- a/src/haz3lcore/dynamics/EvalCtx.re +++ b/src/haz3lcore/dynamics/EvalCtx.re @@ -34,7 +34,7 @@ type term = | Cons2(DHExp.t, t) | ListConcat1(t, DHExp.t) | ListConcat2(DHExp.t, t) - | NonEmptyHole(ErrStatus.HoleReason.t, MetaVar.t, HoleInstanceId.t, t) + | StaticErrorHole(Id.t, t) | Cast(t, Typ.t, Typ.t) | FailedCast(t, Typ.t, Typ.t) | InvalidOperation(t, InvalidOperationError.t) @@ -141,9 +141,9 @@ let rec compose = (ctx: t, d: DHExp.t): DHExp.t => { | InvalidOperation(ctx, err) => let d = compose(ctx, d); InvalidOperation(d, err) |> wrap; - | NonEmptyHole(reason, u, i, ctx) => + | StaticErrorHole(i, ctx) => let d = compose(ctx, d); - NonEmptyHole(reason, u, i, d) |> wrap; + StaticErrorHole(i, d) |> wrap; | MatchScrut(c, ctx, rules) => let d = compose(ctx, d); Match(c, d, rules) |> wrap; diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index 59a1459455..33640e0ba9 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -164,7 +164,7 @@ let rec matches_exp = | (Match(_), _) => false // TODO: should these not default to false? | (MultiHole(_), _) => false - | (NonEmptyHole(_), _) => false + | (StaticErrorHole(_), _) => false | (Invalid(_), _) => false | (InvalidOperation(_), _) => false diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index a1718c328a..a13fae1a85 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -41,7 +41,7 @@ let rec matches = (dp: DHPat.t, d: DHExp.t): match_result => let env = Environment.extend(Environment.empty, (x, d)); Matches(env); | (_, EmptyHole) => IndetMatch - | (_, NonEmptyHole(_)) => IndetMatch + | (_, StaticErrorHole(_)) => IndetMatch | (_, FailedCast(_)) => IndetMatch | (_, InvalidOperation(_)) => IndetMatch | (_, FreeVar(_)) => IndetMatch @@ -247,7 +247,7 @@ and matches_cast_Sum = | BinOp(_) | EmptyHole | MultiHole(_) - | NonEmptyHole(_) + | StaticErrorHole(_) | FailedCast(_, _, _) | Test(_) | InvalidOperation(_) @@ -351,7 +351,7 @@ and matches_cast_Tuple = | Match(_) => IndetMatch | EmptyHole => IndetMatch | MultiHole(_) => IndetMatch - | NonEmptyHole(_) => IndetMatch + | StaticErrorHole(_) => IndetMatch | FailedCast(_, _, _) => IndetMatch | InvalidOperation(_) => IndetMatch | If(_) => IndetMatch @@ -484,7 +484,7 @@ and matches_cast_Cons = | Match(_) => IndetMatch | EmptyHole => IndetMatch | MultiHole(_) => IndetMatch - | NonEmptyHole(_) => IndetMatch + | StaticErrorHole(_) => IndetMatch | FailedCast(_, _, _) => IndetMatch | InvalidOperation(_) => IndetMatch | If(_) => IndetMatch diff --git a/src/haz3lcore/dynamics/Stepper.re b/src/haz3lcore/dynamics/Stepper.re index 9127e5b1c9..94a1196d78 100644 --- a/src/haz3lcore/dynamics/Stepper.re +++ b/src/haz3lcore/dynamics/Stepper.re @@ -142,9 +142,9 @@ let rec matches = | MultiHole(ctx, (dl, dr)) => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); MultiHole(ctx, (dl, dr)) |> rewrap; - | NonEmptyHole(e, u, i, ctx) => + | StaticErrorHole(i, ctx) => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); - NonEmptyHole(e, u, i, ctx) |> rewrap; + StaticErrorHole(i, ctx) |> rewrap; | Cast(ctx, ty, ty') => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); Cast(ctx, ty, ty') |> rewrap; diff --git a/src/haz3lcore/dynamics/Substitution.re b/src/haz3lcore/dynamics/Substitution.re index 8c5bff860d..659326386b 100644 --- a/src/haz3lcore/dynamics/Substitution.re +++ b/src/haz3lcore/dynamics/Substitution.re @@ -95,9 +95,9 @@ let rec subst_var = (d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => { Match(c, ds, rules) |> rewrap; | EmptyHole => EmptyHole |> rewrap | MultiHole(ds) => MultiHole(List.map(subst_var(d1, x), ds)) |> rewrap - | NonEmptyHole(reason, u, i, d3) => + | StaticErrorHole(u, d3) => let d3' = subst_var(d1, x, d3); - NonEmptyHole(reason, u, i, d3') |> rewrap; + StaticErrorHole(u, d3') |> rewrap; | Cast(d, ty1, ty2) => let d' = subst_var(d1, x, d); Cast(d', ty1, ty2) |> rewrap; diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index 75e9a78436..fd1c89ce8d 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -205,12 +205,15 @@ module Transition = (EV: EV_MODE) => { let err_info = Statics.get_error_at(info_map, DHExp.rep_id(d)); let (let.) = switch (err_info) { - | Some(FreeVariable(_) | Common(NoType(_) | Inconsistent(_))) => ( + | Some( + FreeVariable(_) | Common(NoType(_) | Inconsistent(Internal(_))), + ) => ( (x, _) => { let. _ = x; Indet; } ) + | Some(Common(Inconsistent(Expectation(_) | WithArrow(_)))) | None => (let.) }; @@ -414,7 +417,7 @@ module Transition = (EV: EV_MODE) => { c, ); switch (consistent, DHExp.term_of(c')) { - | (Consistent, Bool(b)) => + | (Consistent | Inconsistent(_), Bool(b)) => Step({ apply: () => { b ? d1 : d2; @@ -424,7 +427,7 @@ module Transition = (EV: EV_MODE) => { value: false, }) // Use a seperate case for invalid conditionals. Makes extracting the bool from BoolLit (above) easier. - | (Consistent, _) => + | (Consistent | Inconsistent(_), _) => Step({ apply: () => { raise(EvaluatorError.Exception(InvalidBoxedBoolLit(c'))); @@ -432,8 +435,6 @@ module Transition = (EV: EV_MODE) => { kind: InvalidStep, value: true, }) - // Inconsistent branches should be Indet - | (Inconsistent(_), _) => Indet }; | BinOp(Bool(And), d1, d2) => let. _ = otherwise(env, d1 => BinOp(Bool(And), d1, d2) |> rewrap) @@ -695,12 +696,12 @@ module Transition = (EV: EV_MODE) => { and. d' = req_value(req(state, env'), d1 => Closure(env', d1) |> wrap_ctx, d); Step({apply: () => d', kind: CompleteClosure, value: true}); - | NonEmptyHole(reason, u, i, d1) => - let. _ = otherwise(env, d1 => NonEmptyHole(reason, u, i, d1) |> rewrap) + | StaticErrorHole(sid, d1) => + let. _ = otherwise(env, d1 => StaticErrorHole(sid, d1) |> rewrap) and. _ = req_final( req(state, env), - d1 => NonEmptyHole(reason, u, i, d1) |> wrap_ctx, + d1 => StaticErrorHole(sid, d1) |> wrap_ctx, d1, ); Indet; diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index 85332fc930..9962938554 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -81,7 +81,7 @@ let rec precedence = (~show_casts: bool, d: DHExp.t) => { | BinOp(String(op), _, _) => precedence_bin_string_op(op) | MultiHole(_) => DHDoc_common.precedence_max - | NonEmptyHole(_, _, _, d) => precedence'(d) + | StaticErrorHole(_, d) => precedence'(d) }; }; @@ -283,8 +283,8 @@ let mk = env, ) | MultiHole(ds) => ds |> List.map(go') |> Doc.hcats - | NonEmptyHole(reason, u, i, d') => - go'(d') |> annot(DHAnnot.NonEmptyHole(reason, (u, i))) + | StaticErrorHole(u, d') => + go'(d') |> annot(DHAnnot.NonEmptyHole(TypeInconsistent, (u, 0))) | FreeVar(u, i, x) => text(x) |> annot(DHAnnot.VarHole(Free, (u, i))) | Invalid(t) => DHDoc_common.mk_InvalidText(t) diff --git a/src/test/Test_Elaboration.re b/src/test/Test_Elaboration.re index 8406000451..24470504aa 100644 --- a/src/test/Test_Elaboration.re +++ b/src/test/Test_Elaboration.re @@ -41,13 +41,7 @@ let u3: Term.UExp.t = { term: Parens({ids: [id_at(1)], term: Var("y")}), }; let d3: DHExp.t = - NonEmptyHole( - TypeInconsistent, - id_at(1), - 0, - FreeVar(id_at(1), 0, "y") |> fresh, - ) - |> fresh; + StaticErrorHole(id_at(1), FreeVar(id_at(1), 0, "y") |> fresh) |> fresh; let free_var = () => alco_check( "Nonempty hole with free variable", @@ -112,15 +106,8 @@ let u5: Term.UExp.t = { let d5: DHExp.t = BinOp( Int(Plus), - NonEmptyHole(TypeInconsistent, id_at(1), 0, Bool(false) |> fresh) - |> fresh, - NonEmptyHole( - TypeInconsistent, - id_at(2), - 0, - FreeVar(id_at(2), 0, "y") |> fresh, - ) - |> fresh, + StaticErrorHole(id_at(1), Bool(false) |> fresh) |> fresh, + StaticErrorHole(id_at(2), FreeVar(id_at(2), 0, "y") |> fresh) |> fresh, ) |> fresh; let bin_op = () => @@ -189,13 +176,7 @@ let d7: DHExp.t = None, ) |> fresh, - NonEmptyHole( - TypeInconsistent, - id_at(6), - 0, - FreeVar(id_at(6), 0, "y") |> fresh, - ) - |> fresh, + StaticErrorHole(id_at(6), FreeVar(id_at(6), 0, "y") |> fresh) |> fresh, ) |> fresh; let ap_fun = () => @@ -239,7 +220,7 @@ let d8rules = ]; let d8a: DHExp.t = Match(Inconsistent(id_at(0), 0), d8scrut, d8rules) |> fresh; -let d8: DHExp.t = NonEmptyHole(TypeInconsistent, id_at(0), 0, d8a) |> fresh; +let d8: DHExp.t = StaticErrorHole(id_at(0), d8a) |> fresh; let inconsistent_case = () => alco_check( "Inconsistent branches where the first branch is an integer and second branch is a boolean", From fc667f792a60ee367507a19f3e1677c0cd30d40a Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Tue, 27 Feb 2024 15:26:05 -0500 Subject: [PATCH 025/103] Rearranging DHExp --- src/haz3lcore/dynamics/Builtins.re | 8 +- src/haz3lcore/dynamics/DH.re | 168 ++++++++----------- src/haz3lcore/dynamics/Elaborator.re | 28 +--- src/haz3lcore/dynamics/EvalCtx.re | 47 +++--- src/haz3lcore/dynamics/FilterMatcher.re | 18 +- src/haz3lcore/dynamics/PatternMatch.re | 20 +-- src/haz3lcore/dynamics/Stepper.re | 28 ++-- src/haz3lcore/dynamics/Substitution.re | 16 +- src/haz3lcore/dynamics/Transition.re | 51 +++--- src/haz3lcore/statics/TermBase.re | 58 ++++--- src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 15 +- src/test/Test_Elaboration.re | 13 +- 12 files changed, 198 insertions(+), 272 deletions(-) diff --git a/src/haz3lcore/dynamics/Builtins.re b/src/haz3lcore/dynamics/Builtins.re index bfd8b36f82..374397f4d1 100644 --- a/src/haz3lcore/dynamics/Builtins.re +++ b/src/haz3lcore/dynamics/Builtins.re @@ -173,7 +173,7 @@ module Pervasives = { | None => let d' = DHExp.BuiltinFun(name) |> DHExp.fresh; let d' = DHExp.Ap(Forward, d', d) |> DHExp.fresh; - let d' = InvalidOperation(d', InvalidOfString) |> DHExp.fresh; + let d' = DynamicErrorHole(d', InvalidOfString) |> DHExp.fresh; Ok(d'); } | _ => Error(InvalidBoxedStringLit(d)) @@ -194,7 +194,7 @@ module Pervasives = { | (Int(_), Int(0)) => Ok( fresh( - InvalidOperation( + DynamicErrorHole( DHExp.Ap(Forward, DHExp.BuiltinFun(name) |> fresh, d1) |> fresh, DivideByZero, @@ -246,7 +246,7 @@ module Pervasives = { let string_concat = binary((d1, d2) => switch (term_of(d1), term_of(d2)) { - | (String(s1), ListLit(_, _, _, xs)) => + | (String(s1), ListLit(_, xs)) => switch (xs |> List.map(string_of) |> Util.OptUtil.sequence) { | None => Error(InvalidBoxedStringLit(List.hd(xs))) | Some(xs) => Ok(String(String.concat(s1, xs)) |> fresh) @@ -263,7 +263,7 @@ module Pervasives = { try(Ok(String(String.sub(s, idx, len)) |> fresh)) { | _ => // TODO: make it clear that the problem could be with d3 too - Ok(InvalidOperation(d2, IndexOutOfBounds) |> fresh) + Ok(DynamicErrorHole(d2, IndexOutOfBounds) |> fresh) } | (String(_), Int(_), _) => Error(InvalidBoxedIntLit(d3)) | (String(_), _, _) => Error(InvalidBoxedIntLit(d2)) diff --git a/src/haz3lcore/dynamics/DH.re b/src/haz3lcore/dynamics/DH.re index e679c12128..287542d8cb 100644 --- a/src/haz3lcore/dynamics/DH.re +++ b/src/haz3lcore/dynamics/DH.re @@ -1,33 +1,20 @@ open Sexplib.Std; -[@deriving (show({with_path: false}), sexp, yojson)] -type consistency = - | Consistent - | Inconsistent(MetaVar.t, HoleInstanceId.t); - module rec DHExp: { [@deriving (show({with_path: false}), sexp, yojson)] type term = - // TODO: Add IDs - /* TODO: ADD: - UnOp - TyAlias [and ignore] - Parens - */ - // TODO: Work out how to reconcile the invalids | Invalid(string) | EmptyHole | MultiHole(list(DHExp.t)) - | StaticErrorHole(Id.t, t) - | FreeVar(MetaVar.t, HoleInstanceId.t, Var.t) // TODO: Remove, use info_map /// -------------------------------------------------------------------------------------------------------- - | InvalidOperation(t, InvalidOperationError.t) // Warning will robinson - | FailedCast(t, Typ.t, Typ.t) // TODO: Add to TermBase - | Closure([@show.opaque] ClosureEnvironment.t, t) // > UEXP - | Filter(DHFilter.t, t) // DONE [UEXP TO BE CHANGED] - | Var(Var.t) // DONE [ALREADY] - | Seq(t, t) // DONE [ALREADY] - | Let(DHPat.t, t, t) // DONE [ALREADY] - | FixF(DHPat.t, Typ.t, t) // TODO: surface fix + | StaticErrorHole(Id.t, t) // TODO: Add to TermBase + | DynamicErrorHole(t, InvalidOperationError.t) // TODO: Add to TermBase or remove from here + | FailedCast(t, Typ.t, Typ.t) // TODO: Add to TermBase or remove from here + | Bool(bool) + | Int(int) + | Float(float) + | String(string) + | ListLit(Typ.t, list(t)) + | Constructor(string) | Fun( DHPat.t, Typ.t, @@ -35,24 +22,27 @@ module rec DHExp: { [@show.opaque] option(ClosureEnvironment.t), option(Var.t), ) // TODO: Use info_map for Typ.t - | Ap(TermBase.UExp.ap_direction, t, t) // TODO: Add reverse application + | Tuple(list(t)) + | Var(Var.t) + | Let(DHPat.t, t, t) + | FixF(DHPat.t, Typ.t, t) // TODO: Remove type + // TODO: Add TyAlias + | Ap(TermBase.UExp.ap_direction, t, t) + | If(t, t, t) + | Seq(t, t) + | Test(KeywordID.t, t) // TODO: ! ID + | Filter(DHFilter.t, t) // DONE [UEXP TO BE CHANGED] + | Closure([@show.opaque] ClosureEnvironment.t, t) // > UEXP + // TODO: Add Parens + | Cons(t, t) + | ListConcat(t, t) | ApBuiltin(string, t) // DONE [TO ADD TO UEXP] TODO: Add a loooong comment here | BuiltinFun(string) // DONE [TO ADD TO UEXP] - | Test(KeywordID.t, t) // TODO: ! ID - | Bool(bool) // DONE - | Int(int) // DONE - | Float(float) // DONE - | String(string) // DONE + // TODO: Add UnOp | BinOp(TermBase.UExp.op_bin, t, t) // DONE - | ListLit(MetaVar.t, MetaVarInst.t, Typ.t, list(t)) // TODO: afaict the first three arguments here are never used? 3rd one might be info_map - | Cons(t, t) // DONE [ALREADY] - | ListConcat(t, t) // DONE [ALREADY] - | Tuple(list(t)) // DONE [ALREADY] - | Constructor(string) // DONE [ALREADY] - | Match(consistency, t, list((DHPat.t, t))) + | Match(t, list((DHPat.t, t))) | Cast(t, Typ.t, Typ.t) // TODO: Add to uexp or remove - | If(consistency, t, t, t) - and t; // TODO: CONSISTENCY? from statics + and t; let rep_id: t => Id.t; let term_of: t => term; @@ -73,46 +63,45 @@ module rec DHExp: { } = { [@deriving (show({with_path: false}), sexp, yojson)] type term = - /* Hole types */ | Invalid(string) | EmptyHole | MultiHole(list(DHExp.t)) - | StaticErrorHole(Id.t, t) - | FreeVar(MetaVar.t, HoleInstanceId.t, Var.t) - | InvalidOperation(t, InvalidOperationError.t) - | FailedCast(t, Typ.t, Typ.t) - /* Generalized closures */ - | Closure(ClosureEnvironment.t, t) - | Filter(DHFilter.t, t) - /* Other expressions forms */ - | Var(Var.t) - | Seq(t, t) - | Let(DHPat.t, t, t) - | FixF(DHPat.t, Typ.t, t) + | StaticErrorHole(Id.t, t) // TODO: Add to TermBase + | DynamicErrorHole(t, InvalidOperationError.t) // TODO: Add to TermBase or remove from here + | FailedCast(t, Typ.t, Typ.t) // TODO: Add to TermBase or remove from here + | Bool(bool) + | Int(int) + | Float(float) + | String(string) + | ListLit(Typ.t, list(t)) + | Constructor(string) | Fun( DHPat.t, Typ.t, t, [@show.opaque] option(ClosureEnvironment.t), option(Var.t), - ) + ) // TODO: Use info_map for Typ.t + | Tuple(list(t)) + | Var(Var.t) + | Let(DHPat.t, t, t) + | FixF(DHPat.t, Typ.t, t) // TODO: Remove type + // TODO: Add TyAlias | Ap(TermBase.UExp.ap_direction, t, t) - | ApBuiltin(string, t) - | BuiltinFun(string) - | Test(KeywordID.t, t) - | Bool(bool) - | Int(int) - | Float(float) - | String(string) - | BinOp(TermBase.UExp.op_bin, t, t) - | ListLit(MetaVar.t, MetaVarInst.t, Typ.t, list(t)) + | If(t, t, t) + | Seq(t, t) + | Test(KeywordID.t, t) // TODO: ! ID + | Filter(DHFilter.t, t) // DONE [UEXP TO BE CHANGED] + | Closure([@show.opaque] ClosureEnvironment.t, t) // > UEXP + // TODO: Add Parens | Cons(t, t) | ListConcat(t, t) - | Tuple(list(t)) - | Constructor(string) - | Match(consistency, t, list((DHPat.t, t))) - | Cast(t, Typ.t, Typ.t) - | If(consistency, t, t, t) + | ApBuiltin(string, t) // DONE [TO ADD TO UEXP] TODO: Add a loooong comment here + | BuiltinFun(string) // DONE [TO ADD TO UEXP] + // TODO: Add UnOp + | BinOp(TermBase.UExp.op_bin, t, t) // DONE + | Match(t, list((DHPat.t, t))) + | Cast(t, Typ.t, Typ.t) // TODO: Add to uexp or remove and t = { /* invariant: nonempty, TODO: what happens to later ids in DHExp */ ids: list(Id.t), @@ -168,7 +157,6 @@ module rec DHExp: { ( switch (term) { | EmptyHole - | FreeVar(_) | Invalid(_) | Var(_) | BuiltinFun(_) @@ -179,7 +167,7 @@ module rec DHExp: { | Constructor(_) => term | StaticErrorHole(static_id, d1) => StaticErrorHole(static_id, repair_ids(d1)) - | InvalidOperation(d1, x) => InvalidOperation(repair_ids(d1), x) + | DynamicErrorHole(d1, x) => DynamicErrorHole(repair_ids(d1), x) | FailedCast(d1, t1, t2) => FailedCast(repair_ids(d1), t1, t2) | Closure(env, d1) => Closure(env, repair_ids(d1)) | Filter(flt, d1) => Filter(flt, repair_ids(d1)) @@ -191,21 +179,19 @@ module rec DHExp: { | ApBuiltin(s, d1) => ApBuiltin(s, repair_ids(d1)) | Test(id, d1) => Test(id, repair_ids(d1)) | BinOp(op, d1, d2) => BinOp(op, repair_ids(d1), repair_ids(d2)) - | ListLit(mv, mvi, t, ds) => - ListLit(mv, mvi, t, List.map(repair_ids, ds)) + | ListLit(t, ds) => ListLit(t, List.map(repair_ids, ds)) | Cons(d1, d2) => Cons(repair_ids(d1), repair_ids(d2)) | ListConcat(d1, d2) => ListConcat(repair_ids(d1), repair_ids(d2)) | Tuple(ds) => Tuple(List.map(repair_ids, ds)) | MultiHole(ds) => MultiHole(List.map(repair_ids, ds)) - | Match(c, d1, rls) => + | Match(d1, rls) => Match( - c, repair_ids(d1), List.map(((p, d)) => (p, repair_ids(d)), rls), ) | Cast(d1, t1, t2) => Cast(repair_ids(d1), t1, t2) - | If(c, d1, d2, d3) => - If(c, repair_ids(d1), repair_ids(d2), repair_ids(d3)) + | If(d1, d2, d3) => + If(repair_ids(d1), repair_ids(d2), repair_ids(d3)) } ) |> rewrap; @@ -224,8 +210,7 @@ module rec DHExp: { | Cons(d1, d2) => Cons(strip_casts(d1), strip_casts(d2)) |> rewrap | ListConcat(d1, d2) => ListConcat(strip_casts(d1), strip_casts(d2)) |> rewrap - | ListLit(a, b, c, ds) => - ListLit(a, b, c, List.map(strip_casts, ds)) |> rewrap + | ListLit(t, ds) => ListLit(t, List.map(strip_casts, ds)) |> rewrap | MultiHole(ds) => MultiHole(List.map(strip_casts, ds)) |> rewrap | StaticErrorHole(_, d) => strip_casts(d) | Seq(a, b) => Seq(strip_casts(a), strip_casts(b)) |> rewrap @@ -239,15 +224,13 @@ module rec DHExp: { | ApBuiltin(fn, args) => ApBuiltin(fn, strip_casts(args)) |> rewrap | BuiltinFun(fn) => BuiltinFun(fn) |> rewrap | BinOp(a, b, c) => BinOp(a, strip_casts(b), strip_casts(c)) |> rewrap - | Match(c, a, rules) => + | Match(a, rules) => Match( - c, strip_casts(a), List.map(((k, v)) => (k, strip_casts(v)), rules), ) |> rewrap | EmptyHole as d - | FreeVar(_) as d | Invalid(_) as d | Var(_) as d | Bool(_) as d @@ -255,10 +238,9 @@ module rec DHExp: { | Float(_) as d | String(_) as d | Constructor(_) as d - | InvalidOperation(_) as d => d |> rewrap - | If(consistent, c, d1, d2) => - If(consistent, strip_casts(c), strip_casts(d1), strip_casts(d2)) - |> rewrap + | DynamicErrorHole(_) as d => d |> rewrap + | If(c, d1, d2) => + If(strip_casts(c), strip_casts(d1), strip_casts(d2)) |> rewrap }; }; @@ -306,30 +288,27 @@ module rec DHExp: { && List.for_all2(fast_equal, ds1, ds2) | (ApBuiltin(f1, d1), ApBuiltin(f2, d2)) => f1 == f2 && d1 == d2 | (BuiltinFun(f1), BuiltinFun(f2)) => f1 == f2 - | (ListLit(_, _, _, ds1), ListLit(_, _, _, ds2)) => - List.length(ds1) == List.length(ds2) + | (ListLit(t1, ds1), ListLit(t2, ds2)) => + t1 == t2 + && List.length(ds1) == List.length(ds2) && List.for_all2(fast_equal, ds1, ds2) | (BinOp(op1, d11, d21), BinOp(op2, d12, d22)) => op1 == op2 && fast_equal(d11, d12) && fast_equal(d21, d22) | (Cast(d1, ty11, ty21), Cast(d2, ty12, ty22)) | (FailedCast(d1, ty11, ty21), FailedCast(d2, ty12, ty22)) => fast_equal(d1, d2) && ty11 == ty12 && ty21 == ty22 - | (InvalidOperation(d1, reason1), InvalidOperation(d2, reason2)) => + | (DynamicErrorHole(d1, reason1), DynamicErrorHole(d2, reason2)) => fast_equal(d1, d2) && reason1 == reason2 - | (Match(c1, s1, rs1), Match(c2, s2, rs2)) => - c1 == c2 - && fast_equal(s1, s2) + | (Match(s1, rs1), Match(s2, rs2)) => + fast_equal(s1, s2) && List.length(rs2) == List.length(rs2) && List.for_all2( ((k1, v1), (k2, v2)) => k1 == k2 && fast_equal(v1, v2), rs1, rs2, ) - | (If(c1, d11, d12, d13), If(c2, d21, d22, d23)) => - c1 == c2 - && fast_equal(d11, d21) - && fast_equal(d12, d22) - && fast_equal(d13, d23) + | (If(d11, d12, d13), If(d21, d22, d23)) => + fast_equal(d11, d21) && fast_equal(d12, d22) && fast_equal(d13, d23) /* We can group these all into a `_ => false` clause; separating these so that we get exhaustiveness checking. */ | (Seq(_), _) @@ -348,7 +327,7 @@ module rec DHExp: { | (BinOp(_), _) | (Cast(_), _) | (FailedCast(_), _) - | (InvalidOperation(_), _) + | (DynamicErrorHole(_), _) | (If(_), _) | (Match(_), _) => false @@ -362,15 +341,12 @@ module rec DHExp: { && List.for_all2(fast_equal, ds1, ds2) | (StaticErrorHole(sid1, d1), StaticErrorHole(sid2, d2)) => sid1 == sid2 && d1 == d2 - | (FreeVar(u1, i1, x1), FreeVar(u2, i2, x2)) => - u1 == u2 && i1 == i2 && x1 == x2 | (Invalid(text1), Invalid(text2)) => text1 == text2 | (Closure(sigma1, d1), Closure(sigma2, d2)) => ClosureEnvironment.id_equal(sigma1, sigma2) && fast_equal(d1, d2) | (EmptyHole, _) | (MultiHole(_), _) | (StaticErrorHole(_), _) - | (FreeVar(_), _) | (Invalid(_), _) | (Closure(_), _) => false }; diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 18d7b593f5..aa9957381f 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -103,7 +103,6 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => | FixF(_) => d /* Hole-like forms: Don't cast */ | Invalid(_) - | FreeVar(_) | EmptyHole | MultiHole(_) | StaticErrorHole(_) => d @@ -112,7 +111,7 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => | Closure(_) | Filter(_) | FailedCast(_) - | InvalidOperation(_) => d + | DynamicErrorHole(_) => d /* Normal cases: wrap */ | Var(_) | ApBuiltin(_) @@ -186,7 +185,7 @@ let rec dhexp_of_uexp = let* ds = es |> List.map(dhexp_of_uexp(m)) |> OptUtil.sequence; let+ ty = fixed_exp_typ(m, uexp); let ty = Typ.matched_list(ctx, ty); - DHExp.ListLit(id, 0, ty, ds) |> rewrap; + DHExp.ListLit(ty, ds) |> rewrap; | Fun(p, body) => let* dp = dhpat_of_upat(m, p); let* d1 = dhexp_of_uexp(m, body); @@ -218,7 +217,7 @@ let rec dhexp_of_uexp = (DHPat.(fresh(Bool(true))), DHExp.(fresh(Bool(false)))), (DHPat.(fresh(Bool(false))), DHExp.(fresh(Bool(true)))), ]; - let d = DHExp.(fresh(Match(Consistent, d_scrut, d_rules))); + let d = DHExp.(fresh(Match(d_scrut, d_rules))); /* Manually construct cast (case is not otherwise cast) */ switch (mode) { | Ana(ana_ty) => DHExp.fresh_cast(d, Bool, ana_ty) @@ -240,17 +239,8 @@ let rec dhexp_of_uexp = let* dcond = dhexp_of_uexp(~in_filter=true, m, cond); let+ dbody = dhexp_of_uexp(m, body); DHExp.Filter(Filter(Filter.mk(dcond, act)), dbody) |> rewrap; - | Var(name) => - switch (err_status) { - | InHole(FreeVariable(_)) => Some(FreeVar(id, 0, name) |> rewrap) - | _ => Some(Var(name) |> rewrap) - } - | Constructor(name) => - switch (err_status) { - | InHole(Common(NoType(FreeConstructor(_)))) => - Some(FreeVar(id, 0, name) |> rewrap) - | _ => Some(Constructor(name) |> rewrap) - } + | Var(name) => Some(Var(name) |> rewrap) + | Constructor(name) => Some(Constructor(name) |> rewrap) | Let(p, def, body) => let add_name: (option(string), DHExp.t) => DHExp.t = ( (name, d) => { @@ -296,8 +286,8 @@ let rec dhexp_of_uexp = // Use tag to mark inconsistent branches switch (err_status) { | InHole(Common(Inconsistent(Internal(_)))) => - DHExp.If(DH.Inconsistent(id, 0), c', d1, d2) |> rewrap - | _ => DHExp.If(DH.Consistent, c', d1, d2) |> rewrap + DHExp.If(c', d1, d2) |> rewrap + | _ => DHExp.If(c', d1, d2) |> rewrap }; | Match(scrut, rules) => let* d_scrut = dhexp_of_uexp(m, scrut); @@ -313,8 +303,8 @@ let rec dhexp_of_uexp = |> OptUtil.sequence; switch (err_status) { | InHole(Common(Inconsistent(Internal(_)))) => - DHExp.Match(Inconsistent(id, 0), d_scrut, d_rules) |> rewrap - | _ => DHExp.Match(Consistent, d_scrut, d_rules) |> rewrap + DHExp.Match(d_scrut, d_rules) |> rewrap + | _ => DHExp.Match(d_scrut, d_rules) |> rewrap }; | TyAlias(_, _, e) => dhexp_of_uexp(m, e) }; diff --git a/src/haz3lcore/dynamics/EvalCtx.re b/src/haz3lcore/dynamics/EvalCtx.re index 5dfd5becee..edaea1958d 100644 --- a/src/haz3lcore/dynamics/EvalCtx.re +++ b/src/haz3lcore/dynamics/EvalCtx.re @@ -14,21 +14,15 @@ type term = | FixF(DHPat.t, Typ.t, t) | Ap1(TermBase.UExp.ap_direction, t, DHExp.t) | Ap2(TermBase.UExp.ap_direction, DHExp.t, t) - | If1(consistency, t, DHExp.t, DHExp.t) - | If2(consistency, DHExp.t, t, DHExp.t) - | If3(consistency, DHExp.t, DHExp.t, t) + | If1(t, DHExp.t, DHExp.t) + | If2(DHExp.t, t, DHExp.t) + | If3(DHExp.t, DHExp.t, t) | BinOp1(TermBase.UExp.op_bin, t, DHExp.t) | BinOp2(TermBase.UExp.op_bin, DHExp.t, t) | Tuple(t, (list(DHExp.t), list(DHExp.t))) | ApBuiltin(string, t) | Test(KeywordID.t, t) - | ListLit( - MetaVar.t, - MetaVarInst.t, - Typ.t, - t, - (list(DHExp.t), list(DHExp.t)), - ) + | ListLit(Typ.t, t, (list(DHExp.t), list(DHExp.t))) | MultiHole(t, (list(DHExp.t), list(DHExp.t))) | Cons1(t, DHExp.t) | Cons2(DHExp.t, t) @@ -37,10 +31,9 @@ type term = | StaticErrorHole(Id.t, t) | Cast(t, Typ.t, Typ.t) | FailedCast(t, Typ.t, Typ.t) - | InvalidOperation(t, InvalidOperationError.t) - | MatchScrut(DH.consistency, t, list((DHPat.t, DHExp.t))) + | DynamicErrorHole(t, InvalidOperationError.t) + | MatchScrut(t, list((DHPat.t, DHExp.t))) | MatchRule( - DH.consistency, DHExp.t, DHPat.t, t, @@ -81,15 +74,15 @@ let rec compose = (ctx: t, d: DHExp.t): DHExp.t => { | ApBuiltin(s, ctx) => let d' = compose(ctx, d); ApBuiltin(s, d') |> wrap; - | If1(c, ctx, d2, d3) => + | If1(ctx, d2, d3) => let d' = compose(ctx, d); - If(c, d', d2, d3) |> wrap; - | If2(c, d1, ctx, d3) => + If(d', d2, d3) |> wrap; + | If2(d1, ctx, d3) => let d' = compose(ctx, d); - If(c, d1, d', d3) |> wrap; - | If3(c, d1, d2, ctx) => + If(d1, d', d3) |> wrap; + | If3(d1, d2, ctx) => let d' = compose(ctx, d); - If(c, d1, d2, d') |> wrap; + If(d1, d2, d') |> wrap; | Test(lit, ctx) => let d1 = compose(ctx, d); Test(lit, d1) |> wrap; @@ -114,9 +107,9 @@ let rec compose = (ctx: t, d: DHExp.t): DHExp.t => { | Tuple(ctx, (ld, rd)) => let d = compose(ctx, d); Tuple(ListUtil.rev_concat(ld, [d, ...rd])) |> wrap; - | ListLit(m, i, t, ctx, (ld, rd)) => + | ListLit(t, ctx, (ld, rd)) => let d = compose(ctx, d); - ListLit(m, i, t, ListUtil.rev_concat(ld, [d, ...rd])) |> wrap; + ListLit(t, ListUtil.rev_concat(ld, [d, ...rd])) |> wrap; | MultiHole(ctx, (ld, rd)) => let d = compose(ctx, d); MultiHole(ListUtil.rev_concat(ld, [d, ...rd])) |> wrap; @@ -138,18 +131,18 @@ let rec compose = (ctx: t, d: DHExp.t): DHExp.t => { | FailedCast(ctx, ty1, ty2) => let d = compose(ctx, d); FailedCast(d, ty1, ty2) |> wrap; - | InvalidOperation(ctx, err) => + | DynamicErrorHole(ctx, err) => let d = compose(ctx, d); - InvalidOperation(d, err) |> wrap; + DynamicErrorHole(d, err) |> wrap; | StaticErrorHole(i, ctx) => let d = compose(ctx, d); StaticErrorHole(i, d) |> wrap; - | MatchScrut(c, ctx, rules) => + | MatchScrut(ctx, rules) => let d = compose(ctx, d); - Match(c, d, rules) |> wrap; - | MatchRule(c, scr, p, ctx, (lr, rr)) => + Match(d, rules) |> wrap; + | MatchRule(scr, p, ctx, (lr, rr)) => let d = compose(ctx, d); - Match(c, scr, ListUtil.rev_concat(lr, [(p, d), ...rr])) |> wrap; + Match(scr, ListUtil.rev_concat(lr, [(p, d), ...rr])) |> wrap; } ); }; diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index 33640e0ba9..8dde587812 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -84,10 +84,6 @@ let rec matches_exp = matches_pat(dp, fp) && dt == ft && matches_exp(env, d1, f1) | (FixF(_), _) => false - | (FreeVar(du, di, dx), FreeVar(fu, fi, fx)) => - du == fu && di == fi && dx == fx - | (FreeVar(_), _) => false - | (Let(dp, d1, d2), Let(fp, f1, f2)) => matches_pat(dp, fp) && matches_exp(env, d1, f1) @@ -99,9 +95,8 @@ let rec matches_exp = matches_exp(env, d1, f1) && matches_exp(env, d2, f2) | (Ap(_), _) => false - | (If(dc, d1, d2, d3), If(fc, f1, f2, f3)) => - dc == fc - && matches_exp(env, d1, f1) + | (If(d1, d2, d3), If(f1, f2, f3)) => + matches_exp(env, d1, f1) && matches_exp(env, d2, f2) && matches_exp(env, d3, f3) | (If(_), _) => false @@ -118,7 +113,7 @@ let rec matches_exp = matches_exp(env, d1, f1) && matches_exp(env, d2, f2) | (Cons(_), _) => false - | (ListLit(_, _, dt, dv), ListLit(_, _, ft, fv)) => + | (ListLit(dt, dv), ListLit(ft, fv)) => dt == ft && List.fold_left2( (acc, d, f) => acc && matches_exp(env, d, f), @@ -145,9 +140,8 @@ let rec matches_exp = matches_exp(env, d1, f1) && matches_exp(env, d2, f2) | (ListConcat(_), _) => false - | (Match(dc, dscrut, drule), Match(fc, fscrut, frule)) => - dc == fc - && matches_exp(env, dscrut, fscrut) + | (Match(dscrut, drule), Match(fscrut, frule)) => + matches_exp(env, dscrut, fscrut) && ( switch ( List.for_all2( @@ -166,7 +160,7 @@ let rec matches_exp = | (MultiHole(_), _) => false | (StaticErrorHole(_), _) => false | (Invalid(_), _) => false - | (InvalidOperation(_), _) => false + | (DynamicErrorHole(_), _) => false | (ApBuiltin(dname, darg), ApBuiltin(fname, farg)) => dname == fname && matches_exp(env, darg, farg) diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index a13fae1a85..c32bba5315 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -43,14 +43,13 @@ let rec matches = (dp: DHPat.t, d: DHExp.t): match_result => | (_, EmptyHole) => IndetMatch | (_, StaticErrorHole(_)) => IndetMatch | (_, FailedCast(_)) => IndetMatch - | (_, InvalidOperation(_)) => IndetMatch - | (_, FreeVar(_)) => IndetMatch + | (_, DynamicErrorHole(_)) => IndetMatch | (_, Invalid(_)) => IndetMatch | (_, Let(_)) => IndetMatch | (_, FixF(_)) => DoesNotMatch | (_, Fun(_)) => DoesNotMatch | (_, BinOp(_)) => IndetMatch - | (_, Match(Consistent, _, _)) => IndetMatch + | (_, Match(_, _)) => IndetMatch /* Closure should match like underlying expression. */ | (_, Closure(_, d')) @@ -240,7 +239,6 @@ and matches_cast_Sum = | Cast(d', Sum(_) | Rec(_, Sum(_)), Unknown(_)) | Cast(d', Unknown(_), Sum(_) | Rec(_, Sum(_))) => matches_cast_Sum(ctr, dp, d', castmaps) - | FreeVar(_) | Invalid(_) | Let(_) | ApBuiltin(_) @@ -250,7 +248,7 @@ and matches_cast_Sum = | StaticErrorHole(_) | FailedCast(_, _, _) | Test(_) - | InvalidOperation(_) + | DynamicErrorHole(_) | Match(_) | If(_) | BuiltinFun(_) => IndetMatch @@ -327,7 +325,6 @@ and matches_cast_Tuple = ); | Cast(_, _, _) => DoesNotMatch | Var(_) => DoesNotMatch - | FreeVar(_) => IndetMatch | Invalid(_) => IndetMatch | Let(_, _, _) => IndetMatch | FixF(_, _, _) => DoesNotMatch @@ -353,18 +350,18 @@ and matches_cast_Tuple = | MultiHole(_) => IndetMatch | StaticErrorHole(_) => IndetMatch | FailedCast(_, _, _) => IndetMatch - | InvalidOperation(_) => IndetMatch + | DynamicErrorHole(_) => IndetMatch | If(_) => IndetMatch } and matches_cast_Cons = (dp: DHPat.t, d: DHExp.t, elt_casts: list((Typ.t, Typ.t))): match_result => switch (DHExp.term_of(d)) { - | ListLit(_, _, _, []) => + | ListLit(_, []) => switch (DHPat.term_of(dp)) { | ListLit([]) => Matches(Environment.empty) | _ => DoesNotMatch } - | ListLit(u, i, ty, [dhd, ...dtl] as ds) => + | ListLit(ty, [dhd, ...dtl] as ds) => switch (DHPat.term_of(dp)) { | Cons(dp1, dp2) => switch (matches(dp1, DHExp.apply_casts(dhd, elt_casts))) { @@ -379,7 +376,7 @@ and matches_cast_Cons = }, elt_casts, ); - let d2 = DHExp.ListLit(u, i, ty, dtl) |> DHExp.fresh; + let d2 = DHExp.ListLit(ty, dtl) |> DHExp.fresh; switch (matches(dp2, DHExp.apply_casts(d2, list_casts))) { | DoesNotMatch => DoesNotMatch | IndetMatch => IndetMatch @@ -461,7 +458,6 @@ and matches_cast_Cons = matches_cast_Cons(dp, d', [(Unknown(Internal), ty2), ...elt_casts]) | Cast(_, _, _) => DoesNotMatch | Var(_) => DoesNotMatch - | FreeVar(_) => IndetMatch | Invalid(_) => IndetMatch | Let(_, _, _) => IndetMatch | FixF(_, _, _) => DoesNotMatch @@ -486,6 +482,6 @@ and matches_cast_Cons = | MultiHole(_) => IndetMatch | StaticErrorHole(_) => IndetMatch | FailedCast(_, _, _) => IndetMatch - | InvalidOperation(_) => IndetMatch + | DynamicErrorHole(_) => IndetMatch | If(_) => IndetMatch }; diff --git a/src/haz3lcore/dynamics/Stepper.re b/src/haz3lcore/dynamics/Stepper.re index 94a1196d78..3f030fde99 100644 --- a/src/haz3lcore/dynamics/Stepper.re +++ b/src/haz3lcore/dynamics/Stepper.re @@ -100,15 +100,15 @@ let rec matches = | Ap2(dir, d1, ctx) => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); Ap2(dir, d1, ctx) |> rewrap; - | If1(c, ctx, d2, d3) => + | If1(ctx, d2, d3) => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); - If1(c, ctx, d2, d3) |> rewrap; - | If2(c, d1, ctx, d3) => + If1(ctx, d2, d3) |> rewrap; + | If2(d1, ctx, d3) => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); - If2(c, d1, ctx, d3) |> rewrap; - | If3(c, d1, d2, ctx) => + If2(d1, ctx, d3) |> rewrap; + | If3(d1, d2, ctx) => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); - If3(c, d1, d2, ctx) |> rewrap; + If3(d1, d2, ctx) |> rewrap; | BinOp1(op, ctx, d1) => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); BinOp1(op, ctx, d1) |> rewrap; @@ -124,9 +124,9 @@ let rec matches = | Test(id, ctx) => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); Test(id, ctx) |> rewrap; - | ListLit(u, i, ty, ctx, ds) => + | ListLit(ty, ctx, ds) => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); - ListLit(u, i, ty, ctx, ds) |> rewrap; + ListLit(ty, ctx, ds) |> rewrap; | Cons1(ctx, d2) => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); Cons1(ctx, d2) |> rewrap; @@ -151,15 +151,15 @@ let rec matches = | FailedCast(ctx, ty, ty') => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); FailedCast(ctx, ty, ty') |> rewrap; - | InvalidOperation(ctx, error) => + | DynamicErrorHole(ctx, error) => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); - InvalidOperation(ctx, error) |> rewrap; - | MatchScrut(c, ctx, rs) => + DynamicErrorHole(ctx, error) |> rewrap; + | MatchScrut(ctx, rs) => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); - MatchScrut(c, ctx, rs) |> rewrap; - | MatchRule(c, scr, p, ctx, rs) => + MatchScrut(ctx, rs) |> rewrap; + | MatchRule(scr, p, ctx, rs) => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); - MatchRule(c, scr, p, ctx, rs) |> rewrap; + MatchRule(scr, p, ctx, rs) |> rewrap; }; }; switch (ctx) { diff --git a/src/haz3lcore/dynamics/Substitution.re b/src/haz3lcore/dynamics/Substitution.re index 659326386b..64f938d1d5 100644 --- a/src/haz3lcore/dynamics/Substitution.re +++ b/src/haz3lcore/dynamics/Substitution.re @@ -8,7 +8,6 @@ let rec subst_var = (d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => { } else { d2; } - | FreeVar(_) => d2 | Invalid(_) => d2 | Seq(d3, d4) => let d3 = subst_var(d1, x, d3); @@ -65,8 +64,7 @@ let rec subst_var = (d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => { | Float(_) | String(_) | Constructor(_) => d2 - | ListLit(a, b, c, ds) => - ListLit(a, b, c, List.map(subst_var(d1, x), ds)) |> rewrap + | ListLit(t, ds) => ListLit(t, List.map(subst_var(d1, x), ds)) |> rewrap | Cons(d3, d4) => let d3 = subst_var(d1, x, d3); let d4 = subst_var(d1, x, d4); @@ -80,7 +78,7 @@ let rec subst_var = (d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => { let d3 = subst_var(d1, x, d3); let d4 = subst_var(d1, x, d4); BinOp(op, d3, d4) |> rewrap; - | Match(c, ds, rules) => + | Match(ds, rules) => let ds = subst_var(d1, x, ds); let rules = List.map( @@ -92,7 +90,7 @@ let rec subst_var = (d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => { }, rules, ); - Match(c, ds, rules) |> rewrap; + Match(ds, rules) |> rewrap; | EmptyHole => EmptyHole |> rewrap | MultiHole(ds) => MultiHole(List.map(subst_var(d1, x), ds)) |> rewrap | StaticErrorHole(u, d3) => @@ -104,14 +102,14 @@ let rec subst_var = (d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => { | FailedCast(d, ty1, ty2) => let d' = subst_var(d1, x, d); FailedCast(d', ty1, ty2) |> rewrap; - | InvalidOperation(d, err) => + | DynamicErrorHole(d, err) => let d' = subst_var(d1, x, d); - InvalidOperation(d', err) |> rewrap; - | If(d3, d4, d5, d6) => + DynamicErrorHole(d', err) |> rewrap; + | If(d4, d5, d6) => let d4' = subst_var(d1, x, d4); let d5' = subst_var(d1, x, d5); let d6' = subst_var(d1, x, d6); - If(d3, d4', d5', d6') |> rewrap; + If(d4', d5', d6') |> rewrap; }; } diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index fd1c89ce8d..69aeb9e242 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -408,16 +408,12 @@ module Transition = (EV: EV_MODE) => { | BuiltinFun(_) => let. _ = otherwise(env, d); Constructor; - | If(consistent, c, d1, d2) => - let. _ = otherwise(env, c => If(consistent, c, d1, d2) |> rewrap) + | If(c, d1, d2) => + let. _ = otherwise(env, c => If(c, d1, d2) |> rewrap) and. c' = - req_value( - req(state, env), - c => If1(consistent, c, d1, d2) |> wrap_ctx, - c, - ); - switch (consistent, DHExp.term_of(c')) { - | (Consistent | Inconsistent(_), Bool(b)) => + req_value(req(state, env), c => If1(c, d1, d2) |> wrap_ctx, c); + switch (DHExp.term_of(c')) { + | Bool(b) => Step({ apply: () => { b ? d1 : d2; @@ -427,7 +423,7 @@ module Transition = (EV: EV_MODE) => { value: false, }) // Use a seperate case for invalid conditionals. Makes extracting the bool from BoolLit (above) easier. - | (Consistent | Inconsistent(_), _) => + | _ => Step({ apply: () => { raise(EvaluatorError.Exception(InvalidBoxedBoolLit(c'))); @@ -495,17 +491,15 @@ module Transition = (EV: EV_MODE) => { | Plus => Int(n1 + n2) | Minus => Int(n1 - n2) | Power when n2 < 0 => - InvalidOperation( - BinOp(Int(op), Int(n1) |> fresh, Int(n2) |> fresh) - |> fresh, + DynamicErrorHole( + BinOp(Int(op), d1', d2') |> rewrap, NegativeExponent, ) | Power => Int(IntUtil.ipow(n1, n2)) | Times => Int(n1 * n2) | Divide when n2 == 0 => - InvalidOperation( - BinOp(Int(op), Int(n1) |> fresh, Int(n2) |> fresh) - |> fresh, + DynamicErrorHole( + BinOp(Int(op), d1', d1') |> rewrap, DivideByZero, ) | Divide => Int(n1 / n2) @@ -617,8 +611,7 @@ module Transition = (EV: EV_MODE) => { Step({ apply: () => switch (term_of(d2')) { - | ListLit(u, i, ty, ds) => - ListLit(u, i, ty, [d1', ...ds]) |> fresh + | ListLit(ty, ds) => ListLit(ty, [d1', ...ds]) |> fresh | _ => raise(EvaluatorError.Exception(InvalidBoxedListLit(d2'))) }, kind: ListCons, @@ -642,8 +635,8 @@ module Transition = (EV: EV_MODE) => { Step({ apply: () => switch (term_of(d1'), term_of(d2')) { - | (ListLit(u1, i1, t1, ds1), ListLit(_, _, _, ds2)) => - ListLit(u1, i1, t1, ds1 @ ds2) |> fresh + | (ListLit(t1, ds1), ListLit(_, ds2)) => + ListLit(t1, ds1 @ ds2) |> fresh | (ListLit(_), _) => raise(EvaluatorError.Exception(InvalidBoxedListLit(d2'))) | (_, _) => @@ -652,21 +645,21 @@ module Transition = (EV: EV_MODE) => { kind: ListConcat, value: true, }); - | ListLit(u, i, ty, ds) => - let. _ = otherwise(env, ds => ListLit(u, i, ty, ds) |> rewrap) + | ListLit(t, ds) => + let. _ = otherwise(env, ds => ListLit(t, ds) |> rewrap) and. _ = req_all_final( req(state, env), - (d1, ds) => ListLit(u, i, ty, d1, ds) |> wrap_ctx, + (d1, ds) => ListLit(t, d1, ds) |> wrap_ctx, ds, ); Constructor; - | Match(Consistent, d1, rules) => - let. _ = otherwise(env, d1 => Match(Consistent, d1, rules) |> rewrap) + | Match(d1, rules) => + let. _ = otherwise(env, d1 => Match(d1, rules) |> rewrap) and. d1 = req_final( req(state, env), - d1 => MatchScrut(Consistent, d1, rules) |> wrap_ctx, + d1 => MatchScrut(d1, rules) |> wrap_ctx, d1, ); let rec next_rule = ( @@ -688,9 +681,6 @@ module Transition = (EV: EV_MODE) => { }) | None => Indet }; - | Match(Inconsistent(_, _), _, _) => - let. _ = otherwise(env, d); - Indet; | Closure(env', d) => let. _ = otherwise(env, d => Closure(env', d) |> rewrap) and. d' = @@ -715,9 +705,8 @@ module Transition = (EV: EV_MODE) => { ); Indet; | EmptyHole - | FreeVar(_) | Invalid(_) - | InvalidOperation(_) => + | DynamicErrorHole(_) => let. _ = otherwise(env, d); Indet; | Cast(d, t1, t2) => diff --git a/src/haz3lcore/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index 3f3fc2fe12..b15cf852ba 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -270,39 +270,37 @@ and UExp: { [@deriving (show({with_path: false}), sexp, yojson)] type term = - /* TODO: ADD: - Filter() - ApBuiltin(string, t) // These two are different to `var` to allow shadowing of builtins - BuiltinFun(string) - FixF() - */ - | Invalid(string) // TODO: Reconcile the invalids - | EmptyHole // DONE - | MultiHole(list(Any.t)) // TODO: Reconcile the invalids - | Bool(bool) // DONE [DH CHANGED] - | Int(int) // DONE [DH CHANGED] - | Float(float) // DONE [DH CHANGED] - | String(string) // DONE [DH CHANGED] - | ListLit(list(t)) // DONE [DH TO BE CHANGED] - | Constructor(string) // DONE [ALREADY] - | Fun(UPat.t, t) // TODO: Add option(Var.t) name field to end - | Tuple(list(t)) // DONE [EXCEPT FOR TRIV] - | Var(Var.t) // DONE [ALREADY] - | Let(UPat.t, t, t) // DONE [ALREADY] + | Invalid(string) + | EmptyHole + | MultiHole(list(Any.t)) + // TODO: Add StaticErrorHole, DynamicErrorHole, FailedCast + | Bool(bool) + | Int(int) + | Float(float) + | String(string) + | ListLit(list(t)) + | Constructor(string) + | Fun(UPat.t, t) // TODO: Add option(Var.t) name field to end; Add optional closure to function + | Tuple(list(t)) + | Var(Var.t) + | Let(UPat.t, t, t) | FixF(UPat.t, t) // DONE [CHECK WITH SOMEONE THAT I GOT THE STATIC SEMANTICS RIGHT] - | TyAlias(UTPat.t, UTyp.t, t) // [TO ADD TO DHEXP] + | TyAlias(UTPat.t, UTyp.t, t) // note: function is always first then argument; even in reverse - | Ap(ap_direction, t, t) // TODO: Combine Ap and Pipeline? [alt: add pipeline to dhexp] - | If(t, t, t) // TODO: What to do about consistency? - | Seq(t, t) // DONE [ALREADY] - | Test(t) // [DHEXP TO CHANGE] + | Ap(ap_direction, t, t) + | If(t, t, t) + | Seq(t, t) + | Test(t) | Filter(FilterAction.t, t, t) // TODO: Change to reflect DHExp - | Parens(t) // [TO ADD TO DHEXP] - | Cons(t, t) // DONE [ALREADY] - | ListConcat(t, t) // DONE [ALREADY] - | UnOp(op_un, t) // [TO ADD TO DHEXP] - | BinOp(op_bin, t, t) // DONE [DH CHANGED] - | Match(t, list((UPat.t, t))) // DONE [DH TO CHANGE] + // TODO: Add closures + | Parens(t) + | Cons(t, t) + | ListConcat(t, t) + // TODO: Add Builtins + | UnOp(op_un, t) + | BinOp(op_bin, t, t) + | Match(t, list((UPat.t, t))) + // TODO: Add Casts and t = { // invariant: nonempty ids: list(Id.t), // > DHEXP // Multiple ids?? // Add source?? diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index 9962938554..4628bf615b 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -46,7 +46,6 @@ let rec precedence = (~show_casts: bool, d: DHExp.t) => { let precedence' = precedence(~show_casts); switch (DHExp.term_of(d)) { | Var(_) - | FreeVar(_) | Invalid(_) | Bool(_) | Int(_) @@ -58,7 +57,7 @@ let rec precedence = (~show_casts: bool, d: DHExp.t) => { | EmptyHole | Constructor(_) | FailedCast(_) - | InvalidOperation(_) + | DynamicErrorHole(_) | If(_) | Closure(_) | BuiltinFun(_) @@ -285,11 +284,7 @@ let mk = | MultiHole(ds) => ds |> List.map(go') |> Doc.hcats | StaticErrorHole(u, d') => go'(d') |> annot(DHAnnot.NonEmptyHole(TypeInconsistent, (u, 0))) - | FreeVar(u, i, x) => - text(x) |> annot(DHAnnot.VarHole(Free, (u, i))) | Invalid(t) => DHDoc_common.mk_InvalidText(t) - | Match(Inconsistent(u, i), dscrut, drs) => - go_case(dscrut, drs) |> annot(DHAnnot.InconsistentBranches((u, i))) | Var(x) when List.mem(x, recursive_calls) => text(x) | Var(x) when settings.show_lookup_steps => text(x) | Var(x) => @@ -316,7 +311,7 @@ let mk = | Seq(d1, d2) => let (doc1, doc2) = (go'(d1), go'(d2)); DHDoc_common.mk_Sequence(doc1, doc2); - | ListLit(_, _, _, d_list) => + | ListLit(_, d_list) => let ol = d_list |> List.map(d => go'(d)); DHDoc_common.mk_ListLit(ol); | Ap(Forward, d1, d2) => @@ -368,7 +363,7 @@ let mk = hseps([doc1, mk_bin_bool_op(op), doc2]); | Tuple([]) => DHDoc_common.Delim.triv | Tuple(ds) => DHDoc_common.mk_Tuple(ds |> List.map(d => go'(d))) - | Match(Consistent, dscrut, drs) => go_case(dscrut, drs) + | Match(dscrut, drs) => go_case(dscrut, drs) | Cast(d, _, ty) when settings.show_casts => // TODO[Matt]: Roll multiple casts into one cast let doc = go'(d); @@ -433,14 +428,14 @@ let mk = hcats([d_doc, cast_decoration]); | _ => failwith("unexpected FailedCast without inner cast") } - | InvalidOperation(d, err) => + | DynamicErrorHole(d, err) => let d_doc = go'(d); let decoration = Doc.text(InvalidOperationError.err_msg(err)) |> annot(DHAnnot.OperationError(err)); hcats([d_doc, decoration]); - | If(_, c, d1, d2) => + | If(c, d1, d2) => let c_doc = go_formattable(c); let d1_doc = go_formattable(d1); let d2_doc = go_formattable(d2); diff --git a/src/test/Test_Elaboration.re b/src/test/Test_Elaboration.re index 24470504aa..baab4cf210 100644 --- a/src/test/Test_Elaboration.re +++ b/src/test/Test_Elaboration.re @@ -40,8 +40,7 @@ let u3: Term.UExp.t = { ids: [id_at(0)], term: Parens({ids: [id_at(1)], term: Var("y")}), }; -let d3: DHExp.t = - StaticErrorHole(id_at(1), FreeVar(id_at(1), 0, "y") |> fresh) |> fresh; +let d3: DHExp.t = StaticErrorHole(id_at(1), Var("y") |> fresh) |> fresh; let free_var = () => alco_check( "Nonempty hole with free variable", @@ -107,7 +106,7 @@ let d5: DHExp.t = BinOp( Int(Plus), StaticErrorHole(id_at(1), Bool(false) |> fresh) |> fresh, - StaticErrorHole(id_at(2), FreeVar(id_at(2), 0, "y") |> fresh) |> fresh, + StaticErrorHole(id_at(2), Var("y") |> fresh) |> fresh, ) |> fresh; let bin_op = () => @@ -127,8 +126,7 @@ let u6: Term.UExp.t = { ), }; let d6: DHExp.t = - If(DH.Consistent, Bool(false) |> fresh, Int(8) |> fresh, Int(6) |> fresh) - |> fresh; + If(Bool(false) |> fresh, Int(8) |> fresh, Int(6) |> fresh) |> fresh; let consistent_if = () => alco_check( "Consistent case with rules (BoolLit(true), IntLit(8)) and (BoolLit(false), IntLit(6))", @@ -176,7 +174,7 @@ let d7: DHExp.t = None, ) |> fresh, - StaticErrorHole(id_at(6), FreeVar(id_at(6), 0, "y") |> fresh) |> fresh, + StaticErrorHole(id_at(6), Var("y") |> fresh) |> fresh, ) |> fresh; let ap_fun = () => @@ -218,8 +216,7 @@ let d8rules = (Bool(true) |> DHPat.fresh, Int(24) |> fresh), (Bool(false) |> DHPat.fresh, Bool(false) |> fresh), ]; -let d8a: DHExp.t = - Match(Inconsistent(id_at(0), 0), d8scrut, d8rules) |> fresh; +let d8a: DHExp.t = Match(d8scrut, d8rules) |> fresh; let d8: DHExp.t = StaticErrorHole(id_at(0), d8a) |> fresh; let inconsistent_case = () => alco_check( From 6d73811d59ceef081e23a076af63c1de4a363249 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Tue, 27 Feb 2024 17:00:42 -0500 Subject: [PATCH 026/103] Add TyAlias --- src/haz3lcore/dynamics/DH.re | 7 +++++++ src/haz3lcore/dynamics/Elaborator.re | 10 ++++++++++ src/haz3lcore/dynamics/FilterMatcher.re | 4 ++++ src/haz3lcore/dynamics/PatternMatch.re | 3 +++ src/haz3lcore/dynamics/Stepper.re | 2 +- src/haz3lcore/dynamics/Substitution.re | 3 +++ src/haz3lcore/dynamics/Transition.re | 7 +++++-- src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 4 +++- 8 files changed, 36 insertions(+), 4 deletions(-) diff --git a/src/haz3lcore/dynamics/DH.re b/src/haz3lcore/dynamics/DH.re index 287542d8cb..b1950f74d7 100644 --- a/src/haz3lcore/dynamics/DH.re +++ b/src/haz3lcore/dynamics/DH.re @@ -26,6 +26,7 @@ module rec DHExp: { | Var(Var.t) | Let(DHPat.t, t, t) | FixF(DHPat.t, Typ.t, t) // TODO: Remove type + | TyAlias(TermBase.UTPat.t, TermBase.UTyp.t, t) // TODO: Add TyAlias | Ap(TermBase.UExp.ap_direction, t, t) | If(t, t, t) @@ -86,6 +87,7 @@ module rec DHExp: { | Var(Var.t) | Let(DHPat.t, t, t) | FixF(DHPat.t, Typ.t, t) // TODO: Remove type + | TyAlias(TermBase.UTPat.t, TermBase.UTyp.t, t) // TODO: Add TyAlias | Ap(TermBase.UExp.ap_direction, t, t) | If(t, t, t) @@ -174,6 +176,7 @@ module rec DHExp: { | Seq(d1, d2) => Seq(repair_ids(d1), repair_ids(d2)) | Let(dp, d1, d2) => Let(dp, repair_ids(d1), repair_ids(d2)) | FixF(f, t, d1) => FixF(f, t, repair_ids(d1)) + | TyAlias(tp, t, d) => TyAlias(tp, t, repair_ids(d)) | Fun(dp, t, d1, env, f) => Fun(dp, t, repair_ids(d1), env, f) | Ap(dir, d1, d2) => Ap(dir, repair_ids(d1), repair_ids(d2)) | ApBuiltin(s, d1) => ApBuiltin(s, repair_ids(d1)) @@ -218,6 +221,7 @@ module rec DHExp: { Filter(DHFilter.strip_casts(f), strip_casts(b)) |> rewrap | Let(dp, b, c) => Let(dp, strip_casts(b), strip_casts(c)) |> rewrap | FixF(a, b, c) => FixF(a, b, strip_casts(c)) |> rewrap + | TyAlias(tp, t, d) => TyAlias(tp, t, strip_casts(d)) |> rewrap | Fun(a, b, c, e, d) => Fun(a, b, strip_casts(c), e, d) |> rewrap | Ap(dir, a, b) => Ap(dir, strip_casts(a), strip_casts(b)) |> rewrap | Test(id, a) => Test(id, strip_casts(a)) |> rewrap @@ -294,6 +298,8 @@ module rec DHExp: { && List.for_all2(fast_equal, ds1, ds2) | (BinOp(op1, d11, d21), BinOp(op2, d12, d22)) => op1 == op2 && fast_equal(d11, d12) && fast_equal(d21, d22) + | (TyAlias(tp1, ut1, d1), TyAlias(tp2, ut2, d2)) => + tp1 == tp2 && ut1 == ut2 && fast_equal(d1, d2) | (Cast(d1, ty11, ty21), Cast(d2, ty12, ty22)) | (FailedCast(d1, ty11, ty21), FailedCast(d2, ty12, ty22)) => fast_equal(d1, d2) && ty11 == ty12 && ty21 == ty22 @@ -327,6 +333,7 @@ module rec DHExp: { | (BinOp(_), _) | (Cast(_), _) | (FailedCast(_), _) + | (TyAlias(_), _) | (DynamicErrorHole(_), _) | (If(_), _) | (Match(_), _) => false diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index aa9957381f..499a32462b 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -1,6 +1,15 @@ open Util; open OptUtil.Syntax; +/* + Currently, Elaboration does the following things: + + - Insert casts + - Insert non-empty holes + - Remove TyAlias + - Annotate functions with types, and names + */ + module Elaboration = { [@deriving (show({with_path: false}), sexp, yojson)] type t = { @@ -121,6 +130,7 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => | Float(_) | String(_) | BinOp(_) + | TyAlias(_) | Test(_) => DHExp.fresh_cast(d, self_ty, ana_ty) }; }; diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index 8dde587812..c8c862ac82 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -165,6 +165,10 @@ let rec matches_exp = | (ApBuiltin(dname, darg), ApBuiltin(fname, farg)) => dname == fname && matches_exp(env, darg, farg) | (ApBuiltin(_), _) => false + + | (TyAlias(dtp, dut, dd), TyAlias(ftp, fut, fd)) => + dtp == ftp && dut == fut && matches_exp(env, dd, fd) + | (TyAlias(_), _) => false }; } and matches_pat = (d: DHPat.t, f: DHPat.t): bool => { diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index c32bba5315..30b13c34f6 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -251,6 +251,7 @@ and matches_cast_Sum = | DynamicErrorHole(_) | Match(_) | If(_) + | TyAlias(_) | BuiltinFun(_) => IndetMatch | Cast(_) | Var(_) @@ -333,6 +334,7 @@ and matches_cast_Tuple = | Filter(_, _) => IndetMatch | Ap(_, _, _) => IndetMatch | ApBuiltin(_, _) => IndetMatch + | TyAlias(_) => IndetMatch | BinOp(_, _, _) | Bool(_) => DoesNotMatch | Int(_) => DoesNotMatch @@ -466,6 +468,7 @@ and matches_cast_Cons = | Filter(_, d') => matches_cast_Cons(dp, d', elt_casts) | Ap(_, _, _) => IndetMatch | ApBuiltin(_, _) => IndetMatch + | TyAlias(_) => IndetMatch | BinOp(_, _, _) | ListConcat(_) | BuiltinFun(_) => DoesNotMatch diff --git a/src/haz3lcore/dynamics/Stepper.re b/src/haz3lcore/dynamics/Stepper.re index 3f030fde99..1eadeb7d85 100644 --- a/src/haz3lcore/dynamics/Stepper.re +++ b/src/haz3lcore/dynamics/Stepper.re @@ -367,7 +367,7 @@ let get_justification: step_kind => string = | CompleteFilter => "complete filter" | CompleteClosure => "complete closure" | FunClosure => "function closure" - | Skip => "skipped steps"; + | RemoveTypeAlias => "define type"; type step_info = { d: DHExp.t, diff --git a/src/haz3lcore/dynamics/Substitution.re b/src/haz3lcore/dynamics/Substitution.re index 64f938d1d5..2b728f07ba 100644 --- a/src/haz3lcore/dynamics/Substitution.re +++ b/src/haz3lcore/dynamics/Substitution.re @@ -110,6 +110,9 @@ let rec subst_var = (d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => { let d5' = subst_var(d1, x, d5); let d6' = subst_var(d1, x, d6); If(d4', d5', d6') |> rewrap; + | TyAlias(tp, ut, d4) => + let d4' = subst_var(d1, x, d4); + TyAlias(tp, ut, d4') |> rewrap; }; } diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index 69aeb9e242..6539fc74ea 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -70,7 +70,7 @@ type step_kind = | CompleteClosure | CompleteFilter | Cast - | Skip; + | RemoveTypeAlias; module CastHelpers = { [@deriving sexp] @@ -777,6 +777,9 @@ module Transition = (EV: EV_MODE) => { d1, ); Indet; + | TyAlias(_, _, d) => + let. _ = otherwise(env, d); + Step({apply: () => d, kind: RemoveTypeAlias, value: false}); | Filter(f1, d1) => let. _ = otherwise(env, d1 => Filter(f1, d1) |> rewrap) and. d1 = @@ -801,8 +804,8 @@ let should_hide_step = (~settings: CoreSettings.Evaluation.t) => | ListConcat | CaseApply | Projection // TODO(Matt): We don't want to show projection to the user - | Skip | Conditional(_) + | RemoveTypeAlias | InvalidStep => false | VarLookup => !settings.show_lookup_steps | CastAp diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index 4628bf615b..193b356053 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -71,6 +71,7 @@ let rec precedence = (~show_casts: bool, d: DHExp.t) => { | Tuple(_) => DHDoc_common.precedence_Comma | Fun(_) => DHDoc_common.precedence_max | Let(_) + | TyAlias(_) | FixF(_) | Match(_) => DHDoc_common.precedence_max @@ -166,7 +167,7 @@ let mk = | (CompleteFilter, _) | (Cast, _) | (Conditional(_), _) - | (Skip, _) => [] + | (RemoveTypeAlias, _) => [] // Maybe this last one could count as a substitution? } | _ => recent_subst }; @@ -364,6 +365,7 @@ let mk = | Tuple([]) => DHDoc_common.Delim.triv | Tuple(ds) => DHDoc_common.mk_Tuple(ds |> List.map(d => go'(d))) | Match(dscrut, drs) => go_case(dscrut, drs) + | TyAlias(_, _, d) => go'(d) | Cast(d, _, ty) when settings.show_casts => // TODO[Matt]: Roll multiple casts into one cast let doc = go'(d); From 92c1f631903ddc067cdc2637530bd66b72d26537 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Wed, 28 Feb 2024 15:45:51 -0500 Subject: [PATCH 027/103] Add Unary Operator to DHExp --- src/haz3lcore/dynamics/DH.re | 8 +++- src/haz3lcore/dynamics/Elaborator.re | 16 ++------ src/haz3lcore/dynamics/EvalCtx.re | 4 ++ src/haz3lcore/dynamics/FilterMatcher.re | 4 ++ src/haz3lcore/dynamics/PatternMatch.re | 6 ++- src/haz3lcore/dynamics/Stepper.re | 8 +++- src/haz3lcore/dynamics/Substitution.re | 3 ++ src/haz3lcore/dynamics/Transition.re | 39 +++++++++++++++++++ src/haz3lcore/lang/Form.re | 2 +- src/haz3lcore/lang/Precedence.re | 2 + src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 23 ++++++++++- .../view/dhcode/layout/DHDoc_common.re | 2 +- .../view/dhcode/layout/DHDoc_common.rei | 1 + 13 files changed, 99 insertions(+), 19 deletions(-) diff --git a/src/haz3lcore/dynamics/DH.re b/src/haz3lcore/dynamics/DH.re index b1950f74d7..19f5da3e85 100644 --- a/src/haz3lcore/dynamics/DH.re +++ b/src/haz3lcore/dynamics/DH.re @@ -39,7 +39,7 @@ module rec DHExp: { | ListConcat(t, t) | ApBuiltin(string, t) // DONE [TO ADD TO UEXP] TODO: Add a loooong comment here | BuiltinFun(string) // DONE [TO ADD TO UEXP] - // TODO: Add UnOp + | UnOp(TermBase.UExp.op_un, t) | BinOp(TermBase.UExp.op_bin, t, t) // DONE | Match(t, list((DHPat.t, t))) | Cast(t, Typ.t, Typ.t) // TODO: Add to uexp or remove @@ -100,7 +100,7 @@ module rec DHExp: { | ListConcat(t, t) | ApBuiltin(string, t) // DONE [TO ADD TO UEXP] TODO: Add a loooong comment here | BuiltinFun(string) // DONE [TO ADD TO UEXP] - // TODO: Add UnOp + | UnOp(TermBase.UExp.op_un, t) | BinOp(TermBase.UExp.op_bin, t, t) // DONE | Match(t, list((DHPat.t, t))) | Cast(t, Typ.t, Typ.t) // TODO: Add to uexp or remove @@ -181,6 +181,7 @@ module rec DHExp: { | Ap(dir, d1, d2) => Ap(dir, repair_ids(d1), repair_ids(d2)) | ApBuiltin(s, d1) => ApBuiltin(s, repair_ids(d1)) | Test(id, d1) => Test(id, repair_ids(d1)) + | UnOp(op, d1) => UnOp(op, repair_ids(d1)) | BinOp(op, d1, d2) => BinOp(op, repair_ids(d1), repair_ids(d2)) | ListLit(t, ds) => ListLit(t, List.map(repair_ids, ds)) | Cons(d1, d2) => Cons(repair_ids(d1), repair_ids(d2)) @@ -227,6 +228,7 @@ module rec DHExp: { | Test(id, a) => Test(id, strip_casts(a)) |> rewrap | ApBuiltin(fn, args) => ApBuiltin(fn, strip_casts(args)) |> rewrap | BuiltinFun(fn) => BuiltinFun(fn) |> rewrap + | UnOp(op, d) => UnOp(op, strip_casts(d)) |> rewrap | BinOp(a, b, c) => BinOp(a, strip_casts(b), strip_casts(c)) |> rewrap | Match(a, rules) => Match( @@ -296,6 +298,7 @@ module rec DHExp: { t1 == t2 && List.length(ds1) == List.length(ds2) && List.for_all2(fast_equal, ds1, ds2) + | (UnOp(op1, d1), UnOp(op2, d2)) => op1 == op2 && fast_equal(d1, d2) | (BinOp(op1, d11, d21), BinOp(op2, d12, d22)) => op1 == op2 && fast_equal(d11, d12) && fast_equal(d21, d22) | (TyAlias(tp1, ut1, d1), TyAlias(tp2, ut2, d2)) => @@ -330,6 +333,7 @@ module rec DHExp: { | (ListConcat(_), _) | (ListLit(_), _) | (Tuple(_), _) + | (UnOp(_), _) | (BinOp(_), _) | (Cast(_), _) | (FailedCast(_), _) diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 499a32462b..7531c1a5a0 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -129,6 +129,7 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => | Int(_) | Float(_) | String(_) + | UnOp(_) | BinOp(_) | TyAlias(_) | Test(_) => DHExp.fresh_cast(d, self_ty, ana_ty) @@ -220,19 +221,10 @@ let rec dhexp_of_uexp = } | UnOp(Int(Minus), e) => let+ dc = dhexp_of_uexp(m, e); - DHExp.BinOp(Int(Minus), DHExp.fresh(Int(0)), dc) |> rewrap; + DHExp.UnOp(Int(Minus), dc) |> rewrap; | UnOp(Bool(Not), e) => - let+ d_scrut = dhexp_of_uexp(m, e); - let d_rules = [ - (DHPat.(fresh(Bool(true))), DHExp.(fresh(Bool(false)))), - (DHPat.(fresh(Bool(false))), DHExp.(fresh(Bool(true)))), - ]; - let d = DHExp.(fresh(Match(d_scrut, d_rules))); - /* Manually construct cast (case is not otherwise cast) */ - switch (mode) { - | Ana(ana_ty) => DHExp.fresh_cast(d, Bool, ana_ty) - | _ => d - }; + let+ dc = dhexp_of_uexp(m, e); + DHExp.UnOp(Bool(Not), dc) |> rewrap; | BinOp(op, e1, e2) => let* dc1 = dhexp_of_uexp(m, e1); let+ dc2 = dhexp_of_uexp(m, e2); diff --git a/src/haz3lcore/dynamics/EvalCtx.re b/src/haz3lcore/dynamics/EvalCtx.re index edaea1958d..c80bf279bc 100644 --- a/src/haz3lcore/dynamics/EvalCtx.re +++ b/src/haz3lcore/dynamics/EvalCtx.re @@ -17,6 +17,7 @@ type term = | If1(t, DHExp.t, DHExp.t) | If2(DHExp.t, t, DHExp.t) | If3(DHExp.t, DHExp.t, t) + | UnOp(TermBase.UExp.op_un, t) | BinOp1(TermBase.UExp.op_bin, t, DHExp.t) | BinOp2(TermBase.UExp.op_bin, DHExp.t, t) | Tuple(t, (list(DHExp.t), list(DHExp.t))) @@ -86,6 +87,9 @@ let rec compose = (ctx: t, d: DHExp.t): DHExp.t => { | Test(lit, ctx) => let d1 = compose(ctx, d); Test(lit, d1) |> wrap; + | UnOp(op, ctx) => + let d1 = compose(ctx, d); + UnOp(op, d1) |> wrap; | BinOp1(op, ctx, d2) => let d1 = compose(ctx, d); BinOp(op, d1, d2) |> wrap; diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index c8c862ac82..9eea3f8147 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -132,6 +132,10 @@ let rec matches_exp = ) | (Tuple(_), _) => false + | (UnOp(d_op, d1), UnOp(f_op, f1)) => + d_op == f_op && matches_exp(env, d1, f1) + | (UnOp(_), _) => false + | (BinOp(d_op, d1, d2), BinOp(f_op, f1, f2)) => d_op == f_op && matches_exp(env, d1, f1) && matches_exp(env, d2, f2) | (BinOp(_), _) => false diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index 30b13c34f6..f1a2f03cd3 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -49,6 +49,7 @@ let rec matches = (dp: DHPat.t, d: DHExp.t): match_result => | (_, FixF(_)) => DoesNotMatch | (_, Fun(_)) => DoesNotMatch | (_, BinOp(_)) => IndetMatch + | (_, UnOp(_)) => IndetMatch | (_, Match(_, _)) => IndetMatch /* Closure should match like underlying expression. */ @@ -242,6 +243,7 @@ and matches_cast_Sum = | Invalid(_) | Let(_) | ApBuiltin(_) + | UnOp(_) | BinOp(_) | EmptyHole | MultiHole(_) @@ -335,7 +337,8 @@ and matches_cast_Tuple = | Ap(_, _, _) => IndetMatch | ApBuiltin(_, _) => IndetMatch | TyAlias(_) => IndetMatch - | BinOp(_, _, _) + | UnOp(_, _) + | BinOp(_, _, _) => DoesNotMatch | Bool(_) => DoesNotMatch | Int(_) => DoesNotMatch | Seq(_) @@ -469,6 +472,7 @@ and matches_cast_Cons = | Ap(_, _, _) => IndetMatch | ApBuiltin(_, _) => IndetMatch | TyAlias(_) => IndetMatch + | UnOp(_, _) | BinOp(_, _, _) | ListConcat(_) | BuiltinFun(_) => DoesNotMatch diff --git a/src/haz3lcore/dynamics/Stepper.re b/src/haz3lcore/dynamics/Stepper.re index 1eadeb7d85..1d98ae1fbf 100644 --- a/src/haz3lcore/dynamics/Stepper.re +++ b/src/haz3lcore/dynamics/Stepper.re @@ -109,6 +109,9 @@ let rec matches = | If3(d1, d2, ctx) => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); If3(d1, d2, ctx) |> rewrap; + | UnOp(op, ctx) => + let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); + UnOp(op, ctx) |> rewrap; | BinOp1(op, ctx, d1) => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); BinOp1(op, ctx, d1) |> rewrap; @@ -345,6 +348,7 @@ let get_justification: step_kind => string = | FunAp => "apply function" | BuiltinWrap => "wrap builtin" | BuiltinAp(s) => "evaluate " ++ s + | UnOp(Int(Minus)) | BinIntOp(Plus | Minus | Times | Power | Divide) | BinFloatOp(Plus | Minus | Times | Power | Divide) => "arithmetic" | BinIntOp(LessThan | LessThanOrEqual | GreaterThan | GreaterThanOrEqual) @@ -353,6 +357,7 @@ let get_justification: step_kind => string = | BinFloatOp(Equals | NotEquals) | BinStringOp(Equals) => "check equality" | BinStringOp(Concat) => "string manipulation" + | UnOp(Bool(Not)) | BinBoolOp(_) => "boolean logic" | Conditional(_) => "conditional" | ListCons => "list manipulation" @@ -367,7 +372,8 @@ let get_justification: step_kind => string = | CompleteFilter => "complete filter" | CompleteClosure => "complete closure" | FunClosure => "function closure" - | RemoveTypeAlias => "define type"; + | RemoveTypeAlias => "define type" + | UnOp(Meta(Unquote)) => failwith("INVALID STEP"); type step_info = { d: DHExp.t, diff --git a/src/haz3lcore/dynamics/Substitution.re b/src/haz3lcore/dynamics/Substitution.re index 2b728f07ba..f80373a7f1 100644 --- a/src/haz3lcore/dynamics/Substitution.re +++ b/src/haz3lcore/dynamics/Substitution.re @@ -74,6 +74,9 @@ let rec subst_var = (d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => { let d4 = subst_var(d1, x, d4); ListConcat(d3, d4) |> rewrap; | Tuple(ds) => Tuple(List.map(subst_var(d1, x), ds)) |> rewrap + | UnOp(op, d3) => + let d3 = subst_var(d1, x, d3); + UnOp(op, d3) |> rewrap; | BinOp(op, d3, d4) => let d3 = subst_var(d1, x, d3); let d4 = subst_var(d1, x, d4); diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index 6539fc74ea..f788db40ef 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -58,6 +58,7 @@ type step_kind = | CastAp | BuiltinWrap | BuiltinAp(string) + | UnOp(TermBase.UExp.op_un) | BinBoolOp(TermBase.UExp.op_bin_bool) | BinIntOp(TermBase.UExp.op_bin_int) | BinFloatOp(TermBase.UExp.op_bin_float) @@ -432,6 +433,43 @@ module Transition = (EV: EV_MODE) => { value: true, }) }; + | UnOp(Meta(Unquote), _) => + let. _ = otherwise(env, d); + Indet; + | UnOp(Int(Minus), d1) => + let. _ = otherwise(env, d1 => UnOp(Int(Minus), d1) |> rewrap) + and. d1' = + req_value( + req(state, env), + c => UnOp(Int(Minus), c) |> wrap_ctx, + d1, + ); + Step({ + apply: () => + switch (DHExp.term_of(d1')) { + | Int(n) => Int(- n) |> fresh + | _ => raise(EvaluatorError.Exception(InvalidBoxedIntLit(d1'))) + }, + kind: UnOp(Int(Minus)), + value: true, + }); + | UnOp(Bool(Not), d1) => + let. _ = otherwise(env, d1 => UnOp(Bool(Not), d1) |> rewrap) + and. d1' = + req_value( + req(state, env), + c => UnOp(Bool(Not), c) |> wrap_ctx, + d1, + ); + Step({ + apply: () => + switch (DHExp.term_of(d1')) { + | Bool(b) => Bool(!b) |> fresh + | _ => raise(EvaluatorError.Exception(InvalidBoxedIntLit(d1'))) + }, + kind: UnOp(Bool(Not)), + value: true, + }); | BinOp(Bool(And), d1, d2) => let. _ = otherwise(env, d1 => BinOp(Bool(And), d1, d2) |> rewrap) and. d1' = @@ -800,6 +838,7 @@ let should_hide_step = (~settings: CoreSettings.Evaluation.t) => | BinIntOp(_) | BinFloatOp(_) | BinStringOp(_) + | UnOp(_) | ListCons | ListConcat | CaseApply diff --git a/src/haz3lcore/lang/Form.re b/src/haz3lcore/lang/Form.re index 023bd340de..53b5e5d617 100644 --- a/src/haz3lcore/lang/Form.re +++ b/src/haz3lcore/lang/Form.re @@ -278,7 +278,7 @@ let forms: list((string, t)) = [ ("cons_pat", mk_infix("::", Pat, P.cons)), ("typeann", mk(ss, [":"], mk_bin'(P.ann, Pat, Pat, [], Typ))), // UNARY PREFIX OPERATORS - ("not", mk(ii, ["!"], mk_pre(5, Exp, []))), //TODO: precedence + ("not", mk(ii, ["!"], mk_pre(P.not_, Exp, []))), //TODO: precedence ("typ_sum_single", mk(ss, ["+"], mk_pre(P.or_, Typ, []))), ("unary_minus", mk(ss, ["-"], mk_pre(P.neg, Exp, []))), ("unquote", mk(ss, ["$"], mk_pre(P.unquote, Exp, []))), diff --git a/src/haz3lcore/lang/Precedence.re b/src/haz3lcore/lang/Precedence.re index b7d00796a5..e809621df7 100644 --- a/src/haz3lcore/lang/Precedence.re +++ b/src/haz3lcore/lang/Precedence.re @@ -14,6 +14,8 @@ let ap = 2; let neg = 3; let power = 4; let mult = 5; + +let not_ = 5; let plus = 6; let cons = 7; let concat = 8; diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index 193b356053..e21c1bd406 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -74,7 +74,9 @@ let rec precedence = (~show_casts: bool, d: DHExp.t) => { | TyAlias(_) | FixF(_) | Match(_) => DHDoc_common.precedence_max - + | UnOp(Meta(Unquote), _) => DHDoc_common.precedence_Ap + | UnOp(Bool(Not), _) => DHDoc_common.precedence_Not + | UnOp(Int(Minus), _) => DHDoc_common.precedence_Minus | BinOp(Bool(op), _, _) => precedence_bin_bool_op(op) | BinOp(Int(op), _, _) => precedence_bin_int_op(op) | BinOp(Float(op), _, _) => precedence_bin_float_op(op) @@ -154,6 +156,7 @@ let mk = | (UpdateTest, _) | (CastAp, _) | (BuiltinWrap, _) + | (UnOp(_), _) | (BuiltinAp(_), _) | (BinBoolOp(_), _) | (BinIntOp(_), _) @@ -335,6 +338,24 @@ let mk = go_formattable(d) |> parenthesize(precedence(d) > DHDoc_common.precedence_Ap), ) + | UnOp(Meta(Unquote), d) => + DHDoc_common.mk_Ap( + text("$"), + go_formattable(d) + |> parenthesize(precedence(d) > DHDoc_common.precedence_Ap), + ) + | UnOp(Bool(Not), d) => + DHDoc_common.mk_Ap( + text("!"), + go_formattable(d) + |> parenthesize(precedence(d) > DHDoc_common.precedence_Not), + ) + | UnOp(Int(Minus), d) => + DHDoc_common.mk_Ap( + text("-"), + go_formattable(d) + |> parenthesize(precedence(d) > DHDoc_common.precedence_Minus), + ) | BinOp(Int(op), d1, d2) => // TODO assumes all bin int ops are left associative let (doc1, doc2) = diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_common.re b/src/haz3lweb/view/dhcode/layout/DHDoc_common.re index d777d72f35..1edb1dd884 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_common.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_common.re @@ -8,7 +8,7 @@ module P = Precedence; let precedence_const = P.max; let precedence_Ap = P.ap; let precedence_Power = P.power; - +let precedence_Not = P.not_; let precedence_Times = P.mult; let precedence_Divide = P.mult; let precedence_Plus = P.plus; diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_common.rei b/src/haz3lweb/view/dhcode/layout/DHDoc_common.rei index ccb721c2b7..b08f4215c0 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_common.rei +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_common.rei @@ -9,6 +9,7 @@ let precedence_Power: int; let precedence_Divide: int; let precedence_Plus: int; let precedence_Minus: int; +let precedence_Not: int; let precedence_Cons: int; let precedence_Equals: int; let precedence_LessThan: int; From 82f5c2ce2943db6d62b410866af5d831ae5c2e47 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Wed, 28 Feb 2024 17:03:42 -0500 Subject: [PATCH 028/103] Remove BuiltinAp --- src/haz3lcore/dynamics/DH.re | 6 --- src/haz3lcore/dynamics/Elaborator.re | 1 - src/haz3lcore/dynamics/EvalCtx.re | 4 -- src/haz3lcore/dynamics/Evaluator.re | 7 +++ src/haz3lcore/dynamics/EvaluatorStep.re | 13 +++++ src/haz3lcore/dynamics/FilterMatcher.re | 4 -- src/haz3lcore/dynamics/PatternMatch.re | 3 -- src/haz3lcore/dynamics/Stepper.re | 3 -- src/haz3lcore/dynamics/Substitution.re | 3 -- src/haz3lcore/dynamics/Transition.re | 57 +++++++++----------- src/haz3lcore/dynamics/ValueChecker.re | 7 +++ src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 7 --- 12 files changed, 53 insertions(+), 62 deletions(-) diff --git a/src/haz3lcore/dynamics/DH.re b/src/haz3lcore/dynamics/DH.re index 19f5da3e85..b2b2ca2438 100644 --- a/src/haz3lcore/dynamics/DH.re +++ b/src/haz3lcore/dynamics/DH.re @@ -37,7 +37,6 @@ module rec DHExp: { // TODO: Add Parens | Cons(t, t) | ListConcat(t, t) - | ApBuiltin(string, t) // DONE [TO ADD TO UEXP] TODO: Add a loooong comment here | BuiltinFun(string) // DONE [TO ADD TO UEXP] | UnOp(TermBase.UExp.op_un, t) | BinOp(TermBase.UExp.op_bin, t, t) // DONE @@ -98,7 +97,6 @@ module rec DHExp: { // TODO: Add Parens | Cons(t, t) | ListConcat(t, t) - | ApBuiltin(string, t) // DONE [TO ADD TO UEXP] TODO: Add a loooong comment here | BuiltinFun(string) // DONE [TO ADD TO UEXP] | UnOp(TermBase.UExp.op_un, t) | BinOp(TermBase.UExp.op_bin, t, t) // DONE @@ -179,7 +177,6 @@ module rec DHExp: { | TyAlias(tp, t, d) => TyAlias(tp, t, repair_ids(d)) | Fun(dp, t, d1, env, f) => Fun(dp, t, repair_ids(d1), env, f) | Ap(dir, d1, d2) => Ap(dir, repair_ids(d1), repair_ids(d2)) - | ApBuiltin(s, d1) => ApBuiltin(s, repair_ids(d1)) | Test(id, d1) => Test(id, repair_ids(d1)) | UnOp(op, d1) => UnOp(op, repair_ids(d1)) | BinOp(op, d1, d2) => BinOp(op, repair_ids(d1), repair_ids(d2)) @@ -226,7 +223,6 @@ module rec DHExp: { | Fun(a, b, c, e, d) => Fun(a, b, strip_casts(c), e, d) |> rewrap | Ap(dir, a, b) => Ap(dir, strip_casts(a), strip_casts(b)) |> rewrap | Test(id, a) => Test(id, strip_casts(a)) |> rewrap - | ApBuiltin(fn, args) => ApBuiltin(fn, strip_casts(args)) |> rewrap | BuiltinFun(fn) => BuiltinFun(fn) |> rewrap | UnOp(op, d) => UnOp(op, strip_casts(d)) |> rewrap | BinOp(a, b, c) => BinOp(a, strip_casts(b), strip_casts(c)) |> rewrap @@ -292,7 +288,6 @@ module rec DHExp: { | (Tuple(ds1), Tuple(ds2)) => List.length(ds1) == List.length(ds2) && List.for_all2(fast_equal, ds1, ds2) - | (ApBuiltin(f1, d1), ApBuiltin(f2, d2)) => f1 == f2 && d1 == d2 | (BuiltinFun(f1), BuiltinFun(f2)) => f1 == f2 | (ListLit(t1, ds1), ListLit(t2, ds2)) => t1 == t2 @@ -327,7 +322,6 @@ module rec DHExp: { | (Fun(_), _) | (Test(_), _) | (Ap(_), _) - | (ApBuiltin(_), _) | (BuiltinFun(_), _) | (Cons(_), _) | (ListConcat(_), _) diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 7531c1a5a0..426bee9ab5 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -123,7 +123,6 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => | DynamicErrorHole(_) => d /* Normal cases: wrap */ | Var(_) - | ApBuiltin(_) | BuiltinFun(_) | Bool(_) | Int(_) diff --git a/src/haz3lcore/dynamics/EvalCtx.re b/src/haz3lcore/dynamics/EvalCtx.re index c80bf279bc..f70ccbe06f 100644 --- a/src/haz3lcore/dynamics/EvalCtx.re +++ b/src/haz3lcore/dynamics/EvalCtx.re @@ -21,7 +21,6 @@ type term = | BinOp1(TermBase.UExp.op_bin, t, DHExp.t) | BinOp2(TermBase.UExp.op_bin, DHExp.t, t) | Tuple(t, (list(DHExp.t), list(DHExp.t))) - | ApBuiltin(string, t) | Test(KeywordID.t, t) | ListLit(Typ.t, t, (list(DHExp.t), list(DHExp.t))) | MultiHole(t, (list(DHExp.t), list(DHExp.t))) @@ -72,9 +71,6 @@ let rec compose = (ctx: t, d: DHExp.t): DHExp.t => { | Ap2(dir, d1, ctx) => let d2 = compose(ctx, d); Ap(dir, d1, d2) |> wrap; - | ApBuiltin(s, ctx) => - let d' = compose(ctx, d); - ApBuiltin(s, d') |> wrap; | If1(ctx, d2, d3) => let d' = compose(ctx, d); If(d', d2, d3) |> wrap; diff --git a/src/haz3lcore/dynamics/Evaluator.re b/src/haz3lcore/dynamics/Evaluator.re index eb7d628c81..eb9d885628 100644 --- a/src/haz3lcore/dynamics/Evaluator.re +++ b/src/haz3lcore/dynamics/Evaluator.re @@ -81,6 +81,13 @@ module EvaluatorEVMode: { (r1 && r2, [x', ...xs']); }; + let req_final_or_value = (f, _, x) => + switch (f(x)) { + | BoxedValue(x) => (BoxedReady, (x, true)) + | Indet(x) => (IndetReady, (x, false)) + | Uneval(_) => failwith("Unexpected Uneval") + }; + let otherwise = (_, c) => (BoxedReady, (), c); let (and.) = ((r1, x1, c1), (r2, x2)) => (r1 && r2, (x1, x2), c1(x2)); diff --git a/src/haz3lcore/dynamics/EvaluatorStep.re b/src/haz3lcore/dynamics/EvaluatorStep.re index 0205aa3c5b..2d7d82669e 100644 --- a/src/haz3lcore/dynamics/EvaluatorStep.re +++ b/src/haz3lcore/dynamics/EvaluatorStep.re @@ -105,6 +105,17 @@ module Decompose = { ); }; + let req_final_or_value = (cont, wr, d) => { + switch (cont(d)) { + | Result.Indet => (Result.BoxedValue, (d, false)) + | Result.BoxedValue => (Result.BoxedValue, (d, true)) + | Result.Step(objs) => ( + Result.Step(List.map(EvalObj.wrap(wr), objs)), + (d, false), + ) + }; + }; + let rec req_all_final' = (cont, wr, ds') => fun | [] => (Result.BoxedValue, []) @@ -183,6 +194,8 @@ module TakeStep = { let req_final = (_, _, d) => d; let req_all_final = (_, _, ds) => ds; + let req_final_or_value = (_, _, d) => (d, true); + let (let.) = (rq: requirements('a, DHExp.t), rl: 'a => rule) => switch (rl(rq)) { | Step({apply, _}) => Some(apply()) diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index 9eea3f8147..230046ebdc 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -166,10 +166,6 @@ let rec matches_exp = | (Invalid(_), _) => false | (DynamicErrorHole(_), _) => false - | (ApBuiltin(dname, darg), ApBuiltin(fname, farg)) => - dname == fname && matches_exp(env, darg, farg) - | (ApBuiltin(_), _) => false - | (TyAlias(dtp, dut, dd), TyAlias(ftp, fut, fd)) => dtp == ftp && dut == fut && matches_exp(env, dd, fd) | (TyAlias(_), _) => false diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index f1a2f03cd3..647d7ef44f 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -242,7 +242,6 @@ and matches_cast_Sum = matches_cast_Sum(ctr, dp, d', castmaps) | Invalid(_) | Let(_) - | ApBuiltin(_) | UnOp(_) | BinOp(_) | EmptyHole @@ -335,7 +334,6 @@ and matches_cast_Tuple = | Closure(_, _) => IndetMatch | Filter(_, _) => IndetMatch | Ap(_, _, _) => IndetMatch - | ApBuiltin(_, _) => IndetMatch | TyAlias(_) => IndetMatch | UnOp(_, _) | BinOp(_, _, _) => DoesNotMatch @@ -470,7 +468,6 @@ and matches_cast_Cons = | Closure(_, d') => matches_cast_Cons(dp, d', elt_casts) | Filter(_, d') => matches_cast_Cons(dp, d', elt_casts) | Ap(_, _, _) => IndetMatch - | ApBuiltin(_, _) => IndetMatch | TyAlias(_) => IndetMatch | UnOp(_, _) | BinOp(_, _, _) diff --git a/src/haz3lcore/dynamics/Stepper.re b/src/haz3lcore/dynamics/Stepper.re index 1d98ae1fbf..f00413120a 100644 --- a/src/haz3lcore/dynamics/Stepper.re +++ b/src/haz3lcore/dynamics/Stepper.re @@ -121,9 +121,6 @@ let rec matches = | Tuple(ctx, ds) => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); Tuple(ctx, ds) |> rewrap; - | ApBuiltin(name, ctx) => - let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); - ApBuiltin(name, ctx) |> rewrap; | Test(id, ctx) => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); Test(id, ctx) |> rewrap; diff --git a/src/haz3lcore/dynamics/Substitution.re b/src/haz3lcore/dynamics/Substitution.re index f80373a7f1..12da0ef011 100644 --- a/src/haz3lcore/dynamics/Substitution.re +++ b/src/haz3lcore/dynamics/Substitution.re @@ -54,9 +54,6 @@ let rec subst_var = (d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => { let d3 = subst_var(d1, x, d3); let d4 = subst_var(d1, x, d4); Ap(dir, d3, d4) |> rewrap; - | ApBuiltin(ident, d1) => - let d2 = subst_var(d1, x, d1); - ApBuiltin(ident, d2) |> rewrap; | BuiltinFun(_) => d2 | Test(id, d3) => Test(id, subst_var(d1, x, d3)) |> rewrap | Bool(_) diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index f788db40ef..49363eac99 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -174,6 +174,9 @@ module type EV_MODE = { list(DHExp.t) ) => requirement(list(DHExp.t)); + let req_final_or_value: + (DHExp.t => result, EvalCtx.t => EvalCtx.t, DHExp.t) => + requirement((DHExp.t, bool)); let (let.): (requirements('a, DHExp.t), 'a => rule) => result; let (and.): @@ -337,11 +340,15 @@ module Transition = (EV: EV_MODE) => { value: true, }); | Ap(dir, d1, d2) => - let. _ = otherwise(env, (d1, d2) => Ap(dir, d1, d2) |> rewrap) + let. _ = otherwise(env, (d1, (d2, _)) => Ap(dir, d1, d2) |> rewrap) and. d1' = req_value(req(state, env), d1 => Ap1(dir, d1, d2) |> wrap_ctx, d1) - and. d2' = - req_final(req(state, env), d2 => Ap2(dir, d1, d2) |> wrap_ctx, d2); + and. (d2', d2_is_value) = + req_final_or_value( + req(state, env), + d2 => Ap2(dir, d1, d2) |> wrap_ctx, + d2, + ); switch (DHExp.term_of(d1')) { | Constructor(_) => Constructor | Fun(dp, _, d3, Some(env'), _) => @@ -364,14 +371,22 @@ module Transition = (EV: EV_MODE) => { value: false, }) | BuiltinFun(ident) => - Step({ - apply: () => { - //HACK[Matt]: This step is just so we can check that d2' is not indet - ApBuiltin(ident, d2') |> fresh; - }, - kind: BuiltinWrap, - value: false // Not necessarily a value because of InvalidOperations - }) + if (d2_is_value) { + Step({ + apply: () => { + let builtin = + VarMap.lookup(Builtins.forms_init, ident) + |> OptUtil.get(() => { + raise(EvaluatorError.Exception(InvalidBuiltin(ident))) + }); + builtin(d2); + }, + kind: BuiltinAp(ident), + value: false // Not necessarily a value because of InvalidOperations + }); + } else { + Indet; + } | _ => Step({ apply: () => { @@ -381,26 +396,6 @@ module Transition = (EV: EV_MODE) => { value: true, }) }; - | ApBuiltin(ident, arg) => - let. _ = otherwise(env, arg => ApBuiltin(ident, arg) |> rewrap) - and. arg' = - req_value( - req(state, env), - arg => ApBuiltin(ident, arg) |> wrap_ctx, - arg, - ); - Step({ - apply: () => { - let builtin = - VarMap.lookup(Builtins.forms_init, ident) - |> OptUtil.get(() => { - raise(EvaluatorError.Exception(InvalidBuiltin(ident))) - }); - builtin(arg'); - }, - kind: BuiltinAp(ident), - value: false // Not necessarily a value because of InvalidOperations - }); | Bool(_) | Int(_) | Float(_) diff --git a/src/haz3lcore/dynamics/ValueChecker.re b/src/haz3lcore/dynamics/ValueChecker.re index 4164634a99..f8f73c7536 100644 --- a/src/haz3lcore/dynamics/ValueChecker.re +++ b/src/haz3lcore/dynamics/ValueChecker.re @@ -56,6 +56,13 @@ module ValueCheckerEVMode: { ([], (Value, true)), ); + let req_final_or_value = (vc, _, d) => + switch (vc(d)) { + | Value => ((d, true), (Value, true)) + | Indet => ((d, false), (Value, true)) + | Expr => ((d, false), (Value, false)) + }; + let otherwise = (_, _) => ((), (Value, true)); let (let.) = ((v, (r, b)), rule) => diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index e21c1bd406..9f32592c49 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -65,7 +65,6 @@ let rec precedence = (~show_casts: bool, d: DHExp.t) => { | Cast(d1, _, _) => show_casts ? DHDoc_common.precedence_const : precedence'(d1) | Ap(_) => DHDoc_common.precedence_Ap - | ApBuiltin(_) => DHDoc_common.precedence_Ap | Cons(_) => DHDoc_common.precedence_Cons | ListConcat(_) => DHDoc_common.precedence_Plus | Tuple(_) => DHDoc_common.precedence_Comma @@ -332,12 +331,6 @@ let mk = go'(d2), ); DHDoc_common.mk_rev_Ap(doc2, doc1); - | ApBuiltin(ident, d) => - DHDoc_common.mk_Ap( - text(ident), - go_formattable(d) - |> parenthesize(precedence(d) > DHDoc_common.precedence_Ap), - ) | UnOp(Meta(Unquote), d) => DHDoc_common.mk_Ap( text("$"), From 7e4721368e51504a88f8c18afe9a06aa0d16c24a Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Wed, 28 Feb 2024 17:33:39 -0500 Subject: [PATCH 029/103] Add BuiltinFun to UExp --- src/haz3lcore/dynamics/DH.re | 4 ++-- src/haz3lcore/dynamics/Elaborator.re | 1 + src/haz3lcore/statics/Statics.re | 6 ++++++ src/haz3lcore/statics/Term.re | 7 ++++++- src/haz3lcore/statics/TermBase.re | 2 ++ src/haz3lcore/zipper/EditorUtil.re | 1 + src/haz3lschool/SyntaxTest.re | 10 +++++++--- src/haz3lweb/view/ExplainThis.re | 1 + 8 files changed, 26 insertions(+), 6 deletions(-) diff --git a/src/haz3lcore/dynamics/DH.re b/src/haz3lcore/dynamics/DH.re index b2b2ca2438..f84e653c7a 100644 --- a/src/haz3lcore/dynamics/DH.re +++ b/src/haz3lcore/dynamics/DH.re @@ -37,9 +37,9 @@ module rec DHExp: { // TODO: Add Parens | Cons(t, t) | ListConcat(t, t) - | BuiltinFun(string) // DONE [TO ADD TO UEXP] | UnOp(TermBase.UExp.op_un, t) | BinOp(TermBase.UExp.op_bin, t, t) // DONE + | BuiltinFun(string) // DONE [TO ADD TO UEXP] | Match(t, list((DHPat.t, t))) | Cast(t, Typ.t, Typ.t) // TODO: Add to uexp or remove and t; @@ -97,9 +97,9 @@ module rec DHExp: { // TODO: Add Parens | Cons(t, t) | ListConcat(t, t) - | BuiltinFun(string) // DONE [TO ADD TO UEXP] | UnOp(TermBase.UExp.op_un, t) | BinOp(TermBase.UExp.op_bin, t, t) // DONE + | BuiltinFun(string) // DONE [TO ADD TO UEXP] | Match(t, list((DHPat.t, t))) | Cast(t, Typ.t, Typ.t) // TODO: Add to uexp or remove and t = { diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 426bee9ab5..252958e3b3 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -228,6 +228,7 @@ let rec dhexp_of_uexp = let* dc1 = dhexp_of_uexp(m, e1); let+ dc2 = dhexp_of_uexp(m, e2); DHExp.BinOp(op, dc1, dc2) |> rewrap; + | BuiltinFun(name) => Some(DHExp.BuiltinFun(name) |> rewrap) | Parens(e) => dhexp_of_uexp(m, e) | Seq(e1, e2) => let* d1 = dhexp_of_uexp(m, e1); diff --git a/src/haz3lcore/statics/Statics.re b/src/haz3lcore/statics/Statics.re index 63dd4e9c4c..64e95fbd63 100644 --- a/src/haz3lcore/statics/Statics.re +++ b/src/haz3lcore/statics/Statics.re @@ -262,6 +262,12 @@ and uexp_to_info_map = let (e1, m) = go(~mode=Ana(ty1), e1, m); let (e2, m) = go(~mode=Ana(ty2), e2, m); add(~self=Just(ty_out), ~co_ctx=CoCtx.union([e1.co_ctx, e2.co_ctx]), m); + | BuiltinFun(string) => + add'( + ~self=Self.of_exp_var(Builtins.ctx_init, string), + ~co_ctx=CoCtx.empty, + m, + ) | Tuple(es) => let modes = Mode.of_prod(ctx, mode, List.length(es)); let (es, m) = map_m_go(m, modes, es); diff --git a/src/haz3lcore/statics/Term.re b/src/haz3lcore/statics/Term.re index ff4c9cf7ed..176c7d005a 100644 --- a/src/haz3lcore/statics/Term.re +++ b/src/haz3lcore/statics/Term.re @@ -437,6 +437,7 @@ module UExp = { | Cons | UnOp(op_un) | BinOp(op_bin) + | BuiltinFun | Match | ListConcat; @@ -478,6 +479,7 @@ module UExp = { | ListConcat(_) => ListConcat | UnOp(op, _) => UnOp(op) | BinOp(op, _, _) => BinOp(op) + | BuiltinFun(_) => BuiltinFun | Match(_) => Match; let show_op_un_meta: op_un_meta => string = @@ -572,12 +574,14 @@ module UExp = { | ListConcat => "List Concatenation" | BinOp(op) => show_binop(op) | UnOp(op) => show_unop(op) + | BuiltinFun => "Built-in Function" | Match => "Case expression"; let rec is_fun = (e: t) => { switch (e.term) { | Parens(e) => is_fun(e) - | Fun(_) => true + | Fun(_) + | BuiltinFun(_) => true | Invalid(_) | EmptyHole | MultiHole(_) @@ -620,6 +624,7 @@ module UExp = { | String(_) | ListLit(_) | Fun(_) + | BuiltinFun(_) | Var(_) | Let(_) | FixF(_) diff --git a/src/haz3lcore/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index b15cf852ba..58ed498cf2 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -161,6 +161,7 @@ and UExp: { | ListConcat(t, t) | UnOp(op_un, t) | BinOp(op_bin, t, t) + | BuiltinFun(string) | Match(t, list((UPat.t, t))) and t = { // invariant: nonempty @@ -299,6 +300,7 @@ and UExp: { // TODO: Add Builtins | UnOp(op_un, t) | BinOp(op_bin, t, t) + | BuiltinFun(string) | Match(t, list((UPat.t, t))) // TODO: Add Casts and t = { diff --git a/src/haz3lcore/zipper/EditorUtil.re b/src/haz3lcore/zipper/EditorUtil.re index 7d532520da..5ffe9c30e4 100644 --- a/src/haz3lcore/zipper/EditorUtil.re +++ b/src/haz3lcore/zipper/EditorUtil.re @@ -64,6 +64,7 @@ let rec append_exp = (e1: TermBase.UExp.t, e2: TermBase.UExp.t) => { | ListConcat(_) | UnOp(_) | BinOp(_) + | BuiltinFun(_) | Match(_) => TermBase.UExp.{ids: [Id.mk()], term: Seq(e1, e2)} | Seq(e11, e12) => let e12' = append_exp(e12, e2); diff --git a/src/haz3lschool/SyntaxTest.re b/src/haz3lschool/SyntaxTest.re index a0ad4435a1..b2ba545820 100644 --- a/src/haz3lschool/SyntaxTest.re +++ b/src/haz3lschool/SyntaxTest.re @@ -39,7 +39,8 @@ let rec var_mention = (name: string, uexp: Term.UExp.t): bool => { | Int(_) | Float(_) | String(_) - | Constructor(_) => false + | Constructor(_) + | BuiltinFun(_) => false | FixF(args, body) | Fun(args, body) => find_var_upat(name, args) ? false : var_mention(name, body) @@ -84,7 +85,8 @@ let rec var_applied = (name: string, uexp: Term.UExp.t): bool => { | Int(_) | Float(_) | String(_) - | Constructor(_) => false + | Constructor(_) + | BuiltinFun(_) => false | FixF(args, body) | Fun(args, body) => find_var_upat(name, args) ? false : var_applied(name, body) @@ -204,6 +206,7 @@ let rec find_fn = | Float(_) | String(_) | Constructor(_) + | BuiltinFun(_) | Var(_) => l }; }; @@ -231,7 +234,8 @@ let rec tail_check = (name: string, uexp: Term.UExp.t): bool => { | Float(_) | String(_) | Constructor(_) - | Var(_) => true + | Var(_) + | BuiltinFun(_) => true | FixF(args, body) | Fun(args, body) => find_var_upat(name, args) ? false : tail_check(name, body) diff --git a/src/haz3lweb/view/ExplainThis.re b/src/haz3lweb/view/ExplainThis.re index 618c377e8e..22b64bd691 100644 --- a/src/haz3lweb/view/ExplainThis.re +++ b/src/haz3lweb/view/ExplainThis.re @@ -522,6 +522,7 @@ let get_doc = : (list(Node.t), (list(Node.t), ColorSteps.t), list(Node.t)) => switch (term) { | TermBase.UExp.Invalid(_) => simple("Not a valid expression") + | BuiltinFun(_) => simple("Internal expression") | EmptyHole => get_message(HoleExp.empty_hole_exps) | MultiHole(_children) => get_message(HoleExp.multi_hole_exps) | TyAlias(ty_pat, ty_def, _body) => From 16d2001af1676140399732f1863d719c249c899f Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Wed, 28 Feb 2024 20:10:50 -0500 Subject: [PATCH 030/103] begone DHPat.t --- src/haz3lcore/dynamics/DH.re | 16 +- src/haz3lcore/dynamics/DHPat.re | 153 +++++++++--------- src/haz3lcore/dynamics/Elaborator.re | 76 +-------- src/haz3lcore/dynamics/EvalCtx.re | 23 ++- src/haz3lcore/dynamics/ExpandingKeyword.re | 31 ---- src/haz3lcore/dynamics/FilterMatcher.re | 13 +- src/haz3lcore/dynamics/PatternMatch.re | 17 +- src/haz3lcore/dynamics/PatternMatch.rei | 2 +- src/haz3lcore/dynamics/Substitution.re | 94 +++++------ src/haz3lcore/dynamics/Substitution.rei | 4 +- src/haz3lcore/dynamics/TestMap.re | 4 +- src/haz3lcore/dynamics/Transition.re | 8 +- src/haz3lcore/dynamics/VarErrStatus.re | 3 +- src/haz3lcore/statics/Statics.re | 17 ++ src/haz3lcore/statics/Var.re | 6 - src/haz3lweb/view/Cell.re | 1 + src/haz3lweb/view/StepperView.re | 1 + src/haz3lweb/view/TestView.re | 8 +- src/haz3lweb/view/dhcode/DHCode.re | 4 +- src/haz3lweb/view/dhcode/layout/DHAnnot.re | 2 +- src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 40 +++-- src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re | 32 ++-- src/haz3lweb/view/dhcode/layout/DHDoc_Pat.rei | 11 +- src/haz3lweb/view/dhcode/layout/DHDoc_Util.re | 4 - .../view/dhcode/layout/DHDoc_common.re | 4 - .../view/dhcode/layout/DHDoc_common.rei | 3 - 26 files changed, 268 insertions(+), 309 deletions(-) delete mode 100644 src/haz3lcore/dynamics/ExpandingKeyword.re diff --git a/src/haz3lcore/dynamics/DH.re b/src/haz3lcore/dynamics/DH.re index f84e653c7a..3e1b9e5307 100644 --- a/src/haz3lcore/dynamics/DH.re +++ b/src/haz3lcore/dynamics/DH.re @@ -16,7 +16,7 @@ module rec DHExp: { | ListLit(Typ.t, list(t)) | Constructor(string) | Fun( - DHPat.t, + TermBase.UPat.t, Typ.t, t, [@show.opaque] option(ClosureEnvironment.t), @@ -24,8 +24,8 @@ module rec DHExp: { ) // TODO: Use info_map for Typ.t | Tuple(list(t)) | Var(Var.t) - | Let(DHPat.t, t, t) - | FixF(DHPat.t, Typ.t, t) // TODO: Remove type + | Let(TermBase.UPat.t, t, t) + | FixF(TermBase.UPat.t, Typ.t, t) // TODO: Remove type | TyAlias(TermBase.UTPat.t, TermBase.UTyp.t, t) // TODO: Add TyAlias | Ap(TermBase.UExp.ap_direction, t, t) @@ -40,7 +40,7 @@ module rec DHExp: { | UnOp(TermBase.UExp.op_un, t) | BinOp(TermBase.UExp.op_bin, t, t) // DONE | BuiltinFun(string) // DONE [TO ADD TO UEXP] - | Match(t, list((DHPat.t, t))) + | Match(t, list((TermBase.UPat.t, t))) | Cast(t, Typ.t, Typ.t) // TODO: Add to uexp or remove and t; @@ -76,7 +76,7 @@ module rec DHExp: { | ListLit(Typ.t, list(t)) | Constructor(string) | Fun( - DHPat.t, + TermBase.UPat.t, Typ.t, t, [@show.opaque] option(ClosureEnvironment.t), @@ -84,8 +84,8 @@ module rec DHExp: { ) // TODO: Use info_map for Typ.t | Tuple(list(t)) | Var(Var.t) - | Let(DHPat.t, t, t) - | FixF(DHPat.t, Typ.t, t) // TODO: Remove type + | Let(TermBase.UPat.t, t, t) + | FixF(TermBase.UPat.t, Typ.t, t) // TODO: Remove type | TyAlias(TermBase.UTPat.t, TermBase.UTyp.t, t) // TODO: Add TyAlias | Ap(TermBase.UExp.ap_direction, t, t) @@ -100,7 +100,7 @@ module rec DHExp: { | UnOp(TermBase.UExp.op_un, t) | BinOp(TermBase.UExp.op_bin, t, t) // DONE | BuiltinFun(string) // DONE [TO ADD TO UEXP] - | Match(t, list((DHPat.t, t))) + | Match(t, list((TermBase.UPat.t, t))) | Cast(t, Typ.t, Typ.t) // TODO: Add to uexp or remove and t = { /* invariant: nonempty, TODO: what happens to later ids in DHExp */ diff --git a/src/haz3lcore/dynamics/DHPat.re b/src/haz3lcore/dynamics/DHPat.re index cb49d0573b..32b90ea726 100644 --- a/src/haz3lcore/dynamics/DHPat.re +++ b/src/haz3lcore/dynamics/DHPat.re @@ -1,91 +1,98 @@ -open Sexplib.Std; +open TermBase.UPat; -[@deriving (show({with_path: false}), sexp, yojson)] -type term = - | Invalid(string) - | EmptyHole - // TODO: Multihole - | Wild - | Int(int) - | Float(float) - | Bool(bool) - | String(string) - // TODO: Remove Triv from UPat - | ListLit(list(t)) - | Constructor(string) - | Cons(t, t) - | Var(Var.t) - | Tuple(list(t)) - // TODO: parens - | Ap(t, t) - // TODO: Add Type Annotations??? - // TODO: Work out what to do with invalids - | NonEmptyHole(ErrStatus.HoleReason.t, MetaVar.t, MetaVarInst.t, t) - | ExpandingKeyword(MetaVar.t, MetaVarInst.t, ExpandingKeyword.t) - | BadConstructor(MetaVar.t, MetaVarInst.t, string) -and t = { - ids: list(Id.t), - copied: bool, - term, -}; +// [@deriving (show({with_path: false}), sexp, yojson)] +// type term = +// | Invalid(string) +// | EmptyHole +// // TODO: Multihole +// | Wild +// | Int(int) +// | Float(float) +// | Bool(bool) +// | String(string) +// // TODO: Remove Triv from UPat +// | ListLit(list(t)) +// | Constructor(string) +// | Cons(t, t) +// | Var(Var.t) +// | Tuple(list(t)) +// // TODO: parens +// | Ap(t, t) +// // TODO: Add Type Annotations??? +// // TODO: Work out what to do with invalids +// | NonEmptyHole(ErrStatus.HoleReason.t, MetaVar.t, MetaVarInst.t, t) +// | BadConstructor(MetaVar.t, MetaVarInst.t, string) +// and t = { +// ids: list(Id.t), +// term, +// }; let rep_id = ({ids, _}) => List.hd(ids); let term_of = ({term, _}) => term; -let fast_copy = (id, {term, _}) => {ids: [id], term, copied: true}; // All children of term must have expression-unique ids. -let unwrap = ({ids, term, copied}) => (term, term => {ids, term, copied}); +let unwrap = ({ids, term}) => (term, term => {ids, term}); let fresh = term => { - {ids: [Id.mk()], copied: false, term}; + {ids: [Id.mk()], term}; }; /** * Whether dp contains the variable x outside of a hole. */ -let rec binds_var = (x: Var.t, dp: t): bool => - switch (dp |> term_of) { - | EmptyHole - | NonEmptyHole(_, _, _, _) - | Wild - | Invalid(_) - | BadConstructor(_) - | Int(_) - | Float(_) - | Bool(_) - | String(_) - | Constructor(_) - | ExpandingKeyword(_, _, _) => false - | Var(y) => Var.eq(x, y) - | Tuple(dps) => dps |> List.exists(binds_var(x)) - | Cons(dp1, dp2) => binds_var(x, dp1) || binds_var(x, dp2) - | ListLit(d_list) => - let new_list = List.map(binds_var(x), d_list); - List.fold_left((||), false, new_list); - | Ap(_, _) => false +let rec binds_var = (m: Statics.Map.t, x: Var.t, dp: t): bool => + switch (Statics.get_pat_error_at(m, rep_id(dp))) { + | Some(_) => false + | None => + switch (dp |> term_of) { + | EmptyHole + | MultiHole(_) + | Wild + | Invalid(_) + | Int(_) + | Float(_) + | Bool(_) + | String(_) + | Constructor(_) => false + | TypeAnn(y, _) + | Parens(y) => binds_var(m, x, y) + | Var(y) => Var.eq(x, y) + | Tuple(dps) => dps |> List.exists(binds_var(m, x)) + | Cons(dp1, dp2) => binds_var(m, x, dp1) || binds_var(m, x, dp2) + | ListLit(d_list) => + let new_list = List.map(binds_var(m, x), d_list); + List.fold_left((||), false, new_list); + | Ap(_, _) => false + } }; -let rec bound_vars = (dp: t): list(Var.t) => - switch (dp |> term_of) { - | EmptyHole - | NonEmptyHole(_, _, _, _) - | Wild - | Invalid(_) - | BadConstructor(_) - | Int(_) - | Float(_) - | Bool(_) - | String(_) - | Constructor(_) - | ExpandingKeyword(_, _, _) => [] - | Var(y) => [y] - | Tuple(dps) => List.flatten(List.map(bound_vars, dps)) - | Cons(dp1, dp2) => bound_vars(dp1) @ bound_vars(dp2) - | ListLit(dps) => List.flatten(List.map(bound_vars, dps)) - | Ap(_, dp1) => bound_vars(dp1) +let rec bound_vars = (m, dp: t): list(Var.t) => + switch (Statics.get_pat_error_at(m, rep_id(dp))) { + | Some(_) => [] + | None => + switch (dp |> term_of) { + | EmptyHole + | MultiHole(_) + | Wild + | Invalid(_) + | Int(_) + | Float(_) + | Bool(_) + | String(_) + | Constructor(_) => [] + | TypeAnn(y, _) + | Parens(y) => bound_vars(m, y) + | Var(y) => [y] + | Tuple(dps) => List.flatten(List.map(bound_vars(m), dps)) + | Cons(dp1, dp2) => bound_vars(m, dp1) @ bound_vars(m, dp2) + | ListLit(dps) => List.flatten(List.map(bound_vars(m), dps)) + | Ap(_, dp1) => bound_vars(m, dp1) + } }; -let get_var = (pat: t) => { +let rec get_var = (pat: t) => { switch (pat |> term_of) { | Var(x) => Some(x) + | Parens(x) => get_var(x) + | TypeAnn(x, _) => get_var(x) | Wild | Int(_) | Float(_) @@ -96,10 +103,8 @@ let get_var = (pat: t) => { | Tuple(_) | Constructor(_) | EmptyHole - | NonEmptyHole(_) - | ExpandingKeyword(_) | Invalid(_) - | BadConstructor(_) + | MultiHole(_) | Ap(_) => None }; }; diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 252958e3b3..6cefb72b63 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -197,10 +197,9 @@ let rec dhexp_of_uexp = let ty = Typ.matched_list(ctx, ty); DHExp.ListLit(ty, ds) |> rewrap; | Fun(p, body) => - let* dp = dhpat_of_upat(m, p); let* d1 = dhexp_of_uexp(m, body); let+ ty = fixed_pat_typ(m, p); - DHExp.Fun(dp, ty, d1, None, None) |> rewrap; + DHExp.Fun(p, ty, d1, None, None) |> rewrap; | Tuple(es) => let+ ds = es |> List.map(dhexp_of_uexp(m)) |> OptUtil.sequence; DHExp.Tuple(ds) |> rewrap; @@ -254,29 +253,27 @@ let rec dhexp_of_uexp = }; } ); - let* dp = dhpat_of_upat(m, p); let* ddef = dhexp_of_uexp(m, def); let* dbody = dhexp_of_uexp(m, body); let+ ty = fixed_pat_typ(m, p); switch (Term.UPat.get_recursive_bindings(p)) { | None => /* not recursive */ - DHExp.Let(dp, add_name(Term.UPat.get_var(p), ddef), dbody) + DHExp.Let(p, add_name(Term.UPat.get_var(p), ddef), dbody) |> rewrap | Some(b) => DHExp.Let( - dp, - FixF(dp, ty, add_name(Some(String.concat(",", b)), ddef)) + p, + FixF(p, ty, add_name(Some(String.concat(",", b)), ddef)) |> DHExp.fresh, dbody, ) |> rewrap }; | FixF(p, e) => - let* dp = dhpat_of_upat(m, p); let* de = dhexp_of_uexp(m, e); let+ ty = fixed_pat_typ(m, p); - DHExp.FixF(dp, ty, de) |> rewrap; + DHExp.FixF(p, ty, de) |> rewrap; | Ap(dir, fn, arg) => let* c_fn = dhexp_of_uexp(m, fn); let+ c_arg = dhexp_of_uexp(m, arg); @@ -296,9 +293,8 @@ let rec dhexp_of_uexp = let+ d_rules = List.map( ((p, e)) => { - let* d_p = dhpat_of_upat(m, p); let+ d_e = dhexp_of_uexp(m, e); - (d_p, d_e); + (p, d_e); }, rules, ) @@ -317,66 +313,6 @@ let rec dhexp_of_uexp = | Some(InfoPat(_) | InfoTyp(_) | InfoTPat(_) | Secondary(_)) | None => None }; -} -and dhpat_of_upat = (m: Statics.Map.t, upat: Term.UPat.t): option(DHPat.t) => { - switch (Id.Map.find_opt(Term.UPat.rep_id(upat), m)) { - | Some(InfoPat({mode, self, ctx, _})) => - let err_status = Info.status_pat(ctx, mode, self); - let maybe_reason: option(ErrStatus.HoleReason.t) = - switch (err_status) { - | NotInHole(_) => None - | InHole(_) => Some(TypeInconsistent) - }; - let u = Term.UPat.rep_id(upat); /* NOTE: using term uids for hole ids */ - let wrap = (d: DHPat.t): option(DHPat.t) => - switch (maybe_reason) { - | None => Some(d) - | Some(reason) => Some(NonEmptyHole(reason, u, 0, d) |> DHPat.fresh) - }; - let (pterm, prewrap) = ( - upat.term, - ((term) => ({ids: upat.ids, copied: false, term}: DHPat.t)), - ); - switch (pterm) { - | Invalid(t) => Some(DHPat.Invalid(t) |> prewrap) - | EmptyHole => Some(EmptyHole |> prewrap) - | MultiHole(_) => - // TODO: dhexp, eval for multiholes - Some(EmptyHole |> prewrap) - | Wild => wrap(Wild |> prewrap) - | Bool(b) => wrap(Bool(b) |> prewrap) - | Int(n) => wrap(Int(n) |> prewrap) - | Float(n) => wrap(Float(n) |> prewrap) - | String(s) => wrap(String(s) |> prewrap) - | ListLit(ps) => - let* ds = ps |> List.map(dhpat_of_upat(m)) |> OptUtil.sequence; - wrap(ListLit(ds) |> prewrap); - | Constructor(name) => - switch (err_status) { - | InHole(Common(NoType(FreeConstructor(_)))) => - Some(BadConstructor(u, 0, name) |> prewrap) - | _ => wrap(Constructor(name) |> prewrap) - } - | Cons(hd, tl) => - let* d_hd = dhpat_of_upat(m, hd); - let* d_tl = dhpat_of_upat(m, tl); - wrap(Cons(d_hd, d_tl) |> prewrap); - | Tuple(ps) => - let* ds = ps |> List.map(dhpat_of_upat(m)) |> OptUtil.sequence; - wrap(DHPat.Tuple(ds) |> prewrap); - | Var(name) => Some(Var(name) |> prewrap) - | Parens(p) => dhpat_of_upat(m, p) - | Ap(p1, p2) => - let* d_p1 = dhpat_of_upat(m, p1); - let* d_p2 = dhpat_of_upat(m, p2); - wrap(Ap(d_p1, d_p2) |> prewrap); - | TypeAnn(p, _ty) => - let* dp = dhpat_of_upat(m, p); - wrap(dp); - }; - | Some(InfoExp(_) | InfoTyp(_) | InfoTPat(_) | Secondary(_)) - | None => None - }; }; //let dhexp_of_uexp = Core.Memo.general(~cache_size_bound=1000, dhexp_of_uexp); diff --git a/src/haz3lcore/dynamics/EvalCtx.re b/src/haz3lcore/dynamics/EvalCtx.re index f70ccbe06f..cfbdd999c8 100644 --- a/src/haz3lcore/dynamics/EvalCtx.re +++ b/src/haz3lcore/dynamics/EvalCtx.re @@ -8,10 +8,16 @@ type term = | Filter(DH.DHFilter.t, t) | Seq1(t, DHExp.t) | Seq2(DHExp.t, t) - | Let1(DHPat.t, t, DHExp.t) - | Let2(DHPat.t, DHExp.t, t) - | Fun(DHPat.t, Typ.t, t, option(ClosureEnvironment.t), option(Var.t)) - | FixF(DHPat.t, Typ.t, t) + | Let1(TermBase.UPat.t, t, DHExp.t) + | Let2(TermBase.UPat.t, DHExp.t, t) + | Fun( + TermBase.UPat.t, + Typ.t, + t, + option(ClosureEnvironment.t), + option(Var.t), + ) + | FixF(TermBase.UPat.t, Typ.t, t) | Ap1(TermBase.UExp.ap_direction, t, DHExp.t) | Ap2(TermBase.UExp.ap_direction, DHExp.t, t) | If1(t, DHExp.t, DHExp.t) @@ -32,12 +38,15 @@ type term = | Cast(t, Typ.t, Typ.t) | FailedCast(t, Typ.t, Typ.t) | DynamicErrorHole(t, InvalidOperationError.t) - | MatchScrut(t, list((DHPat.t, DHExp.t))) + | MatchScrut(t, list((TermBase.UPat.t, DHExp.t))) | MatchRule( DHExp.t, - DHPat.t, + TermBase.UPat.t, t, - (list((DHPat.t, DHExp.t)), list((DHPat.t, DHExp.t))), + ( + list((TermBase.UPat.t, DHExp.t)), + list((TermBase.UPat.t, DHExp.t)), + ), ) and t = | Mark diff --git a/src/haz3lcore/dynamics/ExpandingKeyword.re b/src/haz3lcore/dynamics/ExpandingKeyword.re deleted file mode 100644 index 58ecbe7553..0000000000 --- a/src/haz3lcore/dynamics/ExpandingKeyword.re +++ /dev/null @@ -1,31 +0,0 @@ -[@deriving (show({with_path: false}), sexp, yojson)] -type t = - | Let - | Case - | Fun - | Test; - -let is_Let = String.equal("let"); -let is_Case = String.equal("case"); -let is_Fun = String.equal("fun"); -let is_Test = String.equal("test"); - -let mk = (text: string): option(t) => - if (text |> is_Let) { - Some(Let); - } else if (text |> is_Case) { - Some(Case); - } else if (text |> is_Fun) { - Some(Fun); - } else if (text |> is_Test) { - Some(Test); - } else { - None; - }; - -let to_string = - fun - | Let => "let" - | Case => "case" - | Fun => "fun" - | Test => "test"; diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index 230046ebdc..166ce211a0 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -171,9 +171,16 @@ let rec matches_exp = | (TyAlias(_), _) => false }; } -and matches_pat = (d: DHPat.t, f: DHPat.t): bool => { +and matches_pat = (d: TermBase.UPat.t, f: TermBase.UPat.t): bool => { switch (d |> DHPat.term_of, f |> DHPat.term_of) { + // Matt: I'm not sure what the exact semantics of matching should be here. + | (Parens(x), _) => matches_pat(x, f) + | (_, Parens(x)) => matches_pat(d, x) + | (TypeAnn(x, _), _) => matches_pat(x, f) + | (_, TypeAnn(x, _)) => matches_pat(d, x) | (_, EmptyHole) => true + | (MultiHole(_), MultiHole(_)) => true + | (MultiHole(_), _) => false | (Wild, Wild) => true | (Wild, _) => false | (Int(dv), Int(fv)) => dv == fv @@ -206,14 +213,10 @@ and matches_pat = (d: DHPat.t, f: DHPat.t): bool => { | (Tuple(_), _) => false | (Ap(d1, d2), Ap(f1, f2)) => matches_pat(d1, f1) && matches_pat(d2, f2) | (Ap(_), _) => false - | (BadConstructor(_, _, dt), BadConstructor(_, _, ft)) => dt == ft - | (BadConstructor(_), _) => false | (Cons(d1, d2), Cons(f1, f2)) => matches_pat(d1, f1) && matches_pat(d2, f2) | (Cons(_), _) => false | (EmptyHole, _) => false - | (NonEmptyHole(_), _) => false - | (ExpandingKeyword(_), _) => false | (Invalid(_), _) => false }; } diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index 647d7ef44f..bd96b5979a 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -28,15 +28,15 @@ let cast_sum_maps = }; }; -let rec matches = (dp: DHPat.t, d: DHExp.t): match_result => +let rec matches = (dp: TermBase.UPat.t, d: DHExp.t): match_result => switch (DHPat.term_of(dp), DHExp.term_of(d)) { + | (Parens(x), _) => matches(x, d) + | (TypeAnn(x, _), _) => matches(x, d) | (_, Var(_)) => DoesNotMatch | (EmptyHole, _) - | (NonEmptyHole(_), _) => IndetMatch + | (MultiHole(_), _) | (Wild, _) => Matches(Environment.empty) - | (ExpandingKeyword(_), _) => DoesNotMatch | (Invalid(_), _) => IndetMatch - | (BadConstructor(_), _) => IndetMatch | (Var(x), _) => let env = Environment.extend(Environment.empty, (x, d)); Matches(env); @@ -202,7 +202,7 @@ let rec matches = (dp: DHPat.t, d: DHExp.t): match_result => and matches_cast_Sum = ( ctr: string, - dp: option(DHPat.t), + dp: option(TermBase.UPat.t), d: DHExp.t, castmaps: list(ConstructorMap.t((Typ.t, Typ.t))), ) @@ -272,7 +272,7 @@ and matches_cast_Sum = } and matches_cast_Tuple = ( - dps: list(DHPat.t), + dps: list(TermBase.UPat.t), d: DHExp.t, elt_casts: list(list((Typ.t, Typ.t))), ) @@ -357,7 +357,8 @@ and matches_cast_Tuple = | If(_) => IndetMatch } and matches_cast_Cons = - (dp: DHPat.t, d: DHExp.t, elt_casts: list((Typ.t, Typ.t))): match_result => + (dp: TermBase.UPat.t, d: DHExp.t, elt_casts: list((Typ.t, Typ.t))) + : match_result => switch (DHExp.term_of(d)) { | ListLit(_, []) => switch (DHPat.term_of(dp)) { @@ -444,7 +445,7 @@ and matches_cast_Cons = }, elt_casts, ); - let dp2 = DHPat.ListLit(dptl) |> DHPat.fresh; + let dp2 = TermBase.UPat.ListLit(dptl) |> DHPat.fresh; switch (matches(dp2, DHExp.apply_casts(d2, list_casts))) { | DoesNotMatch => DoesNotMatch | IndetMatch => IndetMatch diff --git a/src/haz3lcore/dynamics/PatternMatch.rei b/src/haz3lcore/dynamics/PatternMatch.rei index 96cf6019fa..d61032feb9 100644 --- a/src/haz3lcore/dynamics/PatternMatch.rei +++ b/src/haz3lcore/dynamics/PatternMatch.rei @@ -3,4 +3,4 @@ type match_result = | DoesNotMatch | IndetMatch; -let matches: (DHPat.t, DHExp.t) => match_result; +let matches: (TermBase.UPat.t, DHExp.t) => match_result; diff --git a/src/haz3lcore/dynamics/Substitution.re b/src/haz3lcore/dynamics/Substitution.re index 12da0ef011..66d68630fb 100644 --- a/src/haz3lcore/dynamics/Substitution.re +++ b/src/haz3lcore/dynamics/Substitution.re @@ -1,5 +1,5 @@ /* closed substitution [d1/x]d2 */ -let rec subst_var = (d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => { +let rec subst_var = (m, d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => { let (term, rewrap) = DHExp.unwrap(d2); switch (term) { | Var(y) => @@ -10,114 +10,116 @@ let rec subst_var = (d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => { } | Invalid(_) => d2 | Seq(d3, d4) => - let d3 = subst_var(d1, x, d3); - let d4 = subst_var(d1, x, d4); + let d3 = subst_var(m, d1, x, d3); + let d4 = subst_var(m, d1, x, d4); Seq(d3, d4) |> rewrap; | Filter(filter, dbody) => - let dbody = subst_var(d1, x, dbody); - let filter = subst_var_filter(d1, x, filter); + let dbody = subst_var(m, d1, x, dbody); + let filter = subst_var_filter(m, d1, x, filter); Filter(filter, dbody) |> rewrap; | Let(dp, d3, d4) => - let d3 = subst_var(d1, x, d3); + let d3 = subst_var(m, d1, x, d3); let d4 = - if (DHPat.binds_var(x, dp)) { + if (DHPat.binds_var(m, x, dp)) { d4; } else { - subst_var(d1, x, d4); + subst_var(m, d1, x, d4); }; Let(dp, d3, d4) |> rewrap; | FixF(y, ty, d3) => let d3 = - if (DHPat.binds_var(x, y)) { + if (DHPat.binds_var(m, x, y)) { d3; } else { - subst_var(d1, x, d3); + subst_var(m, d1, x, d3); }; FixF(y, ty, d3) |> rewrap; | Fun(dp, ty, d3, env, s) => /* Function closure shouldn't appear during substitution (which only is called from elaboration currently) */ - let env' = Option.map(subst_var_env(d1, x), env); - if (DHPat.binds_var(x, dp)) { + let env' = Option.map(subst_var_env(m, d1, x), env); + if (DHPat.binds_var(m, x, dp)) { Fun(dp, ty, d3, env', s) |> rewrap; } else { - let d3 = subst_var(d1, x, d3); + let d3 = subst_var(m, d1, x, d3); Fun(dp, ty, d3, env', s) |> rewrap; }; | Closure(env, d3) => /* Closure shouldn't appear during substitution (which only is called from elaboration currently) */ - let env' = subst_var_env(d1, x, env); - let d3' = subst_var(d1, x, d3); + let env' = subst_var_env(m, d1, x, env); + let d3' = subst_var(m, d1, x, d3); Closure(env', d3') |> rewrap; | Ap(dir, d3, d4) => - let d3 = subst_var(d1, x, d3); - let d4 = subst_var(d1, x, d4); + let d3 = subst_var(m, d1, x, d3); + let d4 = subst_var(m, d1, x, d4); Ap(dir, d3, d4) |> rewrap; | BuiltinFun(_) => d2 - | Test(id, d3) => Test(id, subst_var(d1, x, d3)) |> rewrap + | Test(id, d3) => Test(id, subst_var(m, d1, x, d3)) |> rewrap | Bool(_) | Int(_) | Float(_) | String(_) | Constructor(_) => d2 - | ListLit(t, ds) => ListLit(t, List.map(subst_var(d1, x), ds)) |> rewrap + | ListLit(t, ds) => + ListLit(t, List.map(subst_var(m, d1, x), ds)) |> rewrap | Cons(d3, d4) => - let d3 = subst_var(d1, x, d3); - let d4 = subst_var(d1, x, d4); + let d3 = subst_var(m, d1, x, d3); + let d4 = subst_var(m, d1, x, d4); Cons(d3, d4) |> rewrap; | ListConcat(d3, d4) => - let d3 = subst_var(d1, x, d3); - let d4 = subst_var(d1, x, d4); + let d3 = subst_var(m, d1, x, d3); + let d4 = subst_var(m, d1, x, d4); ListConcat(d3, d4) |> rewrap; - | Tuple(ds) => Tuple(List.map(subst_var(d1, x), ds)) |> rewrap + | Tuple(ds) => Tuple(List.map(subst_var(m, d1, x), ds)) |> rewrap | UnOp(op, d3) => - let d3 = subst_var(d1, x, d3); + let d3 = subst_var(m, d1, x, d3); UnOp(op, d3) |> rewrap; | BinOp(op, d3, d4) => - let d3 = subst_var(d1, x, d3); - let d4 = subst_var(d1, x, d4); + let d3 = subst_var(m, d1, x, d3); + let d4 = subst_var(m, d1, x, d4); BinOp(op, d3, d4) |> rewrap; | Match(ds, rules) => - let ds = subst_var(d1, x, ds); + let ds = subst_var(m, d1, x, ds); let rules = List.map( ((p, v)) => - if (DHPat.binds_var(x, p)) { + if (DHPat.binds_var(m, x, p)) { (p, v); } else { - (p, subst_var(d1, x, v)); + (p, subst_var(m, d1, x, v)); }, rules, ); Match(ds, rules) |> rewrap; | EmptyHole => EmptyHole |> rewrap - | MultiHole(ds) => MultiHole(List.map(subst_var(d1, x), ds)) |> rewrap + | MultiHole(ds) => MultiHole(List.map(subst_var(m, d1, x), ds)) |> rewrap | StaticErrorHole(u, d3) => - let d3' = subst_var(d1, x, d3); + let d3' = subst_var(m, d1, x, d3); StaticErrorHole(u, d3') |> rewrap; | Cast(d, ty1, ty2) => - let d' = subst_var(d1, x, d); + let d' = subst_var(m, d1, x, d); Cast(d', ty1, ty2) |> rewrap; | FailedCast(d, ty1, ty2) => - let d' = subst_var(d1, x, d); + let d' = subst_var(m, d1, x, d); FailedCast(d', ty1, ty2) |> rewrap; | DynamicErrorHole(d, err) => - let d' = subst_var(d1, x, d); + let d' = subst_var(m, d1, x, d); DynamicErrorHole(d', err) |> rewrap; | If(d4, d5, d6) => - let d4' = subst_var(d1, x, d4); - let d5' = subst_var(d1, x, d5); - let d6' = subst_var(d1, x, d6); + let d4' = subst_var(m, d1, x, d4); + let d5' = subst_var(m, d1, x, d5); + let d6' = subst_var(m, d1, x, d6); If(d4', d5', d6') |> rewrap; | TyAlias(tp, ut, d4) => - let d4' = subst_var(d1, x, d4); + let d4' = subst_var(m, d1, x, d4); TyAlias(tp, ut, d4') |> rewrap; }; } and subst_var_env = - (d1: DHExp.t, x: Var.t, env: ClosureEnvironment.t): ClosureEnvironment.t => { + (m, d1: DHExp.t, x: Var.t, env: ClosureEnvironment.t) + : ClosureEnvironment.t => { let id = env |> ClosureEnvironment.id_of; let map = env @@ -131,14 +133,14 @@ and subst_var_env = | FixF(_) => map |> Environment.foldo( - ((x'', d''), d) => subst_var(d'', x'', d), + ((x'', d''), d) => subst_var(m, d'', x'', d), d', ) | _ => d' }; /* Substitute. */ - let d' = subst_var(d1, x, d'); + let d' = subst_var(m, d1, x, d'); Environment.extend(map, (x', d')); }, Environment.empty, @@ -148,16 +150,16 @@ and subst_var_env = } and subst_var_filter = - (d1: DHExp.t, x: Var.t, flt: DH.DHFilter.t): DH.DHFilter.t => { - flt |> DH.DHFilter.map(subst_var(d1, x)); + (m, d1: DHExp.t, x: Var.t, flt: DH.DHFilter.t): DH.DHFilter.t => { + flt |> DH.DHFilter.map(subst_var(m, d1, x)); }; -let subst = (env: Environment.t, d: DHExp.t): DHExp.t => +let subst = (m, env: Environment.t, d: DHExp.t): DHExp.t => env |> Environment.foldo( (xd: (Var.t, DHExp.t), d2) => { let (x, d1) = xd; - subst_var(d1, x, d2); + subst_var(m, d1, x, d2); }, d, ); diff --git a/src/haz3lcore/dynamics/Substitution.rei b/src/haz3lcore/dynamics/Substitution.rei index d413bf23c9..49b1e2e92f 100644 --- a/src/haz3lcore/dynamics/Substitution.rei +++ b/src/haz3lcore/dynamics/Substitution.rei @@ -1,3 +1,3 @@ /* closed substitution [d1/x]d2 */ -let subst_var: (DHExp.t, Var.t, DHExp.t) => DHExp.t; -let subst: (Environment.t, DHExp.t) => DHExp.t; +let subst_var: (Statics.Map.t, DHExp.t, Var.t, DHExp.t) => DHExp.t; +let subst: (Statics.Map.t, Environment.t, DHExp.t) => DHExp.t; diff --git a/src/haz3lcore/dynamics/TestMap.re b/src/haz3lcore/dynamics/TestMap.re index 0a77e62d21..8592e0e546 100644 --- a/src/haz3lcore/dynamics/TestMap.re +++ b/src/haz3lcore/dynamics/TestMap.re @@ -2,10 +2,10 @@ open Sexplib.Std; /* FIXME: Make more obvious names. */ [@deriving (show({with_path: false}), sexp, yojson)] -type instance_report = (DHExp.t, TestStatus.t); +type instance_report = (DHExp.t, Statics.Map.t, TestStatus.t); let joint_status: list(instance_report) => TestStatus.t = - reports => TestStatus.join_all(List.map(snd, reports)); + reports => TestStatus.join_all(List.map(((_, _, x)) => x, reports)); [@deriving (show({with_path: false}), sexp, yojson)] type report = (KeywordID.t, list(instance_report)); diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index 49363eac99..c628d18bb8 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -289,7 +289,7 @@ module Transition = (EV: EV_MODE) => { // Mutual Recursion case | (Closure(env, d1), None) => let. _ = otherwise(env, d); - let bindings = DHPat.bound_vars(dp); + let bindings = DHPat.bound_vars(info_map, dp); let substitutions = List.map( binding => @@ -326,14 +326,14 @@ module Transition = (EV: EV_MODE) => { apply: () => switch (DHExp.term_of(d')) { | Bool(true) => - update_test(state, id, (d', Pass)); + update_test(state, id, (d', info_map, Pass)); Tuple([]) |> fresh; | Bool(false) => - update_test(state, id, (d', Fail)); + update_test(state, id, (d', info_map, Fail)); Tuple([]) |> fresh; /* Hack: assume if final and not Bool, then Indet; this won't catch errors in statics */ | _ => - update_test(state, id, (d', Indet)); + update_test(state, id, (d', info_map, Indet)); Tuple([]) |> fresh; }, kind: UpdateTest, diff --git a/src/haz3lcore/dynamics/VarErrStatus.re b/src/haz3lcore/dynamics/VarErrStatus.re index 8bb6c4ebc8..167db32cad 100644 --- a/src/haz3lcore/dynamics/VarErrStatus.re +++ b/src/haz3lcore/dynamics/VarErrStatus.re @@ -2,8 +2,7 @@ module HoleReason = { /* Variable: reason */ [@deriving (show({with_path: false}), sexp, yojson)] type t = - | Free - | ExpandingKeyword(ExpandingKeyword.t); + | Free; }; /* Variable: var_err */ diff --git a/src/haz3lcore/statics/Statics.re b/src/haz3lcore/statics/Statics.re index 64e95fbd63..b11be47f7c 100644 --- a/src/haz3lcore/statics/Statics.re +++ b/src/haz3lcore/statics/Statics.re @@ -660,6 +660,23 @@ let get_error_at = (info_map: Map.t, id: Id.t) => { ); }; +let get_pat_error_at = (info_map: Map.t, id: Id.t) => { + id + |> Id.Map.find_opt(_, info_map) + |> Option.bind( + _, + fun + | InfoPat(e) => Some(e) + | _ => None, + ) + |> Option.bind(_, e => + switch (e.status) { + | InHole(err_info) => Some(err_info) + | NotInHole(_) => None + } + ); +}; + let collect_errors = (map: Map.t): list((Id.t, Info.error)) => Id.Map.fold( (id, info: Info.t, acc) => diff --git a/src/haz3lcore/statics/Var.re b/src/haz3lcore/statics/Var.re index 998e53262b..f684dacfe5 100644 --- a/src/haz3lcore/statics/Var.re +++ b/src/haz3lcore/statics/Var.re @@ -31,12 +31,6 @@ let is_case = eq("case"); let is_wild = eq("_"); -let is_keyword = s => - switch (ExpandingKeyword.mk(s)) { - | Some(_) => true - | None => false - }; - let split = (pos, name) => { let left_var = String.sub(name, 0, pos); let right_var = String.sub(name, pos, String.length(name) - pos); diff --git a/src/haz3lweb/view/Cell.re b/src/haz3lweb/view/Cell.re index 55f5e6f4bd..9edb5f0b40 100644 --- a/src/haz3lweb/view/Cell.re +++ b/src/haz3lweb/view/Cell.re @@ -191,6 +191,7 @@ let live_eval = ~font_metrics, ~width=80, ~result_key, + ~infomap=result.elab.info_map, dhexp, ); let exn_view = diff --git a/src/haz3lweb/view/StepperView.re b/src/haz3lweb/view/StepperView.re index 8ee266e476..d6b3582ccc 100644 --- a/src/haz3lweb/view/StepperView.re +++ b/src/haz3lweb/view/StepperView.re @@ -108,6 +108,7 @@ let stepper_view = ~hidden_steps, ~result_key, ~next_steps, + ~infomap=Stepper.get_elab(stepper).info_map, d, ), ], diff --git a/src/haz3lweb/view/TestView.re b/src/haz3lweb/view/TestView.re index 81cc608411..fb36e28b6e 100644 --- a/src/haz3lweb/view/TestView.re +++ b/src/haz3lweb/view/TestView.re @@ -8,7 +8,12 @@ module TestResults = Haz3lcore.TestResults; module Interface = Haz3lcore.Interface; let test_instance_view = - (~settings, ~inject, ~font_metrics, (d, status): TestMap.instance_report) => + ( + ~settings, + ~inject, + ~font_metrics, + (d, infomap, status): TestMap.instance_report, + ) => div( ~attr= Attr.many([clss(["test-instance", TestStatus.to_string(status)])]), @@ -20,6 +25,7 @@ let test_instance_view = ~font_metrics, ~width=40, ~result_key="", + ~infomap, d, ), ], diff --git a/src/haz3lweb/view/dhcode/DHCode.re b/src/haz3lweb/view/dhcode/DHCode.re index a049ea2b4b..b6f87322c3 100644 --- a/src/haz3lweb/view/dhcode/DHCode.re +++ b/src/haz3lweb/view/dhcode/DHCode.re @@ -105,7 +105,7 @@ let view_of_layout = ds, ) | VarHole(_) => ([with_cls("InVarHole", txt)], ds) - | NonEmptyHole(_) + | NonEmptyHole | InconsistentBranches(_) | Invalid => let offset = start.col - indent; @@ -143,6 +143,7 @@ let view = ~chosen_step: option(EvaluatorStep.step)=None, // The step that will be taken next ~next_steps: list((int, Id.t))=[], ~result_key: string, + ~infomap, d: DHExp.t, ) : Node.t => { @@ -155,6 +156,7 @@ let view = ~settings, ~enforce_inline=false, ~selected_hole_instance, + ~infomap, d, ) |> LayoutOfDoc.layout_of_doc(~width, ~pos) diff --git a/src/haz3lweb/view/dhcode/layout/DHAnnot.re b/src/haz3lweb/view/dhcode/layout/DHAnnot.re index 3d13b7c96f..f6cfcf36f3 100644 --- a/src/haz3lweb/view/dhcode/layout/DHAnnot.re +++ b/src/haz3lweb/view/dhcode/layout/DHAnnot.re @@ -9,7 +9,7 @@ type t = | HoleLabel | Delim | EmptyHole(bool, ClosureEnvironment.t) - | NonEmptyHole(ErrStatus.HoleReason.t, HoleInstance.t) + | NonEmptyHole | VarHole(VarErrStatus.HoleReason.t, HoleInstance.t) | InconsistentBranches(HoleInstance.t) | Invalid diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index 9f32592c49..aa8c4f7d1f 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -109,6 +109,7 @@ let mk = ~chosen_step: option(step), // The step that will be taken next ~next_steps: list((int, Id.t)), // The options for the next step, if it hasn't been chosen yet ~env: ClosureEnvironment.t, + ~infomap: Statics.Map.t, d: DHExp.t, ) : DHDoc.t => { @@ -139,13 +140,13 @@ let mk = switch (ps.knd, DHExp.term_of(ps.d_loc)) { | (FunAp, Ap(_, d2, _)) => switch (DHExp.term_of(d2)) { - | Fun(p, _, _, _, _) => DHPat.bound_vars(p) + | Fun(p, _, _, _, _) => DHPat.bound_vars(infomap, p) | _ => [] } | (FunAp, _) => [] - | (LetBind, Let(p, _, _)) => DHPat.bound_vars(p) + | (LetBind, Let(p, _, _)) => DHPat.bound_vars(infomap, p) | (LetBind, _) => [] - | (FixUnwrap, FixF(p, _, _)) => DHPat.bound_vars(p) + | (FixUnwrap, FixF(p, _, _)) => DHPat.bound_vars(infomap, p) | (FixUnwrap, _) => [] | (InvalidStep, _) | (VarLookup, _) @@ -207,7 +208,7 @@ let mk = : hcat(space(), hidden_clause); hcats([ DHDoc_common.Delim.bar_Rule, - DHDoc_Pat.mk(dp) + DHDoc_Pat.mk(~infomap, dp) |> DHDoc_common.pad_child( ~inline_padding=(space(), space()), ~enforce_inline=false, @@ -285,8 +286,7 @@ let mk = env, ) | MultiHole(ds) => ds |> List.map(go') |> Doc.hcats - | StaticErrorHole(u, d') => - go'(d') |> annot(DHAnnot.NonEmptyHole(TypeInconsistent, (u, 0))) + | StaticErrorHole(_, d') => go'(d') |> annot(DHAnnot.NonEmptyHole) | Invalid(t) => DHDoc_common.mk_InvalidText(t) | Var(x) when List.mem(x, recursive_calls) => text(x) | Var(x) when settings.show_lookup_steps => text(x) @@ -399,12 +399,12 @@ let mk = if (enforce_inline) { fail(); } else { - let bindings = DHPat.bound_vars(dp); + let bindings = DHPat.bound_vars(infomap, dp); let def_doc = go_formattable(ddef); vseps([ hcats([ DHDoc_common.Delim.mk("let"), - DHDoc_Pat.mk(dp) + DHDoc_Pat.mk(~infomap, dp) |> DHDoc_common.pad_child( ~inline_padding=(space(), space()), ~enforce_inline, @@ -479,7 +479,7 @@ let mk = ]); | Fun(dp, ty, d, Some(env'), s) => if (settings.show_fn_bodies) { - let bindings = DHPat.bound_vars(dp); + let bindings = DHPat.bound_vars(infomap, dp); let body_doc = go_formattable( Closure( @@ -489,7 +489,7 @@ let mk = |> DHExp.fresh, ~env= ClosureEnvironment.without_keys( - DHPat.bound_vars(dp) @ Option.to_list(s), + DHPat.bound_vars(infomap, dp) @ Option.to_list(s), env, ), ~recent_subst= @@ -498,7 +498,7 @@ let mk = hcats( [ DHDoc_common.Delim.sym_Fun, - DHDoc_Pat.mk(dp) + DHDoc_Pat.mk(~infomap, dp) |> DHDoc_common.pad_child( ~inline_padding=(space(), space()), ~enforce_inline, @@ -528,7 +528,7 @@ let mk = } | Fun(dp, ty, dbody, None, s) => if (settings.show_fn_bodies) { - let bindings = DHPat.bound_vars(dp); + let bindings = DHPat.bound_vars(infomap, dp); let body_doc = go_formattable( dbody, @@ -540,7 +540,7 @@ let mk = hcats( [ DHDoc_common.Delim.sym_Fun, - DHDoc_Pat.mk(dp) + DHDoc_Pat.mk(~infomap, dp) |> DHDoc_common.pad_child( ~inline_padding=(space(), space()), ~enforce_inline, @@ -572,13 +572,17 @@ let mk = let doc_body = go_formattable( dbody, - ~env=ClosureEnvironment.without_keys(DHPat.bound_vars(dp), env), + ~env= + ClosureEnvironment.without_keys( + DHPat.bound_vars(infomap, dp), + env, + ), ); hcats( [ DHDoc_common.Delim.fix_FixF, space(), - DHDoc_Pat.mk(dp, ~enforce_inline=true), + DHDoc_Pat.mk(~infomap, dp, ~enforce_inline=true), ] @ ( settings.show_casts @@ -598,7 +602,11 @@ let mk = ); | FixF(dp, _, d) => go'( - ~env=ClosureEnvironment.without_keys(DHPat.bound_vars(dp), env), + ~env= + ClosureEnvironment.without_keys( + DHPat.bound_vars(infomap, dp), + env, + ), d, ) }; diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re index f006e73337..dbe1278e22 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re @@ -1,14 +1,12 @@ open Pretty; open Haz3lcore; -let precedence = (dp: DHPat.t) => +let precedence = (dp: TermBase.UPat.t) => switch (DHPat.term_of(dp)) { | EmptyHole - | NonEmptyHole(_) + | MultiHole(_) | Wild - | ExpandingKeyword(_) | Invalid(_) - | BadConstructor(_) | Var(_) | Int(_) | Float(_) @@ -19,11 +17,19 @@ let precedence = (dp: DHPat.t) => | Tuple(_) => DHDoc_common.precedence_Comma | Cons(_) => DHDoc_common.precedence_Cons | Ap(_) => DHDoc_common.precedence_Ap + | Parens(_) => DHDoc_common.precedence_const + | TypeAnn(_) => DHDoc_common.precedence_Times }; let rec mk = - (~parenthesize=false, ~enforce_inline: bool, dp: DHPat.t): DHDoc.t => { - let mk' = mk(~enforce_inline); + ( + ~infomap: Statics.Map.t, + ~parenthesize=false, + ~enforce_inline: bool, + dp: TermBase.UPat.t, + ) + : DHDoc.t => { + let mk' = mk(~enforce_inline, ~infomap); let mk_left_associative_operands = (precedence_op, dp1, dp2) => ( mk'(~parenthesize=precedence(dp1) > precedence_op, dp1), mk'(~parenthesize=precedence(dp2) >= precedence_op, dp2), @@ -34,13 +40,9 @@ let rec mk = ); let doc = switch (DHPat.term_of(dp)) { + | MultiHole(_) | EmptyHole => DHDoc_common.mk_EmptyHole(ClosureEnvironment.empty) - | NonEmptyHole(reason, u, i, dp) => - mk'(dp) |> Doc.annot(DHAnnot.NonEmptyHole(reason, (u, i))) - | ExpandingKeyword(u, i, k) => - DHDoc_common.mk_ExpandingKeyword((u, i), k) | Invalid(t) => DHDoc_common.mk_InvalidText(t) - | BadConstructor(_, _, t) => DHDoc_common.mk_InvalidText(t) | Var(x) => Doc.text(x) | Wild => DHDoc_common.Delim.wild | Constructor(name) => DHDoc_common.mk_ConstructorLit(name) @@ -57,11 +59,19 @@ let rec mk = DHDoc_common.mk_Cons(doc1, doc2); | Tuple([]) => DHDoc_common.Delim.triv | Tuple(ds) => DHDoc_common.mk_Tuple(List.map(mk', ds)) + // TODO: Print type annotations + | TypeAnn(dp, _) + | Parens(dp) => mk(~enforce_inline, ~parenthesize=true, ~infomap, dp) | Ap(dp1, dp2) => let (doc1, doc2) = mk_left_associative_operands(DHDoc_common.precedence_Ap, dp1, dp2); DHDoc_common.mk_Ap(doc1, doc2); }; + let doc = + switch (Statics.get_pat_error_at(infomap, DHPat.rep_id(dp))) { + | Some(_) => Doc.annot(DHAnnot.NonEmptyHole, doc) + | None => doc + }; parenthesize ? Doc.hcats([ DHDoc_common.Delim.open_Parenthesized, diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.rei b/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.rei index 33c37b6092..5eb43e15c8 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.rei +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.rei @@ -1,5 +1,12 @@ open Haz3lcore; -let precedence: DHPat.t => int; +let precedence: TermBase.UPat.t => int; -let mk: (~parenthesize: bool=?, ~enforce_inline: bool, DHPat.t) => DHDoc.t; +let mk: + ( + ~infomap: Statics.Map.t, + ~parenthesize: bool=?, + ~enforce_inline: bool, + TermBase.UPat.t + ) => + DHDoc.t; diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Util.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Util.re index f4ae24947b..9e9578d217 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Util.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Util.re @@ -87,10 +87,6 @@ module Delim = { let mk_EmptyHole = (~selected=false, env) => Delim.empty_hole(env) |> Doc.annot(DHAnnot.EmptyHole(selected, env)); -let mk_Keyword = (u, i, k) => - Doc.text(ExpandingKeyword.to_string(k)) - |> Doc.annot(DHAnnot.VarHole(ExpandingKeyword(k), (u, i))); - let mk_IntLit = n => Doc.text(string_of_int(n)); let mk_FloatLit = (f: float) => diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_common.re b/src/haz3lweb/view/dhcode/layout/DHDoc_common.re index 1edb1dd884..59daac7a56 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_common.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_common.re @@ -89,10 +89,6 @@ module Delim = { let mk_EmptyHole = (~selected=false, env: ClosureEnvironment.t) => Delim.empty_hole(env) |> Doc.annot(DHAnnot.EmptyHole(selected, env)); -let mk_ExpandingKeyword = (hc, k) => - Doc.text(ExpandingKeyword.to_string(k)) - |> Doc.annot(DHAnnot.VarHole(ExpandingKeyword(k), hc)); - let mk_InvalidText = t => Doc.text(t) |> Doc.annot(DHAnnot.Invalid); let mk_Sequence = (doc1, doc2) => Doc.(hcats([doc1, linebreak(), doc2])); diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_common.rei b/src/haz3lweb/view/dhcode/layout/DHDoc_common.rei index b08f4215c0..2a104b4c51 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_common.rei +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_common.rei @@ -65,9 +65,6 @@ module Delim: { let mk_EmptyHole: (~selected: bool=?, ClosureEnvironment.t) => Pretty.Doc.t(DHAnnot.t); -let mk_ExpandingKeyword: - (HoleInstance.t, ExpandingKeyword.t) => Pretty.Doc.t(DHAnnot.t); - let mk_InvalidText: string => Pretty.Doc.t(DHAnnot.t); let mk_Sequence: (Pretty.Doc.t('a), Pretty.Doc.t('a)) => Pretty.Doc.t('a); From 6d328310e75a1d994f3fff653f4acf41f7cd4129 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 29 Feb 2024 09:17:03 -0500 Subject: [PATCH 031/103] Update comments --- src/haz3lcore/dynamics/Elaborator.re | 5 +++-- src/haz3lcore/statics/TermBase.re | 2 +- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 6cefb72b63..b49fd6e47f 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -5,9 +5,10 @@ open OptUtil.Syntax; Currently, Elaboration does the following things: - Insert casts - - Insert non-empty holes - - Remove TyAlias + - Insert non-empty hole wrappers + - Remove TyAlias [should we do this??] - Annotate functions with types, and names + - Insert implicit fixpoints (in types and expressions) */ module Elaboration = { diff --git a/src/haz3lcore/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index 58ed498cf2..3220fe2e68 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -300,7 +300,7 @@ and UExp: { // TODO: Add Builtins | UnOp(op_un, t) | BinOp(op_bin, t, t) - | BuiltinFun(string) + | BuiltinFun(string) /// Doesn't currently have a distinguishable syntax... | Match(t, list((UPat.t, t))) // TODO: Add Casts and t = { From 460a81ab196d58d6e98d1a3a15387c2e0a8a0bab Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 29 Feb 2024 10:21:47 -0500 Subject: [PATCH 032/103] Add dynamic error hole forms to UExp (Hopefully they will be replaced with a better solution soon) --- src/haz3lcore/dynamics/DH.re | 24 ++++++++++++++++-------- src/haz3lcore/dynamics/Elaborator.re | 11 ++++++++++- src/haz3lcore/statics/Statics.re | 5 +++++ src/haz3lcore/statics/Term.re | 15 +++++++++++++++ src/haz3lcore/statics/TermBase.re | 13 ++++++++++++- src/haz3lcore/zipper/EditorUtil.re | 3 +++ src/haz3lschool/SyntaxTest.re | 13 +++++++++++++ src/haz3lweb/view/ExplainThis.re | 3 +++ 8 files changed, 77 insertions(+), 10 deletions(-) diff --git a/src/haz3lcore/dynamics/DH.re b/src/haz3lcore/dynamics/DH.re index 3e1b9e5307..964adea32f 100644 --- a/src/haz3lcore/dynamics/DH.re +++ b/src/haz3lcore/dynamics/DH.re @@ -1,14 +1,23 @@ open Sexplib.Std; +/* + To discuss: + + 1. putting info inside expressions + 2. The issue with recursion capture + + + */ + module rec DHExp: { [@deriving (show({with_path: false}), sexp, yojson)] type term = | Invalid(string) | EmptyHole | MultiHole(list(DHExp.t)) - | StaticErrorHole(Id.t, t) // TODO: Add to TermBase - | DynamicErrorHole(t, InvalidOperationError.t) // TODO: Add to TermBase or remove from here - | FailedCast(t, Typ.t, Typ.t) // TODO: Add to TermBase or remove from here + | StaticErrorHole(Id.t, t) + | DynamicErrorHole(t, InvalidOperationError.t) + | FailedCast(t, Typ.t, Typ.t) | Bool(bool) | Int(int) | Float(float) @@ -16,8 +25,8 @@ module rec DHExp: { | ListLit(Typ.t, list(t)) | Constructor(string) | Fun( - TermBase.UPat.t, - Typ.t, + TermBase.UPat.t, // INVARIANT: always has type assignment on outside + Typ.t, // Would be nice to move this into the pattern, but we'd need to merge UTyp.t and Typ.t t, [@show.opaque] option(ClosureEnvironment.t), option(Var.t), @@ -25,9 +34,8 @@ module rec DHExp: { | Tuple(list(t)) | Var(Var.t) | Let(TermBase.UPat.t, t, t) - | FixF(TermBase.UPat.t, Typ.t, t) // TODO: Remove type + | FixF(TermBase.UPat.t, Typ.t, t) // INVARIANT: always has type assignment on outside // Would be nice to move this into the pattern, but we'd need to merge UTyp.t and Typ.t | TyAlias(TermBase.UTPat.t, TermBase.UTyp.t, t) - // TODO: Add TyAlias | Ap(TermBase.UExp.ap_direction, t, t) | If(t, t, t) | Seq(t, t) @@ -39,7 +47,7 @@ module rec DHExp: { | ListConcat(t, t) | UnOp(TermBase.UExp.op_un, t) | BinOp(TermBase.UExp.op_bin, t, t) // DONE - | BuiltinFun(string) // DONE [TO ADD TO UEXP] + | BuiltinFun(string) // DONE | Match(t, list((TermBase.UPat.t, t))) | Cast(t, Typ.t, Typ.t) // TODO: Add to uexp or remove and t; diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index b49fd6e47f..522a06f340 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -9,6 +9,9 @@ open OptUtil.Syntax; - Remove TyAlias [should we do this??] - Annotate functions with types, and names - Insert implicit fixpoints (in types and expressions) + + Going the other way: + - There's going to be a horrible case with */ module Elaboration = { @@ -184,7 +187,13 @@ let rec dhexp_of_uexp = let+ ds = us |> List.map(dhexp_of_uexp(m)) |> OptUtil.sequence; DHExp.MultiHole(ds) |> rewrap; } - + | StaticErrorHole(_, e) => dhexp_of_uexp(m, e) + | DynamicErrorHole(e, err) => + let+ d1 = dhexp_of_uexp(m, e); + DHExp.DynamicErrorHole(d1, err) |> rewrap; + | FailedCast(e, t1, t2) => + let+ d1 = dhexp_of_uexp(m, e); + DHExp.FailedCast(d1, t1, t2) |> rewrap; /* TODO: add a dhexp case and eval logic for multiholes. Make sure new dhexp form is properly considered Indet to avoid casting issues. */ diff --git a/src/haz3lcore/statics/Statics.re b/src/haz3lcore/statics/Statics.re index b11be47f7c..417e38e954 100644 --- a/src/haz3lcore/statics/Statics.re +++ b/src/haz3lcore/statics/Statics.re @@ -196,6 +196,9 @@ and uexp_to_info_map = | MultiHole(tms) => let (co_ctxs, m) = multi(~ctx, ~ancestors, m, tms); add(~self=IsMulti, ~co_ctx=CoCtx.union(co_ctxs), m); + | FailedCast(e, t1, t2) => + let (e, m) = go(~mode=Ana(t1), e, m); + add(~self=Just(t2), ~co_ctx=e.co_ctx, m); | Invalid(token) => atomic(BadToken(token)) | EmptyHole => atomic(Just(Unknown(Internal))) | Bool(_) => atomic(Just(Bool)) @@ -236,6 +239,8 @@ and uexp_to_info_map = ~co_ctx=CoCtx.singleton(name, UExp.rep_id(uexp), Mode.ty_of(mode)), m, ) + | StaticErrorHole(_, e) + | DynamicErrorHole(e, _) | Parens(e) => let (e, m) = go(~mode, e, m); add(~self=Just(e.ty), ~co_ctx=e.co_ctx, m); diff --git a/src/haz3lcore/statics/Term.re b/src/haz3lcore/statics/Term.re index 176c7d005a..df5b5f584e 100644 --- a/src/haz3lcore/statics/Term.re +++ b/src/haz3lcore/statics/Term.re @@ -414,6 +414,9 @@ module UExp = { | Invalid | EmptyHole | MultiHole + | StaticErrorHole + | DynamicErrorHole + | FailedCast | Bool | Int | Float @@ -457,6 +460,9 @@ module UExp = { | Invalid(_) => Invalid | EmptyHole => EmptyHole | MultiHole(_) => MultiHole + | StaticErrorHole(_) => StaticErrorHole + | DynamicErrorHole(_) => DynamicErrorHole + | FailedCast(_) => FailedCast | Bool(_) => Bool | Int(_) => Int | Float(_) => Float @@ -550,6 +556,9 @@ module UExp = { | Invalid => "Invalid expression" | MultiHole => "Broken expression" | EmptyHole => "Empty expression hole" + | StaticErrorHole => "Static error hole" + | DynamicErrorHole => "Dynamic error hole" + | FailedCast => "Failed cast" | Bool => "Boolean literal" | Int => "Integer literal" | Float => "Float literal" @@ -585,6 +594,9 @@ module UExp = { | Invalid(_) | EmptyHole | MultiHole(_) + | StaticErrorHole(_) + | DynamicErrorHole(_) + | FailedCast(_) | Bool(_) | Int(_) | Float(_) @@ -618,6 +630,9 @@ module UExp = { | Invalid(_) | EmptyHole | MultiHole(_) + | StaticErrorHole(_) + | DynamicErrorHole(_) + | FailedCast(_) | Bool(_) | Int(_) | Float(_) diff --git a/src/haz3lcore/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index 3220fe2e68..2e28416584 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -112,6 +112,9 @@ and UExp: { | Invalid | EmptyHole | MultiHole + | StaticErrorHole + | DynamicErrorHole + | FailedCast | Bool | Int | Float @@ -139,6 +142,9 @@ and UExp: { | Invalid(string) | EmptyHole | MultiHole(list(Any.t)) + | StaticErrorHole(Id.t, t) + | DynamicErrorHole(t, InvalidOperationError.t) + | FailedCast(t, Typ.t, Typ.t) | Bool(bool) | Int(int) | Float(float) @@ -247,6 +253,9 @@ and UExp: { | Invalid | EmptyHole | MultiHole + | StaticErrorHole + | DynamicErrorHole + | FailedCast | Bool | Int | Float @@ -274,7 +283,9 @@ and UExp: { | Invalid(string) | EmptyHole | MultiHole(list(Any.t)) - // TODO: Add StaticErrorHole, DynamicErrorHole, FailedCast + | StaticErrorHole(Id.t, t) + | DynamicErrorHole(t, InvalidOperationError.t) + | FailedCast(t, Typ.t, Typ.t) | Bool(bool) | Int(int) | Float(float) diff --git a/src/haz3lcore/zipper/EditorUtil.re b/src/haz3lcore/zipper/EditorUtil.re index 5ffe9c30e4..c87bff6f96 100644 --- a/src/haz3lcore/zipper/EditorUtil.re +++ b/src/haz3lcore/zipper/EditorUtil.re @@ -46,6 +46,9 @@ let rec append_exp = (e1: TermBase.UExp.t, e2: TermBase.UExp.t) => { | EmptyHole | Invalid(_) | MultiHole(_) + | StaticErrorHole(_) + | DynamicErrorHole(_) + | FailedCast(_) | Bool(_) | Int(_) | Float(_) diff --git a/src/haz3lschool/SyntaxTest.re b/src/haz3lschool/SyntaxTest.re index b2ba545820..6dc2df2dc3 100644 --- a/src/haz3lschool/SyntaxTest.re +++ b/src/haz3lschool/SyntaxTest.re @@ -35,6 +35,10 @@ let rec var_mention = (name: string, uexp: Term.UExp.t): bool => { | EmptyHole | Invalid(_) | MultiHole(_) + // TODO: are we interested in mentions inside these holes? + | StaticErrorHole(_) + | DynamicErrorHole(_) + | FailedCast(_) | Bool(_) | Int(_) | Float(_) @@ -79,6 +83,9 @@ let rec var_applied = (name: string, uexp: Term.UExp.t): bool => { switch (uexp.term) { | Var(_) | EmptyHole + | StaticErrorHole(_) + | DynamicErrorHole(_) + | FailedCast(_) | Invalid(_) | MultiHole(_) | Bool(_) @@ -201,6 +208,9 @@ let rec find_fn = | EmptyHole | Invalid(_) | MultiHole(_) + | StaticErrorHole(_) + | DynamicErrorHole(_) + | FailedCast(_) | Bool(_) | Int(_) | Float(_) @@ -229,6 +239,9 @@ let rec tail_check = (name: string, uexp: Term.UExp.t): bool => { | EmptyHole | Invalid(_) | MultiHole(_) + | StaticErrorHole(_) + | DynamicErrorHole(_) + | FailedCast(_) | Bool(_) | Int(_) | Float(_) diff --git a/src/haz3lweb/view/ExplainThis.re b/src/haz3lweb/view/ExplainThis.re index 22b64bd691..ec4375c117 100644 --- a/src/haz3lweb/view/ExplainThis.re +++ b/src/haz3lweb/view/ExplainThis.re @@ -522,6 +522,9 @@ let get_doc = : (list(Node.t), (list(Node.t), ColorSteps.t), list(Node.t)) => switch (term) { | TermBase.UExp.Invalid(_) => simple("Not a valid expression") + | DynamicErrorHole(_) + | StaticErrorHole(_) + | FailedCast(_) | BuiltinFun(_) => simple("Internal expression") | EmptyHole => get_message(HoleExp.empty_hole_exps) | MultiHole(_children) => get_message(HoleExp.multi_hole_exps) From f9facd46763da5e2fee6eeb6250027cb6db6cb9c Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 29 Feb 2024 10:44:51 -0500 Subject: [PATCH 033/103] Remove id field from test --- src/haz3lcore/dynamics/DH.re | 11 ++++++----- src/haz3lcore/dynamics/Elaborator.re | 2 +- src/haz3lcore/dynamics/EvalCtx.re | 6 +++--- src/haz3lcore/dynamics/FilterMatcher.re | 3 +-- src/haz3lcore/dynamics/Stepper.re | 4 ++-- src/haz3lcore/dynamics/Substitution.re | 2 +- src/haz3lcore/dynamics/Transition.re | 12 ++++++------ src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 2 +- 8 files changed, 21 insertions(+), 21 deletions(-) diff --git a/src/haz3lcore/dynamics/DH.re b/src/haz3lcore/dynamics/DH.re index 964adea32f..c81fe6e299 100644 --- a/src/haz3lcore/dynamics/DH.re +++ b/src/haz3lcore/dynamics/DH.re @@ -39,7 +39,7 @@ module rec DHExp: { | Ap(TermBase.UExp.ap_direction, t, t) | If(t, t, t) | Seq(t, t) - | Test(KeywordID.t, t) // TODO: ! ID + | Test(t) // Id refers to original static id of test | Filter(DHFilter.t, t) // DONE [UEXP TO BE CHANGED] | Closure([@show.opaque] ClosureEnvironment.t, t) // > UEXP // TODO: Add Parens @@ -99,7 +99,7 @@ module rec DHExp: { | Ap(TermBase.UExp.ap_direction, t, t) | If(t, t, t) | Seq(t, t) - | Test(KeywordID.t, t) // TODO: ! ID + | Test(t) | Filter(DHFilter.t, t) // DONE [UEXP TO BE CHANGED] | Closure([@show.opaque] ClosureEnvironment.t, t) // > UEXP // TODO: Add Parens @@ -147,6 +147,7 @@ module rec DHExp: { let apply_casts = (d: t, casts: list((Typ.t, Typ.t))): t => List.fold_left((d, (ty1, ty2)) => fresh_cast(d, ty1, ty2), d, casts); + // TODO: make this function emit a map of changes let rec repair_ids = (require: bool, d: t) => { let child_require = require || d.copied; let repair_ids = repair_ids(child_require); @@ -185,7 +186,7 @@ module rec DHExp: { | TyAlias(tp, t, d) => TyAlias(tp, t, repair_ids(d)) | Fun(dp, t, d1, env, f) => Fun(dp, t, repair_ids(d1), env, f) | Ap(dir, d1, d2) => Ap(dir, repair_ids(d1), repair_ids(d2)) - | Test(id, d1) => Test(id, repair_ids(d1)) + | Test(d1) => Test(repair_ids(d1)) | UnOp(op, d1) => UnOp(op, repair_ids(d1)) | BinOp(op, d1, d2) => BinOp(op, repair_ids(d1), repair_ids(d2)) | ListLit(t, ds) => ListLit(t, List.map(repair_ids, ds)) @@ -230,7 +231,7 @@ module rec DHExp: { | TyAlias(tp, t, d) => TyAlias(tp, t, strip_casts(d)) |> rewrap | Fun(a, b, c, e, d) => Fun(a, b, strip_casts(c), e, d) |> rewrap | Ap(dir, a, b) => Ap(dir, strip_casts(a), strip_casts(b)) |> rewrap - | Test(id, a) => Test(id, strip_casts(a)) |> rewrap + | Test(a) => Test(strip_casts(a)) |> rewrap | BuiltinFun(fn) => BuiltinFun(fn) |> rewrap | UnOp(op, d) => UnOp(op, strip_casts(d)) |> rewrap | BinOp(a, b, c) => BinOp(a, strip_casts(b), strip_casts(c)) |> rewrap @@ -267,7 +268,7 @@ module rec DHExp: { | (String(_), _) => false /* Non-hole forms: recurse */ - | (Test(id1, d1), Test(id2, d2)) => id1 == id2 && fast_equal(d1, d2) + | (Test(d1), Test(d2)) => fast_equal(d1, d2) | (Seq(d11, d21), Seq(d12, d22)) => fast_equal(d11, d12) && fast_equal(d21, d22) | (Filter(f1, d1), Filter(f2, d2)) => diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 522a06f340..a4f1b9a9c7 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -245,7 +245,7 @@ let rec dhexp_of_uexp = DHExp.Seq(d1, d2) |> rewrap; | Test(test) => let+ dtest = dhexp_of_uexp(m, test); - DHExp.Test(id, dtest) |> rewrap; + DHExp.Test(dtest) |> rewrap; | Filter(act, cond, body) => let* dcond = dhexp_of_uexp(~in_filter=true, m, cond); let+ dbody = dhexp_of_uexp(m, body); diff --git a/src/haz3lcore/dynamics/EvalCtx.re b/src/haz3lcore/dynamics/EvalCtx.re index cfbdd999c8..b47cf73b97 100644 --- a/src/haz3lcore/dynamics/EvalCtx.re +++ b/src/haz3lcore/dynamics/EvalCtx.re @@ -27,7 +27,7 @@ type term = | BinOp1(TermBase.UExp.op_bin, t, DHExp.t) | BinOp2(TermBase.UExp.op_bin, DHExp.t, t) | Tuple(t, (list(DHExp.t), list(DHExp.t))) - | Test(KeywordID.t, t) + | Test(t) | ListLit(Typ.t, t, (list(DHExp.t), list(DHExp.t))) | MultiHole(t, (list(DHExp.t), list(DHExp.t))) | Cons1(t, DHExp.t) @@ -89,9 +89,9 @@ let rec compose = (ctx: t, d: DHExp.t): DHExp.t => { | If3(d1, d2, ctx) => let d' = compose(ctx, d); If(d1, d2, d') |> wrap; - | Test(lit, ctx) => + | Test(ctx) => let d1 = compose(ctx, d); - Test(lit, d1) |> wrap; + Test(d1) |> wrap; | UnOp(op, ctx) => let d1 = compose(ctx, d); UnOp(op, d1) |> wrap; diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index 166ce211a0..52c3a31260 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -105,8 +105,7 @@ let rec matches_exp = matches_exp(env, d1, f1) && matches_exp(env, d2, f2) | (Seq(_), _) => false - | (Test(id1, d2), Test(id2, f2)) => - id1 == id2 && matches_exp(env, d2, f2) + | (Test(d2), Test(f2)) => matches_exp(env, d2, f2) | (Test(_), _) => false | (Cons(d1, d2), Cons(f1, f2)) => diff --git a/src/haz3lcore/dynamics/Stepper.re b/src/haz3lcore/dynamics/Stepper.re index f00413120a..b34bc63cfd 100644 --- a/src/haz3lcore/dynamics/Stepper.re +++ b/src/haz3lcore/dynamics/Stepper.re @@ -121,9 +121,9 @@ let rec matches = | Tuple(ctx, ds) => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); Tuple(ctx, ds) |> rewrap; - | Test(id, ctx) => + | Test(ctx) => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); - Test(id, ctx) |> rewrap; + Test(ctx) |> rewrap; | ListLit(ty, ctx, ds) => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); ListLit(ty, ctx, ds) |> rewrap; diff --git a/src/haz3lcore/dynamics/Substitution.re b/src/haz3lcore/dynamics/Substitution.re index 66d68630fb..f968f69891 100644 --- a/src/haz3lcore/dynamics/Substitution.re +++ b/src/haz3lcore/dynamics/Substitution.re @@ -55,7 +55,7 @@ let rec subst_var = (m, d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => { let d4 = subst_var(m, d1, x, d4); Ap(dir, d3, d4) |> rewrap; | BuiltinFun(_) => d2 - | Test(id, d3) => Test(id, subst_var(m, d1, x, d3)) |> rewrap + | Test(d3) => Test(subst_var(m, d1, x, d3)) |> rewrap | Bool(_) | Int(_) | Float(_) diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index c628d18bb8..f2d236b932 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -319,21 +319,21 @@ module Transition = (EV: EV_MODE) => { value: false, }); }; - | Test(id, d) => - let. _ = otherwise(env, d => Test(id, d) |> rewrap) - and. d' = req_final(req(state, env), d => Test(id, d) |> wrap_ctx, d); + | Test(d) => + let. _ = otherwise(env, d => Test(d) |> rewrap) + and. d' = req_final(req(state, env), d => Test(d) |> wrap_ctx, d); Step({ apply: () => switch (DHExp.term_of(d')) { | Bool(true) => - update_test(state, id, (d', info_map, Pass)); + update_test(state, DHExp.rep_id(d), (d', info_map, Pass)); Tuple([]) |> fresh; | Bool(false) => - update_test(state, id, (d', info_map, Fail)); + update_test(state, DHExp.rep_id(d), (d', info_map, Fail)); Tuple([]) |> fresh; /* Hack: assume if final and not Bool, then Indet; this won't catch errors in statics */ | _ => - update_test(state, id, (d', info_map, Indet)); + update_test(state, DHExp.rep_id(d), (d', info_map, Indet)); Tuple([]) |> fresh; }, kind: UpdateTest, diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index aa8c4f7d1f..6d768dbd59 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -310,7 +310,7 @@ let mk = | Int(n) => DHDoc_common.mk_IntLit(n) | Float(f) => DHDoc_common.mk_FloatLit(f) | String(s) => DHDoc_common.mk_StringLit(s) - | Test(_, d) => DHDoc_common.mk_Test(go'(d)) + | Test(d) => DHDoc_common.mk_Test(go'(d)) | Seq(d1, d2) => let (doc1, doc2) = (go'(d1), go'(d2)); DHDoc_common.mk_Sequence(doc1, doc2); From 22541aeaaf88b6fd2392ecfa1dd4de0c85b1c47e Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 29 Feb 2024 12:20:49 -0500 Subject: [PATCH 034/103] Add parens to DHExp.t --- src/haz3lcore/dynamics/DH.re | 18 +++++++++++++----- src/haz3lcore/dynamics/Elaborator.re | 6 +++++- src/haz3lcore/dynamics/FilterMatcher.re | 2 ++ src/haz3lcore/dynamics/PatternMatch.re | 3 +++ src/haz3lcore/dynamics/Stepper.re | 1 + src/haz3lcore/dynamics/Substitution.re | 3 +++ src/haz3lcore/dynamics/Transition.re | 9 +++++++-- src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 4 +++- 8 files changed, 37 insertions(+), 9 deletions(-) diff --git a/src/haz3lcore/dynamics/DH.re b/src/haz3lcore/dynamics/DH.re index c81fe6e299..14a531eba5 100644 --- a/src/haz3lcore/dynamics/DH.re +++ b/src/haz3lcore/dynamics/DH.re @@ -41,13 +41,15 @@ module rec DHExp: { | Seq(t, t) | Test(t) // Id refers to original static id of test | Filter(DHFilter.t, t) // DONE [UEXP TO BE CHANGED] + /* In the long term, it might be nice to have closures be the same as + module opening */ | Closure([@show.opaque] ClosureEnvironment.t, t) // > UEXP - // TODO: Add Parens + | Parens(t) | Cons(t, t) | ListConcat(t, t) | UnOp(TermBase.UExp.op_un, t) - | BinOp(TermBase.UExp.op_bin, t, t) // DONE - | BuiltinFun(string) // DONE + | BinOp(TermBase.UExp.op_bin, t, t) + | BuiltinFun(string) | Match(t, list((TermBase.UPat.t, t))) | Cast(t, Typ.t, Typ.t) // TODO: Add to uexp or remove and t; @@ -102,7 +104,7 @@ module rec DHExp: { | Test(t) | Filter(DHFilter.t, t) // DONE [UEXP TO BE CHANGED] | Closure([@show.opaque] ClosureEnvironment.t, t) // > UEXP - // TODO: Add Parens + | Parens(t) | Cons(t, t) | ListConcat(t, t) | UnOp(TermBase.UExp.op_un, t) @@ -191,6 +193,7 @@ module rec DHExp: { | BinOp(op, d1, d2) => BinOp(op, repair_ids(d1), repair_ids(d2)) | ListLit(t, ds) => ListLit(t, List.map(repair_ids, ds)) | Cons(d1, d2) => Cons(repair_ids(d1), repair_ids(d2)) + | Parens(d1) => Parens(repair_ids(d1)) | ListConcat(d1, d2) => ListConcat(repair_ids(d1), repair_ids(d2)) | Tuple(ds) => Tuple(List.map(repair_ids, ds)) | MultiHole(ds) => MultiHole(List.map(repair_ids, ds)) @@ -241,6 +244,7 @@ module rec DHExp: { List.map(((k, v)) => (k, strip_casts(v)), rules), ) |> rewrap + | Parens(d1) => Parens(strip_casts(d1)) |> rewrap | EmptyHole as d | Invalid(_) as d | Var(_) as d @@ -255,7 +259,8 @@ module rec DHExp: { }; }; - let rec fast_equal = ({term: d1, _}, {term: d2, _}): bool => { + let rec fast_equal = + ({term: d1, _} as d1exp, {term: d2, _} as d2exp): bool => { switch (d1, d2) { /* Primitive forms: regular structural equality */ | (Var(_), _) @@ -267,6 +272,9 @@ module rec DHExp: { | (String(s1), String(s2)) => String.equal(s1, s2) | (String(_), _) => false + | (Parens(x), _) => fast_equal(x, d2exp) + | (_, Parens(x)) => fast_equal(d1exp, x) + /* Non-hole forms: recurse */ | (Test(d1), Test(d2)) => fast_equal(d1, d2) | (Seq(d11, d21), Seq(d12, d22)) => diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index a4f1b9a9c7..0a2d9422e3 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -9,9 +9,12 @@ open OptUtil.Syntax; - Remove TyAlias [should we do this??] - Annotate functions with types, and names - Insert implicit fixpoints (in types and expressions) + - Remove parentheses Going the other way: - - There's going to be a horrible case with + - There's going to be a horrible case with implicit fixpoint shadowing + + A nice property would be that elaboration is idempotent... */ module Elaboration = { @@ -128,6 +131,7 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => /* Normal cases: wrap */ | Var(_) | BuiltinFun(_) + | Parens(_) | Bool(_) | Int(_) | Float(_) diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index 52c3a31260..92b388d2d6 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -8,6 +8,8 @@ let rec matches_exp = : bool => { let matches_exp = matches_exp(info_map); switch (DHExp.term_of(d), DHExp.term_of(f)) { + | (Parens(x), _) => matches_exp(env, x, f) + | (_, Parens(x)) => matches_exp(env, d, x) | (Constructor("$e"), _) => failwith("$e in matched expression") | (Constructor("$v"), _) => failwith("$v in matched expression") | (_, Constructor("$v")) => diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index bd96b5979a..704eeefb45 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -208,6 +208,7 @@ and matches_cast_Sum = ) : match_result => switch (DHExp.term_of(d)) { + | Parens(d) => matches_cast_Sum(ctr, dp, d, castmaps) | Constructor(ctr') => switch ( dp, @@ -278,6 +279,7 @@ and matches_cast_Tuple = ) : match_result => switch (DHExp.term_of(d)) { + | Parens(d) => matches_cast_Tuple(dps, d, elt_casts) | Tuple(ds) => if (List.length(dps) != List.length(ds)) { DoesNotMatch; @@ -360,6 +362,7 @@ and matches_cast_Cons = (dp: TermBase.UPat.t, d: DHExp.t, elt_casts: list((Typ.t, Typ.t))) : match_result => switch (DHExp.term_of(d)) { + | Parens(d) => matches_cast_Cons(dp, d, elt_casts) | ListLit(_, []) => switch (DHPat.term_of(dp)) { | ListLit([]) => Matches(Environment.empty) diff --git a/src/haz3lcore/dynamics/Stepper.re b/src/haz3lcore/dynamics/Stepper.re index b34bc63cfd..206067f8f0 100644 --- a/src/haz3lcore/dynamics/Stepper.re +++ b/src/haz3lcore/dynamics/Stepper.re @@ -370,6 +370,7 @@ let get_justification: step_kind => string = | CompleteClosure => "complete closure" | FunClosure => "function closure" | RemoveTypeAlias => "define type" + | RemoveParens => "remove parentheses" | UnOp(Meta(Unquote)) => failwith("INVALID STEP"); type step_info = { diff --git a/src/haz3lcore/dynamics/Substitution.re b/src/haz3lcore/dynamics/Substitution.re index f968f69891..fa6b8f6aa3 100644 --- a/src/haz3lcore/dynamics/Substitution.re +++ b/src/haz3lcore/dynamics/Substitution.re @@ -114,6 +114,9 @@ let rec subst_var = (m, d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => { | TyAlias(tp, ut, d4) => let d4' = subst_var(m, d1, x, d4); TyAlias(tp, ut, d4') |> rewrap; + | Parens(d4) => + let d4' = subst_var(m, d1, x, d4); + Parens(d4') |> rewrap; }; } diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index f2d236b932..c5a48d2fb3 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -71,7 +71,8 @@ type step_kind = | CompleteClosure | CompleteFilter | Cast - | RemoveTypeAlias; + | RemoveTypeAlias + | RemoveParens; module CastHelpers = { [@deriving sexp] @@ -810,6 +811,9 @@ module Transition = (EV: EV_MODE) => { d1, ); Indet; + | Parens(d) => + let. _ = otherwise(env, d); + Step({apply: () => d, kind: RemoveParens, value: false}); | TyAlias(_, _, d) => let. _ = otherwise(env, d); Step({apply: () => d, kind: RemoveTypeAlias, value: false}); @@ -849,4 +853,5 @@ let should_hide_step = (~settings: CoreSettings.Evaluation.t) => | CompleteFilter | BuiltinWrap | FunClosure - | FixClosure => true; + | FixClosure + | RemoveParens => true; diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index 6d768dbd59..75a1e4907b 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -80,8 +80,8 @@ let rec precedence = (~show_casts: bool, d: DHExp.t) => { | BinOp(Int(op), _, _) => precedence_bin_int_op(op) | BinOp(Float(op), _, _) => precedence_bin_float_op(op) | BinOp(String(op), _, _) => precedence_bin_string_op(op) - | MultiHole(_) => DHDoc_common.precedence_max + | Parens(d) | StaticErrorHole(_, d) => precedence'(d) }; }; @@ -170,6 +170,7 @@ let mk = | (CompleteFilter, _) | (Cast, _) | (Conditional(_), _) + | (RemoveParens, _) | (RemoveTypeAlias, _) => [] // Maybe this last one could count as a substitution? } | _ => recent_subst @@ -248,6 +249,7 @@ let mk = ); let doc = { switch (DHExp.term_of(d)) { + | Parens(d') => go'(d') | Closure(env', d') => go'(d', ~env=env') | Filter(flt, d') => if (settings.show_stepper_filters) { From 16e81934dc2fe5ba05ff86fcc0cf24ee696d7efa Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 29 Feb 2024 14:22:19 -0500 Subject: [PATCH 035/103] Write down which expressions are produced during evaluation --- src/haz3lcore/dynamics/DH.re | 29 +++++++++++++++++++++++----- src/haz3lcore/dynamics/Transition.re | 2 +- 2 files changed, 25 insertions(+), 6 deletions(-) diff --git a/src/haz3lcore/dynamics/DH.re b/src/haz3lcore/dynamics/DH.re index 14a531eba5..7c8741aaa1 100644 --- a/src/haz3lcore/dynamics/DH.re +++ b/src/haz3lcore/dynamics/DH.re @@ -7,6 +7,26 @@ open Sexplib.Std; 2. The issue with recursion capture + */ + +/* + DHExps that can appear during evaluation, and thus won't have static information. + + - Closure + - Var [for mutual recursion; could probably get rid of if needed...] + - Let [for mutual recursion] + - Tuple([]) + - Cast + - Ap [in the casting rules for functions & in builtins] + - DynamicErrorHole + - FailedCast + - Int + - Bool + - Float + - String + - ListLit + - BuiltinFun + */ module rec DHExp: { @@ -34,7 +54,7 @@ module rec DHExp: { | Tuple(list(t)) | Var(Var.t) | Let(TermBase.UPat.t, t, t) - | FixF(TermBase.UPat.t, Typ.t, t) // INVARIANT: always has type assignment on outside // Would be nice to move this into the pattern, but we'd need to merge UTyp.t and Typ.t + | FixF(TermBase.UPat.t, Typ.t, t) // TODO: add closure // INVARIANT: always has type assignment on outside // Would be nice to move this into the pattern, but we'd need to merge UTyp.t and Typ.t | TyAlias(TermBase.UTPat.t, TermBase.UTyp.t, t) | Ap(TermBase.UExp.ap_direction, t, t) | If(t, t, t) @@ -76,9 +96,9 @@ module rec DHExp: { | Invalid(string) | EmptyHole | MultiHole(list(DHExp.t)) - | StaticErrorHole(Id.t, t) // TODO: Add to TermBase - | DynamicErrorHole(t, InvalidOperationError.t) // TODO: Add to TermBase or remove from here - | FailedCast(t, Typ.t, Typ.t) // TODO: Add to TermBase or remove from here + | StaticErrorHole(Id.t, t) + | DynamicErrorHole(t, InvalidOperationError.t) + | FailedCast(t, Typ.t, Typ.t) | Bool(bool) | Int(int) | Float(float) @@ -97,7 +117,6 @@ module rec DHExp: { | Let(TermBase.UPat.t, t, t) | FixF(TermBase.UPat.t, Typ.t, t) // TODO: Remove type | TyAlias(TermBase.UTPat.t, TermBase.UTyp.t, t) - // TODO: Add TyAlias | Ap(TermBase.UExp.ap_direction, t, t) | If(t, t, t) | Seq(t, t) diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index c5a48d2fb3..af5645a5cd 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -264,7 +264,7 @@ module Transition = (EV: EV_MODE) => { | Fun(p, t, d1, None, v) => let. _ = otherwise(env, d); Step({ - apply: () => Fun(p, t, d1, Some(env), v) |> fresh, + apply: () => Fun(p, t, d1, Some(env), v) |> rewrap, kind: FunClosure, value: true, }); From 62f4f0b1197c9074b17fecc90a29777dc680828b Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 29 Feb 2024 14:34:09 -0500 Subject: [PATCH 036/103] Remove type annotations from fun and fix (can be found in infomap if needed) --- src/haz3lcore/dynamics/DH.re | 33 ++++++++------- src/haz3lcore/dynamics/Elaborator.re | 18 ++++----- src/haz3lcore/dynamics/EvalCtx.re | 18 +++------ src/haz3lcore/dynamics/FilterMatcher.re | 11 ++--- src/haz3lcore/dynamics/PatternMatch.re | 8 ++-- src/haz3lcore/dynamics/Stepper.re | 8 ++-- src/haz3lcore/dynamics/Substitution.re | 10 ++--- src/haz3lcore/dynamics/Transition.re | 18 ++++----- src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 42 +++----------------- src/test/Test_Elaboration.re | 1 - 10 files changed, 61 insertions(+), 106 deletions(-) diff --git a/src/haz3lcore/dynamics/DH.re b/src/haz3lcore/dynamics/DH.re index 7c8741aaa1..5ebf444312 100644 --- a/src/haz3lcore/dynamics/DH.re +++ b/src/haz3lcore/dynamics/DH.re @@ -27,6 +27,12 @@ open Sexplib.Std; - ListLit - BuiltinFun + It is important that the following do not appear during evaluation, because they + (theoretically) require static information: + + - Fun + - FixF + */ module rec DHExp: { @@ -46,7 +52,6 @@ module rec DHExp: { | Constructor(string) | Fun( TermBase.UPat.t, // INVARIANT: always has type assignment on outside - Typ.t, // Would be nice to move this into the pattern, but we'd need to merge UTyp.t and Typ.t t, [@show.opaque] option(ClosureEnvironment.t), option(Var.t), @@ -54,7 +59,7 @@ module rec DHExp: { | Tuple(list(t)) | Var(Var.t) | Let(TermBase.UPat.t, t, t) - | FixF(TermBase.UPat.t, Typ.t, t) // TODO: add closure // INVARIANT: always has type assignment on outside // Would be nice to move this into the pattern, but we'd need to merge UTyp.t and Typ.t + | FixF(TermBase.UPat.t, t) // TODO: add closure // INVARIANT: always has type assignment on outside // Would be nice to move this into the pattern, but we'd need to merge UTyp.t and Typ.t | TyAlias(TermBase.UTPat.t, TermBase.UTyp.t, t) | Ap(TermBase.UExp.ap_direction, t, t) | If(t, t, t) @@ -107,7 +112,6 @@ module rec DHExp: { | Constructor(string) | Fun( TermBase.UPat.t, - Typ.t, t, [@show.opaque] option(ClosureEnvironment.t), option(Var.t), @@ -115,7 +119,7 @@ module rec DHExp: { | Tuple(list(t)) | Var(Var.t) | Let(TermBase.UPat.t, t, t) - | FixF(TermBase.UPat.t, Typ.t, t) // TODO: Remove type + | FixF(TermBase.UPat.t, t) // TODO: Remove type | TyAlias(TermBase.UTPat.t, TermBase.UTyp.t, t) | Ap(TermBase.UExp.ap_direction, t, t) | If(t, t, t) @@ -203,9 +207,9 @@ module rec DHExp: { | Filter(flt, d1) => Filter(flt, repair_ids(d1)) | Seq(d1, d2) => Seq(repair_ids(d1), repair_ids(d2)) | Let(dp, d1, d2) => Let(dp, repair_ids(d1), repair_ids(d2)) - | FixF(f, t, d1) => FixF(f, t, repair_ids(d1)) + | FixF(f, d1) => FixF(f, repair_ids(d1)) | TyAlias(tp, t, d) => TyAlias(tp, t, repair_ids(d)) - | Fun(dp, t, d1, env, f) => Fun(dp, t, repair_ids(d1), env, f) + | Fun(dp, d1, env, f) => Fun(dp, repair_ids(d1), env, f) | Ap(dir, d1, d2) => Ap(dir, repair_ids(d1), repair_ids(d2)) | Test(d1) => Test(repair_ids(d1)) | UnOp(op, d1) => UnOp(op, repair_ids(d1)) @@ -249,9 +253,9 @@ module rec DHExp: { | Filter(f, b) => Filter(DHFilter.strip_casts(f), strip_casts(b)) |> rewrap | Let(dp, b, c) => Let(dp, strip_casts(b), strip_casts(c)) |> rewrap - | FixF(a, b, c) => FixF(a, b, strip_casts(c)) |> rewrap + | FixF(a, c) => FixF(a, strip_casts(c)) |> rewrap | TyAlias(tp, t, d) => TyAlias(tp, t, strip_casts(d)) |> rewrap - | Fun(a, b, c, e, d) => Fun(a, b, strip_casts(c), e, d) |> rewrap + | Fun(a, c, e, d) => Fun(a, strip_casts(c), e, d) |> rewrap | Ap(dir, a, b) => Ap(dir, strip_casts(a), strip_casts(b)) |> rewrap | Test(a) => Test(strip_casts(a)) |> rewrap | BuiltinFun(fn) => BuiltinFun(fn) |> rewrap @@ -302,16 +306,11 @@ module rec DHExp: { DHFilter.fast_equal(f1, f2) && fast_equal(d1, d2) | (Let(dp1, d11, d21), Let(dp2, d12, d22)) => dp1 == dp2 && fast_equal(d11, d12) && fast_equal(d21, d22) - | (FixF(f1, ty1, d1), FixF(f2, ty2, d2)) => - f1 == f2 && ty1 == ty2 && fast_equal(d1, d2) - | (Fun(dp1, ty1, d1, None, s1), Fun(dp2, ty2, d2, None, s2)) => - dp1 == dp2 && ty1 == ty2 && fast_equal(d1, d2) && s1 == s2 - | ( - Fun(dp1, ty1, d1, Some(env1), s1), - Fun(dp2, ty2, d2, Some(env2), s2), - ) => + | (FixF(f1, d1), FixF(f2, d2)) => f1 == f2 && fast_equal(d1, d2) + | (Fun(dp1, d1, None, s1), Fun(dp2, d2, None, s2)) => + dp1 == dp2 && fast_equal(d1, d2) && s1 == s2 + | (Fun(dp1, d1, Some(env1), s1), Fun(dp2, d2, Some(env2), s2)) => dp1 == dp2 - && ty1 == ty2 && fast_equal(d1, d2) && ClosureEnvironment.id_equal(env1, env2) && s1 == s2 diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 0a2d9422e3..ffa636175d 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -211,9 +211,8 @@ let rec dhexp_of_uexp = let ty = Typ.matched_list(ctx, ty); DHExp.ListLit(ty, ds) |> rewrap; | Fun(p, body) => - let* d1 = dhexp_of_uexp(m, body); - let+ ty = fixed_pat_typ(m, p); - DHExp.Fun(p, ty, d1, None, None) |> rewrap; + let+ d1 = dhexp_of_uexp(m, body); + DHExp.Fun(p, d1, None, None) |> rewrap; | Tuple(es) => let+ ds = es |> List.map(dhexp_of_uexp(m)) |> OptUtil.sequence; DHExp.Tuple(ds) |> rewrap; @@ -261,15 +260,13 @@ let rec dhexp_of_uexp = (name, d) => { let (term, rewrap) = DHExp.unwrap(d); switch (term) { - | Fun(p, ty, e, ctx, _) => - DHExp.Fun(p, ty, e, ctx, name) |> rewrap + | Fun(p, e, ctx, _) => DHExp.Fun(p, e, ctx, name) |> rewrap | _ => d }; } ); let* ddef = dhexp_of_uexp(m, def); - let* dbody = dhexp_of_uexp(m, body); - let+ ty = fixed_pat_typ(m, p); + let+ dbody = dhexp_of_uexp(m, body); switch (Term.UPat.get_recursive_bindings(p)) { | None => /* not recursive */ @@ -278,16 +275,15 @@ let rec dhexp_of_uexp = | Some(b) => DHExp.Let( p, - FixF(p, ty, add_name(Some(String.concat(",", b)), ddef)) + FixF(p, add_name(Some(String.concat(",", b)), ddef)) |> DHExp.fresh, dbody, ) |> rewrap }; | FixF(p, e) => - let* de = dhexp_of_uexp(m, e); - let+ ty = fixed_pat_typ(m, p); - DHExp.FixF(p, ty, de) |> rewrap; + let+ de = dhexp_of_uexp(m, e); + DHExp.FixF(p, de) |> rewrap; | Ap(dir, fn, arg) => let* c_fn = dhexp_of_uexp(m, fn); let+ c_arg = dhexp_of_uexp(m, arg); diff --git a/src/haz3lcore/dynamics/EvalCtx.re b/src/haz3lcore/dynamics/EvalCtx.re index b47cf73b97..7097fe10ef 100644 --- a/src/haz3lcore/dynamics/EvalCtx.re +++ b/src/haz3lcore/dynamics/EvalCtx.re @@ -10,14 +10,8 @@ type term = | Seq2(DHExp.t, t) | Let1(TermBase.UPat.t, t, DHExp.t) | Let2(TermBase.UPat.t, DHExp.t, t) - | Fun( - TermBase.UPat.t, - Typ.t, - t, - option(ClosureEnvironment.t), - option(Var.t), - ) - | FixF(TermBase.UPat.t, Typ.t, t) + | Fun(TermBase.UPat.t, t, option(ClosureEnvironment.t), option(Var.t)) + | FixF(TermBase.UPat.t, t) | Ap1(TermBase.UExp.ap_direction, t, DHExp.t) | Ap2(TermBase.UExp.ap_direction, DHExp.t, t) | If1(t, DHExp.t, DHExp.t) @@ -128,12 +122,12 @@ let rec compose = (ctx: t, d: DHExp.t): DHExp.t => { | Let2(dp, d1, ctx) => let d = compose(ctx, d); Let(dp, d1, d) |> wrap; - | Fun(dp, t, ctx, env, v) => + | Fun(dp, ctx, env, v) => let d = compose(ctx, d); - Fun(dp, t, d, env, v) |> wrap; - | FixF(v, t, ctx) => + Fun(dp, d, env, v) |> wrap; + | FixF(v, ctx) => let d = compose(ctx, d); - FixF(v, t, d) |> wrap; + FixF(v, d) |> wrap; | Cast(ctx, ty1, ty2) => let d = compose(ctx, d); Cast(d, ty1, ty2) |> wrap; diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index 92b388d2d6..350d096465 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -75,15 +75,12 @@ let rec matches_exp = | (BuiltinFun(_), _) => false // Not sure if we should be checking functions for closures here - | (Fun(dp1, dty1, d1, _, dname1), Fun(fp1, fty1, f1, _, fname1)) => - matches_pat(dp1, fp1) - && dty1 == fty1 - && matches_exp(env, d1, f1) - && dname1 == fname1 + | (Fun(dp1, d1, _, dname1), Fun(fp1, f1, _, fname1)) => + matches_pat(dp1, fp1) && matches_exp(env, d1, f1) && dname1 == fname1 | (Fun(_), _) => false - | (FixF(dp, dt, d1), FixF(fp, ft, f1)) => - matches_pat(dp, fp) && dt == ft && matches_exp(env, d1, f1) + | (FixF(dp, d1), FixF(fp, f1)) => + matches_pat(dp, fp) && matches_exp(env, d1, f1) | (FixF(_), _) => false | (Let(dp, d1, d2), Let(fp, f1, f2)) => diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index 704eeefb45..0f21ae32e2 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -331,8 +331,8 @@ and matches_cast_Tuple = | Var(_) => DoesNotMatch | Invalid(_) => IndetMatch | Let(_, _, _) => IndetMatch - | FixF(_, _, _) => DoesNotMatch - | Fun(_, _, _, _, _) => DoesNotMatch + | FixF(_, _) => DoesNotMatch + | Fun(_, _, _, _) => DoesNotMatch | Closure(_, _) => IndetMatch | Filter(_, _) => IndetMatch | Ap(_, _, _) => IndetMatch @@ -467,8 +467,8 @@ and matches_cast_Cons = | Var(_) => DoesNotMatch | Invalid(_) => IndetMatch | Let(_, _, _) => IndetMatch - | FixF(_, _, _) => DoesNotMatch - | Fun(_, _, _, _, _) => DoesNotMatch + | FixF(_, _) => DoesNotMatch + | Fun(_, _, _, _) => DoesNotMatch | Closure(_, d') => matches_cast_Cons(dp, d', elt_casts) | Filter(_, d') => matches_cast_Cons(dp, d', elt_casts) | Ap(_, _, _) => IndetMatch diff --git a/src/haz3lcore/dynamics/Stepper.re b/src/haz3lcore/dynamics/Stepper.re index 206067f8f0..d4aa08342e 100644 --- a/src/haz3lcore/dynamics/Stepper.re +++ b/src/haz3lcore/dynamics/Stepper.re @@ -79,7 +79,7 @@ let rec matches = | Let2(d1, d2, ctx) => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); Let2(d1, d2, ctx) |> rewrap; - | Fun(dp, ty, ctx, env', name) => + | Fun(dp, ctx, env', name) => let+ ctx = matches( Option.value(~default=env, env'), @@ -90,10 +90,10 @@ let rec matches = act, idx, ); - Fun(dp, ty, ctx, env', name) |> rewrap; - | FixF(name, ty, ctx) => + Fun(dp, ctx, env', name) |> rewrap; + | FixF(name, ctx) => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); - FixF(name, ty, ctx) |> rewrap; + FixF(name, ctx) |> rewrap; | Ap1(dir, ctx, d2) => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); Ap1(dir, ctx, d2) |> rewrap; diff --git a/src/haz3lcore/dynamics/Substitution.re b/src/haz3lcore/dynamics/Substitution.re index fa6b8f6aa3..9fe3066bf9 100644 --- a/src/haz3lcore/dynamics/Substitution.re +++ b/src/haz3lcore/dynamics/Substitution.re @@ -26,23 +26,23 @@ let rec subst_var = (m, d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => { subst_var(m, d1, x, d4); }; Let(dp, d3, d4) |> rewrap; - | FixF(y, ty, d3) => + | FixF(y, d3) => let d3 = if (DHPat.binds_var(m, x, y)) { d3; } else { subst_var(m, d1, x, d3); }; - FixF(y, ty, d3) |> rewrap; - | Fun(dp, ty, d3, env, s) => + FixF(y, d3) |> rewrap; + | Fun(dp, d3, env, s) => /* Function closure shouldn't appear during substitution (which only is called from elaboration currently) */ let env' = Option.map(subst_var_env(m, d1, x), env); if (DHPat.binds_var(m, x, dp)) { - Fun(dp, ty, d3, env', s) |> rewrap; + Fun(dp, d3, env', s) |> rewrap; } else { let d3 = subst_var(m, d1, x, d3); - Fun(dp, ty, d3, env', s) |> rewrap; + Fun(dp, d3, env', s) |> rewrap; }; | Closure(env, d3) => /* Closure shouldn't appear during substitution (which diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index af5645a5cd..b5895111f5 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -258,17 +258,17 @@ module Transition = (EV: EV_MODE) => { kind: LetBind, value: false, }); - | Fun(_, _, _, Some(_), _) => + | Fun(_, _, Some(_), _) => let. _ = otherwise(env, d); Constructor; - | Fun(p, t, d1, None, v) => + | Fun(p, d1, None, v) => let. _ = otherwise(env, d); Step({ - apply: () => Fun(p, t, d1, Some(env), v) |> rewrap, + apply: () => Fun(p, d1, Some(env), v) |> rewrap, kind: FunClosure, value: true, }); - | FixF(dp, t, d1) => + | FixF(dp, d1) => let (term1, rewrap1) = DHExp.unwrap(d1); switch (term1, DHPat.get_var(dp)) { // Simple Recursion case @@ -278,7 +278,7 @@ module Transition = (EV: EV_MODE) => { evaluate_extend_env( Environment.singleton(( f, - FixF(dp, t, Closure(env, d1) |> rewrap1) |> rewrap, + FixF(dp, Closure(env, d1) |> rewrap1) |> rewrap, )), env, ); @@ -298,7 +298,7 @@ module Transition = (EV: EV_MODE) => { binding, Let( dp, - FixF(dp, t, Closure(env, d1) |> rewrap1) |> rewrap, + FixF(dp, Closure(env, d1) |> rewrap1) |> rewrap, Var(binding) |> fresh, ) |> fresh, @@ -313,9 +313,9 @@ module Transition = (EV: EV_MODE) => { value: false, }); | _ => - let. _ = otherwise(env, FixF(dp, t, d1) |> rewrap); + let. _ = otherwise(env, FixF(dp, d1) |> rewrap); Step({ - apply: () => FixF(dp, t, Closure(env, d1) |> fresh) |> rewrap, + apply: () => FixF(dp, Closure(env, d1) |> fresh) |> rewrap, kind: FixClosure, value: false, }); @@ -352,7 +352,7 @@ module Transition = (EV: EV_MODE) => { ); switch (DHExp.term_of(d1')) { | Constructor(_) => Constructor - | Fun(dp, _, d3, Some(env'), _) => + | Fun(dp, d3, Some(env'), _) => let.match env'' = (env', matches(dp, d2')); Step({ apply: () => Closure(env'', d3) |> fresh, diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index 75a1e4907b..c9c2424649 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -140,13 +140,13 @@ let mk = switch (ps.knd, DHExp.term_of(ps.d_loc)) { | (FunAp, Ap(_, d2, _)) => switch (DHExp.term_of(d2)) { - | Fun(p, _, _, _, _) => DHPat.bound_vars(infomap, p) + | Fun(p, _, _, _) => DHPat.bound_vars(infomap, p) | _ => [] } | (FunAp, _) => [] | (LetBind, Let(p, _, _)) => DHPat.bound_vars(infomap, p) | (LetBind, _) => [] - | (FixUnwrap, FixF(p, _, _)) => DHPat.bound_vars(infomap, p) + | (FixUnwrap, FixF(p, _)) => DHPat.bound_vars(infomap, p) | (FixUnwrap, _) => [] | (InvalidStep, _) | (VarLookup, _) @@ -479,7 +479,7 @@ let mk = ), DHDoc_common.Delim.mk(")"), ]); - | Fun(dp, ty, d, Some(env'), s) => + | Fun(dp, d, Some(env'), s) => if (settings.show_fn_bodies) { let bindings = DHPat.bound_vars(infomap, dp); let body_doc = @@ -506,16 +506,6 @@ let mk = ~enforce_inline, ), ] - @ ( - settings.show_casts - ? [ - DHDoc_common.Delim.colon_Fun, - space(), - DHDoc_Typ.mk(~enforce_inline=true, ty), - space(), - ] - : [] - ) @ [ DHDoc_common.Delim.arrow_Fun, space(), @@ -528,7 +518,7 @@ let mk = | Some(name) => annot(DHAnnot.Collapsed, text("<" ++ name ++ ">")) }; } - | Fun(dp, ty, dbody, None, s) => + | Fun(dp, dbody, None, s) => if (settings.show_fn_bodies) { let bindings = DHPat.bound_vars(infomap, dp); let body_doc = @@ -548,16 +538,6 @@ let mk = ~enforce_inline, ), ] - @ ( - settings.show_casts - ? [ - DHDoc_common.Delim.colon_Fun, - space(), - DHDoc_Typ.mk(~enforce_inline=true, ty), - space(), - ] - : [] - ) @ [ DHDoc_common.Delim.arrow_Fun, space(), @@ -570,7 +550,7 @@ let mk = | Some(name) => annot(DHAnnot.Collapsed, text("<" ++ name ++ ">")) }; } - | FixF(dp, ty, dbody) when settings.show_fixpoints => + | FixF(dp, dbody) when settings.show_fixpoints => let doc_body = go_formattable( dbody, @@ -586,23 +566,13 @@ let mk = space(), DHDoc_Pat.mk(~infomap, dp, ~enforce_inline=true), ] - @ ( - settings.show_casts - ? [ - DHDoc_common.Delim.colon_Fun, - space(), - DHDoc_Typ.mk(~enforce_inline=true, ty), - space(), - ] - : [] - ) @ [ DHDoc_common.Delim.arrow_FixF, space(), doc_body |> DHDoc_common.pad_child(~enforce_inline), ], ); - | FixF(dp, _, d) => + | FixF(dp, d) => go'( ~env= ClosureEnvironment.without_keys( diff --git a/src/test/Test_Elaboration.re b/src/test/Test_Elaboration.re index baab4cf210..f7e9989636 100644 --- a/src/test/Test_Elaboration.re +++ b/src/test/Test_Elaboration.re @@ -163,7 +163,6 @@ let d7: DHExp.t = Forward, Fun( Var("x") |> DHPat.fresh, - Unknown(Internal), BinOp( Int(Plus), Int(4) |> fresh, From 1cf3527267dcfd2a406ff65018d013ca85dab81c Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 29 Feb 2024 15:23:38 -0500 Subject: [PATCH 037/103] Add copied field to UExp --- src/haz3lcore/prog/CachedStatics.re | 2 +- src/haz3lcore/statics/MakeTerm.re | 12 ++++-- src/haz3lcore/statics/Statics.re | 3 +- src/haz3lcore/statics/TermBase.re | 6 +-- src/haz3lcore/zipper/EditorUtil.re | 19 +++++++--- src/haz3lschool/Exercise.re | 4 +- src/test/Test_Elaboration.re | 58 ++++++++++++++++++----------- 7 files changed, 68 insertions(+), 36 deletions(-) diff --git a/src/haz3lcore/prog/CachedStatics.re b/src/haz3lcore/prog/CachedStatics.re index 76cbc772c3..e2c23513ed 100644 --- a/src/haz3lcore/prog/CachedStatics.re +++ b/src/haz3lcore/prog/CachedStatics.re @@ -8,7 +8,7 @@ type statics = { }; let empty_statics: statics = { - term: Term.UExp.{ids: [Id.invalid], term: Tuple([])}, + term: Term.UExp.{ids: [Id.invalid], copied: false, term: Tuple([])}, info_map: Id.Map.empty, error_ids: [], }; diff --git a/src/haz3lcore/statics/MakeTerm.re b/src/haz3lcore/statics/MakeTerm.re index a899a10ed2..d57a2897f2 100644 --- a/src/haz3lcore/statics/MakeTerm.re +++ b/src/haz3lcore/statics/MakeTerm.re @@ -138,7 +138,7 @@ let rec go_s = (s: Sort.t, skel: Skel.t, seg: Segment.t): any => and exp = unsorted => { let (term, inner_ids) = exp_term(unsorted); let ids = ids(unsorted) @ inner_ids; - return(e => Exp(e), ids, {ids, term}); + return(e => Exp(e), ids, {ids, copied: false, term}); } and exp_term: unsorted => (UExp.term, list(Id.t)) = { let ret = (tm: UExp.term) => (tm, []); @@ -161,7 +161,7 @@ and exp_term: unsorted => (UExp.term, list(Id.t)) = { | (["(", ")"], [Exp(body)]) => ret(Parens(body)) | (["[", "]"], [Exp(body)]) => switch (body) { - | {ids, term: Tuple(es)} => (ListLit(es), ids) + | {ids, copied: false, term: Tuple(es)} => (ListLit(es), ids) | term => ret(ListLit([term])) } | (["test", "end"], [Exp(test)]) => ret(Test(test)) @@ -208,7 +208,13 @@ and exp_term: unsorted => (UExp.term, list(Id.t)) = { | ([(_id, t)], []) => switch (t) { | (["()"], []) => - ret(Ap(Forward, l, {ids: [Id.nullary_ap_flag], term: Tuple([])})) + ret( + Ap( + Forward, + l, + {ids: [Id.nullary_ap_flag], copied: false, term: Tuple([])}, + ), + ) | (["(", ")"], [Exp(arg)]) => ret(Ap(Forward, l, arg)) | _ => ret(hole(tm)) } diff --git a/src/haz3lcore/statics/Statics.re b/src/haz3lcore/statics/Statics.re index 417e38e954..72e80f6dad 100644 --- a/src/haz3lcore/statics/Statics.re +++ b/src/haz3lcore/statics/Statics.re @@ -154,7 +154,7 @@ and uexp_to_info_map = ~mode=Mode.Syn, ~is_in_filter=false, ~ancestors, - {ids, term} as uexp: UExp.t, + {ids, copied: _, term} as uexp: UExp.t, m: Map.t, ) : (Info.exp, Map.t) => { @@ -247,6 +247,7 @@ and uexp_to_info_map = | UnOp(Meta(Unquote), e) when is_in_filter => let e: UExp.t = { ids: e.ids, + copied: false, term: switch (e.term) { | Var("e") => UExp.Constructor("$e") diff --git a/src/haz3lcore/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index 2e28416584..b2f75190ab 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -172,6 +172,7 @@ and UExp: { and t = { // invariant: nonempty ids: list(Id.t), + copied: bool, term, }; @@ -298,8 +299,7 @@ and UExp: { | Let(UPat.t, t, t) | FixF(UPat.t, t) // DONE [CHECK WITH SOMEONE THAT I GOT THE STATIC SEMANTICS RIGHT] | TyAlias(UTPat.t, UTyp.t, t) - // note: function is always first then argument; even in reverse - | Ap(ap_direction, t, t) + | Ap(ap_direction, t, t) // note: function is always first then argument; even in pipe mode | If(t, t, t) | Seq(t, t) | Test(t) @@ -308,7 +308,6 @@ and UExp: { | Parens(t) | Cons(t, t) | ListConcat(t, t) - // TODO: Add Builtins | UnOp(op_un, t) | BinOp(op_bin, t, t) | BuiltinFun(string) /// Doesn't currently have a distinguishable syntax... @@ -317,6 +316,7 @@ and UExp: { and t = { // invariant: nonempty ids: list(Id.t), // > DHEXP // Multiple ids?? // Add source?? + copied: bool, term, }; diff --git a/src/haz3lcore/zipper/EditorUtil.re b/src/haz3lcore/zipper/EditorUtil.re index c87bff6f96..a6fcf97777 100644 --- a/src/haz3lcore/zipper/EditorUtil.re +++ b/src/haz3lcore/zipper/EditorUtil.re @@ -68,18 +68,27 @@ let rec append_exp = (e1: TermBase.UExp.t, e2: TermBase.UExp.t) => { | UnOp(_) | BinOp(_) | BuiltinFun(_) - | Match(_) => TermBase.UExp.{ids: [Id.mk()], term: Seq(e1, e2)} + | Match(_) => + TermBase.UExp.{ids: [Id.mk()], copied: false, term: Seq(e1, e2)} | Seq(e11, e12) => let e12' = append_exp(e12, e2); - TermBase.UExp.{ids: e1.ids, term: Seq(e11, e12')}; + TermBase.UExp.{ids: e1.ids, copied: false, term: Seq(e11, e12')}; | Filter(act, econd, ebody) => let ebody' = append_exp(ebody, e2); - TermBase.UExp.{ids: e1.ids, term: Filter(act, econd, ebody')}; + TermBase.UExp.{ + ids: e1.ids, + copied: false, + term: Filter(act, econd, ebody'), + }; | Let(p, edef, ebody) => let ebody' = append_exp(ebody, e2); - TermBase.UExp.{ids: e1.ids, term: Let(p, edef, ebody')}; + TermBase.UExp.{ids: e1.ids, copied: false, term: Let(p, edef, ebody')}; | TyAlias(tp, tdef, ebody) => let ebody' = append_exp(ebody, e2); - TermBase.UExp.{ids: e1.ids, term: TyAlias(tp, tdef, ebody')}; + TermBase.UExp.{ + ids: e1.ids, + copied: false, + term: TyAlias(tp, tdef, ebody'), + }; }; }; diff --git a/src/haz3lschool/Exercise.re b/src/haz3lschool/Exercise.re index ab95b6ead2..66888f05d5 100644 --- a/src/haz3lschool/Exercise.re +++ b/src/haz3lschool/Exercise.re @@ -580,9 +580,10 @@ module F = (ExerciseEnv: ExerciseEnv) => { term: TermBase.UExp.Filter( FilterAction.(act, One), - {term: Constructor("$e"), ids: [Id.mk()]}, + {term: Constructor("$e"), copied: false, ids: [Id.mk()]}, term, ), + copied: false, ids: [Id.mk()], }; @@ -761,6 +762,7 @@ module F = (ExerciseEnv: ExerciseEnv) => { let empty: t = { term: { term: Tuple([]), + copied: false, ids: [Id.mk()], }, info_map: Id.Map.empty, diff --git a/src/test/Test_Elaboration.re b/src/test/Test_Elaboration.re index f7e9989636..156c36796e 100644 --- a/src/test/Test_Elaboration.re +++ b/src/test/Test_Elaboration.re @@ -24,7 +24,7 @@ let mk_map = CoreSettings.on |> Interface.Statics.mk_map; let dhexp_of_uexp = u => Elaborator.dhexp_of_uexp(mk_map(u), u, false); let alco_check = dhexp_typ |> Alcotest.check; -let u1: Term.UExp.t = {ids: [id_at(0)], term: Int(8)}; +let u1: Term.UExp.t = {ids: [id_at(0)], copied: false, term: Int(8)}; let single_integer = () => alco_check( "Integer literal 8", @@ -32,13 +32,14 @@ let single_integer = () => dhexp_of_uexp(u1), ); -let u2: Term.UExp.t = {ids: [id_at(0)], term: EmptyHole}; +let u2: Term.UExp.t = {ids: [id_at(0)], copied: false, term: EmptyHole}; let empty_hole = () => alco_check("Empty hole", Some(EmptyHole |> fresh), dhexp_of_uexp(u2)); let u3: Term.UExp.t = { ids: [id_at(0)], - term: Parens({ids: [id_at(1)], term: Var("y")}), + copied: false, + term: Parens({ids: [id_at(1)], copied: false, term: Var("y")}), }; let d3: DHExp.t = StaticErrorHole(id_at(1), Var("y") |> fresh) |> fresh; let free_var = () => @@ -50,6 +51,7 @@ let free_var = () => let u4: Term.UExp.t = { ids: [id_at(0)], + copied: false, term: Let( { @@ -62,19 +64,21 @@ let u4: Term.UExp.t = { }, { ids: [id_at(4)], + copied: false, term: Tuple([ - {ids: [id_at(5)], term: Int(4)}, - {ids: [id_at(6)], term: Int(6)}, + {ids: [id_at(5)], copied: false, term: Int(4)}, + {ids: [id_at(6)], copied: false, term: Int(6)}, ]), }, { ids: [id_at(7)], + copied: false, term: BinOp( Int(Minus), - {ids: [id_at(8)], term: Var("a")}, - {ids: [id_at(9)], term: Var("b")}, + {ids: [id_at(8)], copied: false, term: Var("a")}, + {ids: [id_at(9)], copied: false, term: Var("b")}, ), }, ), @@ -95,11 +99,12 @@ let let_exp = () => let u5: Term.UExp.t = { ids: [id_at(0)], + copied: false, term: BinOp( Int(Plus), - {ids: [id_at(1)], term: Bool(false)}, - {ids: [id_at(2)], term: Var("y")}, + {ids: [id_at(1)], copied: false, term: Bool(false)}, + {ids: [id_at(2)], copied: false, term: Var("y")}, ), }; let d5: DHExp.t = @@ -118,11 +123,12 @@ let bin_op = () => let u6: Term.UExp.t = { ids: [id_at(0)], + copied: false, term: If( - {ids: [id_at(1)], term: Bool(false)}, - {ids: [id_at(2)], term: Int(8)}, - {ids: [id_at(3)], term: Int(6)}, + {ids: [id_at(1)], copied: false, term: Bool(false)}, + {ids: [id_at(2)], copied: false, term: Int(8)}, + {ids: [id_at(3)], copied: false, term: Int(6)}, ), }; let d6: DHExp.t = @@ -136,26 +142,29 @@ let consistent_if = () => let u7: Term.UExp.t = { ids: [id_at(0)], + copied: false, term: Ap( Forward, { ids: [id_at(1)], + copied: false, term: Fun( {ids: [id_at(2)], term: Var("x")}, { ids: [id_at(3)], + copied: false, term: BinOp( Int(Plus), - {ids: [id_at(4)], term: Int(4)}, - {ids: [id_at(5)], term: Var("x")}, + {ids: [id_at(4)], copied: false, term: Int(4)}, + {ids: [id_at(5)], copied: false, term: Var("x")}, ), }, ), }, - {ids: [id_at(6)], term: Var("y")}, + {ids: [id_at(6)], copied: false, term: Var("y")}, ), }; let d7: DHExp.t = @@ -185,25 +194,27 @@ let ap_fun = () => let u8: Term.UExp.t = { ids: [id_at(0)], + copied: false, term: Match( { ids: [id_at(1)], + copied: false, term: BinOp( Int(Equals), - {ids: [id_at(2)], term: Int(4)}, - {ids: [id_at(3)], term: Int(3)}, + {ids: [id_at(2)], copied: false, term: Int(4)}, + {ids: [id_at(3)], copied: false, term: Int(3)}, ), }, [ ( {ids: [id_at(6)], term: Bool(true)}, - {ids: [id_at(4)], term: Int(24)}, + {ids: [id_at(4)], copied: false, term: Int(24)}, ), ( {ids: [id_at(7)], term: Bool(false)}, - {ids: [id_at(5)], term: Bool(false)}, + {ids: [id_at(5)], copied: false, term: Bool(false)}, ), ], ), @@ -226,6 +237,7 @@ let inconsistent_case = () => let u9: Term.UExp.t = { ids: [id_at(0)], + copied: false, term: Let( { @@ -245,21 +257,23 @@ let u9: Term.UExp.t = { }, { ids: [id_at(6)], + copied: false, term: Fun( {ids: [id_at(7)], term: Var("x")}, { ids: [id_at(8)], + copied: false, term: BinOp( Int(Plus), - {ids: [id_at(9)], term: Int(1)}, - {ids: [id_at(10)], term: Var("x")}, + {ids: [id_at(9)], copied: false, term: Int(1)}, + {ids: [id_at(10)], copied: false, term: Var("x")}, ), }, ), }, - {ids: [id_at(11)], term: Int(55)}, + {ids: [id_at(11)], copied: false, term: Int(55)}, ), }; // let d9: DHExp.t = From cf8f0ca9afab2b8317fff9af6b139a10b18d214b Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 29 Feb 2024 17:21:28 -0500 Subject: [PATCH 038/103] Add closures to UExp --- src/haz3lcore/dynamics/DH.re | 13 +- src/haz3lcore/dynamics/Elaborator.re | 10 +- src/haz3lcore/dynamics/EvalCtx.re | 6 +- src/haz3lcore/dynamics/FilterMatcher.re | 2 +- src/haz3lcore/dynamics/PatternMatch.re | 4 +- src/haz3lcore/dynamics/Stepper.re | 15 +- src/haz3lcore/dynamics/Substitution.re | 5 +- src/haz3lcore/dynamics/Transition.re | 32 ++-- src/haz3lcore/statics/MakeTerm.re | 4 +- src/haz3lcore/statics/Statics.re | 8 +- src/haz3lcore/statics/Term.re | 5 + src/haz3lcore/statics/TermBase.re | 150 ++++++++++++++++++- src/haz3lcore/zipper/EditorUtil.re | 1 + src/haz3lschool/SyntaxTest.re | 21 ++- src/haz3lweb/view/ExplainThis.re | 5 +- src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 6 +- src/test/Test_Elaboration.re | 4 + 17 files changed, 230 insertions(+), 61 deletions(-) diff --git a/src/haz3lcore/dynamics/DH.re b/src/haz3lcore/dynamics/DH.re index 5ebf444312..65a40983ae 100644 --- a/src/haz3lcore/dynamics/DH.re +++ b/src/haz3lcore/dynamics/DH.re @@ -59,7 +59,7 @@ module rec DHExp: { | Tuple(list(t)) | Var(Var.t) | Let(TermBase.UPat.t, t, t) - | FixF(TermBase.UPat.t, t) // TODO: add closure // INVARIANT: always has type assignment on outside // Would be nice to move this into the pattern, but we'd need to merge UTyp.t and Typ.t + | FixF(TermBase.UPat.t, t, [@show.opaque] option(ClosureEnvironment.t)) // TODO: add closure // INVARIANT: always has type assignment on outside // Would be nice to move this into the pattern, but we'd need to merge UTyp.t and Typ.t | TyAlias(TermBase.UTPat.t, TermBase.UTyp.t, t) | Ap(TermBase.UExp.ap_direction, t, t) | If(t, t, t) @@ -119,7 +119,7 @@ module rec DHExp: { | Tuple(list(t)) | Var(Var.t) | Let(TermBase.UPat.t, t, t) - | FixF(TermBase.UPat.t, t) // TODO: Remove type + | FixF(TermBase.UPat.t, t, [@show.opaque] option(ClosureEnvironment.t)) | TyAlias(TermBase.UTPat.t, TermBase.UTyp.t, t) | Ap(TermBase.UExp.ap_direction, t, t) | If(t, t, t) @@ -207,7 +207,7 @@ module rec DHExp: { | Filter(flt, d1) => Filter(flt, repair_ids(d1)) | Seq(d1, d2) => Seq(repair_ids(d1), repair_ids(d2)) | Let(dp, d1, d2) => Let(dp, repair_ids(d1), repair_ids(d2)) - | FixF(f, d1) => FixF(f, repair_ids(d1)) + | FixF(f, d1, env) => FixF(f, repair_ids(d1), env) | TyAlias(tp, t, d) => TyAlias(tp, t, repair_ids(d)) | Fun(dp, d1, env, f) => Fun(dp, repair_ids(d1), env, f) | Ap(dir, d1, d2) => Ap(dir, repair_ids(d1), repair_ids(d2)) @@ -253,7 +253,7 @@ module rec DHExp: { | Filter(f, b) => Filter(DHFilter.strip_casts(f), strip_casts(b)) |> rewrap | Let(dp, b, c) => Let(dp, strip_casts(b), strip_casts(c)) |> rewrap - | FixF(a, c) => FixF(a, strip_casts(c)) |> rewrap + | FixF(a, c, env) => FixF(a, strip_casts(c), env) |> rewrap | TyAlias(tp, t, d) => TyAlias(tp, t, strip_casts(d)) |> rewrap | Fun(a, c, e, d) => Fun(a, strip_casts(c), e, d) |> rewrap | Ap(dir, a, b) => Ap(dir, strip_casts(a), strip_casts(b)) |> rewrap @@ -306,7 +306,10 @@ module rec DHExp: { DHFilter.fast_equal(f1, f2) && fast_equal(d1, d2) | (Let(dp1, d11, d21), Let(dp2, d12, d22)) => dp1 == dp2 && fast_equal(d11, d12) && fast_equal(d21, d22) - | (FixF(f1, d1), FixF(f2, d2)) => f1 == f2 && fast_equal(d1, d2) + | (FixF(f1, d1, sigma1), FixF(f2, d2, sigma2)) => + f1 == f2 + && fast_equal(d1, d2) + && Option.equal(ClosureEnvironment.id_equal, sigma1, sigma2) | (Fun(dp1, d1, None, s1), Fun(dp2, d2, None, s2)) => dp1 == dp2 && fast_equal(d1, d2) && s1 == s2 | (Fun(dp1, d1, Some(env1), s1), Fun(dp2, d2, Some(env2), s2)) => diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index ffa636175d..20a1a02289 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -175,6 +175,8 @@ let rec dhexp_of_uexp = let rewrap = DHExp.mk(uexp.ids); let+ d: DHExp.t = switch (uexp.term) { + // TODO: make closure actually convert + | Closure(_, d) => dhexp_of_uexp(m, d) | Invalid(t) => Some(DHExp.Invalid(t) |> rewrap) | EmptyHole => Some(DHExp.EmptyHole |> rewrap) | MultiHole(us: list(TermBase.Any.t)) => @@ -210,7 +212,7 @@ let rec dhexp_of_uexp = let+ ty = fixed_exp_typ(m, uexp); let ty = Typ.matched_list(ctx, ty); DHExp.ListLit(ty, ds) |> rewrap; - | Fun(p, body) => + | Fun(p, body, _, _) => let+ d1 = dhexp_of_uexp(m, body); DHExp.Fun(p, d1, None, None) |> rewrap; | Tuple(es) => @@ -275,15 +277,15 @@ let rec dhexp_of_uexp = | Some(b) => DHExp.Let( p, - FixF(p, add_name(Some(String.concat(",", b)), ddef)) + FixF(p, add_name(Some(String.concat(",", b)), ddef), None) |> DHExp.fresh, dbody, ) |> rewrap }; - | FixF(p, e) => + | FixF(p, e, _) => let+ de = dhexp_of_uexp(m, e); - DHExp.FixF(p, de) |> rewrap; + DHExp.FixF(p, de, None) |> rewrap; | Ap(dir, fn, arg) => let* c_fn = dhexp_of_uexp(m, fn); let+ c_arg = dhexp_of_uexp(m, arg); diff --git a/src/haz3lcore/dynamics/EvalCtx.re b/src/haz3lcore/dynamics/EvalCtx.re index 7097fe10ef..b92f373f33 100644 --- a/src/haz3lcore/dynamics/EvalCtx.re +++ b/src/haz3lcore/dynamics/EvalCtx.re @@ -11,7 +11,7 @@ type term = | Let1(TermBase.UPat.t, t, DHExp.t) | Let2(TermBase.UPat.t, DHExp.t, t) | Fun(TermBase.UPat.t, t, option(ClosureEnvironment.t), option(Var.t)) - | FixF(TermBase.UPat.t, t) + | FixF(TermBase.UPat.t, t, option(ClosureEnvironment.t)) | Ap1(TermBase.UExp.ap_direction, t, DHExp.t) | Ap2(TermBase.UExp.ap_direction, DHExp.t, t) | If1(t, DHExp.t, DHExp.t) @@ -125,9 +125,9 @@ let rec compose = (ctx: t, d: DHExp.t): DHExp.t => { | Fun(dp, ctx, env, v) => let d = compose(ctx, d); Fun(dp, d, env, v) |> wrap; - | FixF(v, ctx) => + | FixF(v, ctx, env) => let d = compose(ctx, d); - FixF(v, d) |> wrap; + FixF(v, d, env) |> wrap; | Cast(ctx, ty1, ty2) => let d = compose(ctx, d); Cast(d, ty1, ty2) |> wrap; diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index 350d096465..579d6c0d45 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -79,7 +79,7 @@ let rec matches_exp = matches_pat(dp1, fp1) && matches_exp(env, d1, f1) && dname1 == fname1 | (Fun(_), _) => false - | (FixF(dp, d1), FixF(fp, f1)) => + | (FixF(dp, d1, _), FixF(fp, f1, _)) => matches_pat(dp, fp) && matches_exp(env, d1, f1) | (FixF(_), _) => false diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index 0f21ae32e2..e6328ed40f 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -331,7 +331,7 @@ and matches_cast_Tuple = | Var(_) => DoesNotMatch | Invalid(_) => IndetMatch | Let(_, _, _) => IndetMatch - | FixF(_, _) => DoesNotMatch + | FixF(_, _, _) => DoesNotMatch | Fun(_, _, _, _) => DoesNotMatch | Closure(_, _) => IndetMatch | Filter(_, _) => IndetMatch @@ -467,7 +467,7 @@ and matches_cast_Cons = | Var(_) => DoesNotMatch | Invalid(_) => IndetMatch | Let(_, _, _) => IndetMatch - | FixF(_, _) => DoesNotMatch + | FixF(_, _, _) => DoesNotMatch | Fun(_, _, _, _) => DoesNotMatch | Closure(_, d') => matches_cast_Cons(dp, d', elt_casts) | Filter(_, d') => matches_cast_Cons(dp, d', elt_casts) diff --git a/src/haz3lcore/dynamics/Stepper.re b/src/haz3lcore/dynamics/Stepper.re index d4aa08342e..a31d6ca81f 100644 --- a/src/haz3lcore/dynamics/Stepper.re +++ b/src/haz3lcore/dynamics/Stepper.re @@ -91,9 +91,18 @@ let rec matches = idx, ); Fun(dp, ctx, env', name) |> rewrap; - | FixF(name, ctx) => - let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); - FixF(name, ctx) |> rewrap; + | FixF(name, ctx, env') => + let+ ctx = + matches( + Option.value(~default=env, env'), + flt, + ctx, + exp, + exp_info_map, + act, + idx, + ); + FixF(name, ctx, env') |> rewrap; | Ap1(dir, ctx, d2) => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); Ap1(dir, ctx, d2) |> rewrap; diff --git a/src/haz3lcore/dynamics/Substitution.re b/src/haz3lcore/dynamics/Substitution.re index 9fe3066bf9..931feec3a2 100644 --- a/src/haz3lcore/dynamics/Substitution.re +++ b/src/haz3lcore/dynamics/Substitution.re @@ -26,14 +26,15 @@ let rec subst_var = (m, d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => { subst_var(m, d1, x, d4); }; Let(dp, d3, d4) |> rewrap; - | FixF(y, d3) => + | FixF(y, d3, env) => + let env' = Option.map(subst_var_env(m, d1, x), env); let d3 = if (DHPat.binds_var(m, x, y)) { d3; } else { subst_var(m, d1, x, d3); }; - FixF(y, d3) |> rewrap; + FixF(y, d3, env') |> rewrap; | Fun(dp, d3, env, s) => /* Function closure shouldn't appear during substitution (which only is called from elaboration currently) */ diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index b5895111f5..1b629f9c17 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -268,18 +268,21 @@ module Transition = (EV: EV_MODE) => { kind: FunClosure, value: true, }); - | FixF(dp, d1) => - let (term1, rewrap1) = DHExp.unwrap(d1); - switch (term1, DHPat.get_var(dp)) { + | FixF(dp, d1, None) => + let. _ = otherwise(env, FixF(dp, d1, None) |> rewrap); + Step({ + apply: () => FixF(dp, d1, Some(env)) |> rewrap, + kind: FixClosure, + value: false, + }); + | FixF(dp, d1, Some(env)) => + switch (DHPat.get_var(dp)) { // Simple Recursion case - | (Closure(env, d1), Some(f)) => + | Some(f) => let. _ = otherwise(env, d); let env'' = evaluate_extend_env( - Environment.singleton(( - f, - FixF(dp, Closure(env, d1) |> rewrap1) |> rewrap, - )), + Environment.singleton((f, FixF(dp, d1, Some(env)) |> rewrap)), env, ); Step({ @@ -288,7 +291,7 @@ module Transition = (EV: EV_MODE) => { value: false, }); // Mutual Recursion case - | (Closure(env, d1), None) => + | None => let. _ = otherwise(env, d); let bindings = DHPat.bound_vars(info_map, dp); let substitutions = @@ -298,7 +301,7 @@ module Transition = (EV: EV_MODE) => { binding, Let( dp, - FixF(dp, Closure(env, d1) |> rewrap1) |> rewrap, + FixF(dp, d1, Some(env)) |> rewrap, Var(binding) |> fresh, ) |> fresh, @@ -312,14 +315,7 @@ module Transition = (EV: EV_MODE) => { kind: FixUnwrap, value: false, }); - | _ => - let. _ = otherwise(env, FixF(dp, d1) |> rewrap); - Step({ - apply: () => FixF(dp, Closure(env, d1) |> fresh) |> rewrap, - kind: FixClosure, - value: false, - }); - }; + } | Test(d) => let. _ = otherwise(env, d => Test(d) |> rewrap) and. d' = req_final(req(state, env), d => Test(d) |> wrap_ctx, d); diff --git a/src/haz3lcore/statics/MakeTerm.re b/src/haz3lcore/statics/MakeTerm.re index d57a2897f2..66c6bc8a50 100644 --- a/src/haz3lcore/statics/MakeTerm.re +++ b/src/haz3lcore/statics/MakeTerm.re @@ -183,8 +183,8 @@ and exp_term: unsorted => (UExp.term, list(Id.t)) = { | (["$"], []) => UnOp(Meta(Unquote), r) | (["-"], []) => UnOp(Int(Minus), r) | (["!"], []) => UnOp(Bool(Not), r) - | (["fun", "->"], [Pat(pat)]) => Fun(pat, r) - | (["fix", "->"], [Pat(pat)]) => FixF(pat, r) + | (["fun", "->"], [Pat(pat)]) => Fun(pat, r, None, None) + | (["fix", "->"], [Pat(pat)]) => FixF(pat, r, None) | (["let", "=", "in"], [Pat(pat), Exp(def)]) => Let(pat, def, r) | (["hide", "in"], [Exp(filter)]) => Filter((Eval, One), filter, r) diff --git a/src/haz3lcore/statics/Statics.re b/src/haz3lcore/statics/Statics.re index 72e80f6dad..53b75eed60 100644 --- a/src/haz3lcore/statics/Statics.re +++ b/src/haz3lcore/statics/Statics.re @@ -193,6 +193,10 @@ and uexp_to_info_map = let go_pat = upat_to_info_map(~ctx, ~ancestors); let atomic = self => add(~self, ~co_ctx=CoCtx.empty, m); switch (term) { + | Closure(_) => + failwith( + "TODO: implement closure type checking - see how dynamic type assignment does it", + ) | MultiHole(tms) => let (co_ctxs, m) = multi(~ctx, ~ancestors, m, tms); add(~self=IsMulti, ~co_ctx=CoCtx.union(co_ctxs), m); @@ -308,7 +312,7 @@ and uexp_to_info_map = && !Typ.is_consistent(ctx, ty_in, Prod([])) ? BadTrivAp(ty_in) : Just(ty_out); add(~self, ~co_ctx=CoCtx.union([fn.co_ctx, arg.co_ctx]), m); - | Fun(p, e) => + | Fun(p, e, _, _) => let (mode_pat, mode_body) = Mode.of_arrow(ctx, mode); let (p', _) = go_pat(~is_synswitch=false, ~co_ctx=CoCtx.empty, ~mode=mode_pat, p, m); @@ -351,7 +355,7 @@ and uexp_to_info_map = CoCtx.union([def.co_ctx, CoCtx.mk(ctx, p_ana.ctx, body.co_ctx)]), m, ); - | FixF(p, e) => + | FixF(p, e, _) => let (p', _) = go_pat(~is_synswitch=false, ~co_ctx=CoCtx.empty, ~mode, p, m); let (e', m) = go'(~ctx=p'.ctx, ~mode=Ana(p'.ty), e, m); diff --git a/src/haz3lcore/statics/Term.re b/src/haz3lcore/statics/Term.re index df5b5f584e..117010ff84 100644 --- a/src/haz3lcore/statics/Term.re +++ b/src/haz3lcore/statics/Term.re @@ -436,6 +436,7 @@ module UExp = { | Seq | Test | Filter + | Closure | Parens | Cons | UnOp(op_un) @@ -480,6 +481,7 @@ module UExp = { | Seq(_) => Seq | Test(_) => Test | Filter(_) => Filter + | Closure(_) => Closure | Parens(_) => Parens | Cons(_) => Cons | ListConcat(_) => ListConcat @@ -578,6 +580,7 @@ module UExp = { | Seq => "Sequence expression" | Test => "Test" | Filter => "Filter" + | Closure => "Closure" | Parens => "Parenthesized expression" | Cons => "Cons" | ListConcat => "List Concatenation" @@ -614,6 +617,7 @@ module UExp = { | Filter(_) | Cons(_) | ListConcat(_) + | Closure(_) | UnOp(_) | BinOp(_) | Match(_) @@ -639,6 +643,7 @@ module UExp = { | String(_) | ListLit(_) | Fun(_) + | Closure(_) | BuiltinFun(_) | Var(_) | Let(_) diff --git a/src/haz3lcore/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index b2f75190ab..2b367eaaa2 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -151,17 +151,23 @@ and UExp: { | String(string) | ListLit(list(t)) | Constructor(string) - | Fun(UPat.t, t) + | Fun( + UPat.t, + t, + [@show.opaque] option(ClosureEnvironment.t), + option(Var.t), + ) | Tuple(list(t)) | Var(Var.t) | Let(UPat.t, t, t) - | FixF(UPat.t, t) + | FixF(UPat.t, t, [@show.opaque] option(ClosureEnvironment.t)) | TyAlias(UTPat.t, UTyp.t, t) | Ap(ap_direction, t, t) | If(t, t, t) | Seq(t, t) | Test(t) | Filter(FilterAction.t, t, t) + | Closure([@show.opaque] ClosureEnvironment.t, t) | Parens(t) // ( | Cons(t, t) | ListConcat(t, t) @@ -293,18 +299,23 @@ and UExp: { | String(string) | ListLit(list(t)) | Constructor(string) - | Fun(UPat.t, t) // TODO: Add option(Var.t) name field to end; Add optional closure to function + | Fun( + UPat.t, + t, + [@show.opaque] option(ClosureEnvironment.t), + option(Var.t), + ) // TODO: Add option(Var.t) name field to end; Add optional closure to function | Tuple(list(t)) | Var(Var.t) | Let(UPat.t, t, t) - | FixF(UPat.t, t) // DONE [CHECK WITH SOMEONE THAT I GOT THE STATIC SEMANTICS RIGHT] + | FixF(UPat.t, t, [@show.opaque] option(ClosureEnvironment.t)) // DONE [CHECK WITH SOMEONE THAT I GOT THE STATIC SEMANTICS RIGHT] | TyAlias(UTPat.t, UTyp.t, t) | Ap(ap_direction, t, t) // note: function is always first then argument; even in pipe mode | If(t, t, t) | Seq(t, t) | Test(t) - | Filter(FilterAction.t, t, t) // TODO: Change to reflect DHExp - // TODO: Add closures + | Filter(FilterAction.t, t, t) // TODO: Change to reflect UExp + | Closure([@show.opaque] ClosureEnvironment.t, t) | Parens(t) | Cons(t, t) | ListConcat(t, t) @@ -507,4 +518,131 @@ and URul: { ids: list(Id.t), term, }; +} + +and Environment: { + include + (module type of VarBstMap.Ordered) with + type t_('a) = VarBstMap.Ordered.t_('a); + + [@deriving (show({with_path: false}), sexp, yojson)] + type t = t_(UExp.t); +} = { + include VarBstMap.Ordered; + + [@deriving (show({with_path: false}), sexp, yojson)] + type t = t_(UExp.t); +} + +and ClosureEnvironment: { + [@deriving (show({with_path: false}), sexp, yojson)] + type t; + + let wrap: (EnvironmentId.t, Environment.t) => t; + + let id_of: t => EnvironmentId.t; + let map_of: t => Environment.t; + + let to_list: t => list((Var.t, UExp.t)); + + let of_environment: Environment.t => t; + + let id_equal: (t, t) => bool; + + let empty: t; + let is_empty: t => bool; + let length: t => int; + + let lookup: (t, Var.t) => option(UExp.t); + let contains: (t, Var.t) => bool; + let update: (Environment.t => Environment.t, t) => t; + let update_keep_id: (Environment.t => Environment.t, t) => t; + let extend: (t, (Var.t, UExp.t)) => t; + let extend_keep_id: (t, (Var.t, UExp.t)) => t; + let union: (t, t) => t; + let union_keep_id: (t, t) => t; + let map: (((Var.t, UExp.t)) => UExp.t, t) => t; + let map_keep_id: (((Var.t, UExp.t)) => UExp.t, t) => t; + let filter: (((Var.t, UExp.t)) => bool, t) => t; + let filter_keep_id: (((Var.t, UExp.t)) => bool, t) => t; + let fold: (((Var.t, UExp.t), 'b) => 'b, 'b, t) => 'b; + + let without_keys: (list(Var.t), t) => t; + + let placeholder: t; +} = { + module Inner: { + [@deriving (show({with_path: false}), sexp, yojson)] + type t; + + let wrap: (EnvironmentId.t, Environment.t) => t; + + let id_of: t => EnvironmentId.t; + let map_of: t => Environment.t; + } = { + [@deriving (show({with_path: false}), sexp, yojson)] + type t = (EnvironmentId.t, Environment.t); + + let wrap = (ei, map): t => (ei, map); + + let id_of = ((ei, _)) => ei; + let map_of = ((_, map)) => map; + let (sexp_of_t, t_of_sexp) = + StructureShareSexp.structure_share_here(id_of, sexp_of_t, t_of_sexp); + }; + include Inner; + + let to_list = env => env |> map_of |> Environment.to_listo; + + let of_environment = map => { + let ei = Id.mk(); + wrap(ei, map); + }; + + /* Equals only needs to check environment id's (faster than structural equality + * checking.) */ + let id_equal = (env1, env2) => id_of(env1) == id_of(env2); + + let empty = Environment.empty |> of_environment; + + let is_empty = env => env |> map_of |> Environment.is_empty; + + let length = env => Environment.length(map_of(env)); + + let lookup = (env, x) => + env |> map_of |> (map => Environment.lookup(map, x)); + + let contains = (env, x) => + env |> map_of |> (map => Environment.contains(map, x)); + + let update = (f, env) => env |> map_of |> f |> of_environment; + + let update_keep_id = (f, env) => env |> map_of |> f |> wrap(env |> id_of); + + let extend = (env, xr) => + env |> update(map => Environment.extend(map, xr)); + + let extend_keep_id = (env, xr) => + env |> update_keep_id(map => Environment.extend(map, xr)); + + let union = (env1, env2) => + env2 |> update(map2 => Environment.union(env1 |> map_of, map2)); + + let union_keep_id = (env1, env2) => + env2 |> update_keep_id(map2 => Environment.union(env1 |> map_of, map2)); + + let map = (f, env) => env |> update(Environment.mapo(f)); + + let map_keep_id = (f, env) => env |> update_keep_id(Environment.mapo(f)); + + let filter = (f, env) => env |> update(Environment.filtero(f)); + + let filter_keep_id = (f, env) => + env |> update_keep_id(Environment.filtero(f)); + + let fold = (f, init, env) => env |> map_of |> Environment.foldo(f, init); + + let placeholder = wrap(EnvironmentId.invalid, Environment.empty); + + let without_keys = keys => update(Environment.without_keys(keys)); }; diff --git a/src/haz3lcore/zipper/EditorUtil.re b/src/haz3lcore/zipper/EditorUtil.re index a6fcf97777..c91140624f 100644 --- a/src/haz3lcore/zipper/EditorUtil.re +++ b/src/haz3lcore/zipper/EditorUtil.re @@ -55,6 +55,7 @@ let rec append_exp = (e1: TermBase.UExp.t, e2: TermBase.UExp.t) => { | String(_) | ListLit(_) | Constructor(_) + | Closure(_) | Fun(_) | FixF(_) | Tuple(_) diff --git a/src/haz3lschool/SyntaxTest.re b/src/haz3lschool/SyntaxTest.re index 6dc2df2dc3..c1435e35d2 100644 --- a/src/haz3lschool/SyntaxTest.re +++ b/src/haz3lschool/SyntaxTest.re @@ -45,8 +45,8 @@ let rec var_mention = (name: string, uexp: Term.UExp.t): bool => { | String(_) | Constructor(_) | BuiltinFun(_) => false - | FixF(args, body) - | Fun(args, body) => + | FixF(args, body, _) + | Fun(args, body, _, _) => find_var_upat(name, args) ? false : var_mention(name, body) | ListLit(l) | Tuple(l) => @@ -54,6 +54,8 @@ let rec var_mention = (name: string, uexp: Term.UExp.t): bool => { | Let(p, def, body) => find_var_upat(name, p) ? false : var_mention(name, def) || var_mention(name, body) + // TODO: should we check within the closure? + | Closure(_, u) | Test(u) | Parens(u) | UnOp(_, u) @@ -94,8 +96,8 @@ let rec var_applied = (name: string, uexp: Term.UExp.t): bool => { | String(_) | Constructor(_) | BuiltinFun(_) => false - | FixF(args, body) - | Fun(args, body) => + | FixF(args, body, _) + | Fun(args, body, _, _) => find_var_upat(name, args) ? false : var_applied(name, body) | ListLit(l) | Tuple(l) => @@ -107,6 +109,7 @@ let rec var_applied = (name: string, uexp: Term.UExp.t): bool => { | Parens(u) | UnOp(_, u) | TyAlias(_, _, u) + | Closure(_, u) | Filter(_, _, u) => var_applied(name, u) | Ap(_, u1, u2) => switch (u1.term) { @@ -185,12 +188,13 @@ let rec find_fn = | ListLit(ul) | Tuple(ul) => List.fold_left((acc, u1) => {find_fn(name, u1, acc)}, l, ul) - | FixF(_, body) - | Fun(_, body) => l |> find_fn(name, body) + | FixF(_, body, _) + | Fun(_, body, _, _) => l |> find_fn(name, body) | Parens(u1) | UnOp(_, u1) | TyAlias(_, _, u1) | Test(u1) + | Closure(_, u1) | Filter(_, _, u1) => l |> find_fn(name, u1) | Ap(_, u1, u2) | Seq(u1, u2) @@ -249,8 +253,8 @@ let rec tail_check = (name: string, uexp: Term.UExp.t): bool => { | Constructor(_) | Var(_) | BuiltinFun(_) => true - | FixF(args, body) - | Fun(args, body) => + | FixF(args, body, _) + | Fun(args, body, _, _) => find_var_upat(name, args) ? false : tail_check(name, body) | Let(p, def, body) => find_var_upat(name, p) || var_mention(name, def) @@ -262,6 +266,7 @@ let rec tail_check = (name: string, uexp: Term.UExp.t): bool => { | Test(_) => false | TyAlias(_, _, u) | Filter(_, _, u) + | Closure(_, u) | Parens(u) => tail_check(name, u) | UnOp(_, u) => !var_mention(name, u) | Ap(_, u1, u2) => var_mention(name, u2) ? false : tail_check(name, u1) diff --git a/src/haz3lweb/view/ExplainThis.re b/src/haz3lweb/view/ExplainThis.re index ec4375c117..8e9d8885a6 100644 --- a/src/haz3lweb/view/ExplainThis.re +++ b/src/haz3lweb/view/ExplainThis.re @@ -525,6 +525,7 @@ let get_doc = | DynamicErrorHole(_) | StaticErrorHole(_) | FailedCast(_) + | Closure(_) | BuiltinFun(_) => simple("Internal expression") | EmptyHole => get_message(HoleExp.empty_hole_exps) | MultiHole(_children) => get_message(HoleExp.multi_hole_exps) @@ -561,7 +562,7 @@ let get_doc = ), ListExp.listlits, ) - | Fun(pat, body) => + | Fun(pat, body, _, _) => let basic = group_id => { let pat_id = List.nth(pat.ids, 0); let body_id = List.nth(body.ids, 0); @@ -1526,7 +1527,7 @@ let get_doc = | Parens(_) => default // Shouldn't get hit? | TypeAnn(_) => default // Shouldn't get hit? }; - | FixF(pat, body) => + | FixF(pat, body, _) => message_single( FixFExp.single( ~pat_id=Term.UPat.rep_id(pat), diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index c9c2424649..aa002ad6ea 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -146,7 +146,7 @@ let mk = | (FunAp, _) => [] | (LetBind, Let(p, _, _)) => DHPat.bound_vars(infomap, p) | (LetBind, _) => [] - | (FixUnwrap, FixF(p, _)) => DHPat.bound_vars(infomap, p) + | (FixUnwrap, FixF(p, _, _)) => DHPat.bound_vars(infomap, p) | (FixUnwrap, _) => [] | (InvalidStep, _) | (VarLookup, _) @@ -550,7 +550,7 @@ let mk = | Some(name) => annot(DHAnnot.Collapsed, text("<" ++ name ++ ">")) }; } - | FixF(dp, dbody) when settings.show_fixpoints => + | FixF(dp, dbody, _) when settings.show_fixpoints => let doc_body = go_formattable( dbody, @@ -572,7 +572,7 @@ let mk = doc_body |> DHDoc_common.pad_child(~enforce_inline), ], ); - | FixF(dp, d) => + | FixF(dp, d, _) => go'( ~env= ClosureEnvironment.without_keys( diff --git a/src/test/Test_Elaboration.re b/src/test/Test_Elaboration.re index 156c36796e..9f0739e087 100644 --- a/src/test/Test_Elaboration.re +++ b/src/test/Test_Elaboration.re @@ -162,6 +162,8 @@ let u7: Term.UExp.t = { {ids: [id_at(5)], copied: false, term: Var("x")}, ), }, + None, + None, ), }, {ids: [id_at(6)], copied: false, term: Var("y")}, @@ -271,6 +273,8 @@ let u9: Term.UExp.t = { {ids: [id_at(10)], copied: false, term: Var("x")}, ), }, + None, + None, ), }, {ids: [id_at(11)], copied: false, term: Int(55)}, From 70101c9f46790f5dec6d576b840707de736f8408 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 29 Feb 2024 17:48:26 -0500 Subject: [PATCH 039/103] Add casts to UExp --- src/haz3lcore/dynamics/DH.re | 6 +++--- src/haz3lcore/dynamics/Elaborator.re | 3 +++ src/haz3lcore/statics/Statics.re | 1 + src/haz3lcore/statics/Term.re | 9 +++++++-- src/haz3lcore/statics/TermBase.re | 3 ++- src/haz3lcore/zipper/EditorUtil.re | 1 + src/haz3lschool/SyntaxTest.re | 4 ++++ src/haz3lweb/view/ExplainThis.re | 1 + 8 files changed, 22 insertions(+), 6 deletions(-) diff --git a/src/haz3lcore/dynamics/DH.re b/src/haz3lcore/dynamics/DH.re index 65a40983ae..082cc131ee 100644 --- a/src/haz3lcore/dynamics/DH.re +++ b/src/haz3lcore/dynamics/DH.re @@ -126,15 +126,15 @@ module rec DHExp: { | Seq(t, t) | Test(t) | Filter(DHFilter.t, t) // DONE [UEXP TO BE CHANGED] - | Closure([@show.opaque] ClosureEnvironment.t, t) // > UEXP + | Closure([@show.opaque] ClosureEnvironment.t, t) | Parens(t) | Cons(t, t) | ListConcat(t, t) | UnOp(TermBase.UExp.op_un, t) - | BinOp(TermBase.UExp.op_bin, t, t) // DONE + | BinOp(TermBase.UExp.op_bin, t, t) | BuiltinFun(string) // DONE [TO ADD TO UEXP] | Match(t, list((TermBase.UPat.t, t))) - | Cast(t, Typ.t, Typ.t) // TODO: Add to uexp or remove + | Cast(t, Typ.t, Typ.t) // TODO: Perhaps merge with failedcast? and t = { /* invariant: nonempty, TODO: what happens to later ids in DHExp */ ids: list(Id.t), diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 20a1a02289..04fd9c753f 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -177,6 +177,9 @@ let rec dhexp_of_uexp = switch (uexp.term) { // TODO: make closure actually convert | Closure(_, d) => dhexp_of_uexp(m, d) + | Cast(d1, t1, t2) => + let+ d1' = dhexp_of_uexp(m, d1); + Cast(d1', t1, t2) |> rewrap; | Invalid(t) => Some(DHExp.Invalid(t) |> rewrap) | EmptyHole => Some(DHExp.EmptyHole |> rewrap) | MultiHole(us: list(TermBase.Any.t)) => diff --git a/src/haz3lcore/statics/Statics.re b/src/haz3lcore/statics/Statics.re index 53b75eed60..cec2879520 100644 --- a/src/haz3lcore/statics/Statics.re +++ b/src/haz3lcore/statics/Statics.re @@ -200,6 +200,7 @@ and uexp_to_info_map = | MultiHole(tms) => let (co_ctxs, m) = multi(~ctx, ~ancestors, m, tms); add(~self=IsMulti, ~co_ctx=CoCtx.union(co_ctxs), m); + | Cast(e, t1, t2) | FailedCast(e, t1, t2) => let (e, m) = go(~mode=Ana(t1), e, m); add(~self=Just(t2), ~co_ctx=e.co_ctx, m); diff --git a/src/haz3lcore/statics/Term.re b/src/haz3lcore/statics/Term.re index 117010ff84..87650ad841 100644 --- a/src/haz3lcore/statics/Term.re +++ b/src/haz3lcore/statics/Term.re @@ -443,6 +443,7 @@ module UExp = { | BinOp(op_bin) | BuiltinFun | Match + | Cast | ListConcat; let hole = (tms: list(any)): term => @@ -488,7 +489,8 @@ module UExp = { | UnOp(op, _) => UnOp(op) | BinOp(op, _, _) => BinOp(op) | BuiltinFun(_) => BuiltinFun - | Match(_) => Match; + | Match(_) => Match + | Cast(_) => Cast; let show_op_un_meta: op_un_meta => string = fun @@ -587,11 +589,13 @@ module UExp = { | BinOp(op) => show_binop(op) | UnOp(op) => show_unop(op) | BuiltinFun => "Built-in Function" - | Match => "Case expression"; + | Match => "Case expression" + | Cast => "Cast expression"; let rec is_fun = (e: t) => { switch (e.term) { | Parens(e) => is_fun(e) + | Cast(e, _, _) => is_fun(e) | Fun(_) | BuiltinFun(_) => true | Invalid(_) @@ -629,6 +633,7 @@ module UExp = { is_fun(e) || ( switch (e.term) { + | Cast(e, _, _) | Parens(e) => is_tuple_of_functions(e) | Tuple(es) => es |> List.for_all(is_fun) | Invalid(_) diff --git a/src/haz3lcore/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index 2b367eaaa2..f5d83bde88 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -175,6 +175,7 @@ and UExp: { | BinOp(op_bin, t, t) | BuiltinFun(string) | Match(t, list((UPat.t, t))) + | Cast(t, Typ.t, Typ.t) and t = { // invariant: nonempty ids: list(Id.t), @@ -323,7 +324,7 @@ and UExp: { | BinOp(op_bin, t, t) | BuiltinFun(string) /// Doesn't currently have a distinguishable syntax... | Match(t, list((UPat.t, t))) - // TODO: Add Casts + | Cast(t, Typ.t, Typ.t) and t = { // invariant: nonempty ids: list(Id.t), // > DHEXP // Multiple ids?? // Add source?? diff --git a/src/haz3lcore/zipper/EditorUtil.re b/src/haz3lcore/zipper/EditorUtil.re index c91140624f..14391b7a59 100644 --- a/src/haz3lcore/zipper/EditorUtil.re +++ b/src/haz3lcore/zipper/EditorUtil.re @@ -69,6 +69,7 @@ let rec append_exp = (e1: TermBase.UExp.t, e2: TermBase.UExp.t) => { | UnOp(_) | BinOp(_) | BuiltinFun(_) + | Cast(_) | Match(_) => TermBase.UExp.{ids: [Id.mk()], copied: false, term: Seq(e1, e2)} | Seq(e11, e12) => diff --git a/src/haz3lschool/SyntaxTest.re b/src/haz3lschool/SyntaxTest.re index c1435e35d2..abcc03a48b 100644 --- a/src/haz3lschool/SyntaxTest.re +++ b/src/haz3lschool/SyntaxTest.re @@ -58,6 +58,7 @@ let rec var_mention = (name: string, uexp: Term.UExp.t): bool => { | Closure(_, u) | Test(u) | Parens(u) + | Cast(u, _, _) | UnOp(_, u) | TyAlias(_, _, u) | Filter(_, _, u) => var_mention(name, u) @@ -107,6 +108,7 @@ let rec var_applied = (name: string, uexp: Term.UExp.t): bool => { ? false : var_applied(name, def) || var_applied(name, body) | Test(u) | Parens(u) + | Cast(u, _, _) | UnOp(_, u) | TyAlias(_, _, u) | Closure(_, u) @@ -191,6 +193,7 @@ let rec find_fn = | FixF(_, body, _) | Fun(_, body, _, _) => l |> find_fn(name, body) | Parens(u1) + | Cast(u1, _, _) | UnOp(_, u1) | TyAlias(_, _, u1) | Test(u1) @@ -265,6 +268,7 @@ let rec tail_check = (name: string, uexp: Term.UExp.t): bool => { !List.fold_left((acc, ue) => {acc || var_mention(name, ue)}, false, l) | Test(_) => false | TyAlias(_, _, u) + | Cast(u, _, _) | Filter(_, _, u) | Closure(_, u) | Parens(u) => tail_check(name, u) diff --git a/src/haz3lweb/view/ExplainThis.re b/src/haz3lweb/view/ExplainThis.re index 8e9d8885a6..95510b9ecb 100644 --- a/src/haz3lweb/view/ExplainThis.re +++ b/src/haz3lweb/view/ExplainThis.re @@ -526,6 +526,7 @@ let get_doc = | StaticErrorHole(_) | FailedCast(_) | Closure(_) + | Cast(_) | BuiltinFun(_) => simple("Internal expression") | EmptyHole => get_message(HoleExp.empty_hole_exps) | MultiHole(_children) => get_message(HoleExp.multi_hole_exps) From 11eee6b0e9998f5b044b10cb16af498c43cadbad Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Fri, 1 Mar 2024 09:50:23 -0500 Subject: [PATCH 040/103] Remove type from ListLit This might need to be re-added at some point for type inference purposes --- src/haz3lcore/dynamics/Builtins.re | 2 +- src/haz3lcore/dynamics/DH.re | 25 +- src/haz3lcore/dynamics/Elaborator.re | 6 +- src/haz3lcore/dynamics/EvalCtx.re | 6 +- src/haz3lcore/dynamics/FilterMatcher.re | 15 +- src/haz3lcore/dynamics/PatternMatch.re | 6 +- src/haz3lcore/dynamics/Stepper.re | 4 +- src/haz3lcore/dynamics/Substitution.re | 3 +- src/haz3lcore/dynamics/Transition.re | 11 +- src/haz3lcore/dynamics/TypeAssignment.re | 280 +++++++++++++++++++ src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 2 +- 11 files changed, 317 insertions(+), 43 deletions(-) create mode 100644 src/haz3lcore/dynamics/TypeAssignment.re diff --git a/src/haz3lcore/dynamics/Builtins.re b/src/haz3lcore/dynamics/Builtins.re index 374397f4d1..11c93f4133 100644 --- a/src/haz3lcore/dynamics/Builtins.re +++ b/src/haz3lcore/dynamics/Builtins.re @@ -246,7 +246,7 @@ module Pervasives = { let string_concat = binary((d1, d2) => switch (term_of(d1), term_of(d2)) { - | (String(s1), ListLit(_, xs)) => + | (String(s1), ListLit(xs)) => switch (xs |> List.map(string_of) |> Util.OptUtil.sequence) { | None => Error(InvalidBoxedStringLit(List.hd(xs))) | Some(xs) => Ok(String(String.concat(s1, xs)) |> fresh) diff --git a/src/haz3lcore/dynamics/DH.re b/src/haz3lcore/dynamics/DH.re index 082cc131ee..d4f3d02830 100644 --- a/src/haz3lcore/dynamics/DH.re +++ b/src/haz3lcore/dynamics/DH.re @@ -48,10 +48,10 @@ module rec DHExp: { | Int(int) | Float(float) | String(string) - | ListLit(Typ.t, list(t)) + | ListLit(list(t)) | Constructor(string) | Fun( - TermBase.UPat.t, // INVARIANT: always has type assignment on outside + TermBase.UPat.t, t, [@show.opaque] option(ClosureEnvironment.t), option(Var.t), @@ -59,12 +59,12 @@ module rec DHExp: { | Tuple(list(t)) | Var(Var.t) | Let(TermBase.UPat.t, t, t) - | FixF(TermBase.UPat.t, t, [@show.opaque] option(ClosureEnvironment.t)) // TODO: add closure // INVARIANT: always has type assignment on outside // Would be nice to move this into the pattern, but we'd need to merge UTyp.t and Typ.t + | FixF(TermBase.UPat.t, t, [@show.opaque] option(ClosureEnvironment.t)) | TyAlias(TermBase.UTPat.t, TermBase.UTyp.t, t) | Ap(TermBase.UExp.ap_direction, t, t) | If(t, t, t) | Seq(t, t) - | Test(t) // Id refers to original static id of test + | Test(t) | Filter(DHFilter.t, t) // DONE [UEXP TO BE CHANGED] /* In the long term, it might be nice to have closures be the same as module opening */ @@ -76,7 +76,7 @@ module rec DHExp: { | BinOp(TermBase.UExp.op_bin, t, t) | BuiltinFun(string) | Match(t, list((TermBase.UPat.t, t))) - | Cast(t, Typ.t, Typ.t) // TODO: Add to uexp or remove + | Cast(t, Typ.t, Typ.t) and t; let rep_id: t => Id.t; @@ -108,14 +108,14 @@ module rec DHExp: { | Int(int) | Float(float) | String(string) - | ListLit(Typ.t, list(t)) + | ListLit(list(t)) | Constructor(string) | Fun( TermBase.UPat.t, t, [@show.opaque] option(ClosureEnvironment.t), option(Var.t), - ) // TODO: Use info_map for Typ.t + ) | Tuple(list(t)) | Var(Var.t) | Let(TermBase.UPat.t, t, t) @@ -132,7 +132,7 @@ module rec DHExp: { | ListConcat(t, t) | UnOp(TermBase.UExp.op_un, t) | BinOp(TermBase.UExp.op_bin, t, t) - | BuiltinFun(string) // DONE [TO ADD TO UEXP] + | BuiltinFun(string) | Match(t, list((TermBase.UPat.t, t))) | Cast(t, Typ.t, Typ.t) // TODO: Perhaps merge with failedcast? and t = { @@ -214,7 +214,7 @@ module rec DHExp: { | Test(d1) => Test(repair_ids(d1)) | UnOp(op, d1) => UnOp(op, repair_ids(d1)) | BinOp(op, d1, d2) => BinOp(op, repair_ids(d1), repair_ids(d2)) - | ListLit(t, ds) => ListLit(t, List.map(repair_ids, ds)) + | ListLit(ds) => ListLit(List.map(repair_ids, ds)) | Cons(d1, d2) => Cons(repair_ids(d1), repair_ids(d2)) | Parens(d1) => Parens(repair_ids(d1)) | ListConcat(d1, d2) => ListConcat(repair_ids(d1), repair_ids(d2)) @@ -246,7 +246,7 @@ module rec DHExp: { | Cons(d1, d2) => Cons(strip_casts(d1), strip_casts(d2)) |> rewrap | ListConcat(d1, d2) => ListConcat(strip_casts(d1), strip_casts(d2)) |> rewrap - | ListLit(t, ds) => ListLit(t, List.map(strip_casts, ds)) |> rewrap + | ListLit(ds) => ListLit(List.map(strip_casts, ds)) |> rewrap | MultiHole(ds) => MultiHole(List.map(strip_casts, ds)) |> rewrap | StaticErrorHole(_, d) => strip_casts(d) | Seq(a, b) => Seq(strip_casts(a), strip_casts(b)) |> rewrap @@ -327,9 +327,8 @@ module rec DHExp: { List.length(ds1) == List.length(ds2) && List.for_all2(fast_equal, ds1, ds2) | (BuiltinFun(f1), BuiltinFun(f2)) => f1 == f2 - | (ListLit(t1, ds1), ListLit(t2, ds2)) => - t1 == t2 - && List.length(ds1) == List.length(ds2) + | (ListLit(ds1), ListLit(ds2)) => + List.length(ds1) == List.length(ds2) && List.for_all2(fast_equal, ds1, ds2) | (UnOp(op1, d1), UnOp(op2, d2)) => op1 == op2 && fast_equal(d1, d2) | (BinOp(op1, d11, d21), BinOp(op2, d12, d22)) => diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 04fd9c753f..a41d93cbb4 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -211,10 +211,8 @@ let rec dhexp_of_uexp = | Float(n) => Some(Float(n) |> rewrap) | String(s) => Some(String(s) |> rewrap) | ListLit(es) => - let* ds = es |> List.map(dhexp_of_uexp(m)) |> OptUtil.sequence; - let+ ty = fixed_exp_typ(m, uexp); - let ty = Typ.matched_list(ctx, ty); - DHExp.ListLit(ty, ds) |> rewrap; + let+ ds = es |> List.map(dhexp_of_uexp(m)) |> OptUtil.sequence; + DHExp.ListLit(ds) |> rewrap; | Fun(p, body, _, _) => let+ d1 = dhexp_of_uexp(m, body); DHExp.Fun(p, d1, None, None) |> rewrap; diff --git a/src/haz3lcore/dynamics/EvalCtx.re b/src/haz3lcore/dynamics/EvalCtx.re index b92f373f33..2b15280635 100644 --- a/src/haz3lcore/dynamics/EvalCtx.re +++ b/src/haz3lcore/dynamics/EvalCtx.re @@ -22,7 +22,7 @@ type term = | BinOp2(TermBase.UExp.op_bin, DHExp.t, t) | Tuple(t, (list(DHExp.t), list(DHExp.t))) | Test(t) - | ListLit(Typ.t, t, (list(DHExp.t), list(DHExp.t))) + | ListLit(t, (list(DHExp.t), list(DHExp.t))) | MultiHole(t, (list(DHExp.t), list(DHExp.t))) | Cons1(t, DHExp.t) | Cons2(DHExp.t, t) @@ -110,9 +110,9 @@ let rec compose = (ctx: t, d: DHExp.t): DHExp.t => { | Tuple(ctx, (ld, rd)) => let d = compose(ctx, d); Tuple(ListUtil.rev_concat(ld, [d, ...rd])) |> wrap; - | ListLit(t, ctx, (ld, rd)) => + | ListLit(ctx, (ld, rd)) => let d = compose(ctx, d); - ListLit(t, ListUtil.rev_concat(ld, [d, ...rd])) |> wrap; + ListLit(ListUtil.rev_concat(ld, [d, ...rd])) |> wrap; | MultiHole(ctx, (ld, rd)) => let d = compose(ctx, d); MultiHole(ListUtil.rev_concat(ld, [d, ...rd])) |> wrap; diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index 579d6c0d45..fb0bf346aa 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -111,14 +111,13 @@ let rec matches_exp = matches_exp(env, d1, f1) && matches_exp(env, d2, f2) | (Cons(_), _) => false - | (ListLit(dt, dv), ListLit(ft, fv)) => - dt == ft - && List.fold_left2( - (acc, d, f) => acc && matches_exp(env, d, f), - true, - dv, - fv, - ) + | (ListLit(dv), ListLit(fv)) => + List.fold_left2( + (acc, d, f) => acc && matches_exp(env, d, f), + true, + dv, + fv, + ) | (ListLit(_), _) => false | (Tuple(dv), Tuple(fv)) => diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index e6328ed40f..9aaded3acf 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -363,12 +363,12 @@ and matches_cast_Cons = : match_result => switch (DHExp.term_of(d)) { | Parens(d) => matches_cast_Cons(dp, d, elt_casts) - | ListLit(_, []) => + | ListLit([]) => switch (DHPat.term_of(dp)) { | ListLit([]) => Matches(Environment.empty) | _ => DoesNotMatch } - | ListLit(ty, [dhd, ...dtl] as ds) => + | ListLit([dhd, ...dtl] as ds) => switch (DHPat.term_of(dp)) { | Cons(dp1, dp2) => switch (matches(dp1, DHExp.apply_casts(dhd, elt_casts))) { @@ -383,7 +383,7 @@ and matches_cast_Cons = }, elt_casts, ); - let d2 = DHExp.ListLit(ty, dtl) |> DHExp.fresh; + let d2 = DHExp.ListLit(dtl) |> DHExp.fresh; switch (matches(dp2, DHExp.apply_casts(d2, list_casts))) { | DoesNotMatch => DoesNotMatch | IndetMatch => IndetMatch diff --git a/src/haz3lcore/dynamics/Stepper.re b/src/haz3lcore/dynamics/Stepper.re index a31d6ca81f..72169cdb81 100644 --- a/src/haz3lcore/dynamics/Stepper.re +++ b/src/haz3lcore/dynamics/Stepper.re @@ -133,9 +133,9 @@ let rec matches = | Test(ctx) => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); Test(ctx) |> rewrap; - | ListLit(ty, ctx, ds) => + | ListLit(ctx, ds) => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); - ListLit(ty, ctx, ds) |> rewrap; + ListLit(ctx, ds) |> rewrap; | Cons1(ctx, d2) => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); Cons1(ctx, d2) |> rewrap; diff --git a/src/haz3lcore/dynamics/Substitution.re b/src/haz3lcore/dynamics/Substitution.re index 931feec3a2..5d252c119d 100644 --- a/src/haz3lcore/dynamics/Substitution.re +++ b/src/haz3lcore/dynamics/Substitution.re @@ -62,8 +62,7 @@ let rec subst_var = (m, d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => { | Float(_) | String(_) | Constructor(_) => d2 - | ListLit(t, ds) => - ListLit(t, List.map(subst_var(m, d1, x), ds)) |> rewrap + | ListLit(ds) => ListLit(List.map(subst_var(m, d1, x), ds)) |> rewrap | Cons(d3, d4) => let d3 = subst_var(m, d1, x, d3); let d4 = subst_var(m, d1, x, d4); diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index 1b629f9c17..0d8b5c4cf4 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -641,7 +641,7 @@ module Transition = (EV: EV_MODE) => { Step({ apply: () => switch (term_of(d2')) { - | ListLit(ty, ds) => ListLit(ty, [d1', ...ds]) |> fresh + | ListLit(ds) => ListLit([d1', ...ds]) |> fresh | _ => raise(EvaluatorError.Exception(InvalidBoxedListLit(d2'))) }, kind: ListCons, @@ -665,8 +665,7 @@ module Transition = (EV: EV_MODE) => { Step({ apply: () => switch (term_of(d1'), term_of(d2')) { - | (ListLit(t1, ds1), ListLit(_, ds2)) => - ListLit(t1, ds1 @ ds2) |> fresh + | (ListLit(ds1), ListLit(ds2)) => ListLit(ds1 @ ds2) |> fresh | (ListLit(_), _) => raise(EvaluatorError.Exception(InvalidBoxedListLit(d2'))) | (_, _) => @@ -675,12 +674,12 @@ module Transition = (EV: EV_MODE) => { kind: ListConcat, value: true, }); - | ListLit(t, ds) => - let. _ = otherwise(env, ds => ListLit(t, ds) |> rewrap) + | ListLit(ds) => + let. _ = otherwise(env, ds => ListLit(ds) |> rewrap) and. _ = req_all_final( req(state, env), - (d1, ds) => ListLit(t, d1, ds) |> wrap_ctx, + (d1, ds) => ListLit(d1, ds) |> wrap_ctx, ds, ); Constructor; diff --git a/src/haz3lcore/dynamics/TypeAssignment.re b/src/haz3lcore/dynamics/TypeAssignment.re new file mode 100644 index 0000000000..9a9dab05ab --- /dev/null +++ b/src/haz3lcore/dynamics/TypeAssignment.re @@ -0,0 +1,280 @@ +// open Util; +// open OptUtil.Syntax; +// /* +// This module is currently unused, but we still theoretically want to be able to do it, particularly for +// when we have property-based testing around elaboration. +// */ +// let equal_typ_case = (l: list(Typ.t)): option(Typ.t) => { +// switch (l) { +// | [] => None +// | _ => +// let ty = List.hd(l); +// List.fold_left((acc, t) => {acc && Typ.eq(t, ty)}, true, l) +// ? Some(ty) : None; +// }; +// }; +// let arrow_aux = (ty: Typ.t): Typ.t => { +// switch (ty) { +// | Unknown(Internal) => Arrow(Unknown(Internal), Unknown(Internal)) +// | _ => ty +// }; +// }; +// let delta_ty = (id: MetaVar.t, m: Statics.Map.t): option(Typ.t) => { +// switch (Id.Map.find_opt(id, m)) { +// | Some(InfoExp({mode, ctx, _})) => +// switch (mode) { +// | Syn +// | SynFun => Some(Unknown(Internal)) +// | Ana(ana_ty) => Some(Typ.normalize(ctx, ana_ty)) +// } +// | _ => None +// }; +// }; +// let ground = (ty: Typ.t): bool => { +// switch (ty) { +// | Bool +// | Int +// | Float +// | String +// | Prod([]) +// | Arrow(Unknown(Internal), Unknown(Internal)) => true +// | _ => false +// }; +// }; +// let rec dhpat_extend_ctx = +// (dhpat: TermBase.UPat.t, ty: Typ.t, ctx: Ctx.t): Ctx.t => { +// switch (dhpat.term, ty) { +// | (Var(name), _) => +// let entry = Ctx.VarEntry({name, id: Id.invalid, typ: ty}); +// Ctx.extend(ctx, entry); +// | (Tuple(l1), Prod(l2)) => +// if (List.length(l1) == List.length(l2)) { +// List.fold_left2( +// (acc, dhp, typ) => {dhpat_extend_ctx(dhp, typ, acc)}, +// ctx, +// l1, +// l2, +// ); +// } else { +// ctx; +// } +// | (Cons(dhp1, dhp2), List(typ)) => +// ctx |> dhpat_extend_ctx(dhp1, typ) |> dhpat_extend_ctx(dhp2, ty) +// | (ListLit(l), List(typ2)) => +// let typ1 = Typ.matched_list(fixed_pat_typ(m, upat)) +// if (Typ.eq(typ1, typ2)) { +// List.fold_left( +// (acc, dhp) => {dhpat_extend_ctx(dhp, typ1, acc)}, +// ctx, +// l, +// ); +// } else { +// ctx; +// }; +// (); +// | (Ap(Constructor(_, typ), dhp), _) => +// let (ty1, ty2) = Typ.matched_arrow(ctx, typ); +// if (Typ.eq(ty2, ty)) { +// ctx |> dhpat_extend_ctx(dhp, ty1); +// } else { +// ctx; +// }; +// | _ => ctx +// }; +// }; +// let rec typ_of_dhexp = +// (ctx: Ctx.t, m: Statics.Map.t, dh: DHExp.t): option(Typ.t) => { +// switch (dh) { +// | EmptyHole(id, _) => delta_ty(id, m) +// | NonEmptyHole(_, id, _, d) => +// switch (typ_of_dhexp(ctx, m, d)) { +// | None => None +// | Some(_) => delta_ty(id, m) +// } +// | ExpandingKeyword(_) => None +// | FreeVar(_) => Some(Unknown(Internal)) +// | InvalidText(_) => None +// | InconsistentBranches(_, _, Case(d_scrut, d_rules, _)) => +// let* ty' = typ_of_dhexp(ctx, m, d_scrut); +// let typ_cases = +// d_rules +// |> List.map(rule_prj) +// |> List.map(((dhp, de)) => { +// typ_of_dhexp(dhpat_extend_ctx(dhp, ty', ctx), m, de) +// }) +// |> OptUtil.sequence; +// switch (typ_cases) { +// | None => None +// | Some(_) => Some(Typ.Unknown(Internal)) +// }; +// | Closure(_, d) => typ_of_dhexp(ctx, m, d) +// | Filter(_, d) => typ_of_dhexp(ctx, m, d) +// | BoundVar(name) => +// let+ var = Ctx.lookup_var(ctx, name); +// var.typ; +// | Sequence(d1, d2) => +// let* _ = typ_of_dhexp(ctx, m, d1); +// typ_of_dhexp(ctx, m, d2); +// | Let(dhp, de, db) => +// let* ty1 = typ_of_dhexp(ctx, m, de); +// typ_of_dhexp(dhpat_extend_ctx(dhp, ty1, ctx), m, db); +// | FixF(name, ty1, d) => +// let entry = Ctx.VarEntry({name, id: Id.invalid, typ: ty1}); +// typ_of_dhexp(Ctx.extend(ctx, entry), m, d); +// | Fun(dhp, ty1, d, _) => +// let+ ty2 = typ_of_dhexp(dhpat_extend_ctx(dhp, ty1, ctx), m, d); +// Typ.Arrow(ty1, ty2); +// | Ap(d1, d2) => +// let* ty1 = typ_of_dhexp(ctx, m, d1); +// let* ty2 = typ_of_dhexp(ctx, m, d2); +// switch (arrow_aux(ty1)) { +// | Arrow(tyl, tyr) when Typ.eq(tyl, ty2) => Some(tyr) +// | _ => None +// }; +// | ApBuiltin(_) +// | BuiltinFun(_) => None +// | Test(_, dtest) => +// let* ty = typ_of_dhexp(ctx, m, dtest); +// Typ.eq(ty, Bool) ? Some(Typ.Prod([])) : None; +// | BoolLit(_) => Some(Bool) +// | IntLit(_) => Some(Int) +// | FloatLit(_) => Some(Float) +// | StringLit(_) => Some(String) +// | BinBoolOp(_, d1, d2) => +// let* ty1 = typ_of_dhexp(ctx, m, d1); +// let* ty2 = typ_of_dhexp(ctx, m, d2); +// Typ.eq(ty1, Bool) && Typ.eq(ty2, Bool) ? Some(Typ.Bool) : None; +// | BinIntOp(op, d1, d2) => +// let* ty1 = typ_of_dhexp(ctx, m, d1); +// let* ty2 = typ_of_dhexp(ctx, m, d2); +// if (Typ.eq(ty1, Int) && Typ.eq(ty2, Int)) { +// switch (op) { +// | Minus +// | Plus +// | Times +// | Power +// | Divide => Some(Typ.Int) +// | LessThan +// | LessThanOrEqual +// | GreaterThan +// | GreaterThanOrEqual +// | Equals +// | NotEquals => Some(Typ.Bool) +// }; +// } else { +// None; +// }; +// | BinFloatOp(op, d1, d2) => +// let* ty1 = typ_of_dhexp(ctx, m, d1); +// let* ty2 = typ_of_dhexp(ctx, m, d2); +// if (Typ.eq(ty1, Float) && Typ.eq(ty2, Float)) { +// switch (op) { +// | Minus +// | Plus +// | Times +// | Power +// | Divide => Some(Typ.Float) +// | LessThan +// | LessThanOrEqual +// | GreaterThan +// | GreaterThanOrEqual +// | Equals +// | NotEquals => Some(Typ.Bool) +// }; +// } else { +// None; +// }; +// | BinStringOp(op, d1, d2) => +// let* ty1 = typ_of_dhexp(ctx, m, d1); +// let* ty2 = typ_of_dhexp(ctx, m, d2); +// if (Typ.eq(ty1, String) && Typ.eq(ty2, String)) { +// switch (op) { +// | Concat => Some(Typ.String) +// | Equals => Some(Typ.Bool) +// }; +// } else { +// None; +// }; +// | ListLit(_, _, ty, _) => Some(List(ty)) +// | Cons(d1, d2) => +// let* ty1 = typ_of_dhexp(ctx, m, d1); +// let* ty2 = typ_of_dhexp(ctx, m, d2); +// switch (ty2) { +// | List(Unknown(Internal)) => Some(Typ.List(ty1)) +// | List(ty3) when Typ.eq(ty3, ty1) => Some(ty2) +// | _ => None +// }; +// | ListConcat(d1, d2) => +// let* ty1 = typ_of_dhexp(ctx, m, d1); +// let* ty2 = typ_of_dhexp(ctx, m, d2); +// switch (ty1, ty2) { +// | (List(Unknown(Internal)), _) +// | (_, List(Unknown(Internal))) => Some(Typ.List(Unknown(Internal))) +// | (List(ty1), List(ty2)) when Typ.eq(ty1, ty2) => Some(Typ.List(ty1)) +// | _ => None +// }; +// | Tuple(dhs) => +// let+ typ_list = +// dhs |> List.map(typ_of_dhexp(ctx, m)) |> OptUtil.sequence; +// Typ.Prod(typ_list); +// | Prj(dh, i) => +// let* ty = typ_of_dhexp(ctx, m, dh); +// switch (ty) { +// | Prod(l) when List.length(l) != 0 => Some(List.nth(l, i)) +// | _ => None +// }; +// | Constructor(_, typ) => Some(typ) +// | ConsistentCase(Case(d_scrut, d_rules, _)) => +// let* ty' = typ_of_dhexp(ctx, m, d_scrut); +// let* typ_cases: list(Typ.t) = +// d_rules +// |> List.map(rule_prj) +// |> List.map(((dhp, de)) => { +// typ_of_dhexp(dhpat_extend_ctx(dhp, ty', ctx), m, de) +// }) +// |> OptUtil.sequence; +// Typ.join_all(~empty=Unknown(Internal), ctx, typ_cases); +// | Cast(d, ty1, ty2) => +// let* _ = Typ.join(~fix=true, ctx, ty1, ty2); +// let* tyd = typ_of_dhexp(ctx, m, d); +// Typ.eq(tyd, ty1) ? Some(ty2) : None; +// | FailedCast(d, ty1, ty2) => +// if (ground(ty1) && ground(ty2) && !Typ.eq(ty1, ty2)) { +// let* tyd = typ_of_dhexp(ctx, m, d); +// Typ.eq(tyd, ty1) ? Some(ty2) : None; +// } else { +// None; +// } +// | InvalidOperation(_) => None +// | IfThenElse(ConsistentIf, d_scrut, d1, d2) => +// let* ty = typ_of_dhexp(ctx, m, d_scrut); +// if (Typ.eq(ty, Bool)) { +// let* ty1 = typ_of_dhexp(ctx, m, d1); +// let* ty2 = typ_of_dhexp(ctx, m, d2); +// Typ.join_all(~empty=Unknown(Internal), ctx, [ty1, ty2]); +// } else { +// None; +// }; +// | IfThenElse(InconsistentIf, d_scrut, d1, d2) => +// let* ty = typ_of_dhexp(ctx, m, d_scrut); +// if (Typ.eq(ty, Bool)) { +// let* _ = typ_of_dhexp(ctx, m, d1); +// let+ _ = typ_of_dhexp(ctx, m, d2); +// Typ.Unknown(Internal); +// } else { +// None; +// }; +// }; +// }; +// let property_test = (uexp_typ: Typ.t, dhexp: DHExp.t, m: Statics.Map.t): bool => { +// let dhexp_typ = typ_of_dhexp(Builtins.ctx_init, m, dhexp); +// print_endline(Typ.show(uexp_typ)); +// switch (dhexp_typ) { +// | None => +// print_endline("Got none"); +// false; +// | Some(dh_typ) => +// print_endline(Typ.show(dh_typ)); +// Typ.eq(dh_typ, uexp_typ); +// }; +// }; diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index aa002ad6ea..0739c948c9 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -316,7 +316,7 @@ let mk = | Seq(d1, d2) => let (doc1, doc2) = (go'(d1), go'(d2)); DHDoc_common.mk_Sequence(doc1, doc2); - | ListLit(_, d_list) => + | ListLit(d_list) => let ol = d_list |> List.map(d => go'(d)); DHDoc_common.mk_ListLit(ol); | Ap(Forward, d1, d2) => From 2e6f73ea2a6072b07685b0f89058163aa7dd81a5 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Fri, 1 Mar 2024 11:37:06 -0500 Subject: [PATCH 041/103] (messily) finally merge DHExp and UExp --- src/haz3lcore/dynamics/ClosureEnvironment.re | 2 +- src/haz3lcore/dynamics/ClosureEnvironment.rei | 4 +- src/haz3lcore/dynamics/DH.re | 324 ++---------------- src/haz3lcore/dynamics/Elaborator.re | 35 +- src/haz3lcore/dynamics/Environment.re | 2 +- src/haz3lcore/dynamics/Environment.rei | 3 +- src/haz3lcore/dynamics/EvalCtx.re | 7 +- src/haz3lcore/dynamics/Filter.re | 1 - src/haz3lcore/dynamics/FilterEnvironment.re | 3 +- src/haz3lcore/dynamics/FilterMatcher.re | 9 +- src/haz3lcore/dynamics/Substitution.re | 8 +- src/haz3lcore/dynamics/Transition.re | 16 +- src/haz3lcore/statics/MakeTerm.re | 8 +- src/haz3lcore/statics/Statics.re | 5 +- src/haz3lcore/statics/TermBase.re | 36 +- src/haz3lcore/zipper/EditorUtil.re | 8 +- src/haz3lschool/Exercise.re | 10 +- src/haz3lschool/SyntaxTest.re | 8 +- src/haz3lweb/view/ExplainThis.re | 9 +- src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 7 +- 20 files changed, 140 insertions(+), 365 deletions(-) delete mode 100644 src/haz3lcore/dynamics/Filter.re diff --git a/src/haz3lcore/dynamics/ClosureEnvironment.re b/src/haz3lcore/dynamics/ClosureEnvironment.re index 95342373fa..52b9ab4d51 100644 --- a/src/haz3lcore/dynamics/ClosureEnvironment.re +++ b/src/haz3lcore/dynamics/ClosureEnvironment.re @@ -1 +1 @@ -include DH.ClosureEnvironment; +include TermBase.ClosureEnvironment; diff --git a/src/haz3lcore/dynamics/ClosureEnvironment.rei b/src/haz3lcore/dynamics/ClosureEnvironment.rei index ccb9ea0284..d2cffb2310 100644 --- a/src/haz3lcore/dynamics/ClosureEnvironment.rei +++ b/src/haz3lcore/dynamics/ClosureEnvironment.rei @@ -1,3 +1,3 @@ include - (module type of DH.ClosureEnvironment) with - type t = DH.ClosureEnvironment.t; + (module type of TermBase.ClosureEnvironment) with + type t = TermBase.ClosureEnvironment.t; diff --git a/src/haz3lcore/dynamics/DH.re b/src/haz3lcore/dynamics/DH.re index d4f3d02830..91f0f9c714 100644 --- a/src/haz3lcore/dynamics/DH.re +++ b/src/haz3lcore/dynamics/DH.re @@ -1,5 +1,3 @@ -open Sexplib.Std; - /* To discuss: @@ -35,49 +33,8 @@ open Sexplib.Std; */ -module rec DHExp: { - [@deriving (show({with_path: false}), sexp, yojson)] - type term = - | Invalid(string) - | EmptyHole - | MultiHole(list(DHExp.t)) - | StaticErrorHole(Id.t, t) - | DynamicErrorHole(t, InvalidOperationError.t) - | FailedCast(t, Typ.t, Typ.t) - | Bool(bool) - | Int(int) - | Float(float) - | String(string) - | ListLit(list(t)) - | Constructor(string) - | Fun( - TermBase.UPat.t, - t, - [@show.opaque] option(ClosureEnvironment.t), - option(Var.t), - ) // TODO: Use info_map for Typ.t - | Tuple(list(t)) - | Var(Var.t) - | Let(TermBase.UPat.t, t, t) - | FixF(TermBase.UPat.t, t, [@show.opaque] option(ClosureEnvironment.t)) - | TyAlias(TermBase.UTPat.t, TermBase.UTyp.t, t) - | Ap(TermBase.UExp.ap_direction, t, t) - | If(t, t, t) - | Seq(t, t) - | Test(t) - | Filter(DHFilter.t, t) // DONE [UEXP TO BE CHANGED] - /* In the long term, it might be nice to have closures be the same as - module opening */ - | Closure([@show.opaque] ClosureEnvironment.t, t) // > UEXP - | Parens(t) - | Cons(t, t) - | ListConcat(t, t) - | UnOp(TermBase.UExp.op_un, t) - | BinOp(TermBase.UExp.op_bin, t, t) - | BuiltinFun(string) - | Match(t, list((TermBase.UPat.t, t))) - | Cast(t, Typ.t, Typ.t) - and t; +module DHExp: { + include (module type of TermBase.UExp); let rep_id: t => Id.t; let term_of: t => term; @@ -95,55 +52,11 @@ module rec DHExp: { let repair_ids: t => t; let fast_equal: (t, t) => bool; + let filter_fast_equal: + (TermBase.StepperFilterKind.t, TermBase.StepperFilterKind.t) => bool; } = { [@deriving (show({with_path: false}), sexp, yojson)] - type term = - | Invalid(string) - | EmptyHole - | MultiHole(list(DHExp.t)) - | StaticErrorHole(Id.t, t) - | DynamicErrorHole(t, InvalidOperationError.t) - | FailedCast(t, Typ.t, Typ.t) - | Bool(bool) - | Int(int) - | Float(float) - | String(string) - | ListLit(list(t)) - | Constructor(string) - | Fun( - TermBase.UPat.t, - t, - [@show.opaque] option(ClosureEnvironment.t), - option(Var.t), - ) - | Tuple(list(t)) - | Var(Var.t) - | Let(TermBase.UPat.t, t, t) - | FixF(TermBase.UPat.t, t, [@show.opaque] option(ClosureEnvironment.t)) - | TyAlias(TermBase.UTPat.t, TermBase.UTyp.t, t) - | Ap(TermBase.UExp.ap_direction, t, t) - | If(t, t, t) - | Seq(t, t) - | Test(t) - | Filter(DHFilter.t, t) // DONE [UEXP TO BE CHANGED] - | Closure([@show.opaque] ClosureEnvironment.t, t) - | Parens(t) - | Cons(t, t) - | ListConcat(t, t) - | UnOp(TermBase.UExp.op_un, t) - | BinOp(TermBase.UExp.op_bin, t, t) - | BuiltinFun(string) - | Match(t, list((TermBase.UPat.t, t))) - | Cast(t, Typ.t, Typ.t) // TODO: Perhaps merge with failedcast? - and t = { - /* invariant: nonempty, TODO: what happens to later ids in DHExp */ - ids: list(Id.t), - /*TODO: Verify: Always false in UExp, if an expression has been copied as part of - evaluation (e.g. fun x -> x + x), then this will be flagged as true. This means - the ids should be replaced after evaluation. */ - copied: bool, - term, - }; + include TermBase.UExp; let rep_id = ({ids, _}) => List.hd(ids); let term_of = ({term, _}) => term; @@ -219,7 +132,8 @@ module rec DHExp: { | Parens(d1) => Parens(repair_ids(d1)) | ListConcat(d1, d2) => ListConcat(repair_ids(d1), repair_ids(d2)) | Tuple(ds) => Tuple(List.map(repair_ids, ds)) - | MultiHole(ds) => MultiHole(List.map(repair_ids, ds)) + // TODO: repair ids inside multihole + | MultiHole(ds) => MultiHole(ds) | Match(d1, rls) => Match( repair_ids(d1), @@ -247,11 +161,12 @@ module rec DHExp: { | ListConcat(d1, d2) => ListConcat(strip_casts(d1), strip_casts(d2)) |> rewrap | ListLit(ds) => ListLit(List.map(strip_casts, ds)) |> rewrap - | MultiHole(ds) => MultiHole(List.map(strip_casts, ds)) |> rewrap + // TODO[Matt]: Strip multihole casts + | MultiHole(ds) => MultiHole(ds) |> rewrap | StaticErrorHole(_, d) => strip_casts(d) | Seq(a, b) => Seq(strip_casts(a), strip_casts(b)) |> rewrap | Filter(f, b) => - Filter(DHFilter.strip_casts(f), strip_casts(b)) |> rewrap + Filter(strip_filter_casts(f), strip_casts(b)) |> rewrap | Let(dp, b, c) => Let(dp, strip_casts(b), strip_casts(c)) |> rewrap | FixF(a, c, env) => FixF(a, strip_casts(c), env) |> rewrap | TyAlias(tp, t, d) => TyAlias(tp, t, strip_casts(d)) |> rewrap @@ -280,6 +195,12 @@ module rec DHExp: { | If(c, d1, d2) => If(strip_casts(c), strip_casts(d1), strip_casts(d2)) |> rewrap }; + } + and strip_filter_casts = f => { + switch (f) { + | Filter({act, pat}) => Filter({act, pat: pat |> strip_casts}) + | Residue(idx, act) => Residue(idx, act) + }; }; let rec fast_equal = @@ -303,7 +224,7 @@ module rec DHExp: { | (Seq(d11, d21), Seq(d12, d22)) => fast_equal(d11, d12) && fast_equal(d21, d22) | (Filter(f1, d1), Filter(f2, d2)) => - DHFilter.fast_equal(f1, f2) && fast_equal(d1, d2) + filter_fast_equal(f1, f2) && fast_equal(d1, d2) | (Let(dp1, d11, d21), Let(dp2, d12, d22)) => dp1 == dp2 && fast_equal(d11, d12) && fast_equal(d21, d22) | (FixF(f1, d1, sigma1), FixF(f2, d2, sigma2)) => @@ -378,9 +299,7 @@ module rec DHExp: { (This resolves a performance issue with many nested holes.) */ | (EmptyHole, EmptyHole) => true - | (MultiHole(ds1), MultiHole(ds2)) => - List.length(ds1) == List.length(ds2) - && List.for_all2(fast_equal, ds1, ds2) + | (MultiHole(_), MultiHole(_)) => rep_id(d1exp) == rep_id(d2exp) | (StaticErrorHole(sid1, d1), StaticErrorHole(sid2, d2)) => sid1 == sid2 && d1 == d2 | (Invalid(text1), Invalid(text2)) => text1 == text2 @@ -392,213 +311,14 @@ module rec DHExp: { | (Invalid(_), _) | (Closure(_), _) => false }; - }; -} - -and Environment: { - include - (module type of VarBstMap.Ordered) with - type t_('a) = VarBstMap.Ordered.t_('a); - - [@deriving (show({with_path: false}), sexp, yojson)] - type t = t_(DHExp.t); -} = { - include VarBstMap.Ordered; - - [@deriving (show({with_path: false}), sexp, yojson)] - type t = t_(DHExp.t); -} - -and ClosureEnvironment: { - [@deriving (show({with_path: false}), sexp, yojson)] - type t; - - let wrap: (EnvironmentId.t, Environment.t) => t; - - let id_of: t => EnvironmentId.t; - let map_of: t => Environment.t; - - let to_list: t => list((Var.t, DHExp.t)); - - let of_environment: Environment.t => t; - - let id_equal: (t, t) => bool; - - let empty: t; - let is_empty: t => bool; - let length: t => int; - - let lookup: (t, Var.t) => option(DHExp.t); - let contains: (t, Var.t) => bool; - let update: (Environment.t => Environment.t, t) => t; - let update_keep_id: (Environment.t => Environment.t, t) => t; - let extend: (t, (Var.t, DHExp.t)) => t; - let extend_keep_id: (t, (Var.t, DHExp.t)) => t; - let union: (t, t) => t; - let union_keep_id: (t, t) => t; - let map: (((Var.t, DHExp.t)) => DHExp.t, t) => t; - let map_keep_id: (((Var.t, DHExp.t)) => DHExp.t, t) => t; - let filter: (((Var.t, DHExp.t)) => bool, t) => t; - let filter_keep_id: (((Var.t, DHExp.t)) => bool, t) => t; - let fold: (((Var.t, DHExp.t), 'b) => 'b, 'b, t) => 'b; - - let without_keys: (list(Var.t), t) => t; - - let placeholder: t; -} = { - module Inner: { - [@deriving (show({with_path: false}), sexp, yojson)] - type t; - - let wrap: (EnvironmentId.t, Environment.t) => t; - - let id_of: t => EnvironmentId.t; - let map_of: t => Environment.t; - } = { - [@deriving (show({with_path: false}), sexp, yojson)] - type t = (EnvironmentId.t, Environment.t); - - let wrap = (ei, map): t => (ei, map); - - let id_of = ((ei, _)) => ei; - let map_of = ((_, map)) => map; - let (sexp_of_t, t_of_sexp) = - StructureShareSexp.structure_share_here(id_of, sexp_of_t, t_of_sexp); - }; - include Inner; - - let to_list = env => env |> map_of |> Environment.to_listo; - - let of_environment = map => { - let ei = Id.mk(); - wrap(ei, map); - }; - - /* Equals only needs to check environment id's (faster than structural equality - * checking.) */ - let id_equal = (env1, env2) => id_of(env1) == id_of(env2); - - let empty = Environment.empty |> of_environment; - - let is_empty = env => env |> map_of |> Environment.is_empty; - - let length = env => Environment.length(map_of(env)); - - let lookup = (env, x) => - env |> map_of |> (map => Environment.lookup(map, x)); - - let contains = (env, x) => - env |> map_of |> (map => Environment.contains(map, x)); - - let update = (f, env) => env |> map_of |> f |> of_environment; - - let update_keep_id = (f, env) => env |> map_of |> f |> wrap(env |> id_of); - - let extend = (env, xr) => - env |> update(map => Environment.extend(map, xr)); - - let extend_keep_id = (env, xr) => - env |> update_keep_id(map => Environment.extend(map, xr)); - - let union = (env1, env2) => - env2 |> update(map2 => Environment.union(env1 |> map_of, map2)); - - let union_keep_id = (env1, env2) => - env2 |> update_keep_id(map2 => Environment.union(env1 |> map_of, map2)); - - let map = (f, env) => env |> update(Environment.mapo(f)); - - let map_keep_id = (f, env) => env |> update_keep_id(Environment.mapo(f)); - - let filter = (f, env) => env |> update(Environment.filtero(f)); - - let filter_keep_id = (f, env) => - env |> update_keep_id(Environment.filtero(f)); - - let fold = (f, init, env) => env |> map_of |> Environment.foldo(f, init); - - let placeholder = wrap(EnvironmentId.invalid, Environment.empty); - - let without_keys = keys => update(Environment.without_keys(keys)); -} - -and Filter: { - [@deriving (show({with_path: false}), sexp, yojson)] - type t = { - pat: DHExp.t, - act: FilterAction.t, - }; - - let mk: (DHExp.t, FilterAction.t) => t; - - let map: (DHExp.t => DHExp.t, t) => t; - - let strip_casts: t => t; - - let fast_equal: (t, t) => bool; -} = { - [@deriving (show({with_path: false}), sexp, yojson)] - type t = { - pat: DHExp.t, - act: FilterAction.t, - }; - - let mk = (pat: DHExp.t, act: FilterAction.t): t => {pat, act}; - - let map = (f: DHExp.t => DHExp.t, filter: t): t => { - ...filter, - pat: f(filter.pat), - }; - - let fast_equal = (f1: t, f2: t): bool => { - DHExp.fast_equal(f1.pat, f2.pat) && f1.act == f2.act; - }; - let strip_casts = (f: t): t => {...f, pat: f.pat |> DHExp.strip_casts}; -} - -and DHFilter: { - [@deriving (show({with_path: false}), sexp, yojson)] - type t = - | Filter(Filter.t) - | Residue(int, FilterAction.t); - let fast_equal: (t, t) => bool; - let strip_casts: t => t; - let map: (DHExp.t => DHExp.t, t) => t; -} = { - [@deriving (show({with_path: false}), sexp, yojson)] - type t = - | Filter(Filter.t) - | Residue(int, FilterAction.t); - let fast_equal = (f1: t, f2: t) => { + } + and filter_fast_equal = (f1, f2) => { switch (f1, f2) { - | (Filter(flt1), Filter(flt2)) => Filter.fast_equal(flt1, flt2) + | (Filter(f1), Filter(f2)) => + fast_equal(f1.pat, f2.pat) && f1.act == f2.act | (Residue(idx1, act1), Residue(idx2, act2)) => idx1 == idx2 && act1 == act2 | _ => false }; }; - let strip_casts = f => { - switch (f) { - | Filter(flt) => Filter(Filter.strip_casts(flt)) - | Residue(idx, act) => Residue(idx, act) - }; - }; - let map = (mapper, filter) => { - switch (filter) { - | Filter(flt) => Filter(Filter.map(mapper, flt)) - | Residue(idx, act) => Residue(idx, act) - }; - }; -} - -and FilterEnvironment: { - [@deriving (show({with_path: false}), sexp, yojson)] - type t = list(Filter.t); - - let extends: (Filter.t, t) => t; -} = { - [@deriving (show({with_path: false}), sexp, yojson)] - type t = list(Filter.t); - - let extends = (flt, env) => [flt, ...env]; }; diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index a41d93cbb4..5f41afd650 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -182,20 +182,20 @@ let rec dhexp_of_uexp = Cast(d1', t1, t2) |> rewrap; | Invalid(t) => Some(DHExp.Invalid(t) |> rewrap) | EmptyHole => Some(DHExp.EmptyHole |> rewrap) - | MultiHole(us: list(TermBase.Any.t)) => - switch ( - us - |> List.filter_map( - fun - | TermBase.Any.Exp(x) => Some(x) - | _ => None, - ) - ) { - | [] => Some(DHExp.EmptyHole |> rewrap) - | us => - let+ ds = us |> List.map(dhexp_of_uexp(m)) |> OptUtil.sequence; - DHExp.MultiHole(ds) |> rewrap; - } + | MultiHole(_: list(TermBase.Any.t)) => Some(EmptyHole |> rewrap) + // switch ( + // us + // |> List.filter_map( + // fun + // | TermBase.Any.Exp(x) => Some(x) + // | _ => None, + // ) + // ) { + // | [] => Some(DHExp.EmptyHole |> rewrap) + // | us => + // let+ ds = us |> List.map(dhexp_of_uexp(m)) |> OptUtil.sequence; + // DHExp.MultiHole(ds) |> rewrap; + // } | StaticErrorHole(_, e) => dhexp_of_uexp(m, e) | DynamicErrorHole(e, err) => let+ d1 = dhexp_of_uexp(m, e); @@ -252,10 +252,13 @@ let rec dhexp_of_uexp = | Test(test) => let+ dtest = dhexp_of_uexp(m, test); DHExp.Test(dtest) |> rewrap; - | Filter(act, cond, body) => + | Filter(Filter({act, pat: cond}), body) => let* dcond = dhexp_of_uexp(~in_filter=true, m, cond); let+ dbody = dhexp_of_uexp(m, body); - DHExp.Filter(Filter(Filter.mk(dcond, act)), dbody) |> rewrap; + DHExp.Filter(Filter({act, pat: dcond}), dbody) |> rewrap; + | Filter(Residue(_) as residue, body) => + let+ dbody = dhexp_of_uexp(m, body); + DHExp.Filter(residue, dbody) |> rewrap; | Var(name) => Some(Var(name) |> rewrap) | Constructor(name) => Some(Constructor(name) |> rewrap) | Let(p, def, body) => diff --git a/src/haz3lcore/dynamics/Environment.re b/src/haz3lcore/dynamics/Environment.re index 9a2c61a96b..726200d7d8 100644 --- a/src/haz3lcore/dynamics/Environment.re +++ b/src/haz3lcore/dynamics/Environment.re @@ -1 +1 @@ -include DH.Environment; +include TermBase.Environment; diff --git a/src/haz3lcore/dynamics/Environment.rei b/src/haz3lcore/dynamics/Environment.rei index 3408ac0aa5..bb9d5214af 100644 --- a/src/haz3lcore/dynamics/Environment.rei +++ b/src/haz3lcore/dynamics/Environment.rei @@ -1 +1,2 @@ -include (module type of DH.Environment) with type t = DH.Environment.t; +include + (module type of TermBase.Environment) with type t = TermBase.Environment.t; diff --git a/src/haz3lcore/dynamics/EvalCtx.re b/src/haz3lcore/dynamics/EvalCtx.re index 2b15280635..1a96d77e12 100644 --- a/src/haz3lcore/dynamics/EvalCtx.re +++ b/src/haz3lcore/dynamics/EvalCtx.re @@ -5,7 +5,7 @@ open DH; [@deriving (show({with_path: false}), sexp, yojson)] type term = | Closure([@show.opaque] ClosureEnvironment.t, t) - | Filter(DH.DHFilter.t, t) + | Filter(TermBase.StepperFilterKind.t, t) | Seq1(t, DHExp.t) | Seq2(DHExp.t, t) | Let1(TermBase.UPat.t, t, DHExp.t) @@ -23,7 +23,7 @@ type term = | Tuple(t, (list(DHExp.t), list(DHExp.t))) | Test(t) | ListLit(t, (list(DHExp.t), list(DHExp.t))) - | MultiHole(t, (list(DHExp.t), list(DHExp.t))) + | MultiHole(t, (list(TermBase.Any.t), list(TermBase.Any.t))) | Cons1(t, DHExp.t) | Cons2(DHExp.t, t) | ListConcat1(t, DHExp.t) @@ -115,7 +115,8 @@ let rec compose = (ctx: t, d: DHExp.t): DHExp.t => { ListLit(ListUtil.rev_concat(ld, [d, ...rd])) |> wrap; | MultiHole(ctx, (ld, rd)) => let d = compose(ctx, d); - MultiHole(ListUtil.rev_concat(ld, [d, ...rd])) |> wrap; + MultiHole(ListUtil.rev_concat(ld, [TermBase.Any.Exp(d), ...rd])) + |> wrap; | Let1(dp, ctx, d2) => let d = compose(ctx, d); Let(dp, d, d2) |> wrap; diff --git a/src/haz3lcore/dynamics/Filter.re b/src/haz3lcore/dynamics/Filter.re deleted file mode 100644 index d6de2b524a..0000000000 --- a/src/haz3lcore/dynamics/Filter.re +++ /dev/null @@ -1 +0,0 @@ -include DH.Filter; diff --git a/src/haz3lcore/dynamics/FilterEnvironment.re b/src/haz3lcore/dynamics/FilterEnvironment.re index ce2f324f4c..284e7353d3 100644 --- a/src/haz3lcore/dynamics/FilterEnvironment.re +++ b/src/haz3lcore/dynamics/FilterEnvironment.re @@ -1 +1,2 @@ -include DH.FilterEnvironment; +type t = list(TermBase.StepperFilterKind.filter); +let extends = (flt, env) => [flt, ...env]; diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index fb0bf346aa..83f15597bb 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -48,7 +48,7 @@ let rec matches_exp = | (EmptyHole, _) => false | (Filter(df, dd), Filter(ff, fd)) => - DH.DHFilter.fast_equal(df, ff) && matches_exp(env, dd, fd) + DHExp.filter_fast_equal(df, ff) && matches_exp(env, dd, fd) | (Filter(_), _) => false | (Bool(dv), Bool(fv)) => dv == fv @@ -225,7 +225,12 @@ and matches_rul = (info_map, env, (dp, d), (fp, f)) => { }; let matches = - (info_map, ~env: ClosureEnvironment.t, ~exp: DHExp.t, ~flt: Filter.t) + ( + info_map, + ~env: ClosureEnvironment.t, + ~exp: DHExp.t, + ~flt: TermBase.StepperFilterKind.filter, + ) : option(FilterAction.t) => if (matches_exp(info_map, env, exp, flt.pat)) { Some(flt.act); diff --git a/src/haz3lcore/dynamics/Substitution.re b/src/haz3lcore/dynamics/Substitution.re index 5d252c119d..e829c22c3c 100644 --- a/src/haz3lcore/dynamics/Substitution.re +++ b/src/haz3lcore/dynamics/Substitution.re @@ -93,7 +93,8 @@ let rec subst_var = (m, d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => { ); Match(ds, rules) |> rewrap; | EmptyHole => EmptyHole |> rewrap - | MultiHole(ds) => MultiHole(List.map(subst_var(m, d1, x), ds)) |> rewrap + // TODO: handle multihole + | MultiHole(_d2) => d2 //MultiHole(List.map(subst_var(m, d1, x), ds)) |> rewrap | StaticErrorHole(u, d3) => let d3' = subst_var(m, d1, x, d3); StaticErrorHole(u, d3') |> rewrap; @@ -153,8 +154,9 @@ and subst_var_env = } and subst_var_filter = - (m, d1: DHExp.t, x: Var.t, flt: DH.DHFilter.t): DH.DHFilter.t => { - flt |> DH.DHFilter.map(subst_var(m, d1, x)); + (m, d1: DHExp.t, x: Var.t, flt: TermBase.StepperFilterKind.t) + : TermBase.StepperFilterKind.t => { + flt |> TermBase.StepperFilterKind.map(subst_var(m, d1, x)); }; let subst = (m, env: Environment.t, d: DHExp.t): DHExp.t => diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index 0d8b5c4cf4..76e222a980 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -724,14 +724,14 @@ module Transition = (EV: EV_MODE) => { d1, ); Indet; - | MultiHole(ds) => - let. _ = otherwise(env, ds => MultiHole(ds) |> rewrap) - and. _ = - req_all_final( - req(state, env), - (d1, ds) => MultiHole(d1, ds) |> wrap_ctx, - ds, - ); + | MultiHole(_) => + let. _ = otherwise(env, d); + // and. _ = + // req_all_final( + // req(state, env), + // (d1, ds) => MultiHole(d1, ds) |> wrap_ctx, + // ds, + // ); Indet; | EmptyHole | Invalid(_) diff --git a/src/haz3lcore/statics/MakeTerm.re b/src/haz3lcore/statics/MakeTerm.re index 66c6bc8a50..1d8bce45bf 100644 --- a/src/haz3lcore/statics/MakeTerm.re +++ b/src/haz3lcore/statics/MakeTerm.re @@ -187,13 +187,13 @@ and exp_term: unsorted => (UExp.term, list(Id.t)) = { | (["fix", "->"], [Pat(pat)]) => FixF(pat, r, None) | (["let", "=", "in"], [Pat(pat), Exp(def)]) => Let(pat, def, r) | (["hide", "in"], [Exp(filter)]) => - Filter((Eval, One), filter, r) + Filter(Filter({act: (Eval, One), pat: filter}), r) | (["eval", "in"], [Exp(filter)]) => - Filter((Eval, All), filter, r) + Filter(Filter({act: (Eval, All), pat: filter}), r) | (["pause", "in"], [Exp(filter)]) => - Filter((Step, One), filter, r) + Filter(Filter({act: (Step, One), pat: filter}), r) | (["debug", "in"], [Exp(filter)]) => - Filter((Step, All), filter, r) + Filter(Filter({act: (Step, All), pat: filter}), r) | (["type", "=", "in"], [TPat(tpat), Typ(def)]) => TyAlias(tpat, def, r) | (["if", "then", "else"], [Exp(cond), Exp(conseq)]) => diff --git a/src/haz3lcore/statics/Statics.re b/src/haz3lcore/statics/Statics.re index cec2879520..5d1819436c 100644 --- a/src/haz3lcore/statics/Statics.re +++ b/src/haz3lcore/statics/Statics.re @@ -290,7 +290,7 @@ and uexp_to_info_map = | Test(e) => let (e, m) = go(~mode=Ana(Bool), e, m); add(~self=Just(Prod([])), ~co_ctx=e.co_ctx, m); - | Filter(_, cond, body) => + | Filter(Filter({pat: cond, _}), body) => let (cond, m) = go(~mode, cond, m, ~is_in_filter=true); let (body, m) = go(~mode, body, m); add( @@ -298,6 +298,9 @@ and uexp_to_info_map = ~co_ctx=CoCtx.union([cond.co_ctx, body.co_ctx]), m, ); + | Filter(Residue(_), body) => + let (body, m) = go(~mode, body, m); + add(~self=Just(body.ty), ~co_ctx=CoCtx.union([body.co_ctx]), m); | Seq(e1, e2) => let (e1, m) = go(~mode=Syn, e1, m); let (e2, m) = go(~mode, e2, m); diff --git a/src/haz3lcore/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index f5d83bde88..602f080670 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -166,7 +166,7 @@ and UExp: { | If(t, t, t) | Seq(t, t) | Test(t) - | Filter(FilterAction.t, t, t) + | Filter(StepperFilterKind.t, t) | Closure([@show.opaque] ClosureEnvironment.t, t) | Parens(t) // ( | Cons(t, t) @@ -315,7 +315,7 @@ and UExp: { | If(t, t, t) | Seq(t, t) | Test(t) - | Filter(FilterAction.t, t, t) // TODO: Change to reflect UExp + | Filter(StepperFilterKind.t, t) // TODO: Change to reflect UExp | Closure([@show.opaque] ClosureEnvironment.t, t) | Parens(t) | Cons(t, t) @@ -646,4 +646,36 @@ and ClosureEnvironment: { let placeholder = wrap(EnvironmentId.invalid, Environment.empty); let without_keys = keys => update(Environment.without_keys(keys)); +} +and StepperFilterKind: { + [@deriving (show({with_path: false}), sexp, yojson)] + type filter = { + pat: UExp.t, + act: FilterAction.t, + }; + + [@deriving (show({with_path: false}), sexp, yojson)] + type t = + | Filter(filter) + | Residue(int, FilterAction.t); + + let map: (UExp.t => UExp.t, t) => t; +} = { + [@deriving (show({with_path: false}), sexp, yojson)] + type filter = { + pat: UExp.t, + act: FilterAction.t, + }; + + [@deriving (show({with_path: false}), sexp, yojson)] + type t = + | Filter(filter) + | Residue(int, FilterAction.t); + + let map = (mapper, filter) => { + switch (filter) { + | Filter({act, pat}) => Filter({act, pat: mapper(pat)}) + | Residue(idx, act) => Residue(idx, act) + }; + }; }; diff --git a/src/haz3lcore/zipper/EditorUtil.re b/src/haz3lcore/zipper/EditorUtil.re index 14391b7a59..9339b3df01 100644 --- a/src/haz3lcore/zipper/EditorUtil.re +++ b/src/haz3lcore/zipper/EditorUtil.re @@ -75,13 +75,9 @@ let rec append_exp = (e1: TermBase.UExp.t, e2: TermBase.UExp.t) => { | Seq(e11, e12) => let e12' = append_exp(e12, e2); TermBase.UExp.{ids: e1.ids, copied: false, term: Seq(e11, e12')}; - | Filter(act, econd, ebody) => + | Filter(kind, ebody) => let ebody' = append_exp(ebody, e2); - TermBase.UExp.{ - ids: e1.ids, - copied: false, - term: Filter(act, econd, ebody'), - }; + TermBase.UExp.{ids: e1.ids, copied: false, term: Filter(kind, ebody')}; | Let(p, edef, ebody) => let ebody' = append_exp(ebody, e2); TermBase.UExp.{ids: e1.ids, copied: false, term: Let(p, edef, ebody')}; diff --git a/src/haz3lschool/Exercise.re b/src/haz3lschool/Exercise.re index 66888f05d5..8cbb7b2013 100644 --- a/src/haz3lschool/Exercise.re +++ b/src/haz3lschool/Exercise.re @@ -579,8 +579,14 @@ module F = (ExerciseEnv: ExerciseEnv) => { TermBase.UExp.{ term: TermBase.UExp.Filter( - FilterAction.(act, One), - {term: Constructor("$e"), copied: false, ids: [Id.mk()]}, + Filter({ + act: FilterAction.(act, One), + pat: { + term: Constructor("$e"), + copied: false, + ids: [Id.mk()], + }, + }), term, ), copied: false, diff --git a/src/haz3lschool/SyntaxTest.re b/src/haz3lschool/SyntaxTest.re index abcc03a48b..7c34e006fa 100644 --- a/src/haz3lschool/SyntaxTest.re +++ b/src/haz3lschool/SyntaxTest.re @@ -61,7 +61,7 @@ let rec var_mention = (name: string, uexp: Term.UExp.t): bool => { | Cast(u, _, _) | UnOp(_, u) | TyAlias(_, _, u) - | Filter(_, _, u) => var_mention(name, u) + | Filter(_, u) => var_mention(name, u) | Ap(_, u1, u2) | Seq(u1, u2) | Cons(u1, u2) @@ -112,7 +112,7 @@ let rec var_applied = (name: string, uexp: Term.UExp.t): bool => { | UnOp(_, u) | TyAlias(_, _, u) | Closure(_, u) - | Filter(_, _, u) => var_applied(name, u) + | Filter(_, u) => var_applied(name, u) | Ap(_, u1, u2) => switch (u1.term) { | Var(x) => x == name ? true : var_applied(name, u2) @@ -198,7 +198,7 @@ let rec find_fn = | TyAlias(_, _, u1) | Test(u1) | Closure(_, u1) - | Filter(_, _, u1) => l |> find_fn(name, u1) + | Filter(_, u1) => l |> find_fn(name, u1) | Ap(_, u1, u2) | Seq(u1, u2) | Cons(u1, u2) @@ -269,7 +269,7 @@ let rec tail_check = (name: string, uexp: Term.UExp.t): bool => { | Test(_) => false | TyAlias(_, _, u) | Cast(u, _, _) - | Filter(_, _, u) + | Filter(_, u) | Closure(_, u) | Parens(u) => tail_check(name, u) | UnOp(_, u) => !var_mention(name, u) diff --git a/src/haz3lweb/view/ExplainThis.re b/src/haz3lweb/view/ExplainThis.re index 95510b9ecb..405472e016 100644 --- a/src/haz3lweb/view/ExplainThis.re +++ b/src/haz3lweb/view/ExplainThis.re @@ -1611,34 +1611,35 @@ let get_doc = ), SeqExp.seqs, ); - | Filter((Step, One), pat, body) => + | Filter(Filter({act: (Step, One), pat}), body) => message_single( FilterExp.filter_pause( ~p_id=Term.UExp.rep_id(pat), ~body_id=Term.UExp.rep_id(body), ), ) - | Filter((Step, All), pat, body) => + | Filter(Filter({act: (Step, All), pat}), body) => message_single( FilterExp.filter_debug( ~p_id=Term.UExp.rep_id(pat), ~body_id=Term.UExp.rep_id(body), ), ) - | Filter((Eval, All), pat, body) => + | Filter(Filter({act: (Eval, All), pat}), body) => message_single( FilterExp.filter_eval( ~p_id=Term.UExp.rep_id(pat), ~body_id=Term.UExp.rep_id(body), ), ) - | Filter((Eval, One), pat, body) => + | Filter(Filter({act: (Eval, One), pat}), body) => message_single( FilterExp.filter_hide( ~p_id=Term.UExp.rep_id(pat), ~body_id=Term.UExp.rep_id(body), ), ) + | Filter(_) => simple("Internal expression") | Test(body) => let body_id = List.nth(body.ids, 0); get_message( diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index 0739c948c9..1b4a9d1407 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -287,7 +287,12 @@ let mk = ~selected=Some(DHExp.rep_id(d)) == selected_hole_instance, env, ) - | MultiHole(ds) => ds |> List.map(go') |> Doc.hcats + | MultiHole(_ds) => + //ds |> List.map(go') |> Doc.hcats + DHDoc_common.mk_EmptyHole( + ~selected=Some(DHExp.rep_id(d)) == selected_hole_instance, + env, + ) | StaticErrorHole(_, d') => go'(d') |> annot(DHAnnot.NonEmptyHole) | Invalid(t) => DHDoc_common.mk_InvalidText(t) | Var(x) when List.mem(x, recursive_calls) => text(x) From e3012a839218b079eedea0ccd18c4f336bb4c703 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Fri, 1 Mar 2024 15:25:13 -0500 Subject: [PATCH 042/103] Split Term into multiple files --- src/haz3lcore/TermMap.re | 4 +- src/haz3lcore/dynamics/Elaborator.re | 22 +- src/haz3lcore/dynamics/EvalCtx.re | 10 +- src/haz3lcore/dynamics/Transition.re | 10 +- src/haz3lcore/lang/Operators.re | 177 ++++ src/haz3lcore/lang/term/Any.re | 45 ++ src/haz3lcore/lang/term/Cls.re | 18 + src/haz3lcore/lang/term/Exp.re | 203 +++++ src/haz3lcore/lang/term/Pat.re | 218 +++++ src/haz3lcore/lang/term/Rul.re | 25 + src/haz3lcore/lang/term/TPat.re | 33 + .../{statics => lang/term}/TermBase.re | 296 +------ src/haz3lcore/lang/term/TypTerm.re | 127 +++ src/haz3lcore/prog/CachedStatics.re | 4 +- src/haz3lcore/statics/Info.re | 27 +- src/haz3lcore/statics/MakeTerm.re | 34 +- src/haz3lcore/statics/Statics.re | 24 +- src/haz3lcore/statics/Term.re | 757 ------------------ src/haz3lcore/statics/uterm/UExp.re | 1 + src/haz3lcore/statics/uterm/UPat.re | 1 + src/haz3lcore/statics/uterm/UTyp.re | 1 + src/haz3lcore/zipper/Editor.re | 2 +- src/haz3lschool/Exercise.re | 5 +- src/haz3lschool/SyntaxTest.re | 27 +- src/haz3lweb/Grading.re | 2 +- src/haz3lweb/explainthis/ExplainThisForm.re | 8 +- src/haz3lweb/view/CursorInspector.re | 24 +- src/haz3lweb/view/Deco.re | 2 +- src/haz3lweb/view/ExplainThis.re | 28 +- src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 24 +- src/test/Test_Elaboration.re | 18 +- 31 files changed, 994 insertions(+), 1183 deletions(-) create mode 100644 src/haz3lcore/lang/Operators.re create mode 100644 src/haz3lcore/lang/term/Any.re create mode 100644 src/haz3lcore/lang/term/Cls.re create mode 100644 src/haz3lcore/lang/term/Exp.re create mode 100644 src/haz3lcore/lang/term/Pat.re create mode 100644 src/haz3lcore/lang/term/Rul.re create mode 100644 src/haz3lcore/lang/term/TPat.re rename src/haz3lcore/{statics => lang/term}/TermBase.re (62%) create mode 100644 src/haz3lcore/lang/term/TypTerm.re delete mode 100644 src/haz3lcore/statics/Term.re create mode 100644 src/haz3lcore/statics/uterm/UExp.re create mode 100644 src/haz3lcore/statics/uterm/UPat.re create mode 100644 src/haz3lcore/statics/uterm/UTyp.re diff --git a/src/haz3lcore/TermMap.re b/src/haz3lcore/TermMap.re index 8f42eb012f..df0f6341de 100644 --- a/src/haz3lcore/TermMap.re +++ b/src/haz3lcore/TermMap.re @@ -1,5 +1,5 @@ include Id.Map; -type t = Id.Map.t(Term.t); +type t = Id.Map.t(Any.t); -let add_all = (ids: list(Id.t), tm: Term.t, map: t) => +let add_all = (ids: list(Id.t), tm: Any.t, map: t) => ids |> List.fold_left((map, id) => add(id, tm, map), map); diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 5f41afd650..46e9dd1818 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -32,14 +32,14 @@ module ElaborationResult = { | DoesNotElaborate; }; -let fixed_exp_typ = (m: Statics.Map.t, e: Term.UExp.t): option(Typ.t) => - switch (Id.Map.find_opt(Term.UExp.rep_id(e), m)) { +let fixed_exp_typ = (m: Statics.Map.t, e: UExp.t): option(Typ.t) => + switch (Id.Map.find_opt(UExp.rep_id(e), m)) { | Some(InfoExp({ty, _})) => Some(ty) | _ => None }; -let fixed_pat_typ = (m: Statics.Map.t, p: Term.UPat.t): option(Typ.t) => - switch (Id.Map.find_opt(Term.UPat.rep_id(p), m)) { +let fixed_pat_typ = (m: Statics.Map.t, p: UPat.t): option(Typ.t) => + switch (Id.Map.find_opt(UPat.rep_id(p), m)) { | Some(InfoPat({ty, _})) => Some(ty) | _ => None }; @@ -163,15 +163,14 @@ let wrap = (ctx: Ctx.t, u: Id.t, mode: Mode.t, self, d: DHExp.t): DHExp.t => }; let rec dhexp_of_uexp = - (m: Statics.Map.t, uexp: Term.UExp.t, in_filter: bool) - : option(DHExp.t) => { + (m: Statics.Map.t, uexp: UExp.t, in_filter: bool): option(DHExp.t) => { let dhexp_of_uexp = (~in_filter=in_filter, m, uexp) => { dhexp_of_uexp(m, uexp, in_filter); }; - switch (Id.Map.find_opt(Term.UExp.rep_id(uexp), m)) { + switch (Id.Map.find_opt(UExp.rep_id(uexp), m)) { | Some(InfoExp({mode, self, ctx, _})) => let err_status = Info.status_exp(ctx, mode, self); - let id = Term.UExp.rep_id(uexp); /* NOTE: using term uids for hole ids */ + let id = UExp.rep_id(uexp); /* NOTE: using term uids for hole ids */ let rewrap = DHExp.mk(uexp.ids); let+ d: DHExp.t = switch (uexp.term) { @@ -273,11 +272,10 @@ let rec dhexp_of_uexp = ); let* ddef = dhexp_of_uexp(m, def); let+ dbody = dhexp_of_uexp(m, body); - switch (Term.UPat.get_recursive_bindings(p)) { + switch (UPat.get_recursive_bindings(p)) { | None => /* not recursive */ - DHExp.Let(p, add_name(Term.UPat.get_var(p), ddef), dbody) - |> rewrap + DHExp.Let(p, add_name(UPat.get_var(p), ddef), dbody) |> rewrap | Some(b) => DHExp.Let( p, @@ -333,7 +331,7 @@ let rec dhexp_of_uexp = //let dhexp_of_uexp = Core.Memo.general(~cache_size_bound=1000, dhexp_of_uexp); -let uexp_elab = (m: Statics.Map.t, uexp: Term.UExp.t): ElaborationResult.t => +let uexp_elab = (m: Statics.Map.t, uexp: UExp.t): ElaborationResult.t => switch (dhexp_of_uexp(m, uexp, false)) { | None => DoesNotElaborate | Some(d) => diff --git a/src/haz3lcore/dynamics/EvalCtx.re b/src/haz3lcore/dynamics/EvalCtx.re index 1a96d77e12..6efd8d9a68 100644 --- a/src/haz3lcore/dynamics/EvalCtx.re +++ b/src/haz3lcore/dynamics/EvalCtx.re @@ -12,14 +12,14 @@ type term = | Let2(TermBase.UPat.t, DHExp.t, t) | Fun(TermBase.UPat.t, t, option(ClosureEnvironment.t), option(Var.t)) | FixF(TermBase.UPat.t, t, option(ClosureEnvironment.t)) - | Ap1(TermBase.UExp.ap_direction, t, DHExp.t) - | Ap2(TermBase.UExp.ap_direction, DHExp.t, t) + | Ap1(Operators.ap_direction, t, DHExp.t) + | Ap2(Operators.ap_direction, DHExp.t, t) | If1(t, DHExp.t, DHExp.t) | If2(DHExp.t, t, DHExp.t) | If3(DHExp.t, DHExp.t, t) - | UnOp(TermBase.UExp.op_un, t) - | BinOp1(TermBase.UExp.op_bin, t, DHExp.t) - | BinOp2(TermBase.UExp.op_bin, DHExp.t, t) + | UnOp(Operators.op_un, t) + | BinOp1(Operators.op_bin, t, DHExp.t) + | BinOp2(Operators.op_bin, DHExp.t, t) | Tuple(t, (list(DHExp.t), list(DHExp.t))) | Test(t) | ListLit(t, (list(DHExp.t), list(DHExp.t))) diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index 76e222a980..ce48ed3386 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -58,11 +58,11 @@ type step_kind = | CastAp | BuiltinWrap | BuiltinAp(string) - | UnOp(TermBase.UExp.op_un) - | BinBoolOp(TermBase.UExp.op_bin_bool) - | BinIntOp(TermBase.UExp.op_bin_int) - | BinFloatOp(TermBase.UExp.op_bin_float) - | BinStringOp(TermBase.UExp.op_bin_string) + | UnOp(Operators.op_un) + | BinBoolOp(Operators.op_bin_bool) + | BinIntOp(Operators.op_bin_int) + | BinFloatOp(Operators.op_bin_float) + | BinStringOp(Operators.op_bin_string) | Conditional(bool) | Projection | ListCons diff --git a/src/haz3lcore/lang/Operators.re b/src/haz3lcore/lang/Operators.re new file mode 100644 index 0000000000..aa8842b72b --- /dev/null +++ b/src/haz3lcore/lang/Operators.re @@ -0,0 +1,177 @@ +[@deriving (show({with_path: false}), sexp, yojson)] +type op_un_bool = + | Not; + +[@deriving (show({with_path: false}), sexp, yojson)] +type op_un_meta = + | Unquote; + +[@deriving (show({with_path: false}), sexp, yojson)] +type op_un_int = + | Minus; + +[@deriving (show({with_path: false}), sexp, yojson)] +type op_bin_bool = + | And + | Or; + +[@deriving (show({with_path: false}), sexp, yojson)] +type op_bin_int = + | Plus + | Minus + | Times + | Power + | Divide + | LessThan + | LessThanOrEqual + | GreaterThan + | GreaterThanOrEqual + | Equals + | NotEquals; + +[@deriving (show({with_path: false}), sexp, yojson)] +type op_bin_float = + | Plus + | Minus + | Times + | Power + | Divide + | LessThan + | LessThanOrEqual + | GreaterThan + | GreaterThanOrEqual + | Equals + | NotEquals; + +[@deriving (show({with_path: false}), sexp, yojson)] +type op_bin_string = + | Concat + | Equals; + +[@deriving (show({with_path: false}), sexp, yojson)] +type op_un = + | Meta(op_un_meta) + | Int(op_un_int) + | Bool(op_un_bool); + +[@deriving (show({with_path: false}), sexp, yojson)] +type op_bin = + | Int(op_bin_int) + | Float(op_bin_float) + | Bool(op_bin_bool) + | String(op_bin_string); + +[@deriving (show({with_path: false}), sexp, yojson)] +type ap_direction = + | Forward + | Reverse; + +// Are these show function necessary? +let show_op_un_meta: op_un_meta => string = + fun + | Unquote => "Un-quotation"; + +let show_op_un_bool: op_un_bool => string = + fun + | Not => "Boolean Negation"; + +let show_op_un_int: op_un_int => string = + fun + | Minus => "Integer Negation"; + +let show_unop: op_un => string = + fun + | Meta(op) => show_op_un_meta(op) + | Bool(op) => show_op_un_bool(op) + | Int(op) => show_op_un_int(op); + +let show_op_bin_bool: op_bin_bool => string = + fun + | And => "Boolean Conjunction" + | Or => "Boolean Disjunction"; + +let show_op_bin_int: op_bin_int => string = + fun + | Plus => "Integer Addition" + | Minus => "Integer Subtraction" + | Times => "Integer Multiplication" + | Power => "Integer Exponentiation" + | Divide => "Integer Division" + | LessThan => "Integer Less Than" + | LessThanOrEqual => "Integer Less Than or Equal" + | GreaterThan => "Integer Greater Than" + | GreaterThanOrEqual => "Integer Greater Than or Equal" + | Equals => "Integer Equality" + | NotEquals => "Integer Inequality"; + +let show_op_bin_float: op_bin_float => string = + fun + | Plus => "Float Addition" + | Minus => "Float Subtraction" + | Times => "Float Multiplication" + | Power => "Float Exponentiation" + | Divide => "Float Division" + | LessThan => "Float Less Than" + | LessThanOrEqual => "Float Less Than or Equal" + | GreaterThan => "Float Greater Than" + | GreaterThanOrEqual => "Float Greater Than or Equal" + | Equals => "Float Equality" + | NotEquals => "Float Inequality"; + +let show_op_bin_string: op_bin_string => string = + fun + | Concat => "String Concatenation" + | Equals => "String Equality"; + +let show_binop: op_bin => string = + fun + | Int(op) => show_op_bin_int(op) + | Float(op) => show_op_bin_float(op) + | Bool(op) => show_op_bin_bool(op) + | String(op) => show_op_bin_string(op); + +let bool_op_to_string = (op: op_bin_bool): string => { + switch (op) { + | And => "&&" + | Or => "||" + }; +}; + +let int_op_to_string = (op: op_bin_int): string => { + switch (op) { + | Plus => "+" + | Minus => "-" + | Times => "*" + | Power => "**" + | Divide => "/" + | LessThan => "<" + | LessThanOrEqual => "<=" + | GreaterThan => ">" + | GreaterThanOrEqual => ">=" + | Equals => "==" + | NotEquals => "!=" + }; +}; + +let float_op_to_string = (op: op_bin_float): string => { + switch (op) { + | Plus => "+." + | Minus => "-." + | Times => "*." + | Power => "**." + | Divide => "/." + | LessThan => "<." + | LessThanOrEqual => "<=." + | GreaterThan => ">." + | GreaterThanOrEqual => ">=." + | Equals => "==." + | NotEquals => "!=." + }; +}; + +let string_op_to_string = (op: op_bin_string): string => { + switch (op) { + | Concat => "++" + | Equals => "$==" + }; +}; diff --git a/src/haz3lcore/lang/term/Any.re b/src/haz3lcore/lang/term/Any.re new file mode 100644 index 0000000000..406d2358ba --- /dev/null +++ b/src/haz3lcore/lang/term/Any.re @@ -0,0 +1,45 @@ +include TermBase.Any; + +let is_exp: t => option(TermBase.UExp.t) = + fun + | Exp(e) => Some(e) + | _ => None; +let is_pat: t => option(TermBase.UPat.t) = + fun + | Pat(p) => Some(p) + | _ => None; +let is_typ: t => option(TermBase.UTyp.t) = + fun + | Typ(t) => Some(t) + | _ => None; + +let rec ids = + fun + | Exp(tm) => tm.ids + | Pat(tm) => tm.ids + | Typ(tm) => tm.ids + | TPat(tm) => tm.ids + | Rul(tm) => Rul.ids(~any_ids=ids, tm) + | Nul () + | Any () => []; + +// Terms may consist of multiple tiles, eg the commas in an n-tuple, +// the rules of a case expression + the surrounding case-end tile, +// the list brackets tile coupled with the elem-separating commas. +// The _representative id_ is the canonical tile id used to identify +// and look up info about a term. +// +// In instances like case expressions and list literals, where a parent +// tile surrounds the other tiles, the representative id is the parent tile's. +// In other instances like n-tuples, where the commas are all siblings, +// the representative id is one of the comma ids, unspecified which one. +// (This would change for n-tuples if we decided parentheses are necessary.) +let rep_id = + fun + | Exp(tm) => Exp.rep_id(tm) + | Pat(tm) => Pat.rep_id(tm) + | Typ(tm) => TypTerm.rep_id(tm) + | TPat(tm) => TPat.rep_id(tm) + | Rul(tm) => Rul.rep_id(~any_ids=ids, tm) + | Nul () + | Any () => raise(Invalid_argument("Term.rep_id")); diff --git a/src/haz3lcore/lang/term/Cls.re b/src/haz3lcore/lang/term/Cls.re new file mode 100644 index 0000000000..dfe8ee6911 --- /dev/null +++ b/src/haz3lcore/lang/term/Cls.re @@ -0,0 +1,18 @@ +[@deriving (show({with_path: false}), sexp, yojson)] +type t = + | Exp(Exp.cls) + | Pat(Pat.cls) + | Typ(TypTerm.cls) + | TPat(TPat.cls) + | Rul(Rul.cls) + | Secondary(Secondary.cls); + +let show = (cls: t) => + switch (cls) { + | Exp(cls) => Exp.show_cls(cls) + | Pat(cls) => Pat.show_cls(cls) + | Typ(cls) => TypTerm.show_cls(cls) + | TPat(cls) => TPat.show_cls(cls) + | Rul(cls) => Rul.show_cls(cls) + | Secondary(cls) => Secondary.show_cls(cls) + }; diff --git a/src/haz3lcore/lang/term/Exp.re b/src/haz3lcore/lang/term/Exp.re new file mode 100644 index 0000000000..968afee766 --- /dev/null +++ b/src/haz3lcore/lang/term/Exp.re @@ -0,0 +1,203 @@ +include TermBase.UExp; + +[@deriving (show({with_path: false}), sexp, yojson)] +type cls = + | Invalid + | EmptyHole + | MultiHole + | StaticErrorHole + | DynamicErrorHole + | FailedCast + | Bool + | Int + | Float + | String + | ListLit + | Constructor + | Fun + | Tuple + | Var + | MetaVar + | Let + | FixF + | TyAlias + | Ap + | Pipeline + | If + | Seq + | Test + | Filter + | Closure + | Parens + | Cons + | UnOp(Operators.op_un) + | BinOp(Operators.op_bin) + | BuiltinFun + | Match + | Cast + | ListConcat; + +let hole = (tms: list(TermBase.Any.t)): term => + switch (tms) { + | [] => EmptyHole + | [_, ..._] => MultiHole(tms) + }; + +let rep_id = ({ids, _}) => { + assert(ids != []); + List.hd(ids); +}; + +let cls_of_term: term => cls = + fun + | Invalid(_) => Invalid + | EmptyHole => EmptyHole + | MultiHole(_) => MultiHole + | StaticErrorHole(_) => StaticErrorHole + | DynamicErrorHole(_) => DynamicErrorHole + | FailedCast(_) => FailedCast + | Bool(_) => Bool + | Int(_) => Int + | Float(_) => Float + | String(_) => String + | ListLit(_) => ListLit + | Constructor(_) => Constructor + | Fun(_) => Fun + | Tuple(_) => Tuple + | Var(_) => Var + | Let(_) => Let + | FixF(_) => FixF + | TyAlias(_) => TyAlias + | Ap(_) => Ap + | If(_) => If + | Seq(_) => Seq + | Test(_) => Test + | Filter(_) => Filter + | Closure(_) => Closure + | Parens(_) => Parens + | Cons(_) => Cons + | ListConcat(_) => ListConcat + | UnOp(op, _) => UnOp(op) + | BinOp(op, _, _) => BinOp(op) + | BuiltinFun(_) => BuiltinFun + | Match(_) => Match + | Cast(_) => Cast; + +let show_cls: cls => string = + fun + | Invalid => "Invalid expression" + | MultiHole => "Broken expression" + | EmptyHole => "Empty expression hole" + | StaticErrorHole => "Static error hole" + | DynamicErrorHole => "Dynamic error hole" + | FailedCast => "Failed cast" + | Bool => "Boolean literal" + | Int => "Integer literal" + | Float => "Float literal" + | String => "String literal" + | ListLit => "List literal" + | Constructor => "Constructor" + | Fun => "Function literal" + | Tuple => "Tuple literal" + | Var => "Variable reference" + | MetaVar => "Meta variable reference" + | Let => "Let expression" + | FixF => "Fixpoint operator" + | TyAlias => "Type Alias definition" + | Ap => "Application" + | Pipeline => "Pipeline expression" + | If => "If expression" + | Seq => "Sequence expression" + | Test => "Test" + | Filter => "Filter" + | Closure => "Closure" + | Parens => "Parenthesized expression" + | Cons => "Cons" + | ListConcat => "List Concatenation" + | BinOp(op) => Operators.show_binop(op) + | UnOp(op) => Operators.show_unop(op) + | BuiltinFun => "Built-in Function" + | Match => "Case expression" + | Cast => "Cast expression"; + +let rec is_fun = (e: t) => { + switch (e.term) { + | Parens(e) => is_fun(e) + | Cast(e, _, _) => is_fun(e) + | Fun(_) + | BuiltinFun(_) => true + | Invalid(_) + | EmptyHole + | MultiHole(_) + | StaticErrorHole(_) + | DynamicErrorHole(_) + | FailedCast(_) + | Bool(_) + | Int(_) + | Float(_) + | String(_) + | ListLit(_) + | Tuple(_) + | Var(_) + | Let(_) + | FixF(_) + | TyAlias(_) + | Ap(_) + | If(_) + | Seq(_) + | Test(_) + | Filter(_) + | Cons(_) + | ListConcat(_) + | Closure(_) + | UnOp(_) + | BinOp(_) + | Match(_) + | Constructor(_) => false + }; +}; + +let rec is_tuple_of_functions = (e: t) => + is_fun(e) + || ( + switch (e.term) { + | Cast(e, _, _) + | Parens(e) => is_tuple_of_functions(e) + | Tuple(es) => es |> List.for_all(is_fun) + | Invalid(_) + | EmptyHole + | MultiHole(_) + | StaticErrorHole(_) + | DynamicErrorHole(_) + | FailedCast(_) + | Bool(_) + | Int(_) + | Float(_) + | String(_) + | ListLit(_) + | Fun(_) + | Closure(_) + | BuiltinFun(_) + | Var(_) + | Let(_) + | FixF(_) + | TyAlias(_) + | Ap(_) + | If(_) + | Seq(_) + | Test(_) + | Filter(_) + | Cons(_) + | ListConcat(_) + | UnOp(_) + | BinOp(_) + | Match(_) + | Constructor(_) => false + } + ); + +let ctr_name = (e: t): option(Constructor.t) => + switch (e.term) { + | Constructor(name) => Some(name) + | _ => None + }; diff --git a/src/haz3lcore/lang/term/Pat.re b/src/haz3lcore/lang/term/Pat.re new file mode 100644 index 0000000000..ab2042f498 --- /dev/null +++ b/src/haz3lcore/lang/term/Pat.re @@ -0,0 +1,218 @@ +[@deriving (show({with_path: false}), sexp, yojson)] +type cls = + | Invalid + | EmptyHole + | MultiHole + | Wild + | Int + | Float + | Bool + | String + | ListLit + | Constructor + | Cons + | Var + | Tuple + | Parens + | Ap + | TypeAnn; + +include TermBase.UPat; + +let rep_id = ({ids, _}: t) => { + assert(ids != []); + List.hd(ids); +}; + +let hole = (tms: list(TermBase.Any.t)) => + switch (tms) { + | [] => EmptyHole + | [_, ..._] => MultiHole(tms) + }; + +let cls_of_term: term => cls = + fun + | Invalid(_) => Invalid + | EmptyHole => EmptyHole + | MultiHole(_) => MultiHole + | Wild => Wild + | Int(_) => Int + | Float(_) => Float + | Bool(_) => Bool + | String(_) => String + | ListLit(_) => ListLit + | Constructor(_) => Constructor + | Cons(_) => Cons + | Var(_) => Var + | Tuple(_) => Tuple + | Parens(_) => Parens + | Ap(_) => Ap + | TypeAnn(_) => TypeAnn; + +let show_cls: cls => string = + fun + | Invalid => "Invalid pattern" + | MultiHole => "Broken pattern" + | EmptyHole => "Empty pattern hole" + | Wild => "Wildcard" + | Int => "Integer literal" + | Float => "Float literal" + | Bool => "Boolean literal" + | String => "String literal" + | ListLit => "List literal" + | Constructor => "Constructor" + | Cons => "Cons" + | Var => "Variable binding" + | Tuple => "Tuple" + | Parens => "Parenthesized pattern" + | Ap => "Constructor application" + | TypeAnn => "Annotation"; + +let rec is_var = (pat: t) => { + switch (pat.term) { + | Parens(pat) => is_var(pat) + | Var(_) => true + | TypeAnn(_) + | Invalid(_) + | EmptyHole + | MultiHole(_) + | Wild + | Int(_) + | Float(_) + | Bool(_) + | String(_) + | ListLit(_) + | Cons(_, _) + | Tuple(_) + | Constructor(_) + | Ap(_) => false + }; +}; + +let rec is_fun_var = (pat: t) => { + switch (pat.term) { + | Parens(pat) => is_fun_var(pat) + | TypeAnn(pat, typ) => is_var(pat) && UTyp.is_arrow(typ) + | Invalid(_) + | EmptyHole + | MultiHole(_) + | Wild + | Int(_) + | Float(_) + | Bool(_) + | String(_) + | ListLit(_) + | Cons(_, _) + | Var(_) + | Tuple(_) + | Constructor(_) + | Ap(_) => false + }; +}; + +let rec is_tuple_of_arrows = (pat: t) => + is_fun_var(pat) + || ( + switch (pat.term) { + | Parens(pat) => is_tuple_of_arrows(pat) + | Tuple(pats) => pats |> List.for_all(is_fun_var) + | Invalid(_) + | EmptyHole + | MultiHole(_) + | Wild + | Int(_) + | Float(_) + | Bool(_) + | String(_) + | ListLit(_) + | Cons(_, _) + | Var(_) + | TypeAnn(_) + | Constructor(_) + | Ap(_) => false + } + ); + +let rec get_var = (pat: t) => { + switch (pat.term) { + | Parens(pat) => get_var(pat) + | Var(x) => Some(x) + | TypeAnn(_) + | Invalid(_) + | EmptyHole + | MultiHole(_) + | Wild + | Int(_) + | Float(_) + | Bool(_) + | String(_) + | ListLit(_) + | Cons(_, _) + | Tuple(_) + | Constructor(_) + | Ap(_) => None + }; +}; + +let rec get_fun_var = (pat: t) => { + switch (pat.term) { + | Parens(pat) => get_fun_var(pat) + | TypeAnn(pat, typ) => + if (UTyp.is_arrow(typ)) { + get_var(pat) |> Option.map(var => var); + } else { + None; + } + | Invalid(_) + | EmptyHole + | MultiHole(_) + | Wild + | Int(_) + | Float(_) + | Bool(_) + | String(_) + | ListLit(_) + | Cons(_, _) + | Var(_) + | Tuple(_) + | Constructor(_) + | Ap(_) => None + }; +}; + +let rec get_recursive_bindings = (pat: t) => { + switch (get_fun_var(pat)) { + | Some(x) => Some([x]) + | None => + switch (pat.term) { + | Parens(pat) => get_recursive_bindings(pat) + | Tuple(pats) => + let fun_vars = pats |> List.map(get_fun_var); + if (List.exists(Option.is_none, fun_vars)) { + None; + } else { + Some(List.map(Option.get, fun_vars)); + }; + | Invalid(_) + | EmptyHole + | MultiHole(_) + | Wild + | Int(_) + | Float(_) + | Bool(_) + | String(_) + | ListLit(_) + | Cons(_, _) + | Var(_) + | TypeAnn(_) + | Constructor(_) + | Ap(_) => None + } + }; +}; + +let ctr_name = (p: t): option(Constructor.t) => + switch (p.term) { + | Constructor(name) => Some(name) + | _ => None + }; diff --git a/src/haz3lcore/lang/term/Rul.re b/src/haz3lcore/lang/term/Rul.re new file mode 100644 index 0000000000..b9183e667d --- /dev/null +++ b/src/haz3lcore/lang/term/Rul.re @@ -0,0 +1,25 @@ +include TermBase.Rul; + +[@deriving (show({with_path: false}), sexp, yojson)] +type cls = + | Rule; + +// example of awkwardness induced by having forms like rules +// that may have a different-sorted child with no delimiters +// (eg scrut with no rules) +let ids = (~any_ids, {ids, term}: t) => + switch (ids) { + | [_, ..._] => ids + | [] => + switch (term) { + | Hole([tm, ..._]) => any_ids(tm) + | Rules(scrut, []) => scrut.ids + | _ => [] + } + }; + +let rep_id = (~any_ids, tm) => + switch (ids(~any_ids, tm)) { + | [] => raise(Invalid_argument("UExp.rep_id")) + | [id, ..._] => id + }; diff --git a/src/haz3lcore/lang/term/TPat.re b/src/haz3lcore/lang/term/TPat.re new file mode 100644 index 0000000000..abc0a79891 --- /dev/null +++ b/src/haz3lcore/lang/term/TPat.re @@ -0,0 +1,33 @@ +[@deriving (show({with_path: false}), sexp, yojson)] +type cls = + | Invalid + | EmptyHole + | MultiHole + | Var; + +include TermBase.TPat; + +let rep_id = ({ids, _}) => { + assert(ids != []); + List.hd(ids); +}; + +let hole = (tms: list(TermBase.Any.t)) => + switch (tms) { + | [] => EmptyHole + | [_, ..._] => MultiHole(tms) + }; + +let cls_of_term: term => cls = + fun + | Invalid(_) => Invalid + | EmptyHole => EmptyHole + | MultiHole(_) => MultiHole + | Var(_) => Var; + +let show_cls: cls => string = + fun + | Invalid => "Invalid type alias" + | MultiHole => "Broken type alias" + | EmptyHole => "Empty type alias hole" + | Var => "Type alias"; diff --git a/src/haz3lcore/statics/TermBase.re b/src/haz3lcore/lang/term/TermBase.re similarity index 62% rename from src/haz3lcore/statics/TermBase.re rename to src/haz3lcore/lang/term/TermBase.re index 602f080670..520a5acd9b 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/lang/term/TermBase.re @@ -6,137 +6,22 @@ module rec Any: { | Exp(UExp.t) | Pat(UPat.t) | Typ(UTyp.t) - | TPat(UTPat.t) - | Rul(URul.t) + | TPat(TPat.t) + | Rul(Rul.t) | Nul(unit) | Any(unit); - - let is_exp: t => option(UExp.t); - let is_pat: t => option(UPat.t); - let is_typ: t => option(UTyp.t); } = { [@deriving (show({with_path: false}), sexp, yojson)] type t = | Exp(UExp.t) | Pat(UPat.t) | Typ(UTyp.t) - | TPat(UTPat.t) - | Rul(URul.t) + | TPat(TPat.t) + | Rul(Rul.t) | Nul(unit) | Any(unit); - - let is_exp: t => option(UExp.t) = - fun - | Exp(e) => Some(e) - | _ => None; - let is_pat: t => option(UPat.t) = - fun - | Pat(p) => Some(p) - | _ => None; - let is_typ: t => option(UTyp.t) = - fun - | Typ(t) => Some(t) - | _ => None; } and UExp: { - [@deriving (show({with_path: false}), sexp, yojson)] - type op_un_bool = - | Not; - - [@deriving (show({with_path: false}), sexp, yojson)] - type op_un_meta = - | Unquote; - - [@deriving (show({with_path: false}), sexp, yojson)] - type op_un_int = - | Minus; - - [@deriving (show({with_path: false}), sexp, yojson)] - type op_bin_bool = - | And - | Or; - - [@deriving (show({with_path: false}), sexp, yojson)] - type op_bin_int = - | Plus - | Minus - | Times - | Power - | Divide - | LessThan - | LessThanOrEqual - | GreaterThan - | GreaterThanOrEqual - | Equals - | NotEquals; - - [@deriving (show({with_path: false}), sexp, yojson)] - type op_bin_float = - | Plus - | Minus - | Times - | Power - | Divide - | LessThan - | LessThanOrEqual - | GreaterThan - | GreaterThanOrEqual - | Equals - | NotEquals; - - [@deriving (show({with_path: false}), sexp, yojson)] - type op_bin_string = - | Concat - | Equals; - - [@deriving (show({with_path: false}), sexp, yojson)] - type op_un = - | Meta(op_un_meta) - | Int(op_un_int) - | Bool(op_un_bool); - - [@deriving (show({with_path: false}), sexp, yojson)] - type op_bin = - | Int(op_bin_int) - | Float(op_bin_float) - | Bool(op_bin_bool) - | String(op_bin_string); - - [@deriving (show({with_path: false}), sexp, yojson)] - type ap_direction = - | Forward - | Reverse; - - [@deriving (show({with_path: false}), sexp, yojson)] - type cls = - | Invalid - | EmptyHole - | MultiHole - | StaticErrorHole - | DynamicErrorHole - | FailedCast - | Bool - | Int - | Float - | String - | ListLit - | Tag - | Fun - | Tuple - | Var - | Let - | Ap(ap_direction) - | If - | Seq - | Test - | Filter - | Parens - | Cons - | ListConcat - | UnOp(op_un) - | BinOp(op_bin) - | Match; - [@deriving (show({with_path: false}), sexp, yojson)] type term = | Invalid(string) @@ -161,8 +46,8 @@ and UExp: { | Var(Var.t) | Let(UPat.t, t, t) | FixF(UPat.t, t, [@show.opaque] option(ClosureEnvironment.t)) - | TyAlias(UTPat.t, UTyp.t, t) - | Ap(ap_direction, t, t) + | TyAlias(TPat.t, UTyp.t, t) + | Ap(Operators.ap_direction, t, t) | If(t, t, t) | Seq(t, t) | Test(t) @@ -171,8 +56,8 @@ and UExp: { | Parens(t) // ( | Cons(t, t) | ListConcat(t, t) - | UnOp(op_un, t) - | BinOp(op_bin, t, t) + | UnOp(Operators.op_un, t) + | BinOp(Operators.op_bin, t, t) | BuiltinFun(string) | Match(t, list((UPat.t, t))) | Cast(t, Typ.t, Typ.t) @@ -182,110 +67,7 @@ and UExp: { copied: bool, term, }; - - let bool_op_to_string: op_bin_bool => string; - let int_op_to_string: op_bin_int => string; - let float_op_to_string: op_bin_float => string; - let string_op_to_string: op_bin_string => string; } = { - [@deriving (show({with_path: false}), sexp, yojson)] - type op_un_bool = - | Not; - - [@deriving (show({with_path: false}), sexp, yojson)] - type op_un_meta = - | Unquote; - - [@deriving (show({with_path: false}), sexp, yojson)] - type op_un_int = - | Minus; - - [@deriving (show({with_path: false}), sexp, yojson)] - type op_bin_bool = - | And - | Or; - - [@deriving (show({with_path: false}), sexp, yojson)] - type op_bin_int = - | Plus - | Minus - | Times - | Power - | Divide - | LessThan - | LessThanOrEqual - | GreaterThan - | GreaterThanOrEqual - | Equals - | NotEquals; - - [@deriving (show({with_path: false}), sexp, yojson)] - type op_bin_float = - | Plus - | Minus - | Times - | Power - | Divide - | LessThan - | LessThanOrEqual - | GreaterThan - | GreaterThanOrEqual - | Equals - | NotEquals; - - [@deriving (show({with_path: false}), sexp, yojson)] - type op_bin_string = - | Concat - | Equals; - - [@deriving (show({with_path: false}), sexp, yojson)] - type op_un = - | Meta(op_un_meta) - | Int(op_un_int) - | Bool(op_un_bool); - - [@deriving (show({with_path: false}), sexp, yojson)] - type op_bin = - | Int(op_bin_int) - | Float(op_bin_float) - | Bool(op_bin_bool) - | String(op_bin_string); - - [@deriving (show({with_path: false}), sexp, yojson)] - type ap_direction = - | Forward - | Reverse; - - [@deriving (show({with_path: false}), sexp, yojson)] - type cls = - | Invalid - | EmptyHole - | MultiHole - | StaticErrorHole - | DynamicErrorHole - | FailedCast - | Bool - | Int - | Float - | String - | ListLit - | Tag - | Fun - | Tuple - | Var - | Let - | Ap(ap_direction) - | If - | Seq - | Test - | Filter - | Parens - | Cons - | ListConcat - | UnOp(op_un) - | BinOp(op_bin) - | Match; - [@deriving (show({with_path: false}), sexp, yojson)] type term = | Invalid(string) @@ -305,13 +87,13 @@ and UExp: { t, [@show.opaque] option(ClosureEnvironment.t), option(Var.t), - ) // TODO: Add option(Var.t) name field to end; Add optional closure to function + ) | Tuple(list(t)) | Var(Var.t) | Let(UPat.t, t, t) - | FixF(UPat.t, t, [@show.opaque] option(ClosureEnvironment.t)) // DONE [CHECK WITH SOMEONE THAT I GOT THE STATIC SEMANTICS RIGHT] - | TyAlias(UTPat.t, UTyp.t, t) - | Ap(ap_direction, t, t) // note: function is always first then argument; even in pipe mode + | FixF(UPat.t, t, [@show.opaque] option(ClosureEnvironment.t)) // TODO[Matt]: CHECK WITH SOMEONE THAT I GOT THE STATIC SEMANTICS RIGHT + | TyAlias(TPat.t, UTyp.t, t) + | Ap(Operators.ap_direction, t, t) // note: function is always first then argument; even in pipe mode | If(t, t, t) | Seq(t, t) | Test(t) @@ -320,8 +102,8 @@ and UExp: { | Parens(t) | Cons(t, t) | ListConcat(t, t) - | UnOp(op_un, t) - | BinOp(op_bin, t, t) + | UnOp(Operators.op_un, t) + | BinOp(Operators.op_bin, t, t) | BuiltinFun(string) /// Doesn't currently have a distinguishable syntax... | Match(t, list((UPat.t, t))) | Cast(t, Typ.t, Typ.t) @@ -331,52 +113,6 @@ and UExp: { copied: bool, term, }; - - let bool_op_to_string = (op: op_bin_bool): string => { - switch (op) { - | And => "&&" - | Or => "||" - }; - }; - - let int_op_to_string = (op: op_bin_int): string => { - switch (op) { - | Plus => "+" - | Minus => "-" - | Times => "*" - | Power => "**" - | Divide => "/" - | LessThan => "<" - | LessThanOrEqual => "<=" - | GreaterThan => ">" - | GreaterThanOrEqual => ">=" - | Equals => "==" - | NotEquals => "!=" - }; - }; - - let float_op_to_string = (op: op_bin_float): string => { - switch (op) { - | Plus => "+." - | Minus => "-." - | Times => "*." - | Power => "**." - | Divide => "/." - | LessThan => "<." - | LessThanOrEqual => "<=." - | GreaterThan => ">." - | GreaterThanOrEqual => ">=." - | Equals => "==." - | NotEquals => "!=." - }; - }; - - let string_op_to_string = (op: op_bin_string): string => { - switch (op) { - | Concat => "++" - | Equals => "$==" - }; - }; } and UPat: { [@deriving (show({with_path: false}), sexp, yojson)] @@ -476,7 +212,7 @@ and UTyp: { term, }; } -and UTPat: { +and TPat: { [@deriving (show({with_path: false}), sexp, yojson)] type term = | Invalid(string) @@ -499,7 +235,7 @@ and UTPat: { term, }; } -and URul: { +and Rul: { [@deriving (show({with_path: false}), sexp, yojson)] type term = | Invalid(string) diff --git a/src/haz3lcore/lang/term/TypTerm.re b/src/haz3lcore/lang/term/TypTerm.re new file mode 100644 index 0000000000..af50298459 --- /dev/null +++ b/src/haz3lcore/lang/term/TypTerm.re @@ -0,0 +1,127 @@ +[@deriving (show({with_path: false}), sexp, yojson)] +type cls = + | Invalid + | EmptyHole + | MultiHole + | Int + | Float + | Bool + | String + | Arrow + | Tuple + | Sum + | List + | Var + | Constructor + | Parens + | Ap; + +include TermBase.UTyp; + +let rep_id = ({ids, _}: t) => { + assert(ids != []); + List.hd(ids); +}; + +let hole = (tms: list(TermBase.Any.t)) => + switch (tms) { + | [] => EmptyHole + | [_, ..._] => MultiHole(tms) + }; + +let cls_of_term: term => cls = + fun + | Invalid(_) => Invalid + | EmptyHole => EmptyHole + | MultiHole(_) => MultiHole + | Int => Int + | Float => Float + | Bool => Bool + | String => String + | List(_) => List + | Arrow(_) => Arrow + | Var(_) => Var + | Constructor(_) => Constructor + | Tuple(_) => Tuple + | Parens(_) => Parens + | Ap(_) => Ap + | Sum(_) => Sum; + +let show_cls: cls => string = + fun + | Invalid => "Invalid type" + | MultiHole => "Broken type" + | EmptyHole => "Empty type hole" + | Int + | Float + | String + | Bool => "Base type" + | Var => "Type variable" + | Constructor => "Sum constructor" + | List => "List type" + | Arrow => "Function type" + | Tuple => "Product type" + | Sum => "Sum type" + | Parens => "Parenthesized type" + | Ap => "Constructor application"; + +let rec is_arrow = (typ: t) => { + switch (typ.term) { + | Parens(typ) => is_arrow(typ) + | Arrow(_) => true + | Invalid(_) + | EmptyHole + | MultiHole(_) + | Int + | Float + | Bool + | String + | List(_) + | Tuple(_) + | Var(_) + | Constructor(_) + | Ap(_) + | Sum(_) => false + }; +}; + +/* Converts a syntactic type into a semantic type */ +let rec to_typ: (Ctx.t, t) => Typ.t = + (ctx, utyp) => + switch (utyp.term) { + | Invalid(_) + | MultiHole(_) => Unknown(Internal) + | EmptyHole => Unknown(TypeHole) + | Bool => Bool + | Int => Int + | Float => Float + | String => String + | Var(name) => + switch (Ctx.lookup_tvar(ctx, name)) { + | Some(_) => Var(name) + | None => Unknown(Free(name)) + } + | Arrow(u1, u2) => Arrow(to_typ(ctx, u1), to_typ(ctx, u2)) + | Tuple(us) => Prod(List.map(to_typ(ctx), us)) + | Sum(uts) => Sum(to_ctr_map(ctx, uts)) + | List(u) => List(to_typ(ctx, u)) + | Parens(u) => to_typ(ctx, u) + /* The below cases should occur only inside sums */ + | Constructor(_) + | Ap(_) => Unknown(Internal) + } +and to_variant: + (Ctx.t, variant) => option(ConstructorMap.binding(option(Typ.t))) = + ctx => + fun + | Variant(ctr, _, u) => Some((ctr, Option.map(to_typ(ctx), u))) + | BadEntry(_) => None +and to_ctr_map = (ctx: Ctx.t, uts: list(variant)): Typ.sum_map => { + List.fold_left( + (acc, ut) => + List.find_opt(((ctr, _)) => ctr == fst(ut), acc) == None + ? acc @ [ut] : acc, + [], + List.filter_map(to_variant(ctx), uts), + ); +}; diff --git a/src/haz3lcore/prog/CachedStatics.re b/src/haz3lcore/prog/CachedStatics.re index e2c23513ed..ba277463ea 100644 --- a/src/haz3lcore/prog/CachedStatics.re +++ b/src/haz3lcore/prog/CachedStatics.re @@ -2,13 +2,13 @@ open Sexplib.Std; [@deriving (show({with_path: false}), sexp, yojson)] type statics = { - term: Term.UExp.t, + term: UExp.t, info_map: Statics.Map.t, error_ids: list(Id.t), }; let empty_statics: statics = { - term: Term.UExp.{ids: [Id.invalid], copied: false, term: Tuple([])}, + term: UExp.{ids: [Id.invalid], copied: false, term: Tuple([])}, info_map: Id.Map.empty, error_ids: [], }; diff --git a/src/haz3lcore/statics/Info.re b/src/haz3lcore/statics/Info.re index fedd189113..740e49ca66 100644 --- a/src/haz3lcore/statics/Info.re +++ b/src/haz3lcore/statics/Info.re @@ -1,7 +1,6 @@ open Sexplib.Std; open Util; open OptUtil.Syntax; -open Term; /* INFO.re @@ -187,7 +186,7 @@ type exp = { mode: Mode.t, /* Parental type expectations */ self: Self.exp, /* Expectation-independent type info */ co_ctx: CoCtx.t, /* Locally free variables */ - cls: Term.Cls.t, /* DERIVED: Syntax class (i.e. form name) */ + cls: Cls.t, /* DERIVED: Syntax class (i.e. form name) */ status: status_exp, /* DERIVED: Ok/Error statuses for display */ ty: Typ.t /* DERIVED: Type after nonempty hole fixing */ }; @@ -200,7 +199,7 @@ type pat = { co_ctx: CoCtx.t, mode: Mode.t, self: Self.pat, - cls: Term.Cls.t, + cls: Cls.t, status: status_pat, ty: Typ.t, }; @@ -211,24 +210,24 @@ type typ = { ancestors, ctx: Ctx.t, expects: typ_expects, - cls: Term.Cls.t, + cls: Cls.t, status: status_typ, ty: Typ.t, }; [@deriving (show({with_path: false}), sexp, yojson)] type tpat = { - term: UTPat.t, + term: TPat.t, ancestors, ctx: Ctx.t, - cls: Term.Cls.t, + cls: Cls.t, status: status_tpat, }; [@deriving (show({with_path: false}), sexp, yojson)] type secondary = { id: Id.t, // Id of term static info is sourced from - cls: Term.Cls.t, // Cls of secondary, not source term + cls: Cls.t, // Cls of secondary, not source term sort: Sort.t, // from source term ctx: Ctx.t // from source term }; @@ -283,10 +282,10 @@ let ancestors_of: t => ancestors = let id_of: t => Id.t = fun - | InfoExp(i) => Term.UExp.rep_id(i.term) - | InfoPat(i) => Term.UPat.rep_id(i.term) - | InfoTyp(i) => Term.UTyp.rep_id(i.term) - | InfoTPat(i) => Term.UTPat.rep_id(i.term) + | InfoExp(i) => Exp.rep_id(i.term) + | InfoPat(i) => Pat.rep_id(i.term) + | InfoTyp(i) => TypTerm.rep_id(i.term) + | InfoTPat(i) => TPat.rep_id(i.term) | Secondary(s) => s.id; let error_of: t => option(error) = @@ -427,7 +426,7 @@ let status_typ = } }; -let status_tpat = (ctx: Ctx.t, utpat: UTPat.t): status_tpat => +let status_tpat = (ctx: Ctx.t, utpat: TPat.t): status_tpat => switch (utpat.term) { | EmptyHole => NotInHole(Empty) | Var(name) @@ -518,8 +517,8 @@ let derived_typ = (~utyp: UTyp.t, ~ctx, ~ancestors, ~expects): typ => { }; /* Add derivable attributes for type patterns */ -let derived_tpat = (~utpat: UTPat.t, ~ctx, ~ancestors): tpat => { - let cls = Cls.TPat(UTPat.cls_of_term(utpat.term)); +let derived_tpat = (~utpat: TPat.t, ~ctx, ~ancestors): tpat => { + let cls = Cls.TPat(TPat.cls_of_term(utpat.term)); let status = status_tpat(ctx, utpat); {cls, ancestors, status, ctx, term: utpat}; }; diff --git a/src/haz3lcore/statics/MakeTerm.re b/src/haz3lcore/statics/MakeTerm.re index 1d8bce45bf..b179752a45 100644 --- a/src/haz3lcore/statics/MakeTerm.re +++ b/src/haz3lcore/statics/MakeTerm.re @@ -11,7 +11,7 @@ */ open Util; -open Term; +open Any; // TODO make less hacky let tokens = @@ -35,7 +35,7 @@ type unsorted = | Bin(t, tiles, t); let is_nary = - (is_sort: any => option('sort), delim: Token.t, (delims, kids): tiles) + (is_sort: Any.t => option('sort), delim: Token.t, (delims, kids): tiles) : option(list('sort)) => if (delims |> List.map(snd) |> List.for_all((==)(([delim], [])))) { kids |> List.map(is_sort) |> OptUtil.sequence; @@ -43,10 +43,10 @@ let is_nary = None; }; -let is_tuple_exp = is_nary(TermBase.Any.is_exp, ","); -let is_tuple_pat = is_nary(TermBase.Any.is_pat, ","); -let is_tuple_typ = is_nary(TermBase.Any.is_typ, ","); -let is_typ_bsum = is_nary(TermBase.Any.is_typ, "+"); +let is_tuple_exp = is_nary(Any.is_exp, ","); +let is_tuple_pat = is_nary(Any.is_pat, ","); +let is_tuple_typ = is_nary(Any.is_typ, ","); +let is_typ_bsum = is_nary(Any.is_typ, "+"); let is_grout = tiles => Aba.get_as(tiles) |> List.map(snd) |> List.for_all((==)(([" "], []))); @@ -57,7 +57,7 @@ let is_rules = ((ts, kids): tiles): option(Aba.t(UPat.t, UExp.t)) => { ts |> List.map( fun - | (_, (["|", "=>"], [Pat(p)])) => Some(p) + | (_, (["|", "=>"], [Any.Pat(p)])) => Some(p) | _ => None, ) |> OptUtil.sequence @@ -109,7 +109,7 @@ let parse_sum_term: UTyp.t => UTyp.variant = Variant(ctr, ids_ctr @ ids_ap, Some(u)) | t => BadEntry(t); -let rec go_s = (s: Sort.t, skel: Skel.t, seg: Segment.t): any => +let rec go_s = (s: Sort.t, skel: Skel.t, seg: Segment.t): t => switch (s) { | Pat => Pat(pat(unsorted(skel, seg))) | TPat => TPat(tpat(unsorted(skel, seg))) @@ -142,7 +142,7 @@ and exp = unsorted => { } and exp_term: unsorted => (UExp.term, list(Id.t)) = { let ret = (tm: UExp.term) => (tm, []); - let hole = unsorted => Term.UExp.hole(kids_of_unsorted(unsorted)); + let hole = unsorted => UExp.hole(kids_of_unsorted(unsorted)); fun | Op(tiles) as tm => switch (tiles) { @@ -274,7 +274,7 @@ and pat = unsorted => { } and pat_term: unsorted => (UPat.term, list(Id.t)) = { let ret = (term: UPat.term) => (term, []); - let hole = unsorted => Term.UPat.hole(kids_of_unsorted(unsorted)); + let hole = unsorted => UPat.hole(kids_of_unsorted(unsorted)); fun | Op(tiles) as tm => switch (tiles) { @@ -341,7 +341,7 @@ and typ = unsorted => { } and typ_term: unsorted => (UTyp.term, list(Id.t)) = { let ret = (term: UTyp.term) => (term, []); - let hole = unsorted => Term.UTyp.hole(kids_of_unsorted(unsorted)); + let hole = unsorted => UTyp.hole(kids_of_unsorted(unsorted)); fun | Op(tiles) as tm => switch (tiles) { @@ -401,9 +401,9 @@ and tpat = unsorted => { let ids = ids(unsorted); return(ty => TPat(ty), ids, {ids, term}); } -and tpat_term: unsorted => UTPat.term = { - let ret = (term: UTPat.term) => term; - let hole = unsorted => Term.UTPat.hole(kids_of_unsorted(unsorted)); +and tpat_term: unsorted => TPat.term = { + let ret = (term: TPat.term) => term; + let hole = unsorted => TPat.hole(kids_of_unsorted(unsorted)); fun | Op(tiles) as tm => switch (tiles) { @@ -427,8 +427,8 @@ and tpat_term: unsorted => UTPat.term = { // let ids = ids(unsorted); // return(r => Rul(r), ids, {ids, term}); // } -and rul = (unsorted: unsorted): URul.t => { - let hole = Term.URul.Hole(kids_of_unsorted(unsorted)); +and rul = (unsorted: unsorted): Rul.t => { + let hole = Rul.Hole(kids_of_unsorted(unsorted)); switch (exp(unsorted)) { | {term: MultiHole(_), _} => switch (unsorted) { @@ -448,7 +448,7 @@ and rul = (unsorted: unsorted): URul.t => { } and unsorted = (skel: Skel.t, seg: Segment.t): unsorted => { - let tile_kids = (p: Piece.t): list(any) => + let tile_kids = (p: Piece.t): list(t) => switch (p) { | Secondary(_) | Grout(_) => [] diff --git a/src/haz3lcore/statics/Statics.re b/src/haz3lcore/statics/Statics.re index 5d1819436c..a0bc6f7651 100644 --- a/src/haz3lcore/statics/Statics.re +++ b/src/haz3lcore/statics/Statics.re @@ -1,5 +1,3 @@ -open Term; - /* STATICS.re This module determines the statics semantics of a program. @@ -72,7 +70,7 @@ let extend_let_def_ctx = ctx; }; -let typ_exp_binop_bin_int: UExp.op_bin_int => Typ.t = +let typ_exp_binop_bin_int: Operators.op_bin_int => Typ.t = fun | (Plus | Minus | Times | Power | Divide) as _op => Int | ( @@ -81,7 +79,7 @@ let typ_exp_binop_bin_int: UExp.op_bin_int => Typ.t = ) as _op => Bool; -let typ_exp_binop_bin_float: UExp.op_bin_float => Typ.t = +let typ_exp_binop_bin_float: Operators.op_bin_float => Typ.t = fun | (Plus | Minus | Times | Power | Divide) as _op => Float | ( @@ -90,26 +88,26 @@ let typ_exp_binop_bin_float: UExp.op_bin_float => Typ.t = ) as _op => Bool; -let typ_exp_binop_bin_string: UExp.op_bin_string => Typ.t = +let typ_exp_binop_bin_string: Operators.op_bin_string => Typ.t = fun | Concat => String | Equals => Bool; -let typ_exp_binop: UExp.op_bin => (Typ.t, Typ.t, Typ.t) = +let typ_exp_binop: Operators.op_bin => (Typ.t, Typ.t, Typ.t) = fun | Bool(And | Or) => (Bool, Bool, Bool) | Int(op) => (Int, Int, typ_exp_binop_bin_int(op)) | Float(op) => (Float, Float, typ_exp_binop_bin_float(op)) | String(op) => (String, String, typ_exp_binop_bin_string(op)); -let typ_exp_unop: UExp.op_un => (Typ.t, Typ.t) = +let typ_exp_unop: Operators.op_un => (Typ.t, Typ.t) = fun | Meta(Unquote) => (Var("$Meta"), Unknown(Free("$Meta"))) | Bool(Not) => (Bool, Bool) | Int(Minus) => (Int, Int); let rec any_to_info_map = - (~ctx: Ctx.t, ~ancestors, any: any, m: Map.t): (CoCtx.t, Map.t) => + (~ctx: Ctx.t, ~ancestors, any: Any.t, m: Map.t): (CoCtx.t, Map.t) => switch (any) { | Exp(e) => let ({co_ctx, _}: Info.exp, m) = @@ -229,7 +227,7 @@ and uexp_to_info_map = m, ); | ListConcat(e1, e2) => - let ids = List.map(Term.UExp.rep_id, [e1, e2]); + let ids = List.map(UExp.rep_id, [e1, e2]); let mode = Mode.of_list_concat(ctx, mode); let (e1, m) = go(~mode, e1, m); let (e2, m) = go(~mode, e2, m); @@ -439,11 +437,11 @@ and uexp_to_info_map = //let ty_rec = Typ.Rec("α", Typ.subst(Var("α"), name, ty_pre)); let ty_rec = Typ.Rec(name, ty_pre); let ctx_def = - Ctx.extend_alias(ctx, name, UTPat.rep_id(typat), ty_rec); + Ctx.extend_alias(ctx, name, TPat.rep_id(typat), ty_rec); (ty_rec, ctx_def, ctx_def); | _ => let ty = UTyp.to_typ(ctx, utyp); - (ty, ctx, Ctx.extend_alias(ctx, name, UTPat.rep_id(typat), ty)); + (ty, ctx, Ctx.extend_alias(ctx, name, TPat.rep_id(typat), ty)); }; }; let ctx_body = @@ -614,13 +612,13 @@ and utyp_to_info_map = }; } and utpat_to_info_map = - (~ctx, ~ancestors, {ids, term} as utpat: UTPat.t, m: Map.t) + (~ctx, ~ancestors, {ids, term} as utpat: TPat.t, m: Map.t) : (Info.tpat, Map.t) => { let add = m => { let info = Info.derived_tpat(~utpat, ~ctx, ~ancestors); (info, add_info(ids, InfoTPat(info), m)); }; - let ancestors = [UTPat.rep_id(utpat)] @ ancestors; + let ancestors = [TPat.rep_id(utpat)] @ ancestors; switch (term) { | MultiHole(tms) => let (_, m) = multi(~ctx, ~ancestors, m, tms); diff --git a/src/haz3lcore/statics/Term.re b/src/haz3lcore/statics/Term.re deleted file mode 100644 index 87650ad841..0000000000 --- a/src/haz3lcore/statics/Term.re +++ /dev/null @@ -1,757 +0,0 @@ -/* TERM - - These data structures define the term structures on which - the static and dynamic semantics of the language are based. - Each sort has a corresponding U module. - - The contained cls type lists the terms of that sort, and - should be in 1-1 correspondence with the term type which - is used to build composite terms. - - This is wrapped in a record type to associate a unique id - with each term. These unique ids are the same as from the - tile structure from the syntax module, as there is a 1-1 - correspondence between terms and tiles. - - TODO: add tests to check if there are forms and/or terms - without correponding syntax classes */ - -include TermBase.Any; - -type any = t; -module UTyp = { - [@deriving (show({with_path: false}), sexp, yojson)] - type cls = - | Invalid - | EmptyHole - | MultiHole - | Int - | Float - | Bool - | String - | Arrow - | Tuple - | Sum - | List - | Var - | Constructor - | Parens - | Ap; - - include TermBase.UTyp; - - let rep_id = ({ids, _}: t) => { - assert(ids != []); - List.hd(ids); - }; - - let hole = (tms: list(any)) => - switch (tms) { - | [] => EmptyHole - | [_, ..._] => MultiHole(tms) - }; - - let cls_of_term: term => cls = - fun - | Invalid(_) => Invalid - | EmptyHole => EmptyHole - | MultiHole(_) => MultiHole - | Int => Int - | Float => Float - | Bool => Bool - | String => String - | List(_) => List - | Arrow(_) => Arrow - | Var(_) => Var - | Constructor(_) => Constructor - | Tuple(_) => Tuple - | Parens(_) => Parens - | Ap(_) => Ap - | Sum(_) => Sum; - - let show_cls: cls => string = - fun - | Invalid => "Invalid type" - | MultiHole => "Broken type" - | EmptyHole => "Empty type hole" - | Int - | Float - | String - | Bool => "Base type" - | Var => "Type variable" - | Constructor => "Sum constructor" - | List => "List type" - | Arrow => "Function type" - | Tuple => "Product type" - | Sum => "Sum type" - | Parens => "Parenthesized type" - | Ap => "Constructor application"; - - let rec is_arrow = (typ: t) => { - switch (typ.term) { - | Parens(typ) => is_arrow(typ) - | Arrow(_) => true - | Invalid(_) - | EmptyHole - | MultiHole(_) - | Int - | Float - | Bool - | String - | List(_) - | Tuple(_) - | Var(_) - | Constructor(_) - | Ap(_) - | Sum(_) => false - }; - }; - - /* Converts a syntactic type into a semantic type */ - let rec to_typ: (Ctx.t, t) => Typ.t = - (ctx, utyp) => - switch (utyp.term) { - | Invalid(_) - | MultiHole(_) => Unknown(Internal) - | EmptyHole => Unknown(TypeHole) - | Bool => Bool - | Int => Int - | Float => Float - | String => String - | Var(name) => - switch (Ctx.lookup_tvar(ctx, name)) { - | Some(_) => Var(name) - | None => Unknown(Free(name)) - } - | Arrow(u1, u2) => Arrow(to_typ(ctx, u1), to_typ(ctx, u2)) - | Tuple(us) => Prod(List.map(to_typ(ctx), us)) - | Sum(uts) => Sum(to_ctr_map(ctx, uts)) - | List(u) => List(to_typ(ctx, u)) - | Parens(u) => to_typ(ctx, u) - /* The below cases should occur only inside sums */ - | Constructor(_) - | Ap(_) => Unknown(Internal) - } - and to_variant: - (Ctx.t, variant) => option(ConstructorMap.binding(option(Typ.t))) = - ctx => - fun - | Variant(ctr, _, u) => Some((ctr, Option.map(to_typ(ctx), u))) - | BadEntry(_) => None - and to_ctr_map = (ctx: Ctx.t, uts: list(variant)): Typ.sum_map => { - List.fold_left( - (acc, ut) => - List.find_opt(((ctr, _)) => ctr == fst(ut), acc) == None - ? acc @ [ut] : acc, - [], - List.filter_map(to_variant(ctx), uts), - ); - }; -}; - -module UTPat = { - [@deriving (show({with_path: false}), sexp, yojson)] - type cls = - | Invalid - | EmptyHole - | MultiHole - | Var; - - include TermBase.UTPat; - - let rep_id = ({ids, _}) => { - assert(ids != []); - List.hd(ids); - }; - - let hole = (tms: list(any)) => - switch (tms) { - | [] => EmptyHole - | [_, ..._] => MultiHole(tms) - }; - - let cls_of_term: term => cls = - fun - | Invalid(_) => Invalid - | EmptyHole => EmptyHole - | MultiHole(_) => MultiHole - | Var(_) => Var; - - let show_cls: cls => string = - fun - | Invalid => "Invalid type alias" - | MultiHole => "Broken type alias" - | EmptyHole => "Empty type alias hole" - | Var => "Type alias"; -}; - -module UPat = { - [@deriving (show({with_path: false}), sexp, yojson)] - type cls = - | Invalid - | EmptyHole - | MultiHole - | Wild - | Int - | Float - | Bool - | String - | ListLit - | Constructor - | Cons - | Var - | Tuple - | Parens - | Ap - | TypeAnn; - - include TermBase.UPat; - - let rep_id = ({ids, _}: t) => { - assert(ids != []); - List.hd(ids); - }; - - let hole = (tms: list(any)) => - switch (tms) { - | [] => EmptyHole - | [_, ..._] => MultiHole(tms) - }; - - let cls_of_term: term => cls = - fun - | Invalid(_) => Invalid - | EmptyHole => EmptyHole - | MultiHole(_) => MultiHole - | Wild => Wild - | Int(_) => Int - | Float(_) => Float - | Bool(_) => Bool - | String(_) => String - | ListLit(_) => ListLit - | Constructor(_) => Constructor - | Cons(_) => Cons - | Var(_) => Var - | Tuple(_) => Tuple - | Parens(_) => Parens - | Ap(_) => Ap - | TypeAnn(_) => TypeAnn; - - let show_cls: cls => string = - fun - | Invalid => "Invalid pattern" - | MultiHole => "Broken pattern" - | EmptyHole => "Empty pattern hole" - | Wild => "Wildcard" - | Int => "Integer literal" - | Float => "Float literal" - | Bool => "Boolean literal" - | String => "String literal" - | ListLit => "List literal" - | Constructor => "Constructor" - | Cons => "Cons" - | Var => "Variable binding" - | Tuple => "Tuple" - | Parens => "Parenthesized pattern" - | Ap => "Constructor application" - | TypeAnn => "Annotation"; - - let rec is_var = (pat: t) => { - switch (pat.term) { - | Parens(pat) => is_var(pat) - | Var(_) => true - | TypeAnn(_) - | Invalid(_) - | EmptyHole - | MultiHole(_) - | Wild - | Int(_) - | Float(_) - | Bool(_) - | String(_) - | ListLit(_) - | Cons(_, _) - | Tuple(_) - | Constructor(_) - | Ap(_) => false - }; - }; - - let rec is_fun_var = (pat: t) => { - switch (pat.term) { - | Parens(pat) => is_fun_var(pat) - | TypeAnn(pat, typ) => is_var(pat) && UTyp.is_arrow(typ) - | Invalid(_) - | EmptyHole - | MultiHole(_) - | Wild - | Int(_) - | Float(_) - | Bool(_) - | String(_) - | ListLit(_) - | Cons(_, _) - | Var(_) - | Tuple(_) - | Constructor(_) - | Ap(_) => false - }; - }; - - let rec is_tuple_of_arrows = (pat: t) => - is_fun_var(pat) - || ( - switch (pat.term) { - | Parens(pat) => is_tuple_of_arrows(pat) - | Tuple(pats) => pats |> List.for_all(is_fun_var) - | Invalid(_) - | EmptyHole - | MultiHole(_) - | Wild - | Int(_) - | Float(_) - | Bool(_) - | String(_) - | ListLit(_) - | Cons(_, _) - | Var(_) - | TypeAnn(_) - | Constructor(_) - | Ap(_) => false - } - ); - - let rec get_var = (pat: t) => { - switch (pat.term) { - | Parens(pat) => get_var(pat) - | Var(x) => Some(x) - | TypeAnn(_) - | Invalid(_) - | EmptyHole - | MultiHole(_) - | Wild - | Int(_) - | Float(_) - | Bool(_) - | String(_) - | ListLit(_) - | Cons(_, _) - | Tuple(_) - | Constructor(_) - | Ap(_) => None - }; - }; - - let rec get_fun_var = (pat: t) => { - switch (pat.term) { - | Parens(pat) => get_fun_var(pat) - | TypeAnn(pat, typ) => - if (UTyp.is_arrow(typ)) { - get_var(pat) |> Option.map(var => var); - } else { - None; - } - | Invalid(_) - | EmptyHole - | MultiHole(_) - | Wild - | Int(_) - | Float(_) - | Bool(_) - | String(_) - | ListLit(_) - | Cons(_, _) - | Var(_) - | Tuple(_) - | Constructor(_) - | Ap(_) => None - }; - }; - - let rec get_recursive_bindings = (pat: t) => { - switch (get_fun_var(pat)) { - | Some(x) => Some([x]) - | None => - switch (pat.term) { - | Parens(pat) => get_recursive_bindings(pat) - | Tuple(pats) => - let fun_vars = pats |> List.map(get_fun_var); - if (List.exists(Option.is_none, fun_vars)) { - None; - } else { - Some(List.map(Option.get, fun_vars)); - }; - | Invalid(_) - | EmptyHole - | MultiHole(_) - | Wild - | Int(_) - | Float(_) - | Bool(_) - | String(_) - | ListLit(_) - | Cons(_, _) - | Var(_) - | TypeAnn(_) - | Constructor(_) - | Ap(_) => None - } - }; - }; - - let ctr_name = (p: t): option(Constructor.t) => - switch (p.term) { - | Constructor(name) => Some(name) - | _ => None - }; -}; - -module UExp = { - include TermBase.UExp; - - [@deriving (show({with_path: false}), sexp, yojson)] - type cls = - | Invalid - | EmptyHole - | MultiHole - | StaticErrorHole - | DynamicErrorHole - | FailedCast - | Bool - | Int - | Float - | String - | ListLit - | Constructor - | Fun - | Tuple - | Var - | MetaVar - | Let - | FixF - | TyAlias - | Ap - | Pipeline - | If - | Seq - | Test - | Filter - | Closure - | Parens - | Cons - | UnOp(op_un) - | BinOp(op_bin) - | BuiltinFun - | Match - | Cast - | ListConcat; - - let hole = (tms: list(any)): term => - switch (tms) { - | [] => EmptyHole - | [_, ..._] => MultiHole(tms) - }; - - let rep_id = ({ids, _}) => { - assert(ids != []); - List.hd(ids); - }; - - let cls_of_term: term => cls = - fun - | Invalid(_) => Invalid - | EmptyHole => EmptyHole - | MultiHole(_) => MultiHole - | StaticErrorHole(_) => StaticErrorHole - | DynamicErrorHole(_) => DynamicErrorHole - | FailedCast(_) => FailedCast - | Bool(_) => Bool - | Int(_) => Int - | Float(_) => Float - | String(_) => String - | ListLit(_) => ListLit - | Constructor(_) => Constructor - | Fun(_) => Fun - | Tuple(_) => Tuple - | Var(_) => Var - | Let(_) => Let - | FixF(_) => FixF - | TyAlias(_) => TyAlias - | Ap(_) => Ap - | If(_) => If - | Seq(_) => Seq - | Test(_) => Test - | Filter(_) => Filter - | Closure(_) => Closure - | Parens(_) => Parens - | Cons(_) => Cons - | ListConcat(_) => ListConcat - | UnOp(op, _) => UnOp(op) - | BinOp(op, _, _) => BinOp(op) - | BuiltinFun(_) => BuiltinFun - | Match(_) => Match - | Cast(_) => Cast; - - let show_op_un_meta: op_un_meta => string = - fun - | Unquote => "Un-quotation"; - - let show_op_un_bool: op_un_bool => string = - fun - | Not => "Boolean Negation"; - - let show_op_un_int: op_un_int => string = - fun - | Minus => "Integer Negation"; - - let show_unop: op_un => string = - fun - | Meta(op) => show_op_un_meta(op) - | Bool(op) => show_op_un_bool(op) - | Int(op) => show_op_un_int(op); - - let show_op_bin_bool: op_bin_bool => string = - fun - | And => "Boolean Conjunction" - | Or => "Boolean Disjunction"; - - let show_op_bin_int: op_bin_int => string = - fun - | Plus => "Integer Addition" - | Minus => "Integer Subtraction" - | Times => "Integer Multiplication" - | Power => "Integer Exponentiation" - | Divide => "Integer Division" - | LessThan => "Integer Less Than" - | LessThanOrEqual => "Integer Less Than or Equal" - | GreaterThan => "Integer Greater Than" - | GreaterThanOrEqual => "Integer Greater Than or Equal" - | Equals => "Integer Equality" - | NotEquals => "Integer Inequality"; - - let show_op_bin_float: op_bin_float => string = - fun - | Plus => "Float Addition" - | Minus => "Float Subtraction" - | Times => "Float Multiplication" - | Power => "Float Exponentiation" - | Divide => "Float Division" - | LessThan => "Float Less Than" - | LessThanOrEqual => "Float Less Than or Equal" - | GreaterThan => "Float Greater Than" - | GreaterThanOrEqual => "Float Greater Than or Equal" - | Equals => "Float Equality" - | NotEquals => "Float Inequality"; - - let show_op_bin_string: op_bin_string => string = - fun - | Concat => "String Concatenation" - | Equals => "String Equality"; - - let show_binop: op_bin => string = - fun - | Int(op) => show_op_bin_int(op) - | Float(op) => show_op_bin_float(op) - | Bool(op) => show_op_bin_bool(op) - | String(op) => show_op_bin_string(op); - - let show_cls: cls => string = - fun - | Invalid => "Invalid expression" - | MultiHole => "Broken expression" - | EmptyHole => "Empty expression hole" - | StaticErrorHole => "Static error hole" - | DynamicErrorHole => "Dynamic error hole" - | FailedCast => "Failed cast" - | Bool => "Boolean literal" - | Int => "Integer literal" - | Float => "Float literal" - | String => "String literal" - | ListLit => "List literal" - | Constructor => "Constructor" - | Fun => "Function literal" - | Tuple => "Tuple literal" - | Var => "Variable reference" - | MetaVar => "Meta variable reference" - | Let => "Let expression" - | FixF => "Fixpoint operator" - | TyAlias => "Type Alias definition" - | Ap => "Application" - | Pipeline => "Pipeline expression" - | If => "If expression" - | Seq => "Sequence expression" - | Test => "Test" - | Filter => "Filter" - | Closure => "Closure" - | Parens => "Parenthesized expression" - | Cons => "Cons" - | ListConcat => "List Concatenation" - | BinOp(op) => show_binop(op) - | UnOp(op) => show_unop(op) - | BuiltinFun => "Built-in Function" - | Match => "Case expression" - | Cast => "Cast expression"; - - let rec is_fun = (e: t) => { - switch (e.term) { - | Parens(e) => is_fun(e) - | Cast(e, _, _) => is_fun(e) - | Fun(_) - | BuiltinFun(_) => true - | Invalid(_) - | EmptyHole - | MultiHole(_) - | StaticErrorHole(_) - | DynamicErrorHole(_) - | FailedCast(_) - | Bool(_) - | Int(_) - | Float(_) - | String(_) - | ListLit(_) - | Tuple(_) - | Var(_) - | Let(_) - | FixF(_) - | TyAlias(_) - | Ap(_) - | If(_) - | Seq(_) - | Test(_) - | Filter(_) - | Cons(_) - | ListConcat(_) - | Closure(_) - | UnOp(_) - | BinOp(_) - | Match(_) - | Constructor(_) => false - }; - }; - - let rec is_tuple_of_functions = (e: t) => - is_fun(e) - || ( - switch (e.term) { - | Cast(e, _, _) - | Parens(e) => is_tuple_of_functions(e) - | Tuple(es) => es |> List.for_all(is_fun) - | Invalid(_) - | EmptyHole - | MultiHole(_) - | StaticErrorHole(_) - | DynamicErrorHole(_) - | FailedCast(_) - | Bool(_) - | Int(_) - | Float(_) - | String(_) - | ListLit(_) - | Fun(_) - | Closure(_) - | BuiltinFun(_) - | Var(_) - | Let(_) - | FixF(_) - | TyAlias(_) - | Ap(_) - | If(_) - | Seq(_) - | Test(_) - | Filter(_) - | Cons(_) - | ListConcat(_) - | UnOp(_) - | BinOp(_) - | Match(_) - | Constructor(_) => false - } - ); - - let ctr_name = (e: t): option(Constructor.t) => - switch (e.term) { - | Constructor(name) => Some(name) - | _ => None - }; -}; - -// TODO(d): consider just folding this into UExp -module URul = { - include TermBase.URul; - - [@deriving (show({with_path: false}), sexp, yojson)] - type cls = - | Rule; - - // example of awkwardness induced by having forms like rules - // that may have a different-sorted child with no delimiters - // (eg scrut with no rules) - let ids = (~any_ids, {ids, term}: t) => - switch (ids) { - | [_, ..._] => ids - | [] => - switch (term) { - | Hole([tm, ..._]) => any_ids(tm) - | Rules(scrut, []) => scrut.ids - | _ => [] - } - }; - - let rep_id = (~any_ids, tm) => - switch (ids(~any_ids, tm)) { - | [] => raise(Invalid_argument("Term.UExp.rep_id")) - | [id, ..._] => id - }; -}; - -module Cls = { - [@deriving (show({with_path: false}), sexp, yojson)] - type t = - | Exp(UExp.cls) - | Pat(UPat.cls) - | Typ(UTyp.cls) - | TPat(UTPat.cls) - | Rul(URul.cls) - | Secondary(Secondary.cls); - - let show = (cls: t) => - switch (cls) { - | Exp(cls) => UExp.show_cls(cls) - | Pat(cls) => UPat.show_cls(cls) - | Typ(cls) => UTyp.show_cls(cls) - | TPat(cls) => UTPat.show_cls(cls) - | Rul(cls) => URul.show_cls(cls) - | Secondary(cls) => Secondary.show_cls(cls) - }; -}; - -let rec ids = - fun - | Exp(tm) => tm.ids - | Pat(tm) => tm.ids - | Typ(tm) => tm.ids - | TPat(tm) => tm.ids - | Rul(tm) => URul.ids(~any_ids=ids, tm) - | Nul () - | Any () => []; - -// Terms may consist of multiple tiles, eg the commas in an n-tuple, -// the rules of a case expression + the surrounding case-end tile, -// the list brackets tile coupled with the elem-separating commas. -// The _representative id_ is the canonical tile id used to identify -// and look up info about a term. -// -// In instances like case expressions and list literals, where a parent -// tile surrounds the other tiles, the representative id is the parent tile's. -// In other instances like n-tuples, where the commas are all siblings, -// the representative id is one of the comma ids, unspecified which one. -// (This would change for n-tuples if we decided parentheses are necessary.) -let rep_id = - fun - | Exp(tm) => UExp.rep_id(tm) - | Pat(tm) => UPat.rep_id(tm) - | Typ(tm) => UTyp.rep_id(tm) - | TPat(tm) => UTPat.rep_id(tm) - | Rul(tm) => URul.rep_id(~any_ids=ids, tm) - | Nul () - | Any () => raise(Invalid_argument("Term.rep_id")); diff --git a/src/haz3lcore/statics/uterm/UExp.re b/src/haz3lcore/statics/uterm/UExp.re new file mode 100644 index 0000000000..16d6db0412 --- /dev/null +++ b/src/haz3lcore/statics/uterm/UExp.re @@ -0,0 +1 @@ +include Exp; diff --git a/src/haz3lcore/statics/uterm/UPat.re b/src/haz3lcore/statics/uterm/UPat.re new file mode 100644 index 0000000000..9bd15c6ba8 --- /dev/null +++ b/src/haz3lcore/statics/uterm/UPat.re @@ -0,0 +1 @@ +include Pat; diff --git a/src/haz3lcore/statics/uterm/UTyp.re b/src/haz3lcore/statics/uterm/UTyp.re new file mode 100644 index 0000000000..194c5270fd --- /dev/null +++ b/src/haz3lcore/statics/uterm/UTyp.re @@ -0,0 +1 @@ +include TypTerm; diff --git a/src/haz3lcore/zipper/Editor.re b/src/haz3lcore/zipper/Editor.re index 1ee7c9fd3b..b9f51d9919 100644 --- a/src/haz3lcore/zipper/Editor.re +++ b/src/haz3lcore/zipper/Editor.re @@ -9,7 +9,7 @@ module Meta = { term_ranges: TermRanges.t, unselected: Segment.t, segment: Segment.t, - view_term: Term.UExp.t, + view_term: UExp.t, terms: TermMap.t, tiles: TileMap.t, holes: list(Grout.t), diff --git a/src/haz3lschool/Exercise.re b/src/haz3lschool/Exercise.re index 8cbb7b2013..b8e32fd122 100644 --- a/src/haz3lschool/Exercise.re +++ b/src/haz3lschool/Exercise.re @@ -575,7 +575,7 @@ module F = (ExerciseEnv: ExerciseEnv) => { hidden_tests: 'a, }; - let wrap_filter = (act: FilterAction.action, term: Term.UExp.t): Term.UExp.t => + let wrap_filter = (act: FilterAction.action, term: UExp.t): UExp.t => TermBase.UExp.{ term: TermBase.UExp.Filter( @@ -598,8 +598,7 @@ module F = (ExerciseEnv: ExerciseEnv) => { term_ranges: editor.state.meta.term_ranges, }; - let term_of = (editor: Editor.t): Term.UExp.t => - editor.state.meta.view_term; + let term_of = (editor: Editor.t): UExp.t => editor.state.meta.view_term; let stitch3 = (ed1: Editor.t, ed2: Editor.t, ed3: Editor.t) => EditorUtil.append_exp( diff --git a/src/haz3lschool/SyntaxTest.re b/src/haz3lschool/SyntaxTest.re index 7c34e006fa..f53379727b 100644 --- a/src/haz3lschool/SyntaxTest.re +++ b/src/haz3lschool/SyntaxTest.re @@ -7,7 +7,7 @@ type syntax_result = { percentage: float, }; -let rec find_var_upat = (name: string, upat: Term.UPat.t): bool => { +let rec find_var_upat = (name: string, upat: UPat.t): bool => { switch (upat.term) { | Var(x) => x == name | EmptyHole @@ -29,7 +29,7 @@ let rec find_var_upat = (name: string, upat: Term.UPat.t): bool => { }; }; -let rec var_mention = (name: string, uexp: Term.UExp.t): bool => { +let rec var_mention = (name: string, uexp: UExp.t): bool => { switch (uexp.term) { | Var(x) => x == name | EmptyHole @@ -82,7 +82,7 @@ let rec var_mention = (name: string, uexp: Term.UExp.t): bool => { }; }; -let rec var_applied = (name: string, uexp: Term.UExp.t): bool => { +let rec var_applied = (name: string, uexp: UExp.t): bool => { switch (uexp.term) { | Var(_) | EmptyHole @@ -138,13 +138,8 @@ let rec var_applied = (name: string, uexp: Term.UExp.t): bool => { }; let rec find_in_let = - ( - name: string, - upat: Term.UPat.t, - def: Term.UExp.t, - l: list(Term.UExp.t), - ) - : list(Term.UExp.t) => { + (name: string, upat: UPat.t, def: UExp.t, l: list(UExp.t)) + : list(UExp.t) => { switch (upat.term, def.term) { | (Parens(up), Parens(ue)) => find_in_let(name, up, ue, l) | (Parens(up), _) => find_in_let(name, up, def, l) @@ -182,8 +177,7 @@ let rec find_in_let = }; let rec find_fn = - (name: string, uexp: Term.UExp.t, l: list(Term.UExp.t)) - : list(Term.UExp.t) => { + (name: string, uexp: UExp.t, l: list(UExp.t)): list(UExp.t) => { switch (uexp.term) { | Let(up, def, body) => l |> find_in_let(name, up, def) |> find_fn(name, body) @@ -228,7 +222,7 @@ let rec find_fn = }; }; -let is_recursive = (name: string, uexp: Term.UExp.t): bool => { +let is_recursive = (name: string, uexp: UExp.t): bool => { let fn_bodies = [] |> find_fn(name, uexp); if (List.length(fn_bodies) == 0) { false; @@ -241,7 +235,7 @@ let is_recursive = (name: string, uexp: Term.UExp.t): bool => { }; }; -let rec tail_check = (name: string, uexp: Term.UExp.t): bool => { +let rec tail_check = (name: string, uexp: UExp.t): bool => { switch (uexp.term) { | EmptyHole | Invalid(_) @@ -294,7 +288,7 @@ let rec tail_check = (name: string, uexp: Term.UExp.t): bool => { }; }; -let is_tail_recursive = (name: string, uexp: Term.UExp.t): bool => { +let is_tail_recursive = (name: string, uexp: UExp.t): bool => { let fn_bodies = [] |> find_fn(name, uexp); if (List.length(fn_bodies) == 0) { false; @@ -307,8 +301,7 @@ let is_tail_recursive = (name: string, uexp: Term.UExp.t): bool => { }; }; -let check = - (uexp: Term.UExp.t, predicates: list(Term.UExp.t => bool)): syntax_result => { +let check = (uexp: UExp.t, predicates: list(UExp.t => bool)): syntax_result => { let results = List.map(pred => {uexp |> pred}, predicates); let length = List.length(predicates); let passing = Util.ListUtil.count_pred(res => res, results); diff --git a/src/haz3lweb/Grading.re b/src/haz3lweb/Grading.re index ac7414a5a1..43e5473a65 100644 --- a/src/haz3lweb/Grading.re +++ b/src/haz3lweb/Grading.re @@ -212,7 +212,7 @@ module MutationTestingReport = { // |> Zipper.zip // |> MakeTerm.go // |> fst - // |> Term.UExp.show + // |> UExp.show // |> print_endline // |> (_ => Virtual_dom.Vdom.Effect.Ignore); diff --git a/src/haz3lweb/explainthis/ExplainThisForm.re b/src/haz3lweb/explainthis/ExplainThisForm.re index 527bedde4f..7d68fe73cb 100644 --- a/src/haz3lweb/explainthis/ExplainThisForm.re +++ b/src/haz3lweb/explainthis/ExplainThisForm.re @@ -160,8 +160,8 @@ type form_id = | IfExp | SeqExp | TestExp - | UnOpExp(Term.UExp.op_un) - | BinOpExp(Term.UExp.op_bin) + | UnOpExp(Operators.op_un) + | BinOpExp(Operators.op_bin) | CaseExp | TyAliasExp | EmptyHolePat @@ -246,8 +246,8 @@ type group_id = | IfExp | SeqExp | TestExp - | UnOpExp(Term.UExp.op_un) - | BinOpExp(Term.UExp.op_bin) + | UnOpExp(Operators.op_un) + | BinOpExp(Operators.op_bin) | CaseExp | TyAliasExp | PipelineExp diff --git a/src/haz3lweb/view/CursorInspector.re b/src/haz3lweb/view/CursorInspector.re index 2e6045b065..22112a3e08 100644 --- a/src/haz3lweb/view/CursorInspector.re +++ b/src/haz3lweb/view/CursorInspector.re @@ -26,10 +26,7 @@ let explain_this_toggle = (~inject, ~show_explain_this: bool): Node.t => { }; let cls_view = (ci: Info.t): Node.t => - div( - ~attr=clss(["syntax-class"]), - [text(ci |> Info.cls_of |> Term.Cls.show)], - ); + div(~attr=clss(["syntax-class"]), [text(ci |> Info.cls_of |> Cls.show)]); let ctx_toggle = (~inject, context_inspector: bool): Node.t => div( @@ -58,7 +55,7 @@ let term_view = (~inject, ~settings: Settings.t, ci) => { ); }; -let elements_noun: Term.Cls.t => string = +let elements_noun: Cls.t => string = fun | Exp(Match | If) => "Branches" | Exp(ListLit) @@ -66,7 +63,7 @@ let elements_noun: Term.Cls.t => string = | Exp(ListConcat) => "Operands" | _ => failwith("elements_noun: Cls doesn't have elements"); -let common_err_view = (cls: Term.Cls.t, err: Info.error_common) => +let common_err_view = (cls: Cls.t, err: Info.error_common) => switch (err) { | NoType(BadToken(token)) => switch (Form.bad_token_cls(token)) { @@ -97,7 +94,7 @@ let common_err_view = (cls: Term.Cls.t, err: Info.error_common) => ] }; -let common_ok_view = (cls: Term.Cls.t, ok: Info.ok_pat) => { +let common_ok_view = (cls: Cls.t, ok: Info.ok_pat) => { switch (cls, ok) { | (Exp(MultiHole) | Pat(MultiHole), _) => [ text("Expecting operator or delimiter"), @@ -137,7 +134,7 @@ let common_ok_view = (cls: Term.Cls.t, ok: Info.ok_pat) => { }; }; -let typ_ok_view = (cls: Term.Cls.t, ok: Info.ok_typ) => +let typ_ok_view = (cls: Cls.t, ok: Info.ok_typ) => switch (ok) { | Type(_) when cls == Typ(EmptyHole) => [text("Fillable by any type")] | Type(ty) => [Type.view(ty)] @@ -166,7 +163,7 @@ let typ_err_view = (ok: Info.error_typ) => ] }; -let exp_view = (cls: Term.Cls.t, status: Info.status_exp) => +let exp_view = (cls: Cls.t, status: Info.status_exp) => switch (status) { | InHole(FreeVariable(name)) => div_err([code_err(name), text("not found")]) @@ -174,20 +171,20 @@ let exp_view = (cls: Term.Cls.t, status: Info.status_exp) => | NotInHole(ok) => div_ok(common_ok_view(cls, ok)) }; -let pat_view = (cls: Term.Cls.t, status: Info.status_pat) => +let pat_view = (cls: Cls.t, status: Info.status_pat) => switch (status) { | InHole(ExpectedConstructor) => div_err([text("Expected a constructor")]) | InHole(Common(error)) => div_err(common_err_view(cls, error)) | NotInHole(ok) => div_ok(common_ok_view(cls, ok)) }; -let typ_view = (cls: Term.Cls.t, status: Info.status_typ) => +let typ_view = (cls: Cls.t, status: Info.status_typ) => switch (status) { | NotInHole(ok) => div_ok(typ_ok_view(cls, ok)) | InHole(err) => div_err(typ_err_view(err)) }; -let tpat_view = (_: Term.Cls.t, status: Info.status_tpat) => +let tpat_view = (_: Cls.t, status: Info.status_tpat) => switch (status) { | NotInHole(Empty) => div_ok([text("Fillable with a new alias")]) | NotInHole(Var(name)) => div_ok([Type.alias_view(name)]) @@ -200,8 +197,7 @@ let tpat_view = (_: Term.Cls.t, status: Info.status_tpat) => div_err([text("Can't shadow existing alias"), Type.view(Var(name))]) }; -let secondary_view = (cls: Term.Cls.t) => - div_ok([text(cls |> Term.Cls.show)]); +let secondary_view = (cls: Cls.t) => div_ok([text(cls |> Cls.show)]); let view_of_info = (~inject, ~settings, ci): Node.t => { let wrapper = status_view => diff --git a/src/haz3lweb/view/Deco.re b/src/haz3lweb/view/Deco.re index 0019dfa085..500702dc87 100644 --- a/src/haz3lweb/view/Deco.re +++ b/src/haz3lweb/view/Deco.re @@ -137,7 +137,7 @@ module Deco = | Some(range) => let tiles = Id.Map.find(Piece.id(p), M.terms) - |> Term.ids + |> Any.ids /* NOTE(andrew): dark_ids were originally filtered here. * Leaving this comment in place in case issues in the * future are traced back to here. diff --git a/src/haz3lweb/view/ExplainThis.re b/src/haz3lweb/view/ExplainThis.re index 405472e016..149224989a 100644 --- a/src/haz3lweb/view/ExplainThis.re +++ b/src/haz3lweb/view/ExplainThis.re @@ -1531,15 +1531,15 @@ let get_doc = | FixF(pat, body, _) => message_single( FixFExp.single( - ~pat_id=Term.UPat.rep_id(pat), - ~body_id=Term.UExp.rep_id(body), + ~pat_id=UPat.rep_id(pat), + ~body_id=UExp.rep_id(body), ), ) | Ap(Reverse, arg, fn) => message_single( PipelineExp.single( - ~arg_id=Term.UExp.rep_id(arg), - ~fn_id=Term.UExp.rep_id(fn), + ~arg_id=UExp.rep_id(arg), + ~fn_id=UExp.rep_id(fn), ), ) | Ap(Forward, x, arg) => @@ -1614,29 +1614,29 @@ let get_doc = | Filter(Filter({act: (Step, One), pat}), body) => message_single( FilterExp.filter_pause( - ~p_id=Term.UExp.rep_id(pat), - ~body_id=Term.UExp.rep_id(body), + ~p_id=UExp.rep_id(pat), + ~body_id=UExp.rep_id(body), ), ) | Filter(Filter({act: (Step, All), pat}), body) => message_single( FilterExp.filter_debug( - ~p_id=Term.UExp.rep_id(pat), - ~body_id=Term.UExp.rep_id(body), + ~p_id=UExp.rep_id(pat), + ~body_id=UExp.rep_id(body), ), ) | Filter(Filter({act: (Eval, All), pat}), body) => message_single( FilterExp.filter_eval( - ~p_id=Term.UExp.rep_id(pat), - ~body_id=Term.UExp.rep_id(body), + ~p_id=UExp.rep_id(pat), + ~body_id=UExp.rep_id(body), ), ) | Filter(Filter({act: (Eval, One), pat}), body) => message_single( FilterExp.filter_hide( - ~p_id=Term.UExp.rep_id(pat), - ~body_id=Term.UExp.rep_id(body), + ~p_id=UExp.rep_id(pat), + ~body_id=UExp.rep_id(body), ), ) | Filter(_) => simple("Internal expression") @@ -1718,7 +1718,7 @@ let get_doc = OpExp.int_un_minus, ); | Meta(Unquote) => - message_single(FilterExp.unquote(~sel_id=Term.UExp.rep_id(exp))) + message_single(FilterExp.unquote(~sel_id=UExp.rep_id(exp))) } | BinOp(op, left, right) => open OpExp; @@ -2282,7 +2282,7 @@ let view = ~title= switch (info) { | None => "Whitespace or Comment" - | Some(info) => Info.cls_of(info) |> Term.Cls.show + | Some(info) => Info.cls_of(info) |> Cls.show }, syn_form @ explanation, ), diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index 1b4a9d1407..4daaa9f3cb 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -3,13 +3,13 @@ open EvaluatorStep; open Transition; module Doc = Pretty.Doc; -let precedence_bin_bool_op = (op: TermBase.UExp.op_bin_bool) => +let precedence_bin_bool_op = (op: Operators.op_bin_bool) => switch (op) { | And => DHDoc_common.precedence_And | Or => DHDoc_common.precedence_Or }; -let precedence_bin_int_op = (bio: TermBase.UExp.op_bin_int) => +let precedence_bin_int_op = (bio: Operators.op_bin_int) => switch (bio) { | Times => DHDoc_common.precedence_Times | Power => DHDoc_common.precedence_Power @@ -23,7 +23,7 @@ let precedence_bin_int_op = (bio: TermBase.UExp.op_bin_int) => | GreaterThan => DHDoc_common.precedence_GreaterThan | GreaterThanOrEqual => DHDoc_common.precedence_GreaterThan }; -let precedence_bin_float_op = (bfo: TermBase.UExp.op_bin_float) => +let precedence_bin_float_op = (bfo: Operators.op_bin_float) => switch (bfo) { | Times => DHDoc_common.precedence_Times | Power => DHDoc_common.precedence_Power @@ -37,7 +37,7 @@ let precedence_bin_float_op = (bfo: TermBase.UExp.op_bin_float) => | GreaterThan => DHDoc_common.precedence_GreaterThan | GreaterThanOrEqual => DHDoc_common.precedence_GreaterThan }; -let precedence_bin_string_op = (bso: TermBase.UExp.op_bin_string) => +let precedence_bin_string_op = (bso: Operators.op_bin_string) => switch (bso) { | Concat => DHDoc_common.precedence_Plus | Equals => DHDoc_common.precedence_Equals @@ -86,17 +86,17 @@ let rec precedence = (~show_casts: bool, d: DHExp.t) => { }; }; -let mk_bin_bool_op = (op: TermBase.UExp.op_bin_bool): DHDoc.t => - Doc.text(TermBase.UExp.bool_op_to_string(op)); +let mk_bin_bool_op = (op: Operators.op_bin_bool): DHDoc.t => + Doc.text(Operators.bool_op_to_string(op)); -let mk_bin_int_op = (op: TermBase.UExp.op_bin_int): DHDoc.t => - Doc.text(TermBase.UExp.int_op_to_string(op)); +let mk_bin_int_op = (op: Operators.op_bin_int): DHDoc.t => + Doc.text(Operators.int_op_to_string(op)); -let mk_bin_float_op = (op: TermBase.UExp.op_bin_float): DHDoc.t => - Doc.text(TermBase.UExp.float_op_to_string(op)); +let mk_bin_float_op = (op: Operators.op_bin_float): DHDoc.t => + Doc.text(Operators.float_op_to_string(op)); -let mk_bin_string_op = (op: TermBase.UExp.op_bin_string): DHDoc.t => - Doc.text(TermBase.UExp.string_op_to_string(op)); +let mk_bin_string_op = (op: Operators.op_bin_string): DHDoc.t => + Doc.text(Operators.string_op_to_string(op)); let mk = ( diff --git a/src/test/Test_Elaboration.re b/src/test/Test_Elaboration.re index 9f0739e087..f6b1d9271d 100644 --- a/src/test/Test_Elaboration.re +++ b/src/test/Test_Elaboration.re @@ -24,7 +24,7 @@ let mk_map = CoreSettings.on |> Interface.Statics.mk_map; let dhexp_of_uexp = u => Elaborator.dhexp_of_uexp(mk_map(u), u, false); let alco_check = dhexp_typ |> Alcotest.check; -let u1: Term.UExp.t = {ids: [id_at(0)], copied: false, term: Int(8)}; +let u1: UExp.t = {ids: [id_at(0)], copied: false, term: Int(8)}; let single_integer = () => alco_check( "Integer literal 8", @@ -32,11 +32,11 @@ let single_integer = () => dhexp_of_uexp(u1), ); -let u2: Term.UExp.t = {ids: [id_at(0)], copied: false, term: EmptyHole}; +let u2: UExp.t = {ids: [id_at(0)], copied: false, term: EmptyHole}; let empty_hole = () => alco_check("Empty hole", Some(EmptyHole |> fresh), dhexp_of_uexp(u2)); -let u3: Term.UExp.t = { +let u3: UExp.t = { ids: [id_at(0)], copied: false, term: Parens({ids: [id_at(1)], copied: false, term: Var("y")}), @@ -49,7 +49,7 @@ let free_var = () => dhexp_of_uexp(u3), ); -let u4: Term.UExp.t = { +let u4: UExp.t = { ids: [id_at(0)], copied: false, term: @@ -97,7 +97,7 @@ let let_exp = () => dhexp_of_uexp(u4), ); -let u5: Term.UExp.t = { +let u5: UExp.t = { ids: [id_at(0)], copied: false, term: @@ -121,7 +121,7 @@ let bin_op = () => dhexp_of_uexp(u5), ); -let u6: Term.UExp.t = { +let u6: UExp.t = { ids: [id_at(0)], copied: false, term: @@ -140,7 +140,7 @@ let consistent_if = () => dhexp_of_uexp(u6), ); -let u7: Term.UExp.t = { +let u7: UExp.t = { ids: [id_at(0)], copied: false, term: @@ -194,7 +194,7 @@ let ap_fun = () => dhexp_of_uexp(u7), ); -let u8: Term.UExp.t = { +let u8: UExp.t = { ids: [id_at(0)], copied: false, term: @@ -237,7 +237,7 @@ let inconsistent_case = () => dhexp_of_uexp(u8), ); -let u9: Term.UExp.t = { +let u9: UExp.t = { ids: [id_at(0)], copied: false, term: From 8fcd42c19fad63cefe132561ab0ae9c711556507 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Fri, 1 Mar 2024 16:06:35 -0500 Subject: [PATCH 043/103] Rename DHExp to DExp Revert "Rename DHExp to DExp" This reverts commit 22925be5cade444d882b70ec6d9089d5c603ea46. Revert "Rename DHExp to DExp" This reverts commit 22925be5cade444d882b70ec6d9089d5c603ea46. Fix capitalization --- docs/overview.md | 4 +- src/haz3lcore/dynamics/Builtins.re | 54 ++-- src/haz3lcore/dynamics/DH.re | 4 +- src/haz3lcore/dynamics/DHExp.re | 2 +- src/haz3lcore/dynamics/Elaborator.re | 112 +++---- src/haz3lcore/dynamics/EvalCtx.re | 49 ++- src/haz3lcore/dynamics/Evaluator.re | 20 +- src/haz3lcore/dynamics/Evaluator.rei | 12 +- src/haz3lcore/dynamics/EvaluatorError.re | 18 +- src/haz3lcore/dynamics/EvaluatorError.rei | 18 +- src/haz3lcore/dynamics/EvaluatorResult.re | 6 +- src/haz3lcore/dynamics/EvaluatorResult.rei | 10 +- src/haz3lcore/dynamics/EvaluatorStep.re | 28 +- src/haz3lcore/dynamics/FilterMatcher.re | 14 +- src/haz3lcore/dynamics/MetaVarInst.re | 2 +- src/haz3lcore/dynamics/MetaVarInst.rei | 2 +- src/haz3lcore/dynamics/PatternMatch.re | 38 +-- src/haz3lcore/dynamics/PatternMatch.rei | 2 +- src/haz3lcore/dynamics/Stepper.re | 16 +- src/haz3lcore/dynamics/Substitution.re | 17 +- src/haz3lcore/dynamics/Substitution.rei | 4 +- src/haz3lcore/dynamics/TestMap.re | 2 +- src/haz3lcore/dynamics/Transition.re | 68 ++--- src/haz3lcore/dynamics/TypeAssignment.re | 4 +- src/haz3lcore/dynamics/ValueChecker.re | 4 +- src/haz3lcore/dynamics/dterm/DExp.re | 299 +++++++++++++++++++ src/haz3lcore/prog/Interface.re | 4 +- src/haz3lcore/prog/ModelResult.re | 2 +- src/haz3lcore/tiles/Id.re | 2 +- src/haz3lweb/view/Cell.re | 2 +- src/haz3lweb/view/StepperView.re | 2 +- src/haz3lweb/view/dhcode/DHCode.re | 2 +- src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 32 +- src/test/Test_Elaboration.re | 30 +- 34 files changed, 588 insertions(+), 297 deletions(-) create mode 100644 src/haz3lcore/dynamics/dterm/DExp.re diff --git a/docs/overview.md b/docs/overview.md index 1a3299cc2d..56c20771cb 100644 --- a/docs/overview.md +++ b/docs/overview.md @@ -14,7 +14,7 @@ Code in `hazelcore`should be pure OCaml. ## Module Organization Users edit external expressions, of type `UHExp.t`, via edit actions. External -expressions are elaborated to internal expressions, of type `DHExp.t`, for +expressions are elaborated to internal expressions, of type `DExp.t`, for evaluation. The external and internal languages share a type system. Types are of type `Typ.t`. @@ -44,7 +44,7 @@ of type `Typ.t`. - `IDGen` - `TextShape` - dynamics - - internal syntax: `DHExp`, `DHPat` + - internal syntax: `DExp`, `DHPat` - external expressions are for editing - need to elaborate external expressions to internal in order to insert casts and closure information diff --git a/src/haz3lcore/dynamics/Builtins.re b/src/haz3lcore/dynamics/Builtins.re index 11c93f4133..d6f12d8d79 100644 --- a/src/haz3lcore/dynamics/Builtins.re +++ b/src/haz3lcore/dynamics/Builtins.re @@ -1,4 +1,4 @@ -open DHExp; +open DExp; /* Built-in functions for Hazel. @@ -11,43 +11,43 @@ open DHExp; [@deriving (show({with_path: false}), sexp, yojson)] type builtin = - | Const(Typ.t, DHExp.t) - | Fn(Typ.t, Typ.t, DHExp.t => DHExp.t); + | Const(Typ.t, DExp.t) + | Fn(Typ.t, Typ.t, DExp.t => DExp.t); [@deriving (show({with_path: false}), sexp, yojson)] type t = VarMap.t_(builtin); [@deriving (show({with_path: false}), sexp, yojson)] -type forms = VarMap.t_(DHExp.t => DHExp.t); +type forms = VarMap.t_(DExp.t => DExp.t); -type result = Result.t(DHExp.t, EvaluatorError.t); +type result = Result.t(DExp.t, EvaluatorError.t); -let const = (name: Var.t, typ: Typ.t, v: DHExp.t, builtins: t): t => +let const = (name: Var.t, typ: Typ.t, v: DExp.t, builtins: t): t => VarMap.extend(builtins, (name, Const(typ, v))); let fn = - (name: Var.t, t1: Typ.t, t2: Typ.t, impl: DHExp.t => DHExp.t, builtins: t) + (name: Var.t, t1: Typ.t, t2: Typ.t, impl: DExp.t => DExp.t, builtins: t) : t => VarMap.extend(builtins, (name, Fn(t1, t2, impl))); module Pervasives = { module Impls = { /* constants */ - let infinity = DHExp.Float(Float.infinity) |> fresh; - let neg_infinity = DHExp.Float(Float.neg_infinity) |> fresh; - let nan = DHExp.Float(Float.nan) |> fresh; - let epsilon_float = DHExp.Float(epsilon_float) |> fresh; - let pi = DHExp.Float(Float.pi) |> fresh; - let max_int = DHExp.Int(Int.max_int) |> fresh; - let min_int = DHExp.Int(Int.min_int) |> fresh; - - let unary = (f: DHExp.t => result, d: DHExp.t) => { + let infinity = DExp.Float(Float.infinity) |> fresh; + let neg_infinity = DExp.Float(Float.neg_infinity) |> fresh; + let nan = DExp.Float(Float.nan) |> fresh; + let epsilon_float = DExp.Float(epsilon_float) |> fresh; + let pi = DExp.Float(Float.pi) |> fresh; + let max_int = DExp.Int(Int.max_int) |> fresh; + let min_int = DExp.Int(Int.min_int) |> fresh; + + let unary = (f: DExp.t => result, d: DExp.t) => { switch (f(d)) { | Ok(r') => r' | Error(e) => EvaluatorError.Exception(e) |> raise }; }; - let binary = (f: (DHExp.t, DHExp.t) => result, d: DHExp.t) => { + let binary = (f: (DExp.t, DExp.t) => result, d: DExp.t) => { switch (term_of(d)) { | Tuple([d1, d2]) => switch (f(d1, d2)) { @@ -58,7 +58,7 @@ module Pervasives = { }; }; - let ternary = (f: (DHExp.t, DHExp.t, DHExp.t) => result, d: DHExp.t) => { + let ternary = (f: (DExp.t, DExp.t, DExp.t) => result, d: DExp.t) => { switch (term_of(d)) { | Tuple([d1, d2, d3]) => switch (f(d1, d2, d3)) { @@ -164,16 +164,16 @@ module Pervasives = { let atan = float_op(atan); let of_string = - (convert: string => option('a), wrap: 'a => DHExp.t, name: string) => + (convert: string => option('a), wrap: 'a => DExp.t, name: string) => unary(d => switch (term_of(d)) { | String(s) => switch (convert(s)) { | Some(n) => Ok(wrap(n)) | None => - let d' = DHExp.BuiltinFun(name) |> DHExp.fresh; - let d' = DHExp.Ap(Forward, d', d) |> DHExp.fresh; - let d' = DynamicErrorHole(d', InvalidOfString) |> DHExp.fresh; + let d' = DExp.BuiltinFun(name) |> DExp.fresh; + let d' = DExp.Ap(Forward, d', d) |> DExp.fresh; + let d' = DynamicErrorHole(d', InvalidOfString) |> DExp.fresh; Ok(d'); } | _ => Error(InvalidBoxedStringLit(d)) @@ -181,11 +181,11 @@ module Pervasives = { ); let int_of_string = - of_string(int_of_string_opt, n => Int(n) |> DHExp.fresh); + of_string(int_of_string_opt, n => Int(n) |> DExp.fresh); let float_of_string = - of_string(float_of_string_opt, f => Float(f) |> DHExp.fresh); + of_string(float_of_string_opt, f => Float(f) |> DExp.fresh); let bool_of_string = - of_string(bool_of_string_opt, b => Bool(b) |> DHExp.fresh); + of_string(bool_of_string_opt, b => Bool(b) |> DExp.fresh); let int_mod = (name, d1) => binary( @@ -195,7 +195,7 @@ module Pervasives = { Ok( fresh( DynamicErrorHole( - DHExp.Ap(Forward, DHExp.BuiltinFun(name) |> fresh, d1) + DExp.Ap(Forward, DExp.BuiltinFun(name) |> fresh, d1) |> fresh, DivideByZero, ), @@ -236,7 +236,7 @@ module Pervasives = { } ); - let string_of: DHExp.t => option(string) = + let string_of: DExp.t => option(string) = d => switch (term_of(d)) { | String(s) => Some(s) diff --git a/src/haz3lcore/dynamics/DH.re b/src/haz3lcore/dynamics/DH.re index 91f0f9c714..8fc73c3335 100644 --- a/src/haz3lcore/dynamics/DH.re +++ b/src/haz3lcore/dynamics/DH.re @@ -8,7 +8,7 @@ */ /* - DHExps that can appear during evaluation, and thus won't have static information. + DExps that can appear during evaluation, and thus won't have static information. - Closure - Var [for mutual recursion; could probably get rid of if needed...] @@ -33,7 +33,7 @@ */ -module DHExp: { +module DExp: { include (module type of TermBase.UExp); let rep_id: t => Id.t; diff --git a/src/haz3lcore/dynamics/DHExp.re b/src/haz3lcore/dynamics/DHExp.re index ca152a800e..9a2863aa97 100644 --- a/src/haz3lcore/dynamics/DHExp.re +++ b/src/haz3lcore/dynamics/DHExp.re @@ -1 +1 @@ -include DH.DHExp; +include DH.DExp; diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 46e9dd1818..e9ee38ce92 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -20,7 +20,7 @@ open OptUtil.Syntax; module Elaboration = { [@deriving (show({with_path: false}), sexp, yojson)] type t = { - d: DHExp.t, + d: DExp.t, info_map: Statics.Map.t, }; }; @@ -28,7 +28,7 @@ module Elaboration = { module ElaborationResult = { [@deriving sexp] type t = - | Elaborates(DHExp.t, Typ.t, Delta.t) + | Elaborates(DExp.t, Typ.t, Delta.t) | DoesNotElaborate; }; @@ -44,13 +44,13 @@ let fixed_pat_typ = (m: Statics.Map.t, p: UPat.t): option(Typ.t) => | _ => None }; -let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => +let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DExp.t) => switch (mode) { | Syn => d | SynFun => switch (self_ty) { | Unknown(prov) => - DHExp.fresh_cast( + DExp.fresh_cast( d, Unknown(prov), Arrow(Unknown(prov), Unknown(prov)), @@ -61,55 +61,55 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => | Ana(ana_ty) => let ana_ty = Typ.normalize(ctx, ana_ty); /* Forms with special ana rules get cast from their appropriate Matched types */ - switch (DHExp.term_of(d)) { + switch (DExp.term_of(d)) { | ListLit(_) | ListConcat(_) | Cons(_) => switch (ana_ty) { | Unknown(prov) => - DHExp.fresh_cast(d, List(Unknown(prov)), Unknown(prov)) + DExp.fresh_cast(d, List(Unknown(prov)), Unknown(prov)) | _ => d } | Fun(_) => /* See regression tests in Documentation/Dynamics */ let (_, ana_out) = Typ.matched_arrow(ctx, ana_ty); let (self_in, _) = Typ.matched_arrow(ctx, self_ty); - DHExp.fresh_cast(d, Arrow(self_in, ana_out), ana_ty); + DExp.fresh_cast(d, Arrow(self_in, ana_out), ana_ty); | Tuple(ds) => switch (ana_ty) { | Unknown(prov) => let us = List.init(List.length(ds), _ => Typ.Unknown(prov)); - DHExp.fresh_cast(d, Prod(us), Unknown(prov)); + DExp.fresh_cast(d, Prod(us), Unknown(prov)); | _ => d } | Constructor(_) => switch (ana_ty, self_ty) { | (Unknown(prov), Rec(_, Sum(_))) | (Unknown(prov), Sum(_)) => - DHExp.fresh_cast(d, self_ty, Unknown(prov)) + DExp.fresh_cast(d, self_ty, Unknown(prov)) | _ => d } | Ap(_, f, _) => - switch (DHExp.term_of(f)) { + switch (DExp.term_of(f)) { | Constructor(_) => switch (ana_ty, self_ty) { | (Unknown(prov), Rec(_, Sum(_))) | (Unknown(prov), Sum(_)) => - DHExp.fresh_cast(d, self_ty, Unknown(prov)) + DExp.fresh_cast(d, self_ty, Unknown(prov)) | _ => d } | StaticErrorHole(_, g) => - switch (DHExp.term_of(g)) { + switch (DExp.term_of(g)) { | Constructor(_) => switch (ana_ty, self_ty) { | (Unknown(prov), Rec(_, Sum(_))) | (Unknown(prov), Sum(_)) => - DHExp.fresh_cast(d, self_ty, Unknown(prov)) + DExp.fresh_cast(d, self_ty, Unknown(prov)) | _ => d } - | _ => DHExp.fresh_cast(d, self_ty, ana_ty) + | _ => DExp.fresh_cast(d, self_ty, ana_ty) } - | _ => DHExp.fresh_cast(d, self_ty, ana_ty) + | _ => DExp.fresh_cast(d, self_ty, ana_ty) } /* Forms with special ana rules but no particular typing requirements */ | Match(_) @@ -122,7 +122,7 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => | EmptyHole | MultiHole(_) | StaticErrorHole(_) => d - /* DHExp-specific forms: Don't cast */ + /* DExp-specific forms: Don't cast */ | Cast(_) | Closure(_) | Filter(_) @@ -139,13 +139,13 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => | UnOp(_) | BinOp(_) | TyAlias(_) - | Test(_) => DHExp.fresh_cast(d, self_ty, ana_ty) + | Test(_) => DExp.fresh_cast(d, self_ty, ana_ty) }; }; /* Handles cast insertion and non-empty-hole wrapping for elaborated expressions */ -let wrap = (ctx: Ctx.t, u: Id.t, mode: Mode.t, self, d: DHExp.t): DHExp.t => +let wrap = (ctx: Ctx.t, u: Id.t, mode: Mode.t, self, d: DExp.t): DExp.t => switch (Info.status_exp(ctx, mode, self)) { | NotInHole(_) => let self_ty = @@ -159,11 +159,11 @@ let wrap = (ctx: Ctx.t, u: Id.t, mode: Mode.t, self, d: DHExp.t): DHExp.t => Common(Inconsistent(Internal(_))), ) => d | InHole(Common(Inconsistent(Expectation(_) | WithArrow(_)))) => - DHExp.fresh(StaticErrorHole(u, d)) + DExp.fresh(StaticErrorHole(u, d)) }; let rec dhexp_of_uexp = - (m: Statics.Map.t, uexp: UExp.t, in_filter: bool): option(DHExp.t) => { + (m: Statics.Map.t, uexp: UExp.t, in_filter: bool): option(DExp.t) => { let dhexp_of_uexp = (~in_filter=in_filter, m, uexp) => { dhexp_of_uexp(m, uexp, in_filter); }; @@ -171,16 +171,16 @@ let rec dhexp_of_uexp = | Some(InfoExp({mode, self, ctx, _})) => let err_status = Info.status_exp(ctx, mode, self); let id = UExp.rep_id(uexp); /* NOTE: using term uids for hole ids */ - let rewrap = DHExp.mk(uexp.ids); - let+ d: DHExp.t = + let rewrap = DExp.mk(uexp.ids); + let+ d: DExp.t = switch (uexp.term) { // TODO: make closure actually convert | Closure(_, d) => dhexp_of_uexp(m, d) | Cast(d1, t1, t2) => let+ d1' = dhexp_of_uexp(m, d1); Cast(d1', t1, t2) |> rewrap; - | Invalid(t) => Some(DHExp.Invalid(t) |> rewrap) - | EmptyHole => Some(DHExp.EmptyHole |> rewrap) + | Invalid(t) => Some(DExp.Invalid(t) |> rewrap) + | EmptyHole => Some(DExp.EmptyHole |> rewrap) | MultiHole(_: list(TermBase.Any.t)) => Some(EmptyHole |> rewrap) // switch ( // us @@ -190,18 +190,18 @@ let rec dhexp_of_uexp = // | _ => None, // ) // ) { - // | [] => Some(DHExp.EmptyHole |> rewrap) + // | [] => Some(DExp.EmptyHole |> rewrap) // | us => // let+ ds = us |> List.map(dhexp_of_uexp(m)) |> OptUtil.sequence; - // DHExp.MultiHole(ds) |> rewrap; + // DExp.MultiHole(ds) |> rewrap; // } | StaticErrorHole(_, e) => dhexp_of_uexp(m, e) | DynamicErrorHole(e, err) => let+ d1 = dhexp_of_uexp(m, e); - DHExp.DynamicErrorHole(d1, err) |> rewrap; + DExp.DynamicErrorHole(d1, err) |> rewrap; | FailedCast(e, t1, t2) => let+ d1 = dhexp_of_uexp(m, e); - DHExp.FailedCast(d1, t1, t2) |> rewrap; + DExp.FailedCast(d1, t1, t2) |> rewrap; /* TODO: add a dhexp case and eval logic for multiholes. Make sure new dhexp form is properly considered Indet to avoid casting issues. */ @@ -211,61 +211,61 @@ let rec dhexp_of_uexp = | String(s) => Some(String(s) |> rewrap) | ListLit(es) => let+ ds = es |> List.map(dhexp_of_uexp(m)) |> OptUtil.sequence; - DHExp.ListLit(ds) |> rewrap; + DExp.ListLit(ds) |> rewrap; | Fun(p, body, _, _) => let+ d1 = dhexp_of_uexp(m, body); - DHExp.Fun(p, d1, None, None) |> rewrap; + DExp.Fun(p, d1, None, None) |> rewrap; | Tuple(es) => let+ ds = es |> List.map(dhexp_of_uexp(m)) |> OptUtil.sequence; - DHExp.Tuple(ds) |> rewrap; + DExp.Tuple(ds) |> rewrap; | Cons(e1, e2) => let* dc1 = dhexp_of_uexp(m, e1); let+ dc2 = dhexp_of_uexp(m, e2); - DHExp.Cons(dc1, dc2) |> rewrap; + DExp.Cons(dc1, dc2) |> rewrap; | ListConcat(e1, e2) => let* dc1 = dhexp_of_uexp(m, e1); let+ dc2 = dhexp_of_uexp(m, e2); - DHExp.ListConcat(dc1, dc2) |> rewrap; + DExp.ListConcat(dc1, dc2) |> rewrap; | UnOp(Meta(Unquote), e) => switch (e.term) { - | Var("e") when in_filter => Some(Constructor("$e") |> DHExp.fresh) - | Var("v") when in_filter => Some(Constructor("$v") |> DHExp.fresh) - | _ => Some(DHExp.EmptyHole |> rewrap) + | Var("e") when in_filter => Some(Constructor("$e") |> DExp.fresh) + | Var("v") when in_filter => Some(Constructor("$v") |> DExp.fresh) + | _ => Some(DExp.EmptyHole |> rewrap) } | UnOp(Int(Minus), e) => let+ dc = dhexp_of_uexp(m, e); - DHExp.UnOp(Int(Minus), dc) |> rewrap; + DExp.UnOp(Int(Minus), dc) |> rewrap; | UnOp(Bool(Not), e) => let+ dc = dhexp_of_uexp(m, e); - DHExp.UnOp(Bool(Not), dc) |> rewrap; + DExp.UnOp(Bool(Not), dc) |> rewrap; | BinOp(op, e1, e2) => let* dc1 = dhexp_of_uexp(m, e1); let+ dc2 = dhexp_of_uexp(m, e2); - DHExp.BinOp(op, dc1, dc2) |> rewrap; - | BuiltinFun(name) => Some(DHExp.BuiltinFun(name) |> rewrap) + DExp.BinOp(op, dc1, dc2) |> rewrap; + | BuiltinFun(name) => Some(DExp.BuiltinFun(name) |> rewrap) | Parens(e) => dhexp_of_uexp(m, e) | Seq(e1, e2) => let* d1 = dhexp_of_uexp(m, e1); let+ d2 = dhexp_of_uexp(m, e2); - DHExp.Seq(d1, d2) |> rewrap; + DExp.Seq(d1, d2) |> rewrap; | Test(test) => let+ dtest = dhexp_of_uexp(m, test); - DHExp.Test(dtest) |> rewrap; + DExp.Test(dtest) |> rewrap; | Filter(Filter({act, pat: cond}), body) => let* dcond = dhexp_of_uexp(~in_filter=true, m, cond); let+ dbody = dhexp_of_uexp(m, body); - DHExp.Filter(Filter({act, pat: dcond}), dbody) |> rewrap; + DExp.Filter(Filter({act, pat: dcond}), dbody) |> rewrap; | Filter(Residue(_) as residue, body) => let+ dbody = dhexp_of_uexp(m, body); - DHExp.Filter(residue, dbody) |> rewrap; + DExp.Filter(residue, dbody) |> rewrap; | Var(name) => Some(Var(name) |> rewrap) | Constructor(name) => Some(Constructor(name) |> rewrap) | Let(p, def, body) => - let add_name: (option(string), DHExp.t) => DHExp.t = ( + let add_name: (option(string), DExp.t) => DExp.t = ( (name, d) => { - let (term, rewrap) = DHExp.unwrap(d); + let (term, rewrap) = DExp.unwrap(d); switch (term) { - | Fun(p, e, ctx, _) => DHExp.Fun(p, e, ctx, name) |> rewrap + | Fun(p, e, ctx, _) => DExp.Fun(p, e, ctx, name) |> rewrap | _ => d }; } @@ -275,23 +275,23 @@ let rec dhexp_of_uexp = switch (UPat.get_recursive_bindings(p)) { | None => /* not recursive */ - DHExp.Let(p, add_name(UPat.get_var(p), ddef), dbody) |> rewrap + DExp.Let(p, add_name(UPat.get_var(p), ddef), dbody) |> rewrap | Some(b) => - DHExp.Let( + DExp.Let( p, FixF(p, add_name(Some(String.concat(",", b)), ddef), None) - |> DHExp.fresh, + |> DExp.fresh, dbody, ) |> rewrap }; | FixF(p, e, _) => let+ de = dhexp_of_uexp(m, e); - DHExp.FixF(p, de, None) |> rewrap; + DExp.FixF(p, de, None) |> rewrap; | Ap(dir, fn, arg) => let* c_fn = dhexp_of_uexp(m, fn); let+ c_arg = dhexp_of_uexp(m, arg); - DHExp.Ap(dir, c_fn, c_arg) |> rewrap; + DExp.Ap(dir, c_fn, c_arg) |> rewrap; | If(c, e1, e2) => let* c' = dhexp_of_uexp(m, c); let* d1 = dhexp_of_uexp(m, e1); @@ -299,8 +299,8 @@ let rec dhexp_of_uexp = // Use tag to mark inconsistent branches switch (err_status) { | InHole(Common(Inconsistent(Internal(_)))) => - DHExp.If(c', d1, d2) |> rewrap - | _ => DHExp.If(c', d1, d2) |> rewrap + DExp.If(c', d1, d2) |> rewrap + | _ => DExp.If(c', d1, d2) |> rewrap }; | Match(scrut, rules) => let* d_scrut = dhexp_of_uexp(m, scrut); @@ -315,8 +315,8 @@ let rec dhexp_of_uexp = |> OptUtil.sequence; switch (err_status) { | InHole(Common(Inconsistent(Internal(_)))) => - DHExp.Match(d_scrut, d_rules) |> rewrap - | _ => DHExp.Match(d_scrut, d_rules) |> rewrap + DExp.Match(d_scrut, d_rules) |> rewrap + | _ => DExp.Match(d_scrut, d_rules) |> rewrap }; | TyAlias(_, _, e) => dhexp_of_uexp(m, e) }; diff --git a/src/haz3lcore/dynamics/EvalCtx.re b/src/haz3lcore/dynamics/EvalCtx.re index 6efd8d9a68..8a85ea9def 100644 --- a/src/haz3lcore/dynamics/EvalCtx.re +++ b/src/haz3lcore/dynamics/EvalCtx.re @@ -6,41 +6,38 @@ open DH; type term = | Closure([@show.opaque] ClosureEnvironment.t, t) | Filter(TermBase.StepperFilterKind.t, t) - | Seq1(t, DHExp.t) - | Seq2(DHExp.t, t) - | Let1(TermBase.UPat.t, t, DHExp.t) - | Let2(TermBase.UPat.t, DHExp.t, t) + | Seq1(t, DExp.t) + | Seq2(DExp.t, t) + | Let1(TermBase.UPat.t, t, DExp.t) + | Let2(TermBase.UPat.t, DExp.t, t) | Fun(TermBase.UPat.t, t, option(ClosureEnvironment.t), option(Var.t)) | FixF(TermBase.UPat.t, t, option(ClosureEnvironment.t)) - | Ap1(Operators.ap_direction, t, DHExp.t) - | Ap2(Operators.ap_direction, DHExp.t, t) - | If1(t, DHExp.t, DHExp.t) - | If2(DHExp.t, t, DHExp.t) - | If3(DHExp.t, DHExp.t, t) + | Ap1(Operators.ap_direction, t, DExp.t) + | Ap2(Operators.ap_direction, DExp.t, t) + | If1(t, DExp.t, DExp.t) + | If2(DExp.t, t, DExp.t) + | If3(DExp.t, DExp.t, t) | UnOp(Operators.op_un, t) - | BinOp1(Operators.op_bin, t, DHExp.t) - | BinOp2(Operators.op_bin, DHExp.t, t) - | Tuple(t, (list(DHExp.t), list(DHExp.t))) + | BinOp1(Operators.op_bin, t, DExp.t) + | BinOp2(Operators.op_bin, DExp.t, t) + | Tuple(t, (list(DExp.t), list(DExp.t))) | Test(t) - | ListLit(t, (list(DHExp.t), list(DHExp.t))) + | ListLit(t, (list(DExp.t), list(DExp.t))) | MultiHole(t, (list(TermBase.Any.t), list(TermBase.Any.t))) - | Cons1(t, DHExp.t) - | Cons2(DHExp.t, t) - | ListConcat1(t, DHExp.t) - | ListConcat2(DHExp.t, t) + | Cons1(t, DExp.t) + | Cons2(DExp.t, t) + | ListConcat1(t, DExp.t) + | ListConcat2(DExp.t, t) | StaticErrorHole(Id.t, t) | Cast(t, Typ.t, Typ.t) | FailedCast(t, Typ.t, Typ.t) | DynamicErrorHole(t, InvalidOperationError.t) - | MatchScrut(t, list((TermBase.UPat.t, DHExp.t))) + | MatchScrut(t, list((TermBase.UPat.t, DExp.t))) | MatchRule( - DHExp.t, + DExp.t, TermBase.UPat.t, t, - ( - list((TermBase.UPat.t, DHExp.t)), - list((TermBase.UPat.t, DHExp.t)), - ), + (list((TermBase.UPat.t, DExp.t)), list((TermBase.UPat.t, DExp.t))), ) and t = | Mark @@ -49,12 +46,12 @@ and t = ids: list(Id.t), }); -let rec compose = (ctx: t, d: DHExp.t): DHExp.t => { +let rec compose = (ctx: t, d: DExp.t): DExp.t => { switch (ctx) { | Mark => d | Term({term, ids}) => - let wrap = DHExp.mk(ids); - DHExp.( + let wrap = DExp.mk(ids); + DExp.( switch (term) { | Closure(env, ctx) => let d = compose(ctx, d); diff --git a/src/haz3lcore/dynamics/Evaluator.re b/src/haz3lcore/dynamics/Evaluator.re index eb9d885628..7c69c715fb 100644 --- a/src/haz3lcore/dynamics/Evaluator.re +++ b/src/haz3lcore/dynamics/Evaluator.re @@ -3,10 +3,10 @@ open Transition; module EvaluatorEVMode: { type result_unfinished = - | BoxedValue(DHExp.t) - | Indet(DHExp.t) - | Uneval(DHExp.t); - let unbox: result_unfinished => DHExp.t; + | BoxedValue(DExp.t) + | Indet(DExp.t) + | Uneval(DExp.t); + let unbox: result_unfinished => DExp.t; include EV_MODE with @@ -37,9 +37,9 @@ module EvaluatorEVMode: { let get_info_map = (state: state) => EvaluatorState.get_info_map(state^); type result_unfinished = - | BoxedValue(DHExp.t) - | Indet(DHExp.t) - | Uneval(DHExp.t); + | BoxedValue(DExp.t) + | Indet(DExp.t) + | Uneval(DExp.t); type result = result_unfinished; @@ -121,9 +121,9 @@ let evaluate = (env, {d, info_map}: Elaborator.Elaboration.t) => { let result = evaluate(state, env, d); let result = switch (result) { - | BoxedValue(x) => BoxedValue(x |> DHExp.repair_ids) - | Indet(x) => Indet(x |> DHExp.repair_ids) - | Uneval(x) => Indet(x |> DHExp.repair_ids) + | BoxedValue(x) => BoxedValue(x |> DExp.repair_ids) + | Indet(x) => Indet(x |> DExp.repair_ids) + | Uneval(x) => Indet(x |> DExp.repair_ids) }; (state^, result); }; diff --git a/src/haz3lcore/dynamics/Evaluator.rei b/src/haz3lcore/dynamics/Evaluator.rei index e505c371af..26e1a723d5 100644 --- a/src/haz3lcore/dynamics/Evaluator.rei +++ b/src/haz3lcore/dynamics/Evaluator.rei @@ -11,11 +11,11 @@ let evaluate: module EvaluatorEVMode: { type result_unfinished = - | BoxedValue(DHExp.t) - | Indet(DHExp.t) - | Uneval(DHExp.t); + | BoxedValue(DExp.t) + | Indet(DExp.t) + | Uneval(DExp.t); - let unbox: result_unfinished => DHExp.t; + let unbox: result_unfinished => DExp.t; include EV_MODE with @@ -25,11 +25,11 @@ module EvaluatorEVMode: { module Eval: { let transition: ( - (EvaluatorEVMode.state, ClosureEnvironment.t, DHExp.t) => + (EvaluatorEVMode.state, ClosureEnvironment.t, DExp.t) => EvaluatorEVMode.result_unfinished, EvaluatorEVMode.state, ClosureEnvironment.t, - DHExp.t + DExp.t ) => EvaluatorEVMode.result_unfinished; }; diff --git a/src/haz3lcore/dynamics/EvaluatorError.re b/src/haz3lcore/dynamics/EvaluatorError.re index 7cd750d1bc..981b7d4c82 100644 --- a/src/haz3lcore/dynamics/EvaluatorError.re +++ b/src/haz3lcore/dynamics/EvaluatorError.re @@ -6,16 +6,16 @@ type t = | StepDoesNotMatch | FreeInvalidVar(Var.t) | BadPatternMatch - | CastBVHoleGround(DHExp.t) - | InvalidBoxedFun(DHExp.t) - | InvalidBoxedBoolLit(DHExp.t) - | InvalidBoxedIntLit(DHExp.t) - | InvalidBoxedFloatLit(DHExp.t) - | InvalidBoxedListLit(DHExp.t) - | InvalidBoxedStringLit(DHExp.t) - | InvalidBoxedTuple(DHExp.t) + | CastBVHoleGround(DExp.t) + | InvalidBoxedFun(DExp.t) + | InvalidBoxedBoolLit(DExp.t) + | InvalidBoxedIntLit(DExp.t) + | InvalidBoxedFloatLit(DExp.t) + | InvalidBoxedListLit(DExp.t) + | InvalidBoxedStringLit(DExp.t) + | InvalidBoxedTuple(DExp.t) | InvalidBuiltin(string) - | BadBuiltinAp(string, list(DHExp.t)) + | BadBuiltinAp(string, list(DExp.t)) | InvalidProjection(int); exception Exception(t); diff --git a/src/haz3lcore/dynamics/EvaluatorError.rei b/src/haz3lcore/dynamics/EvaluatorError.rei index e5a07fe847..e7c0421163 100644 --- a/src/haz3lcore/dynamics/EvaluatorError.rei +++ b/src/haz3lcore/dynamics/EvaluatorError.rei @@ -4,16 +4,16 @@ type t = | StepDoesNotMatch | FreeInvalidVar(Var.t) | BadPatternMatch - | CastBVHoleGround(DHExp.t) - | InvalidBoxedFun(DHExp.t) - | InvalidBoxedBoolLit(DHExp.t) - | InvalidBoxedIntLit(DHExp.t) - | InvalidBoxedFloatLit(DHExp.t) - | InvalidBoxedListLit(DHExp.t) - | InvalidBoxedStringLit(DHExp.t) - | InvalidBoxedTuple(DHExp.t) + | CastBVHoleGround(DExp.t) + | InvalidBoxedFun(DExp.t) + | InvalidBoxedBoolLit(DExp.t) + | InvalidBoxedIntLit(DExp.t) + | InvalidBoxedFloatLit(DExp.t) + | InvalidBoxedListLit(DExp.t) + | InvalidBoxedStringLit(DExp.t) + | InvalidBoxedTuple(DExp.t) | InvalidBuiltin(string) - | BadBuiltinAp(string, list(DHExp.t)) + | BadBuiltinAp(string, list(DExp.t)) | InvalidProjection(int); [@deriving (show({with_path: false}), sexp, yojson)] diff --git a/src/haz3lcore/dynamics/EvaluatorResult.re b/src/haz3lcore/dynamics/EvaluatorResult.re index 73628a7c89..13d8d06d88 100644 --- a/src/haz3lcore/dynamics/EvaluatorResult.re +++ b/src/haz3lcore/dynamics/EvaluatorResult.re @@ -1,7 +1,7 @@ [@deriving (show({with_path: false}), sexp, yojson)] type t = - | BoxedValue(DHExp.t) - | Indet(DHExp.t); + | BoxedValue(DExp.t) + | Indet(DExp.t); let unbox = fun @@ -11,6 +11,6 @@ let unbox = let fast_equal = (r1, r2) => switch (r1, r2) { | (BoxedValue(d1), BoxedValue(d2)) - | (Indet(d1), Indet(d2)) => DHExp.fast_equal(d1, d2) + | (Indet(d1), Indet(d2)) => DExp.fast_equal(d1, d2) | _ => false }; diff --git a/src/haz3lcore/dynamics/EvaluatorResult.rei b/src/haz3lcore/dynamics/EvaluatorResult.rei index 350c3cec62..2443977eba 100644 --- a/src/haz3lcore/dynamics/EvaluatorResult.rei +++ b/src/haz3lcore/dynamics/EvaluatorResult.rei @@ -3,20 +3,20 @@ */ /** - The type for the evaluation result, a {!type:DHExp.t} wrapped in its {v final + The type for the evaluation result, a {!type:DExp.t} wrapped in its {v final v} judgment (boxed value or indeterminate). */ [@deriving (show({with_path: false}), sexp, yojson)] type t = - | BoxedValue(DHExp.t) - | Indet(DHExp.t); + | BoxedValue(DExp.t) + | Indet(DExp.t); /** [unbox r] is the inner expression. */ -let unbox: t => DHExp.t; +let unbox: t => DExp.t; /** - See {!val:DHExp.fast_equal}. + See {!val:DExp.fast_equal}. */ let fast_equal: (t, t) => bool; diff --git a/src/haz3lcore/dynamics/EvaluatorStep.re b/src/haz3lcore/dynamics/EvaluatorStep.re index 2d7d82669e..5084d7cff7 100644 --- a/src/haz3lcore/dynamics/EvaluatorStep.re +++ b/src/haz3lcore/dynamics/EvaluatorStep.re @@ -2,10 +2,10 @@ open Transition; [@deriving (show({with_path: false}), sexp, yojson)] type step = { - d: DHExp.t, // technically can be calculated from d_loc and ctx + d: DExp.t, // technically can be calculated from d_loc and ctx state: EvaluatorState.t, - d_loc: DHExp.t, // the expression at the location given by ctx - d_loc': DHExp.t, + d_loc: DExp.t, // the expression at the location given by ctx + d_loc': DExp.t, ctx: EvalCtx.t, knd: step_kind, }; @@ -14,7 +14,7 @@ module EvalObj = { [@deriving (show({with_path: false}), sexp, yojson)] type t = { env: ClosureEnvironment.t, // technically can be calculated from ctx - d_loc: DHExp.t, + d_loc: DExp.t, ctx: EvalCtx.t, knd: step_kind, }; @@ -129,7 +129,7 @@ module Decompose = { req_all_final'(cont, wr, [], ds); }; - let (let.): (requirements('a, DHExp.t), 'a => rule) => result = + let (let.): (requirements('a, DExp.t), 'a => rule) => result = (rq, rl) => switch (rq) { | (_, Result.Indet, _, _) => Result.Indet @@ -155,18 +155,16 @@ module Decompose = { module Decomp = Transition(DecomposeEVMode); let rec decompose = (state, env, exp) => { - let (term, rewrap) = DHExp.unwrap(exp); + let (term, rewrap) = DExp.unwrap(exp); switch (term) { - | DHExp.Filter(flt, d1) => + | DExp.Filter(flt, d1) => DecomposeEVMode.( { - let. _ = - otherwise(env, (d1) => (Filter(flt, d1) |> rewrap: DHExp.t)) + let. _ = otherwise(env, (d1) => (Filter(flt, d1) |> rewrap: DExp.t)) and. d1 = req_final( decompose(state, env), - d1 => - Term({term: Filter(flt, d1), ids: [DHExp.rep_id(exp)]}), + d1 => Term({term: Filter(flt, d1), ids: [DExp.rep_id(exp)]}), d1, ); Step({apply: () => d1, kind: CompleteFilter, value: true}); @@ -181,12 +179,12 @@ module TakeStep = { module TakeStepEVMode: { include EV_MODE with - type result = option(DHExp.t) and type state = ref(EvaluatorState.t); + type result = option(DExp.t) and type state = ref(EvaluatorState.t); } = { type state = ref(EvaluatorState.t); type requirement('a) = 'a; type requirements('a, 'b) = 'a; - type result = option(DHExp.t); + type result = option(DExp.t); // Assume that everything is either value or final as required. let req_value = (_, _, d) => d; @@ -196,7 +194,7 @@ module TakeStep = { let req_final_or_value = (_, _, d) => (d, true); - let (let.) = (rq: requirements('a, DHExp.t), rl: 'a => rule) => + let (let.) = (rq: requirements('a, DExp.t), rl: 'a => rule) => switch (rl(rq)) { | Step({apply, _}) => Some(apply()) | Constructor @@ -220,7 +218,7 @@ module TakeStep = { let take_step = TakeStep.take_step; -let decompose = (d: DHExp.t, es: EvaluatorState.t) => { +let decompose = (d: DExp.t, es: EvaluatorState.t) => { let env = ClosureEnvironment.of_environment(Builtins.env_init); let rs = Decompose.decompose(ref(es), env, d); Decompose.Result.unbox(rs); diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index 83f15597bb..ed107fb7a9 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -2,12 +2,12 @@ let rec matches_exp = ( info_map: Statics.Map.t, env: ClosureEnvironment.t, - d: DHExp.t, - f: DHExp.t, + d: DExp.t, + f: DExp.t, ) : bool => { let matches_exp = matches_exp(info_map); - switch (DHExp.term_of(d), DHExp.term_of(f)) { + switch (DExp.term_of(d), DExp.term_of(f)) { | (Parens(x), _) => matches_exp(env, x, f) | (_, Parens(x)) => matches_exp(env, d, x) | (Constructor("$e"), _) => failwith("$e in matched expression") @@ -48,7 +48,7 @@ let rec matches_exp = | (EmptyHole, _) => false | (Filter(df, dd), Filter(ff, fd)) => - DHExp.filter_fast_equal(df, ff) && matches_exp(env, dd, fd) + DExp.filter_fast_equal(df, ff) && matches_exp(env, dd, fd) | (Filter(_), _) => false | (Bool(dv), Bool(fv)) => dv == fv @@ -64,7 +64,7 @@ let rec matches_exp = | (String(_), _) => false | (Constructor(_), Ap(_, d1, d2)) => - switch (DHExp.term_of(d1), DHExp.term_of(d2)) { + switch (DExp.term_of(d1), DExp.term_of(d2)) { | (Constructor("~MVal"), Tuple([])) => true | _ => false } @@ -228,7 +228,7 @@ let matches = ( info_map, ~env: ClosureEnvironment.t, - ~exp: DHExp.t, + ~exp: DExp.t, ~flt: TermBase.StepperFilterKind.filter, ) : option(FilterAction.t) => @@ -241,7 +241,7 @@ let matches = let matches = ( ~env: ClosureEnvironment.t, - ~exp: DHExp.t, + ~exp: DExp.t, ~exp_info_map: Statics.Map.t, ~act: FilterAction.t, flt_env, diff --git a/src/haz3lcore/dynamics/MetaVarInst.re b/src/haz3lcore/dynamics/MetaVarInst.re index 9b410f2e61..bb3c1bd31c 100644 --- a/src/haz3lcore/dynamics/MetaVarInst.re +++ b/src/haz3lcore/dynamics/MetaVarInst.re @@ -1,7 +1,7 @@ open Sexplib.Std; /** - * Hole instance index in DHPat and DHExp + * Hole instance index in DHPat and DExp */ [@deriving (show({with_path: false}), sexp, yojson)] type t = int; diff --git a/src/haz3lcore/dynamics/MetaVarInst.rei b/src/haz3lcore/dynamics/MetaVarInst.rei index 89692b7bed..40b35d61ca 100644 --- a/src/haz3lcore/dynamics/MetaVarInst.rei +++ b/src/haz3lcore/dynamics/MetaVarInst.rei @@ -1,5 +1,5 @@ /** - * Hole instance index in DHPat and DHExp + * Hole instance index in DHPat and DExp */ [@deriving (show({with_path: false}), sexp, yojson)] type t = int; diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index 9aaded3acf..8d3786c284 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -28,8 +28,8 @@ let cast_sum_maps = }; }; -let rec matches = (dp: TermBase.UPat.t, d: DHExp.t): match_result => - switch (DHPat.term_of(dp), DHExp.term_of(d)) { +let rec matches = (dp: TermBase.UPat.t, d: DExp.t): match_result => + switch (DHPat.term_of(dp), DExp.term_of(d)) { | (Parens(x), _) => matches(x, d) | (TypeAnn(x, _), _) => matches(x, d) | (_, Var(_)) => DoesNotMatch @@ -203,11 +203,11 @@ and matches_cast_Sum = ( ctr: string, dp: option(TermBase.UPat.t), - d: DHExp.t, + d: DExp.t, castmaps: list(ConstructorMap.t((Typ.t, Typ.t))), ) : match_result => - switch (DHExp.term_of(d)) { + switch (DExp.term_of(d)) { | Parens(d) => matches_cast_Sum(ctr, dp, d, castmaps) | Constructor(ctr') => switch ( @@ -219,7 +219,7 @@ and matches_cast_Sum = | _ => DoesNotMatch } | Ap(_, d1, d2) => - switch (DHExp.term_of(d1)) { + switch (DExp.term_of(d1)) { | Constructor(ctr') => switch ( dp, @@ -228,7 +228,7 @@ and matches_cast_Sum = |> OptUtil.sequence, ) { | (Some(dp), Some(side_casts)) => - matches(dp, DHExp.apply_casts(d2, side_casts)) + matches(dp, DExp.apply_casts(d2, side_casts)) | _ => DoesNotMatch } | _ => IndetMatch @@ -274,11 +274,11 @@ and matches_cast_Sum = and matches_cast_Tuple = ( dps: list(TermBase.UPat.t), - d: DHExp.t, + d: DExp.t, elt_casts: list(list((Typ.t, Typ.t))), ) : match_result => - switch (DHExp.term_of(d)) { + switch (DExp.term_of(d)) { | Parens(d) => matches_cast_Tuple(dps, d, elt_casts) | Tuple(ds) => if (List.length(dps) != List.length(ds)) { @@ -291,7 +291,7 @@ and matches_cast_Tuple = | DoesNotMatch | IndetMatch => result | Matches(env) => - switch (matches(dp, DHExp.apply_casts(d, casts))) { + switch (matches(dp, DExp.apply_casts(d, casts))) { | DoesNotMatch => DoesNotMatch | IndetMatch => IndetMatch | Matches(env') => Matches(Environment.union(env, env')) @@ -359,9 +359,9 @@ and matches_cast_Tuple = | If(_) => IndetMatch } and matches_cast_Cons = - (dp: TermBase.UPat.t, d: DHExp.t, elt_casts: list((Typ.t, Typ.t))) + (dp: TermBase.UPat.t, d: DExp.t, elt_casts: list((Typ.t, Typ.t))) : match_result => - switch (DHExp.term_of(d)) { + switch (DExp.term_of(d)) { | Parens(d) => matches_cast_Cons(dp, d, elt_casts) | ListLit([]) => switch (DHPat.term_of(dp)) { @@ -371,7 +371,7 @@ and matches_cast_Cons = | ListLit([dhd, ...dtl] as ds) => switch (DHPat.term_of(dp)) { | Cons(dp1, dp2) => - switch (matches(dp1, DHExp.apply_casts(dhd, elt_casts))) { + switch (matches(dp1, DExp.apply_casts(dhd, elt_casts))) { | DoesNotMatch => DoesNotMatch | IndetMatch => IndetMatch | Matches(env1) => @@ -383,8 +383,8 @@ and matches_cast_Cons = }, elt_casts, ); - let d2 = DHExp.ListLit(dtl) |> DHExp.fresh; - switch (matches(dp2, DHExp.apply_casts(d2, list_casts))) { + let d2 = DExp.ListLit(dtl) |> DExp.fresh; + switch (matches(dp2, DExp.apply_casts(d2, list_casts))) { | DoesNotMatch => DoesNotMatch | IndetMatch => IndetMatch | Matches(env2) => Matches(Environment.union(env1, env2)) @@ -396,7 +396,7 @@ and matches_cast_Cons = | Some(lst) => lst |> List.map(((dp, d)) => - matches(dp, DHExp.apply_casts(d, elt_casts)) + matches(dp, DExp.apply_casts(d, elt_casts)) ) |> List.fold_left( (match1, match2) => @@ -416,7 +416,7 @@ and matches_cast_Cons = | Cons(d1, d2) => switch (DHPat.term_of(dp)) { | Cons(dp1, dp2) => - switch (matches(dp1, DHExp.apply_casts(d1, elt_casts))) { + switch (matches(dp1, DExp.apply_casts(d1, elt_casts))) { | DoesNotMatch => DoesNotMatch | IndetMatch => IndetMatch | Matches(env1) => @@ -428,7 +428,7 @@ and matches_cast_Cons = }, elt_casts, ); - switch (matches(dp2, DHExp.apply_casts(d2, list_casts))) { + switch (matches(dp2, DExp.apply_casts(d2, list_casts))) { | DoesNotMatch => DoesNotMatch | IndetMatch => IndetMatch | Matches(env2) => Matches(Environment.union(env1, env2)) @@ -436,7 +436,7 @@ and matches_cast_Cons = } | ListLit([]) => DoesNotMatch | ListLit([dphd, ...dptl]) => - switch (matches(dphd, DHExp.apply_casts(d1, elt_casts))) { + switch (matches(dphd, DExp.apply_casts(d1, elt_casts))) { | DoesNotMatch => DoesNotMatch | IndetMatch => IndetMatch | Matches(env1) => @@ -449,7 +449,7 @@ and matches_cast_Cons = elt_casts, ); let dp2 = TermBase.UPat.ListLit(dptl) |> DHPat.fresh; - switch (matches(dp2, DHExp.apply_casts(d2, list_casts))) { + switch (matches(dp2, DExp.apply_casts(d2, list_casts))) { | DoesNotMatch => DoesNotMatch | IndetMatch => IndetMatch | Matches(env2) => Matches(Environment.union(env1, env2)) diff --git a/src/haz3lcore/dynamics/PatternMatch.rei b/src/haz3lcore/dynamics/PatternMatch.rei index d61032feb9..dbe1124fd2 100644 --- a/src/haz3lcore/dynamics/PatternMatch.rei +++ b/src/haz3lcore/dynamics/PatternMatch.rei @@ -3,4 +3,4 @@ type match_result = | DoesNotMatch | IndetMatch; -let matches: (TermBase.UPat.t, DHExp.t) => match_result; +let matches: (TermBase.UPat.t, DExp.t) => match_result; diff --git a/src/haz3lcore/dynamics/Stepper.re b/src/haz3lcore/dynamics/Stepper.re index 72169cdb81..c51832ae0e 100644 --- a/src/haz3lcore/dynamics/Stepper.re +++ b/src/haz3lcore/dynamics/Stepper.re @@ -13,7 +13,7 @@ type stepper_state = | StepTimeout(EvalObj.t); [@deriving (show({with_path: false}), sexp, yojson)] -type history = Aba.t((DHExp.t, EvaluatorState.t), step); +type history = Aba.t((DExp.t, EvaluatorState.t), step); [@deriving (show({with_path: false}), sexp, yojson)] type t = { @@ -27,7 +27,7 @@ let rec matches = env: ClosureEnvironment.t, flt: FilterEnvironment.t, ctx: EvalCtx.t, - exp: DHExp.t, + exp: DExp.t, exp_info_map: Statics.Map.t, act: FilterAction.t, idx: int, @@ -283,7 +283,7 @@ let rec evaluate_pending = (~settings, s: t) => { | None => raise(Exception) } ) - |> DHExp.repair_ids; + |> DExp.repair_ids; let d' = EvalCtx.compose(eo.ctx, d_loc'); let new_step = { d, @@ -383,7 +383,7 @@ let get_justification: step_kind => string = | UnOp(Meta(Unquote)) => failwith("INVALID STEP"); type step_info = { - d: DHExp.t, + d: DExp.t, chosen_step: option(step), // The step that was taken next hidden_steps: list((step, Id.t)), // The hidden steps between previous_step and the current one (an Id in included because it may have changed since the step was taken) previous_step: option((step, Id.t)) // The step that will be displayed above this one (an Id in included because it may have changed since the step was taken) @@ -408,7 +408,7 @@ let get_history = (~settings, stepper) => { ( ( chosen_step: option(step), - (d: DHExp.t, hidden_steps: list(step)), + (d: DExp.t, hidden_steps: list(step)), previous_step: option(step), ), ) => { @@ -416,13 +416,13 @@ let get_history = (~settings, stepper) => { List.fold_left( ((ps, hs), h: step) => { let replacement = - replace_id(h.d_loc |> DHExp.rep_id, h.d_loc' |> DHExp.rep_id); + replace_id(h.d_loc |> DExp.rep_id, h.d_loc' |> DExp.rep_id); ( Option.map(replacement, ps), - [(h, h.d_loc' |> DHExp.rep_id), ...List.map(replacement, hs)], + [(h, h.d_loc' |> DExp.rep_id), ...List.map(replacement, hs)], ); }, - (Option.map(x => (x, x.d_loc' |> DHExp.rep_id), previous_step), []), + (Option.map(x => (x, x.d_loc' |> DExp.rep_id), previous_step), []), hidden_steps, ); {d, previous_step, hidden_steps, chosen_step}; diff --git a/src/haz3lcore/dynamics/Substitution.re b/src/haz3lcore/dynamics/Substitution.re index e829c22c3c..42fa93a803 100644 --- a/src/haz3lcore/dynamics/Substitution.re +++ b/src/haz3lcore/dynamics/Substitution.re @@ -1,6 +1,6 @@ /* closed substitution [d1/x]d2 */ -let rec subst_var = (m, d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => { - let (term, rewrap) = DHExp.unwrap(d2); +let rec subst_var = (m, d1: DExp.t, x: Var.t, d2: DExp.t): DExp.t => { + let (term, rewrap) = DExp.unwrap(d2); switch (term) { | Var(y) => if (Var.eq(x, y)) { @@ -122,16 +122,15 @@ let rec subst_var = (m, d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => { } and subst_var_env = - (m, d1: DHExp.t, x: Var.t, env: ClosureEnvironment.t) - : ClosureEnvironment.t => { + (m, d1: DExp.t, x: Var.t, env: ClosureEnvironment.t): ClosureEnvironment.t => { let id = env |> ClosureEnvironment.id_of; let map = env |> ClosureEnvironment.map_of |> Environment.foldo( - ((x', d': DHExp.t), map) => { + ((x', d': DExp.t), map) => { let d' = - switch (DHExp.term_of(d')) { + switch (DExp.term_of(d')) { /* Substitute each previously substituted binding into the * fixpoint. */ | FixF(_) => @@ -154,15 +153,15 @@ and subst_var_env = } and subst_var_filter = - (m, d1: DHExp.t, x: Var.t, flt: TermBase.StepperFilterKind.t) + (m, d1: DExp.t, x: Var.t, flt: TermBase.StepperFilterKind.t) : TermBase.StepperFilterKind.t => { flt |> TermBase.StepperFilterKind.map(subst_var(m, d1, x)); }; -let subst = (m, env: Environment.t, d: DHExp.t): DHExp.t => +let subst = (m, env: Environment.t, d: DExp.t): DExp.t => env |> Environment.foldo( - (xd: (Var.t, DHExp.t), d2) => { + (xd: (Var.t, DExp.t), d2) => { let (x, d1) = xd; subst_var(m, d1, x, d2); }, diff --git a/src/haz3lcore/dynamics/Substitution.rei b/src/haz3lcore/dynamics/Substitution.rei index 49b1e2e92f..35eb631b77 100644 --- a/src/haz3lcore/dynamics/Substitution.rei +++ b/src/haz3lcore/dynamics/Substitution.rei @@ -1,3 +1,3 @@ /* closed substitution [d1/x]d2 */ -let subst_var: (Statics.Map.t, DHExp.t, Var.t, DHExp.t) => DHExp.t; -let subst: (Statics.Map.t, Environment.t, DHExp.t) => DHExp.t; +let subst_var: (Statics.Map.t, DExp.t, Var.t, DExp.t) => DExp.t; +let subst: (Statics.Map.t, Environment.t, DExp.t) => DExp.t; diff --git a/src/haz3lcore/dynamics/TestMap.re b/src/haz3lcore/dynamics/TestMap.re index 8592e0e546..57064a44c9 100644 --- a/src/haz3lcore/dynamics/TestMap.re +++ b/src/haz3lcore/dynamics/TestMap.re @@ -2,7 +2,7 @@ open Sexplib.Std; /* FIXME: Make more obvious names. */ [@deriving (show({with_path: false}), sexp, yojson)] -type instance_report = (DHExp.t, Statics.Map.t, TestStatus.t); +type instance_report = (DExp.t, Statics.Map.t, TestStatus.t); let joint_status: list(instance_report) => TestStatus.t = reports => TestStatus.join_all(List.map(((_, _, x)) => x, reports)); diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index ce48ed3386..135e06ac3c 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -142,7 +142,7 @@ let evaluate_extend_env = type rule = | Step({ - apply: unit => DHExp.t, + apply: unit => DExp.t, kind: step_kind, value: bool, }) @@ -156,30 +156,28 @@ module type EV_MODE = { type requirements('a, 'b); let req_value: - (DHExp.t => result, EvalCtx.t => EvalCtx.t, DHExp.t) => - requirement(DHExp.t); + (DExp.t => result, EvalCtx.t => EvalCtx.t, DExp.t) => requirement(DExp.t); let req_all_value: ( - DHExp.t => result, - (EvalCtx.t, (list(DHExp.t), list(DHExp.t))) => EvalCtx.t, - list(DHExp.t) + DExp.t => result, + (EvalCtx.t, (list(DExp.t), list(DExp.t))) => EvalCtx.t, + list(DExp.t) ) => - requirement(list(DHExp.t)); + requirement(list(DExp.t)); let req_final: - (DHExp.t => result, EvalCtx.t => EvalCtx.t, DHExp.t) => - requirement(DHExp.t); + (DExp.t => result, EvalCtx.t => EvalCtx.t, DExp.t) => requirement(DExp.t); let req_all_final: ( - DHExp.t => result, - (EvalCtx.t, (list(DHExp.t), list(DHExp.t))) => EvalCtx.t, - list(DHExp.t) + DExp.t => result, + (EvalCtx.t, (list(DExp.t), list(DExp.t))) => EvalCtx.t, + list(DExp.t) ) => - requirement(list(DHExp.t)); + requirement(list(DExp.t)); let req_final_or_value: - (DHExp.t => result, EvalCtx.t => EvalCtx.t, DHExp.t) => - requirement((DHExp.t, bool)); + (DExp.t => result, EvalCtx.t => EvalCtx.t, DExp.t) => + requirement((DExp.t, bool)); - let (let.): (requirements('a, DHExp.t), 'a => rule) => result; + let (let.): (requirements('a, DExp.t), 'a => rule) => result; let (and.): (requirements('a, 'c => 'b), requirement('c)) => requirements(('a, 'c), 'b); @@ -192,7 +190,7 @@ module type EV_MODE = { module Transition = (EV: EV_MODE) => { open EV; - open DHExp; + open DExp; let (let.match) = ((env, match_result), r) => switch (match_result) { | IndetMatch @@ -207,7 +205,7 @@ module Transition = (EV: EV_MODE) => { let transition = (req, state, env, d): 'a => { // If there is an error at this location, swap out the rule for indet. let info_map = get_info_map(state); - let err_info = Statics.get_error_at(info_map, DHExp.rep_id(d)); + let err_info = Statics.get_error_at(info_map, DExp.rep_id(d)); let (let.) = switch (err_info) { | Some( @@ -222,8 +220,8 @@ module Transition = (EV: EV_MODE) => { | None => (let.) }; - // Split DHExp into term and id information - let (term, rewrap) = DHExp.unwrap(d); + // Split DExp into term and id information + let (term, rewrap) = DExp.unwrap(d); let wrap_ctx = (term): EvalCtx.t => Term({term, ids: [rep_id(d)]}); // Transition rules @@ -321,16 +319,16 @@ module Transition = (EV: EV_MODE) => { and. d' = req_final(req(state, env), d => Test(d) |> wrap_ctx, d); Step({ apply: () => - switch (DHExp.term_of(d')) { + switch (DExp.term_of(d')) { | Bool(true) => - update_test(state, DHExp.rep_id(d), (d', info_map, Pass)); + update_test(state, DExp.rep_id(d), (d', info_map, Pass)); Tuple([]) |> fresh; | Bool(false) => - update_test(state, DHExp.rep_id(d), (d', info_map, Fail)); + update_test(state, DExp.rep_id(d), (d', info_map, Fail)); Tuple([]) |> fresh; /* Hack: assume if final and not Bool, then Indet; this won't catch errors in statics */ | _ => - update_test(state, DHExp.rep_id(d), (d', info_map, Indet)); + update_test(state, DExp.rep_id(d), (d', info_map, Indet)); Tuple([]) |> fresh; }, kind: UpdateTest, @@ -346,7 +344,7 @@ module Transition = (EV: EV_MODE) => { d2 => Ap2(dir, d1, d2) |> wrap_ctx, d2, ); - switch (DHExp.term_of(d1')) { + switch (DExp.term_of(d1')) { | Constructor(_) => Constructor | Fun(dp, d3, Some(env'), _) => let.match env'' = (env', matches(dp, d2')); @@ -405,7 +403,7 @@ module Transition = (EV: EV_MODE) => { let. _ = otherwise(env, c => If(c, d1, d2) |> rewrap) and. c' = req_value(req(state, env), c => If1(c, d1, d2) |> wrap_ctx, c); - switch (DHExp.term_of(c')) { + switch (DExp.term_of(c')) { | Bool(b) => Step({ apply: () => { @@ -438,7 +436,7 @@ module Transition = (EV: EV_MODE) => { ); Step({ apply: () => - switch (DHExp.term_of(d1')) { + switch (DExp.term_of(d1')) { | Int(n) => Int(- n) |> fresh | _ => raise(EvaluatorError.Exception(InvalidBoxedIntLit(d1'))) }, @@ -455,7 +453,7 @@ module Transition = (EV: EV_MODE) => { ); Step({ apply: () => - switch (DHExp.term_of(d1')) { + switch (DExp.term_of(d1')) { | Bool(b) => Bool(!b) |> fresh | _ => raise(EvaluatorError.Exception(InvalidBoxedIntLit(d1'))) }, @@ -472,7 +470,7 @@ module Transition = (EV: EV_MODE) => { ); Step({ apply: () => - switch (DHExp.term_of(d1')) { + switch (DExp.term_of(d1')) { | Bool(true) => d2 | Bool(false) => Bool(false) |> fresh | _ => raise(EvaluatorError.Exception(InvalidBoxedBoolLit(d1'))) @@ -490,7 +488,7 @@ module Transition = (EV: EV_MODE) => { ); Step({ apply: () => - switch (DHExp.term_of(d1')) { + switch (DExp.term_of(d1')) { | Bool(true) => Bool(true) |> fresh | Bool(false) => d2 | _ => raise(EvaluatorError.Exception(InvalidBoxedBoolLit(d2))) @@ -514,7 +512,7 @@ module Transition = (EV: EV_MODE) => { ); Step({ apply: () => - switch (DHExp.term_of(d1'), DHExp.term_of(d2')) { + switch (DExp.term_of(d1'), DExp.term_of(d2')) { | (Int(n1), Int(n2)) => ( switch (op) { @@ -567,7 +565,7 @@ module Transition = (EV: EV_MODE) => { ); Step({ apply: () => - switch (DHExp.term_of(d1'), DHExp.term_of(d2')) { + switch (DExp.term_of(d1'), DExp.term_of(d2')) { | (Float(n1), Float(n2)) => ( switch (op) { @@ -609,7 +607,7 @@ module Transition = (EV: EV_MODE) => { ); Step({ apply: () => - switch (DHExp.term_of(d1'), DHExp.term_of(d2')) { + switch (DExp.term_of(d1'), DExp.term_of(d2')) { | (String(s1), String(s2)) => switch (op) { | Concat => String(s1 ++ s2) |> fresh @@ -771,7 +769,7 @@ module Transition = (EV: EV_MODE) => { /* ITExpand rule */ Step({ apply: () => - DHExp.Cast(Cast(d', t1, t2_grounded) |> fresh, t2_grounded, t2) + DExp.Cast(Cast(d', t1, t2_grounded) |> fresh, t2_grounded, t2) |> fresh, kind: Cast, value: false, @@ -780,7 +778,7 @@ module Transition = (EV: EV_MODE) => { /* ITGround rule */ Step({ apply: () => - DHExp.Cast(Cast(d', t1, t1_grounded) |> fresh, t1_grounded, t2) + DExp.Cast(Cast(d', t1, t1_grounded) |> fresh, t1_grounded, t2) |> fresh, kind: Cast, value: false, diff --git a/src/haz3lcore/dynamics/TypeAssignment.re b/src/haz3lcore/dynamics/TypeAssignment.re index 9a9dab05ab..0a6a1e3d90 100644 --- a/src/haz3lcore/dynamics/TypeAssignment.re +++ b/src/haz3lcore/dynamics/TypeAssignment.re @@ -83,7 +83,7 @@ // }; // }; // let rec typ_of_dhexp = -// (ctx: Ctx.t, m: Statics.Map.t, dh: DHExp.t): option(Typ.t) => { +// (ctx: Ctx.t, m: Statics.Map.t, dh: DExp.t): option(Typ.t) => { // switch (dh) { // | EmptyHole(id, _) => delta_ty(id, m) // | NonEmptyHole(_, id, _, d) => @@ -266,7 +266,7 @@ // }; // }; // }; -// let property_test = (uexp_typ: Typ.t, dhexp: DHExp.t, m: Statics.Map.t): bool => { +// let property_test = (uexp_typ: Typ.t, dhexp: DExp.t, m: Statics.Map.t): bool => { // let dhexp_typ = typ_of_dhexp(Builtins.ctx_init, m, dhexp); // print_endline(Typ.show(uexp_typ)); // switch (dhexp_typ) { diff --git a/src/haz3lcore/dynamics/ValueChecker.re b/src/haz3lcore/dynamics/ValueChecker.re index f8f73c7536..1842bfcfca 100644 --- a/src/haz3lcore/dynamics/ValueChecker.re +++ b/src/haz3lcore/dynamics/ValueChecker.re @@ -1,4 +1,4 @@ -open DHExp; +open DExp; open Transition; open Util; @@ -88,7 +88,7 @@ let rec check_value = (state, env, d) => CV.transition(check_value, state, env, d); let rec check_value_mod_ctx = (info_map: Statics.Map.t, env, d) => - switch (DHExp.term_of(d)) { + switch (DExp.term_of(d)) { | Var(x) => check_value_mod_ctx( info_map, diff --git a/src/haz3lcore/dynamics/dterm/DExp.re b/src/haz3lcore/dynamics/dterm/DExp.re new file mode 100644 index 0000000000..64903dfccf --- /dev/null +++ b/src/haz3lcore/dynamics/dterm/DExp.re @@ -0,0 +1,299 @@ +/* + To discuss: + + 1. putting info inside expressions + 2. The issue with recursion capture + + + */ +/* + DExps that can appear during evaluation, and thus won't have static information. + + - Closure + - Var [for mutual recursion; could probably get rid of if needed...] + - Let [for mutual recursion] + - Tuple([]) + - Cast + - Ap [in the casting rules for functions & in builtins] + - DynamicErrorHole + - FailedCast + - Int + - Bool + - Float + - String + - ListLit + - BuiltinFun + + It is important that the following do not appear during evaluation, because they + (theoretically) require static information: + + - Fun + - FixF + + */ + +/* DExp.re + + This module is specifically for dynamic expressions. They are stored + using the same data structure as user expressions, but have a few + important invariants. + */ + +include Exp; + +let term_of = ({term, _}) => term; +let fast_copy = (id, {term, _}) => {ids: [id], term, copied: true}; +// All children of term must have expression-unique ids. +let fresh = term => { + {ids: [Id.mk()], copied: false, term}; +}; +let unwrap = ({ids, term, copied}) => (term, term => {ids, term, copied}); + +let mk = (ids, term) => { + {ids, copied: true, term}; +}; + +// All children of d must have expression-unique ids. +let fresh_cast = (d: t, t1: Typ.t, t2: Typ.t): t => + if (Typ.eq(t1, t2) || t2 == Unknown(SynSwitch)) { + d; + } else { + fresh(Cast(d, t1, t2)); + }; + +let apply_casts = (d: t, casts: list((Typ.t, Typ.t))): t => + List.fold_left((d, (ty1, ty2)) => fresh_cast(d, ty1, ty2), d, casts); + +// TODO: make this function emit a map of changes +let rec repair_ids = (require: bool, d: t) => { + let child_require = require || d.copied; + let repair_ids = repair_ids(child_require); + let term = term_of(d); + let rewrap = term => { + ids: + child_require + ? { + let id = Id.mk(); + [id]; + } + : d.ids, + copied: false, + term, + }; + ( + switch (term) { + | EmptyHole + | Invalid(_) + | Var(_) + | BuiltinFun(_) + | Bool(_) + | Int(_) + | Float(_) + | String(_) + | Constructor(_) => term + | StaticErrorHole(static_id, d1) => + StaticErrorHole(static_id, repair_ids(d1)) + | DynamicErrorHole(d1, x) => DynamicErrorHole(repair_ids(d1), x) + | FailedCast(d1, t1, t2) => FailedCast(repair_ids(d1), t1, t2) + | Closure(env, d1) => Closure(env, repair_ids(d1)) + | Filter(flt, d1) => Filter(flt, repair_ids(d1)) + | Seq(d1, d2) => Seq(repair_ids(d1), repair_ids(d2)) + | Let(dp, d1, d2) => Let(dp, repair_ids(d1), repair_ids(d2)) + | FixF(f, d1, env) => FixF(f, repair_ids(d1), env) + | TyAlias(tp, t, d) => TyAlias(tp, t, repair_ids(d)) + | Fun(dp, d1, env, f) => Fun(dp, repair_ids(d1), env, f) + | Ap(dir, d1, d2) => Ap(dir, repair_ids(d1), repair_ids(d2)) + | Test(d1) => Test(repair_ids(d1)) + | UnOp(op, d1) => UnOp(op, repair_ids(d1)) + | BinOp(op, d1, d2) => BinOp(op, repair_ids(d1), repair_ids(d2)) + | ListLit(ds) => ListLit(List.map(repair_ids, ds)) + | Cons(d1, d2) => Cons(repair_ids(d1), repair_ids(d2)) + | Parens(d1) => Parens(repair_ids(d1)) + | ListConcat(d1, d2) => ListConcat(repair_ids(d1), repair_ids(d2)) + | Tuple(ds) => Tuple(List.map(repair_ids, ds)) + // TODO: repair ids inside multihole + | MultiHole(ds) => MultiHole(ds) + | Match(d1, rls) => + Match( + repair_ids(d1), + List.map(((p, d)) => (p, repair_ids(d)), rls), + ) + | Cast(d1, t1, t2) => Cast(repair_ids(d1), t1, t2) + | If(d1, d2, d3) => If(repair_ids(d1), repair_ids(d2), repair_ids(d3)) + } + ) + |> rewrap; +}; + +let repair_ids = repair_ids(false); + +// Also strips static error holes - kinda like unelaboration +let rec strip_casts = d => { + let (term, rewrap) = unwrap(d); + switch (term) { + | Closure(ei, d) => Closure(ei, strip_casts(d)) |> rewrap + | Cast(d, _, _) => strip_casts(d) + | FailedCast(d, _, _) => strip_casts(d) + | Tuple(ds) => Tuple(ds |> List.map(strip_casts)) |> rewrap + | Cons(d1, d2) => Cons(strip_casts(d1), strip_casts(d2)) |> rewrap + | ListConcat(d1, d2) => + ListConcat(strip_casts(d1), strip_casts(d2)) |> rewrap + | ListLit(ds) => ListLit(List.map(strip_casts, ds)) |> rewrap + // TODO[Matt]: Strip multihole casts + | MultiHole(ds) => MultiHole(ds) |> rewrap + | StaticErrorHole(_, d) => strip_casts(d) + | Seq(a, b) => Seq(strip_casts(a), strip_casts(b)) |> rewrap + | Filter(f, b) => Filter(strip_filter_casts(f), strip_casts(b)) |> rewrap + | Let(dp, b, c) => Let(dp, strip_casts(b), strip_casts(c)) |> rewrap + | FixF(a, c, env) => FixF(a, strip_casts(c), env) |> rewrap + | TyAlias(tp, t, d) => TyAlias(tp, t, strip_casts(d)) |> rewrap + | Fun(a, c, e, d) => Fun(a, strip_casts(c), e, d) |> rewrap + | Ap(dir, a, b) => Ap(dir, strip_casts(a), strip_casts(b)) |> rewrap + | Test(a) => Test(strip_casts(a)) |> rewrap + | BuiltinFun(fn) => BuiltinFun(fn) |> rewrap + | UnOp(op, d) => UnOp(op, strip_casts(d)) |> rewrap + | BinOp(a, b, c) => BinOp(a, strip_casts(b), strip_casts(c)) |> rewrap + | Match(a, rules) => + Match( + strip_casts(a), + List.map(((k, v)) => (k, strip_casts(v)), rules), + ) + |> rewrap + | Parens(d1) => Parens(strip_casts(d1)) |> rewrap + | EmptyHole as d + | Invalid(_) as d + | Var(_) as d + | Bool(_) as d + | Int(_) as d + | Float(_) as d + | String(_) as d + | Constructor(_) as d + | DynamicErrorHole(_) as d => d |> rewrap + | If(c, d1, d2) => + If(strip_casts(c), strip_casts(d1), strip_casts(d2)) |> rewrap + }; +} +and strip_filter_casts = f => { + switch (f) { + | Filter({act, pat}) => Filter({act, pat: pat |> strip_casts}) + | Residue(idx, act) => Residue(idx, act) + }; +}; + +let rec fast_equal = ({term: d1, _} as d1exp, {term: d2, _} as d2exp): bool => { + switch (d1, d2) { + /* Primitive forms: regular structural equality */ + | (Var(_), _) + /* TODO: Not sure if this is right... */ + | (Bool(_), _) + | (Int(_), _) + | (Float(_), _) + | (Constructor(_), _) => d1 == d2 + | (String(s1), String(s2)) => String.equal(s1, s2) + | (String(_), _) => false + + | (Parens(x), _) => fast_equal(x, d2exp) + | (_, Parens(x)) => fast_equal(d1exp, x) + + /* Non-hole forms: recurse */ + | (Test(d1), Test(d2)) => fast_equal(d1, d2) + | (Seq(d11, d21), Seq(d12, d22)) => + fast_equal(d11, d12) && fast_equal(d21, d22) + | (Filter(f1, d1), Filter(f2, d2)) => + filter_fast_equal(f1, f2) && fast_equal(d1, d2) + | (Let(dp1, d11, d21), Let(dp2, d12, d22)) => + dp1 == dp2 && fast_equal(d11, d12) && fast_equal(d21, d22) + | (FixF(f1, d1, sigma1), FixF(f2, d2, sigma2)) => + f1 == f2 + && fast_equal(d1, d2) + && Option.equal(ClosureEnvironment.id_equal, sigma1, sigma2) + | (Fun(dp1, d1, None, s1), Fun(dp2, d2, None, s2)) => + dp1 == dp2 && fast_equal(d1, d2) && s1 == s2 + | (Fun(dp1, d1, Some(env1), s1), Fun(dp2, d2, Some(env2), s2)) => + dp1 == dp2 + && fast_equal(d1, d2) + && ClosureEnvironment.id_equal(env1, env2) + && s1 == s2 + | (Ap(dir1, d11, d21), Ap(dir2, d12, d22)) => + dir1 == dir2 && fast_equal(d11, d12) && fast_equal(d21, d22) + | (Cons(d11, d21), Cons(d12, d22)) => + fast_equal(d11, d12) && fast_equal(d21, d22) + | (ListConcat(d11, d21), ListConcat(d12, d22)) => + fast_equal(d11, d12) && fast_equal(d21, d22) + | (Tuple(ds1), Tuple(ds2)) => + List.length(ds1) == List.length(ds2) + && List.for_all2(fast_equal, ds1, ds2) + | (BuiltinFun(f1), BuiltinFun(f2)) => f1 == f2 + | (ListLit(ds1), ListLit(ds2)) => + List.length(ds1) == List.length(ds2) + && List.for_all2(fast_equal, ds1, ds2) + | (UnOp(op1, d1), UnOp(op2, d2)) => op1 == op2 && fast_equal(d1, d2) + | (BinOp(op1, d11, d21), BinOp(op2, d12, d22)) => + op1 == op2 && fast_equal(d11, d12) && fast_equal(d21, d22) + | (TyAlias(tp1, ut1, d1), TyAlias(tp2, ut2, d2)) => + tp1 == tp2 && ut1 == ut2 && fast_equal(d1, d2) + | (Cast(d1, ty11, ty21), Cast(d2, ty12, ty22)) + | (FailedCast(d1, ty11, ty21), FailedCast(d2, ty12, ty22)) => + fast_equal(d1, d2) && ty11 == ty12 && ty21 == ty22 + | (DynamicErrorHole(d1, reason1), DynamicErrorHole(d2, reason2)) => + fast_equal(d1, d2) && reason1 == reason2 + | (Match(s1, rs1), Match(s2, rs2)) => + fast_equal(s1, s2) + && List.length(rs2) == List.length(rs2) + && List.for_all2( + ((k1, v1), (k2, v2)) => k1 == k2 && fast_equal(v1, v2), + rs1, + rs2, + ) + | (If(d11, d12, d13), If(d21, d22, d23)) => + fast_equal(d11, d21) && fast_equal(d12, d22) && fast_equal(d13, d23) + /* We can group these all into a `_ => false` clause; separating + these so that we get exhaustiveness checking. */ + | (Seq(_), _) + | (Filter(_), _) + | (Let(_), _) + | (FixF(_), _) + | (Fun(_), _) + | (Test(_), _) + | (Ap(_), _) + | (BuiltinFun(_), _) + | (Cons(_), _) + | (ListConcat(_), _) + | (ListLit(_), _) + | (Tuple(_), _) + | (UnOp(_), _) + | (BinOp(_), _) + | (Cast(_), _) + | (FailedCast(_), _) + | (TyAlias(_), _) + | (DynamicErrorHole(_), _) + | (If(_), _) + | (Match(_), _) => false + + /* Hole forms: when checking environments, only check that + environment ID's are equal, don't check structural equality. + + (This resolves a performance issue with many nested holes.) */ + | (EmptyHole, EmptyHole) => true + | (MultiHole(_), MultiHole(_)) => rep_id(d1exp) == rep_id(d2exp) + | (StaticErrorHole(sid1, d1), StaticErrorHole(sid2, d2)) => + sid1 == sid2 && d1 == d2 + | (Invalid(text1), Invalid(text2)) => text1 == text2 + | (Closure(sigma1, d1), Closure(sigma2, d2)) => + ClosureEnvironment.id_equal(sigma1, sigma2) && fast_equal(d1, d2) + | (EmptyHole, _) + | (MultiHole(_), _) + | (StaticErrorHole(_), _) + | (Invalid(_), _) + | (Closure(_), _) => false + }; +} +and filter_fast_equal = (f1, f2) => { + switch (f1, f2) { + | (Filter(f1), Filter(f2)) => + fast_equal(f1.pat, f2.pat) && f1.act == f2.act + | (Residue(idx1, act1), Residue(idx2, act2)) => + idx1 == idx2 && act1 == act2 + | _ => false + }; +}; diff --git a/src/haz3lcore/prog/Interface.re b/src/haz3lcore/prog/Interface.re index b47008640b..3c352cedb2 100644 --- a/src/haz3lcore/prog/Interface.re +++ b/src/haz3lcore/prog/Interface.re @@ -34,13 +34,13 @@ module Statics = { core.statics ? mk_map_ctx(ctx, exp) : Id.Map.empty; }; -let dh_err = (error: string): DHExp.t => Var(error) |> DHExp.fresh; +let dh_err = (error: string): DExp.t => Var(error) |> DExp.fresh; let elaborate = Core.Memo.general(~cache_size_bound=1000, Elaborator.uexp_elab); exception DoesNotElaborate; -let elaborate = (~settings: CoreSettings.t, map, term): DHExp.t => +let elaborate = (~settings: CoreSettings.t, map, term): DExp.t => switch () { | _ when !settings.statics => dh_err("Statics disabled") | _ when !settings.dynamics && !settings.elaborate => diff --git a/src/haz3lcore/prog/ModelResult.re b/src/haz3lcore/prog/ModelResult.re index 25cee41b13..52c992d264 100644 --- a/src/haz3lcore/prog/ModelResult.re +++ b/src/haz3lcore/prog/ModelResult.re @@ -20,7 +20,7 @@ let update_elab = elab => Evaluation({elab, evaluation: ResultPending, previous: ResultPending}) | Evaluation({evaluation, _}) => Evaluation({elab, evaluation: ResultPending, previous: evaluation}) - | Stepper(s) as s' when DHExp.fast_equal(elab.d, Stepper.get_elab(s).d) => s' + | Stepper(s) as s' when DExp.fast_equal(elab.d, Stepper.get_elab(s).d) => s' | Stepper(_) => Stepper(Stepper.init(elab)); let update_stepper = f => diff --git a/src/haz3lcore/tiles/Id.re b/src/haz3lcore/tiles/Id.re index b377ca02b0..bc992204a4 100644 --- a/src/haz3lcore/tiles/Id.re +++ b/src/haz3lcore/tiles/Id.re @@ -23,7 +23,7 @@ CAN I USE IDS IN DYNAMICS? - Currently, DHExps (as produced by the elaborator and produced/consumed + Currently, DExps (as produced by the elaborator and produced/consumed by the evaluator) do not in general persist ids; the exceptions are things like holes and tests which have additional metadata which is accumulated duting evaluation. There are many use cases for tracking diff --git a/src/haz3lweb/view/Cell.re b/src/haz3lweb/view/Cell.re index 9edb5f0b40..05f22a25f2 100644 --- a/src/haz3lweb/view/Cell.re +++ b/src/haz3lweb/view/Cell.re @@ -397,7 +397,7 @@ let locked = statics.info_map, editor.state.meta.view_term, ) - : DHExp.Bool(true) |> DHExp.fresh; + : DExp.Bool(true) |> DExp.fresh; let elab: Elaborator.Elaboration.t = {d: elab, info_map: statics.info_map}; let result: ModelResult.t = settings.core.dynamics diff --git a/src/haz3lweb/view/StepperView.re b/src/haz3lweb/view/StepperView.re index d6b3582ccc..8b79eac5ad 100644 --- a/src/haz3lweb/view/StepperView.re +++ b/src/haz3lweb/view/StepperView.re @@ -150,7 +150,7 @@ let stepper_view = ~next_steps= List.mapi( (i, x: EvaluatorStep.EvalObj.t) => - (i, x.d_loc |> DHExp.rep_id), + (i, x.d_loc |> DExp.rep_id), Stepper.get_next_steps(stepper), ), hd, diff --git a/src/haz3lweb/view/dhcode/DHCode.re b/src/haz3lweb/view/dhcode/DHCode.re index b6f87322c3..bf856f7dc2 100644 --- a/src/haz3lweb/view/dhcode/DHCode.re +++ b/src/haz3lweb/view/dhcode/DHCode.re @@ -144,7 +144,7 @@ let view = ~next_steps: list((int, Id.t))=[], ~result_key: string, ~infomap, - d: DHExp.t, + d: DExp.t, ) : Node.t => { DHDoc_Exp.mk( diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index 4daaa9f3cb..dd5d3cb09a 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -42,9 +42,9 @@ let precedence_bin_string_op = (bso: Operators.op_bin_string) => | Concat => DHDoc_common.precedence_Plus | Equals => DHDoc_common.precedence_Equals }; -let rec precedence = (~show_casts: bool, d: DHExp.t) => { +let rec precedence = (~show_casts: bool, d: DExp.t) => { let precedence' = precedence(~show_casts); - switch (DHExp.term_of(d)) { + switch (DExp.term_of(d)) { | Var(_) | Invalid(_) | Bool(_) @@ -110,7 +110,7 @@ let mk = ~next_steps: list((int, Id.t)), // The options for the next step, if it hasn't been chosen yet ~env: ClosureEnvironment.t, ~infomap: Statics.Map.t, - d: DHExp.t, + d: DExp.t, ) : DHDoc.t => { // // print_endline(""); @@ -126,7 +126,7 @@ let mk = let precedence = precedence(~show_casts=settings.show_casts); let rec go = ( - d: DHExp.t, + d: DExp.t, env: ClosureEnvironment.t, enforce_inline: bool, recent_subst: list(Var.t), @@ -136,10 +136,10 @@ let mk = open Doc; let recent_subst = switch (previous_step) { - | Some((ps, id)) when id == DHExp.rep_id(d) => - switch (ps.knd, DHExp.term_of(ps.d_loc)) { + | Some((ps, id)) when id == DExp.rep_id(d) => + switch (ps.knd, DExp.term_of(ps.d_loc)) { | (FunAp, Ap(_, d2, _)) => - switch (DHExp.term_of(d2)) { + switch (DExp.term_of(d2)) { | Fun(p, _, _, _) => DHPat.bound_vars(infomap, p) | _ => [] } @@ -248,7 +248,7 @@ let mk = go_formattable(d2) |> parenthesize(precedence(d2) > precedence_op), ); let doc = { - switch (DHExp.term_of(d)) { + switch (DExp.term_of(d)) { | Parens(d') => go'(d') | Closure(env', d') => go'(d', ~env=env') | Filter(flt, d') => @@ -284,13 +284,13 @@ let mk = the postprocessed result */ | EmptyHole => DHDoc_common.mk_EmptyHole( - ~selected=Some(DHExp.rep_id(d)) == selected_hole_instance, + ~selected=Some(DExp.rep_id(d)) == selected_hole_instance, env, ) | MultiHole(_ds) => //ds |> List.map(go') |> Doc.hcats DHDoc_common.mk_EmptyHole( - ~selected=Some(DHExp.rep_id(d)) == selected_hole_instance, + ~selected=Some(DExp.rep_id(d)) == selected_hole_instance, env, ) | StaticErrorHole(_, d') => go'(d') |> annot(DHAnnot.NonEmptyHole) @@ -434,7 +434,7 @@ let mk = ]); } | FailedCast(d1, ty2', ty3) => - switch (DHExp.term_of(d1)) { + switch (DExp.term_of(d1)) { | Cast(d, ty1, ty2) when Typ.eq(ty2, ty2') => let d_doc = go'(d); let cast_decoration = @@ -493,7 +493,7 @@ let mk = ClosureEnvironment.without_keys(Option.to_list(s), env'), d, ) - |> DHExp.fresh, + |> DExp.fresh, ~env= ClosureEnvironment.without_keys( DHPat.bound_vars(infomap, dp) @ Option.to_list(s), @@ -589,22 +589,22 @@ let mk = }; }; let steppable = - next_steps |> List.find_opt(((_, id)) => id == DHExp.rep_id(d)); + next_steps |> List.find_opt(((_, id)) => id == DExp.rep_id(d)); let stepped = chosen_step - |> Option.map(x => DHExp.rep_id(x.d_loc) == DHExp.rep_id(d)) + |> Option.map(x => DExp.rep_id(x.d_loc) == DExp.rep_id(d)) |> Option.value(~default=false); let substitution = hidden_steps |> List.find_opt(((step, id)) => step.knd == VarLookup // HACK[Matt]: to prevent substitutions hiding inside casts - && id == DHExp.rep_id(d) + && id == DExp.rep_id(d) ); let doc = switch (substitution) { | Some((step, _)) => - switch (DHExp.term_of(step.d_loc)) { + switch (DExp.term_of(step.d_loc)) { | Var(v) when List.mem(v, recent_subst) => hcats([text(v) |> annot(DHAnnot.Substituted), doc]) | _ => doc diff --git a/src/test/Test_Elaboration.re b/src/test/Test_Elaboration.re index f6b1d9271d..b70b2ace34 100644 --- a/src/test/Test_Elaboration.re +++ b/src/test/Test_Elaboration.re @@ -1,17 +1,17 @@ open Alcotest; open Haz3lcore; -open DHExp; +open DExp; -let dhexp_eq = (d1: option(DHExp.t), d2: option(DHExp.t)): bool => +let dhexp_eq = (d1: option(DExp.t), d2: option(DExp.t)): bool => switch (d1, d2) { - | (Some(d1), Some(d2)) => DHExp.fast_equal(d1, d2) + | (Some(d1), Some(d2)) => DExp.fast_equal(d1, d2) | _ => false }; -let dhexp_print = (d: option(DHExp.t)): string => +let dhexp_print = (d: option(DExp.t)): string => switch (d) { | None => "None" - | Some(d) => DHExp.show(d) + | Some(d) => DExp.show(d) }; /*Create a testable type for dhexp which requires @@ -41,7 +41,7 @@ let u3: UExp.t = { copied: false, term: Parens({ids: [id_at(1)], copied: false, term: Var("y")}), }; -let d3: DHExp.t = StaticErrorHole(id_at(1), Var("y") |> fresh) |> fresh; +let d3: DExp.t = StaticErrorHole(id_at(1), Var("y") |> fresh) |> fresh; let free_var = () => alco_check( "Nonempty hole with free variable", @@ -83,7 +83,7 @@ let u4: UExp.t = { }, ), }; -let d4: DHExp.t = +let d4: DExp.t = Let( Tuple([Var("a") |> DHPat.fresh, Var("b") |> DHPat.fresh]) |> DHPat.fresh, Tuple([Int(4) |> fresh, Int(6) |> fresh]) |> fresh, @@ -107,7 +107,7 @@ let u5: UExp.t = { {ids: [id_at(2)], copied: false, term: Var("y")}, ), }; -let d5: DHExp.t = +let d5: DExp.t = BinOp( Int(Plus), StaticErrorHole(id_at(1), Bool(false) |> fresh) |> fresh, @@ -131,7 +131,7 @@ let u6: UExp.t = { {ids: [id_at(3)], copied: false, term: Int(6)}, ), }; -let d6: DHExp.t = +let d6: DExp.t = If(Bool(false) |> fresh, Int(8) |> fresh, Int(6) |> fresh) |> fresh; let consistent_if = () => alco_check( @@ -169,7 +169,7 @@ let u7: UExp.t = { {ids: [id_at(6)], copied: false, term: Var("y")}, ), }; -let d7: DHExp.t = +let d7: DExp.t = Ap( Forward, Fun( @@ -221,15 +221,15 @@ let u8: UExp.t = { ], ), }; -let d8scrut: DHExp.t = +let d8scrut: DExp.t = BinOp(Int(Equals), Int(4) |> fresh, Int(3) |> fresh) |> fresh; let d8rules = - DHExp.[ + DExp.[ (Bool(true) |> DHPat.fresh, Int(24) |> fresh), (Bool(false) |> DHPat.fresh, Bool(false) |> fresh), ]; -let d8a: DHExp.t = Match(d8scrut, d8rules) |> fresh; -let d8: DHExp.t = StaticErrorHole(id_at(0), d8a) |> fresh; +let d8a: DExp.t = Match(d8scrut, d8rules) |> fresh; +let d8: DExp.t = StaticErrorHole(id_at(0), d8a) |> fresh; let inconsistent_case = () => alco_check( "Inconsistent branches where the first branch is an integer and second branch is a boolean", @@ -280,7 +280,7 @@ let u9: UExp.t = { {ids: [id_at(11)], copied: false, term: Int(55)}, ), }; -// let d9: DHExp.t = +// let d9: DExp.t = // Let( // Var("f"), // FixF( From 7c00c384f132a3a5dad9375644d2927642c27024 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Tue, 5 Mar 2024 12:04:12 -0500 Subject: [PATCH 044/103] Add a big map for terms --- src/haz3lcore/dynamics/DH.re | 4 +- src/haz3lcore/dynamics/DHPat.re | 2 +- src/haz3lcore/dynamics/Elaborator.re | 8 +- src/haz3lcore/dynamics/EvalCtx.re | 16 +- src/haz3lcore/dynamics/FilterMatcher.re | 2 +- src/haz3lcore/dynamics/PatternMatch.re | 15 +- src/haz3lcore/dynamics/PatternMatch.rei | 2 +- src/haz3lcore/dynamics/dterm/DExp.re | 1 - src/haz3lcore/lang/term/Any.re | 6 +- src/haz3lcore/lang/term/Exp.re | 2 +- src/haz3lcore/lang/term/Pat.re | 2 +- src/haz3lcore/lang/term/TermBase.re | 454 ++++++++++++++++-- src/haz3lcore/lang/term/TypTerm.re | 2 +- src/haz3lcore/statics/Info.re | 3 +- src/haz3lcore/zipper/EditorUtil.re | 17 +- src/haz3lschool/Exercise.re | 8 +- src/haz3lweb/DebugConsole.re | 2 +- src/haz3lweb/view/ExplainThis.re | 16 +- src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re | 4 +- src/haz3lweb/view/dhcode/layout/DHDoc_Pat.rei | 4 +- 20 files changed, 467 insertions(+), 103 deletions(-) diff --git a/src/haz3lcore/dynamics/DH.re b/src/haz3lcore/dynamics/DH.re index 8fc73c3335..0f2c80b04f 100644 --- a/src/haz3lcore/dynamics/DH.re +++ b/src/haz3lcore/dynamics/DH.re @@ -34,7 +34,7 @@ */ module DExp: { - include (module type of TermBase.UExp); + include (module type of TermBase.Exp); let rep_id: t => Id.t; let term_of: t => term; @@ -56,7 +56,7 @@ module DExp: { (TermBase.StepperFilterKind.t, TermBase.StepperFilterKind.t) => bool; } = { [@deriving (show({with_path: false}), sexp, yojson)] - include TermBase.UExp; + include TermBase.Exp; let rep_id = ({ids, _}) => List.hd(ids); let term_of = ({term, _}) => term; diff --git a/src/haz3lcore/dynamics/DHPat.re b/src/haz3lcore/dynamics/DHPat.re index 32b90ea726..814c439552 100644 --- a/src/haz3lcore/dynamics/DHPat.re +++ b/src/haz3lcore/dynamics/DHPat.re @@ -1,4 +1,4 @@ -open TermBase.UPat; +open TermBase.Pat; // [@deriving (show({with_path: false}), sexp, yojson)] // type term = diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index e9ee38ce92..2ca85be35c 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -205,10 +205,10 @@ let rec dhexp_of_uexp = /* TODO: add a dhexp case and eval logic for multiholes. Make sure new dhexp form is properly considered Indet to avoid casting issues. */ - | Bool(b) => Some(Bool(b) |> rewrap) - | Int(n) => Some(Int(n) |> rewrap) - | Float(n) => Some(Float(n) |> rewrap) - | String(s) => Some(String(s) |> rewrap) + | Bool(_) + | Int(_) + | Float(_) + | String(_) => Some(uexp) | ListLit(es) => let+ ds = es |> List.map(dhexp_of_uexp(m)) |> OptUtil.sequence; DExp.ListLit(ds) |> rewrap; diff --git a/src/haz3lcore/dynamics/EvalCtx.re b/src/haz3lcore/dynamics/EvalCtx.re index 8a85ea9def..b7758de80f 100644 --- a/src/haz3lcore/dynamics/EvalCtx.re +++ b/src/haz3lcore/dynamics/EvalCtx.re @@ -8,10 +8,10 @@ type term = | Filter(TermBase.StepperFilterKind.t, t) | Seq1(t, DExp.t) | Seq2(DExp.t, t) - | Let1(TermBase.UPat.t, t, DExp.t) - | Let2(TermBase.UPat.t, DExp.t, t) - | Fun(TermBase.UPat.t, t, option(ClosureEnvironment.t), option(Var.t)) - | FixF(TermBase.UPat.t, t, option(ClosureEnvironment.t)) + | Let1(Pat.t, t, DExp.t) + | Let2(Pat.t, DExp.t, t) + | Fun(Pat.t, t, option(ClosureEnvironment.t), option(Var.t)) + | FixF(Pat.t, t, option(ClosureEnvironment.t)) | Ap1(Operators.ap_direction, t, DExp.t) | Ap2(Operators.ap_direction, DExp.t, t) | If1(t, DExp.t, DExp.t) @@ -23,7 +23,7 @@ type term = | Tuple(t, (list(DExp.t), list(DExp.t))) | Test(t) | ListLit(t, (list(DExp.t), list(DExp.t))) - | MultiHole(t, (list(TermBase.Any.t), list(TermBase.Any.t))) + | MultiHole(t, (list(Any.t), list(Any.t))) | Cons1(t, DExp.t) | Cons2(DExp.t, t) | ListConcat1(t, DExp.t) @@ -32,12 +32,12 @@ type term = | Cast(t, Typ.t, Typ.t) | FailedCast(t, Typ.t, Typ.t) | DynamicErrorHole(t, InvalidOperationError.t) - | MatchScrut(t, list((TermBase.UPat.t, DExp.t))) + | MatchScrut(t, list((UPat.t, DExp.t))) | MatchRule( DExp.t, - TermBase.UPat.t, + UPat.t, t, - (list((TermBase.UPat.t, DExp.t)), list((TermBase.UPat.t, DExp.t))), + (list((UPat.t, DExp.t)), list((UPat.t, DExp.t))), ) and t = | Mark diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index ed107fb7a9..fbdb152e71 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -168,7 +168,7 @@ let rec matches_exp = | (TyAlias(_), _) => false }; } -and matches_pat = (d: TermBase.UPat.t, f: TermBase.UPat.t): bool => { +and matches_pat = (d: Pat.t, f: Pat.t): bool => { switch (d |> DHPat.term_of, f |> DHPat.term_of) { // Matt: I'm not sure what the exact semantics of matching should be here. | (Parens(x), _) => matches_pat(x, f) diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index 8d3786c284..09eea52cb2 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -28,7 +28,7 @@ let cast_sum_maps = }; }; -let rec matches = (dp: TermBase.UPat.t, d: DExp.t): match_result => +let rec matches = (dp: Pat.t, d: DExp.t): match_result => switch (DHPat.term_of(dp), DExp.term_of(d)) { | (Parens(x), _) => matches(x, d) | (TypeAnn(x, _), _) => matches(x, d) @@ -202,7 +202,7 @@ let rec matches = (dp: TermBase.UPat.t, d: DExp.t): match_result => and matches_cast_Sum = ( ctr: string, - dp: option(TermBase.UPat.t), + dp: option(Pat.t), d: DExp.t, castmaps: list(ConstructorMap.t((Typ.t, Typ.t))), ) @@ -272,11 +272,7 @@ and matches_cast_Sum = | ListConcat(_) => DoesNotMatch } and matches_cast_Tuple = - ( - dps: list(TermBase.UPat.t), - d: DExp.t, - elt_casts: list(list((Typ.t, Typ.t))), - ) + (dps: list(Pat.t), d: DExp.t, elt_casts: list(list((Typ.t, Typ.t)))) : match_result => switch (DExp.term_of(d)) { | Parens(d) => matches_cast_Tuple(dps, d, elt_casts) @@ -359,8 +355,7 @@ and matches_cast_Tuple = | If(_) => IndetMatch } and matches_cast_Cons = - (dp: TermBase.UPat.t, d: DExp.t, elt_casts: list((Typ.t, Typ.t))) - : match_result => + (dp: Pat.t, d: DExp.t, elt_casts: list((Typ.t, Typ.t))): match_result => switch (DExp.term_of(d)) { | Parens(d) => matches_cast_Cons(dp, d, elt_casts) | ListLit([]) => @@ -448,7 +443,7 @@ and matches_cast_Cons = }, elt_casts, ); - let dp2 = TermBase.UPat.ListLit(dptl) |> DHPat.fresh; + let dp2 = Pat.ListLit(dptl) |> DHPat.fresh; switch (matches(dp2, DExp.apply_casts(d2, list_casts))) { | DoesNotMatch => DoesNotMatch | IndetMatch => IndetMatch diff --git a/src/haz3lcore/dynamics/PatternMatch.rei b/src/haz3lcore/dynamics/PatternMatch.rei index dbe1124fd2..b2d3dd08aa 100644 --- a/src/haz3lcore/dynamics/PatternMatch.rei +++ b/src/haz3lcore/dynamics/PatternMatch.rei @@ -3,4 +3,4 @@ type match_result = | DoesNotMatch | IndetMatch; -let matches: (TermBase.UPat.t, DExp.t) => match_result; +let matches: (Pat.t, DExp.t) => match_result; diff --git a/src/haz3lcore/dynamics/dterm/DExp.re b/src/haz3lcore/dynamics/dterm/DExp.re index 64903dfccf..08e5f4f3e8 100644 --- a/src/haz3lcore/dynamics/dterm/DExp.re +++ b/src/haz3lcore/dynamics/dterm/DExp.re @@ -2,7 +2,6 @@ To discuss: 1. putting info inside expressions - 2. The issue with recursion capture */ diff --git a/src/haz3lcore/lang/term/Any.re b/src/haz3lcore/lang/term/Any.re index 406d2358ba..4e5905f4d0 100644 --- a/src/haz3lcore/lang/term/Any.re +++ b/src/haz3lcore/lang/term/Any.re @@ -1,14 +1,14 @@ include TermBase.Any; -let is_exp: t => option(TermBase.UExp.t) = +let is_exp: t => option(TermBase.Exp.t) = fun | Exp(e) => Some(e) | _ => None; -let is_pat: t => option(TermBase.UPat.t) = +let is_pat: t => option(TermBase.Pat.t) = fun | Pat(p) => Some(p) | _ => None; -let is_typ: t => option(TermBase.UTyp.t) = +let is_typ: t => option(TermBase.TypTerm.t) = fun | Typ(t) => Some(t) | _ => None; diff --git a/src/haz3lcore/lang/term/Exp.re b/src/haz3lcore/lang/term/Exp.re index 968afee766..7141cb41ab 100644 --- a/src/haz3lcore/lang/term/Exp.re +++ b/src/haz3lcore/lang/term/Exp.re @@ -1,4 +1,4 @@ -include TermBase.UExp; +include TermBase.Exp; [@deriving (show({with_path: false}), sexp, yojson)] type cls = diff --git a/src/haz3lcore/lang/term/Pat.re b/src/haz3lcore/lang/term/Pat.re index ab2042f498..48218b1afd 100644 --- a/src/haz3lcore/lang/term/Pat.re +++ b/src/haz3lcore/lang/term/Pat.re @@ -17,7 +17,7 @@ type cls = | Ap | TypeAnn; -include TermBase.UPat; +include TermBase.Pat; let rep_id = ({ids, _}: t) => { assert(ids != []); diff --git a/src/haz3lcore/lang/term/TermBase.re b/src/haz3lcore/lang/term/TermBase.re index 520a5acd9b..bd5cad1648 100644 --- a/src/haz3lcore/lang/term/TermBase.re +++ b/src/haz3lcore/lang/term/TermBase.re @@ -1,27 +1,84 @@ open Sexplib.Std; +let continue = x => x; +let stop = (_, x) => x; + +/* TODO: Explain map_term */ + module rec Any: { [@deriving (show({with_path: false}), sexp, yojson)] type t = - | Exp(UExp.t) - | Pat(UPat.t) - | Typ(UTyp.t) + | Exp(Exp.t) + | Pat(Pat.t) + | Typ(TypTerm.t) | TPat(TPat.t) | Rul(Rul.t) | Nul(unit) | Any(unit); + + let map_term: + ( + ~f_exp: (Exp.t => Exp.t, Exp.t) => Exp.t=?, + ~f_pat: (Pat.t => Pat.t, Pat.t) => Pat.t=?, + ~f_typ: (TypTerm.t => TypTerm.t, TypTerm.t) => TypTerm.t=?, + ~f_tpat: (TPat.t => TPat.t, TPat.t) => TPat.t=?, + ~f_rul: (Rul.t => Rul.t, Rul.t) => Rul.t=?, + ~f_any: (Any.t => Any.t, Any.t) => Any.t=?, + t + ) => + t; } = { [@deriving (show({with_path: false}), sexp, yojson)] type t = - | Exp(UExp.t) - | Pat(UPat.t) - | Typ(UTyp.t) + | Exp(Exp.t) + | Pat(Pat.t) + | Typ(TypTerm.t) | TPat(TPat.t) | Rul(Rul.t) | Nul(unit) | Any(unit); + + let map_term = + ( + ~f_exp=continue, + ~f_pat=continue, + ~f_typ=continue, + ~f_tpat=continue, + ~f_rul=continue, + ~f_any=continue, + x, + ) => { + let rec_call = y => + switch (y) { + | Exp(x) => + Exp(Exp.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any, x)) + | Pat(x) => + Pat(Pat.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any, x)) + | Typ(x) => + Typ( + TypTerm.map_term( + ~f_exp, + ~f_pat, + ~f_typ, + ~f_tpat, + ~f_rul, + ~f_any, + x, + ), + ) + | TPat(x) => + TPat( + TPat.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any, x), + ) + | Rul(x) => + Rul(Rul.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any, x)) + | Nul () => Nul() + | Any () => Any() + }; + x |> f_any(rec_call); + }; } -and UExp: { +and Exp: { [@deriving (show({with_path: false}), sexp, yojson)] type term = | Invalid(string) @@ -37,16 +94,16 @@ and UExp: { | ListLit(list(t)) | Constructor(string) | Fun( - UPat.t, + Pat.t, t, [@show.opaque] option(ClosureEnvironment.t), option(Var.t), ) | Tuple(list(t)) | Var(Var.t) - | Let(UPat.t, t, t) - | FixF(UPat.t, t, [@show.opaque] option(ClosureEnvironment.t)) - | TyAlias(TPat.t, UTyp.t, t) + | Let(Pat.t, t, t) + | FixF(Pat.t, t, [@show.opaque] option(ClosureEnvironment.t)) + | TyAlias(TPat.t, TypTerm.t, t) | Ap(Operators.ap_direction, t, t) | If(t, t, t) | Seq(t, t) @@ -59,7 +116,7 @@ and UExp: { | UnOp(Operators.op_un, t) | BinOp(Operators.op_bin, t, t) | BuiltinFun(string) - | Match(t, list((UPat.t, t))) + | Match(t, list((Pat.t, t))) | Cast(t, Typ.t, Typ.t) and t = { // invariant: nonempty @@ -67,6 +124,18 @@ and UExp: { copied: bool, term, }; + + let map_term: + ( + ~f_exp: (Exp.t => Exp.t, Exp.t) => Exp.t=?, + ~f_pat: (Pat.t => Pat.t, Pat.t) => Pat.t=?, + ~f_typ: (TypTerm.t => TypTerm.t, TypTerm.t) => TypTerm.t=?, + ~f_tpat: (TPat.t => TPat.t, TPat.t) => TPat.t=?, + ~f_rul: (Rul.t => Rul.t, Rul.t) => Rul.t=?, + ~f_any: (Any.t => Any.t, Any.t) => Any.t=?, + t + ) => + t; } = { [@deriving (show({with_path: false}), sexp, yojson)] type term = @@ -83,21 +152,21 @@ and UExp: { | ListLit(list(t)) | Constructor(string) | Fun( - UPat.t, + Pat.t, t, [@show.opaque] option(ClosureEnvironment.t), option(Var.t), ) | Tuple(list(t)) | Var(Var.t) - | Let(UPat.t, t, t) - | FixF(UPat.t, t, [@show.opaque] option(ClosureEnvironment.t)) // TODO[Matt]: CHECK WITH SOMEONE THAT I GOT THE STATIC SEMANTICS RIGHT - | TyAlias(TPat.t, UTyp.t, t) + | Let(Pat.t, t, t) + | FixF(Pat.t, t, [@show.opaque] option(ClosureEnvironment.t)) // TODO[Matt]: CHECK WITH SOMEONE THAT I GOT THE STATIC SEMANTICS RIGHT + | TyAlias(TPat.t, TypTerm.t, t) | Ap(Operators.ap_direction, t, t) // note: function is always first then argument; even in pipe mode | If(t, t, t) | Seq(t, t) | Test(t) - | Filter(StepperFilterKind.t, t) // TODO: Change to reflect UExp + | Filter(StepperFilterKind.t, t) // TODO: Change to reflect Exp | Closure([@show.opaque] ClosureEnvironment.t, t) | Parens(t) | Cons(t, t) @@ -105,7 +174,7 @@ and UExp: { | UnOp(Operators.op_un, t) | BinOp(Operators.op_bin, t, t) | BuiltinFun(string) /// Doesn't currently have a distinguishable syntax... - | Match(t, list((UPat.t, t))) + | Match(t, list((Pat.t, t))) // Why doesn't this use list(Rul.t)? | Cast(t, Typ.t, Typ.t) and t = { // invariant: nonempty @@ -113,8 +182,91 @@ and UExp: { copied: bool, term, }; + + let map_term = + ( + ~f_exp=continue, + ~f_pat=continue, + ~f_typ=continue, + ~f_tpat=continue, + ~f_rul=continue, + ~f_any=continue, + x, + ) => { + let exp_map_term = + Exp.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); + let pat_map_term = + Pat.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); + let typ_map_term = + TypTerm.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); + let tpat_map_term = + TPat.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); + let any_map_term = + Any.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); + let flt_map_term = + StepperFilterKind.map_term( + ~f_exp, + ~f_pat, + ~f_typ, + ~f_tpat, + ~f_rul, + ~f_any, + ); + let rec_call = ({term, _} as exp) => { + ...exp, + term: + switch (term) { + | EmptyHole + | Invalid(_) + | Bool(_) + | Int(_) + | Float(_) + | Constructor(_) + | String(_) + | Var(_) => term + | MultiHole(things) => MultiHole(List.map(any_map_term, things)) + | StaticErrorHole(id, e) => StaticErrorHole(id, exp_map_term(e)) + | DynamicErrorHole(e, err) => DynamicErrorHole(exp_map_term(e), err) + | FailedCast(e, t1, t2) => FailedCast(exp_map_term(e), t1, t2) + | ListLit(ts) => ListLit(List.map(exp_map_term, ts)) + | Fun(p, e, env, f) => + Fun(pat_map_term(p), exp_map_term(e), env, f) + | Tuple(xs) => Tuple(List.map(exp_map_term, xs)) + | Let(p, e1, e2) => + Let(pat_map_term(p), exp_map_term(e1), exp_map_term(e2)) + | FixF(p, e, env) => FixF(pat_map_term(p), exp_map_term(e), env) + | TyAlias(tp, t, e) => + TyAlias(tpat_map_term(tp), typ_map_term(t), exp_map_term(e)) + | Ap(op, e1, e2) => Ap(op, exp_map_term(e1), exp_map_term(e2)) + | If(e1, e2, e3) => + If(exp_map_term(e1), exp_map_term(e2), exp_map_term(e3)) + | Seq(e1, e2) => Seq(exp_map_term(e1), exp_map_term(e2)) + | Test(e) => Test(exp_map_term(e)) + | Filter(f, e) => Filter(flt_map_term(f), exp_map_term(e)) + | Closure(env, e) => Closure(env, exp_map_term(e)) + | Parens(e) => Parens(exp_map_term(e)) + | Cons(e1, e2) => Cons(exp_map_term(e1), exp_map_term(e2)) + | ListConcat(e1, e2) => + ListConcat(exp_map_term(e1), exp_map_term(e2)) + | UnOp(op, e) => UnOp(op, exp_map_term(e)) + | BinOp(op, e1, e2) => + BinOp(op, exp_map_term(e1), exp_map_term(e2)) + | BuiltinFun(str) => BuiltinFun(str) + | Match(e, rls) => + Match( + exp_map_term(e), + List.map( + ((p, e)) => (pat_map_term(p), exp_map_term(e)), + rls, + ), + ) + | Cast(e, t1, t2) => Cast(exp_map_term(e), t1, t2) + }, + }; + x |> f_exp(rec_call); + }; } -and UPat: { +and Pat: { [@deriving (show({with_path: false}), sexp, yojson)] type term = | Invalid(string) @@ -132,11 +284,23 @@ and UPat: { | Tuple(list(t)) | Parens(t) | Ap(t, t) - | TypeAnn(t, UTyp.t) + | TypeAnn(t, TypTerm.t) and t = { ids: list(Id.t), term, }; + + let map_term: + ( + ~f_exp: (Exp.t => Exp.t, Exp.t) => Exp.t=?, + ~f_pat: (Pat.t => Pat.t, Pat.t) => Pat.t=?, + ~f_typ: (TypTerm.t => TypTerm.t, TypTerm.t) => TypTerm.t=?, + ~f_tpat: (TPat.t => TPat.t, TPat.t) => TPat.t=?, + ~f_rul: (Rul.t => Rul.t, Rul.t) => Rul.t=?, + ~f_any: (Any.t => Any.t, Any.t) => Any.t=?, + t + ) => + t; } = { [@deriving (show({with_path: false}), sexp, yojson)] type term = @@ -155,13 +319,54 @@ and UPat: { | Tuple(list(t)) | Parens(t) | Ap(t, t) - | TypeAnn(t, UTyp.t) + | TypeAnn(t, TypTerm.t) and t = { ids: list(Id.t), term, }; + + let map_term = + ( + ~f_exp=continue, + ~f_pat=continue, + ~f_typ=continue, + ~f_tpat=continue, + ~f_rul=continue, + ~f_any=continue, + x, + ) => { + let pat_map_term = + Pat.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); + let typ_map_term = + TypTerm.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); + let any_map_term = + Any.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); + let rec_call = ({term, _} as exp) => { + ...exp, + term: + switch (term) { + | EmptyHole + | Invalid(_) + | Wild + | Bool(_) + | Int(_) + | Float(_) + | Constructor(_) + | String(_) + | Var(_) => term + | MultiHole(things) => MultiHole(List.map(any_map_term, things)) + | ListLit(ts) => ListLit(List.map(pat_map_term, ts)) + | Ap(e1, e2) => Ap(pat_map_term(e1), pat_map_term(e2)) + | Cons(e1, e2) => Cons(pat_map_term(e1), pat_map_term(e2)) + | Tuple(xs) => Tuple(List.map(pat_map_term, xs)) + | Parens(e) => Parens(pat_map_term(e)) + | TypeAnn(e, t) => TypeAnn(pat_map_term(e), typ_map_term(t)) + }, + }; + x |> f_pat(rec_call); + }; } -and UTyp: { +and TypTerm: { [@deriving (show({with_path: false}), sexp, yojson)] type term = | Invalid(string) @@ -180,12 +385,24 @@ and UTyp: { | Ap(t, t) | Sum(list(variant)) and variant = - | Variant(Constructor.t, list(Id.t), option(t)) + | Variant(Constructor.t, list(Id.t), option(t)) // What are the ids for? | BadEntry(t) and t = { ids: list(Id.t), term, }; + + let map_term: + ( + ~f_exp: (Exp.t => Exp.t, Exp.t) => Exp.t=?, + ~f_pat: (Pat.t => Pat.t, Pat.t) => Pat.t=?, + ~f_typ: (TypTerm.t => TypTerm.t, TypTerm.t) => TypTerm.t=?, + ~f_tpat: (TPat.t => TPat.t, TPat.t) => TPat.t=?, + ~f_rul: (Rul.t => Rul.t, Rul.t) => Rul.t=?, + ~f_any: (Any.t => Any.t, Any.t) => Any.t=?, + t + ) => + t; } = { [@deriving (show({with_path: false}), sexp, yojson)] type term = @@ -211,6 +428,53 @@ and UTyp: { ids: list(Id.t), term, }; + + let map_term = + ( + ~f_exp=continue, + ~f_pat=continue, + ~f_typ=continue, + ~f_tpat=continue, + ~f_rul=continue, + ~f_any=continue, + x, + ) => { + let typ_map_term = + TypTerm.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); + let any_map_term = + Any.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); + let rec_call = ({term, _} as exp) => { + ...exp, + term: + switch (term) { + | EmptyHole + | Invalid(_) + | Bool + | Int + | Float + | Constructor(_) + | String + | Var(_) => term + | List(t) => List(typ_map_term(t)) + | MultiHole(things) => MultiHole(List.map(any_map_term, things)) + | Ap(e1, e2) => Ap(typ_map_term(e1), typ_map_term(e2)) + | Tuple(xs) => Tuple(List.map(typ_map_term, xs)) + | Parens(e) => Parens(typ_map_term(e)) + | Arrow(t1, t2) => Arrow(typ_map_term(t1), typ_map_term(t2)) + | Sum(variants) => + Sum( + List.map( + fun + | Variant(c, ids, t) => + Variant(c, ids, Option.map(typ_map_term, t)) + | BadEntry(t) => BadEntry(typ_map_term(t)), + variants, + ), + ) + }, + }; + x |> f_typ(rec_call); + }; } and TPat: { [@deriving (show({with_path: false}), sexp, yojson)] @@ -223,6 +487,18 @@ and TPat: { ids: list(Id.t), term, }; + + let map_term: + ( + ~f_exp: (Exp.t => Exp.t, Exp.t) => Exp.t=?, + ~f_pat: (Pat.t => Pat.t, Pat.t) => Pat.t=?, + ~f_typ: (TypTerm.t => TypTerm.t, TypTerm.t) => TypTerm.t=?, + ~f_tpat: (TPat.t => TPat.t, TPat.t) => TPat.t=?, + ~f_rul: (Rul.t => Rul.t, Rul.t) => Rul.t=?, + ~f_any: (Any.t => Any.t, Any.t) => Any.t=?, + t + ) => + t; } = { [@deriving (show({with_path: false}), sexp, yojson)] type term = @@ -234,27 +510,99 @@ and TPat: { ids: list(Id.t), term, }; + + let map_term = + ( + ~f_exp=continue, + ~f_pat=continue, + ~f_typ=continue, + ~f_tpat=continue, + ~f_rul=continue, + ~f_any=continue, + x, + ) => { + let any_map_term = + Any.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); + let rec_call = ({term, _} as exp) => { + ...exp, + term: + switch (term) { + | EmptyHole + | Invalid(_) + | Var(_) => term + | MultiHole(things) => MultiHole(List.map(any_map_term, things)) + }, + }; + x |> f_tpat(rec_call); + }; } and Rul: { [@deriving (show({with_path: false}), sexp, yojson)] type term = | Invalid(string) | Hole(list(Any.t)) - | Rules(UExp.t, list((UPat.t, UExp.t))) + | Rules(Exp.t, list((Pat.t, Exp.t))) and t = { ids: list(Id.t), term, }; + + let map_term: + ( + ~f_exp: (Exp.t => Exp.t, Exp.t) => Exp.t=?, + ~f_pat: (Pat.t => Pat.t, Pat.t) => Pat.t=?, + ~f_typ: (TypTerm.t => TypTerm.t, TypTerm.t) => TypTerm.t=?, + ~f_tpat: (TPat.t => TPat.t, TPat.t) => TPat.t=?, + ~f_rul: (Rul.t => Rul.t, Rul.t) => Rul.t=?, + ~f_any: (Any.t => Any.t, Any.t) => Any.t=?, + t + ) => + t; } = { [@deriving (show({with_path: false}), sexp, yojson)] type term = | Invalid(string) | Hole(list(Any.t)) - | Rules(UExp.t, list((UPat.t, UExp.t))) + | Rules(Exp.t, list((Pat.t, Exp.t))) and t = { ids: list(Id.t), term, }; + + let map_term = + ( + ~f_exp=continue, + ~f_pat=continue, + ~f_typ=continue, + ~f_tpat=continue, + ~f_rul=continue, + ~f_any=continue, + x, + ) => { + let exp_map_term = + Exp.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); + let pat_map_term = + Pat.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); + let any_map_term = + Any.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); + let rec_call = ({term, _} as exp) => { + ...exp, + term: + switch (term) { + | Invalid(_) => term + | Hole(things) => Hole(List.map(any_map_term, things)) + | Rules(e, rls) => + Rules( + exp_map_term(e), + List.map( + ((p, e)) => (pat_map_term(p), exp_map_term(e)), + rls, + ), + ) + }, + }; + x |> f_rul(rec_call); + }; } and Environment: { @@ -263,12 +611,12 @@ and Environment: { type t_('a) = VarBstMap.Ordered.t_('a); [@deriving (show({with_path: false}), sexp, yojson)] - type t = t_(UExp.t); + type t = t_(Exp.t); } = { include VarBstMap.Ordered; [@deriving (show({with_path: false}), sexp, yojson)] - type t = t_(UExp.t); + type t = t_(Exp.t); } and ClosureEnvironment: { @@ -280,7 +628,7 @@ and ClosureEnvironment: { let id_of: t => EnvironmentId.t; let map_of: t => Environment.t; - let to_list: t => list((Var.t, UExp.t)); + let to_list: t => list((Var.t, Exp.t)); let of_environment: Environment.t => t; @@ -290,19 +638,19 @@ and ClosureEnvironment: { let is_empty: t => bool; let length: t => int; - let lookup: (t, Var.t) => option(UExp.t); + let lookup: (t, Var.t) => option(Exp.t); let contains: (t, Var.t) => bool; let update: (Environment.t => Environment.t, t) => t; let update_keep_id: (Environment.t => Environment.t, t) => t; - let extend: (t, (Var.t, UExp.t)) => t; - let extend_keep_id: (t, (Var.t, UExp.t)) => t; + let extend: (t, (Var.t, Exp.t)) => t; + let extend_keep_id: (t, (Var.t, Exp.t)) => t; let union: (t, t) => t; let union_keep_id: (t, t) => t; - let map: (((Var.t, UExp.t)) => UExp.t, t) => t; - let map_keep_id: (((Var.t, UExp.t)) => UExp.t, t) => t; - let filter: (((Var.t, UExp.t)) => bool, t) => t; - let filter_keep_id: (((Var.t, UExp.t)) => bool, t) => t; - let fold: (((Var.t, UExp.t), 'b) => 'b, 'b, t) => 'b; + let map: (((Var.t, Exp.t)) => Exp.t, t) => t; + let map_keep_id: (((Var.t, Exp.t)) => Exp.t, t) => t; + let filter: (((Var.t, Exp.t)) => bool, t) => t; + let filter_keep_id: (((Var.t, Exp.t)) => bool, t) => t; + let fold: (((Var.t, Exp.t), 'b) => 'b, 'b, t) => 'b; let without_keys: (list(Var.t), t) => t; @@ -386,7 +734,7 @@ and ClosureEnvironment: { and StepperFilterKind: { [@deriving (show({with_path: false}), sexp, yojson)] type filter = { - pat: UExp.t, + pat: Exp.t, act: FilterAction.t, }; @@ -395,11 +743,23 @@ and StepperFilterKind: { | Filter(filter) | Residue(int, FilterAction.t); - let map: (UExp.t => UExp.t, t) => t; + let map_term: + ( + ~f_exp: (Exp.t => Exp.t, Exp.t) => Exp.t=?, + ~f_pat: (Pat.t => Pat.t, Pat.t) => Pat.t=?, + ~f_typ: (TypTerm.t => TypTerm.t, TypTerm.t) => TypTerm.t=?, + ~f_tpat: (TPat.t => TPat.t, TPat.t) => TPat.t=?, + ~f_rul: (Rul.t => Rul.t, Rul.t) => Rul.t=?, + ~f_any: (Any.t => Any.t, Any.t) => Any.t=?, + t + ) => + t; + + let map: (Exp.t => Exp.t, t) => t; } = { [@deriving (show({with_path: false}), sexp, yojson)] type filter = { - pat: UExp.t, + pat: Exp.t, act: FilterAction.t, }; @@ -414,4 +774,20 @@ and StepperFilterKind: { | Residue(idx, act) => Residue(idx, act) }; }; + + let map_term = + ( + ~f_exp=continue, + ~f_pat=continue, + ~f_typ=continue, + ~f_tpat=continue, + ~f_rul=continue, + ~f_any=continue, + ) => { + let exp_map_term = + Exp.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); + fun + | Filter({pat: e, act}) => Filter({pat: exp_map_term(e), act}) + | Residue(i, a) => Residue(i, a); + }; }; diff --git a/src/haz3lcore/lang/term/TypTerm.re b/src/haz3lcore/lang/term/TypTerm.re index af50298459..abcf6a601a 100644 --- a/src/haz3lcore/lang/term/TypTerm.re +++ b/src/haz3lcore/lang/term/TypTerm.re @@ -16,7 +16,7 @@ type cls = | Parens | Ap; -include TermBase.UTyp; +include TermBase.TypTerm; let rep_id = ({ids, _}: t) => { assert(ids != []); diff --git a/src/haz3lcore/statics/Info.re b/src/haz3lcore/statics/Info.re index 740e49ca66..7a176b8daa 100644 --- a/src/haz3lcore/statics/Info.re +++ b/src/haz3lcore/statics/Info.re @@ -386,8 +386,7 @@ let status_exp = (ctx: Ctx.t, mode: Mode.t, self: Self.exp): status_exp => such as whether or not a type variable reference is free, and whether a ctr name is a dupe. */ let status_typ = - (ctx: Ctx.t, expects: typ_expects, term: TermBase.UTyp.t, ty: Typ.t) - : status_typ => + (ctx: Ctx.t, expects: typ_expects, term: TypTerm.t, ty: Typ.t): status_typ => switch (term.term) { | Invalid(token) => InHole(BadToken(token)) | EmptyHole => NotInHole(Type(ty)) diff --git a/src/haz3lcore/zipper/EditorUtil.re b/src/haz3lcore/zipper/EditorUtil.re index 9339b3df01..2ce51611c3 100644 --- a/src/haz3lcore/zipper/EditorUtil.re +++ b/src/haz3lcore/zipper/EditorUtil.re @@ -41,7 +41,7 @@ let editors_of_strings = (~read_only=false, xs: list(string)) => { (i, List.map(((_, oe)) => Option.get(oe), aes)); }; -let rec append_exp = (e1: TermBase.UExp.t, e2: TermBase.UExp.t) => { +let rec append_exp = (e1: Exp.t, e2: Exp.t) => { switch (e1.term) { | EmptyHole | Invalid(_) @@ -70,23 +70,18 @@ let rec append_exp = (e1: TermBase.UExp.t, e2: TermBase.UExp.t) => { | BinOp(_) | BuiltinFun(_) | Cast(_) - | Match(_) => - TermBase.UExp.{ids: [Id.mk()], copied: false, term: Seq(e1, e2)} + | Match(_) => Exp.{ids: [Id.mk()], copied: false, term: Seq(e1, e2)} | Seq(e11, e12) => let e12' = append_exp(e12, e2); - TermBase.UExp.{ids: e1.ids, copied: false, term: Seq(e11, e12')}; + Exp.{ids: e1.ids, copied: false, term: Seq(e11, e12')}; | Filter(kind, ebody) => let ebody' = append_exp(ebody, e2); - TermBase.UExp.{ids: e1.ids, copied: false, term: Filter(kind, ebody')}; + Exp.{ids: e1.ids, copied: false, term: Filter(kind, ebody')}; | Let(p, edef, ebody) => let ebody' = append_exp(ebody, e2); - TermBase.UExp.{ids: e1.ids, copied: false, term: Let(p, edef, ebody')}; + Exp.{ids: e1.ids, copied: false, term: Let(p, edef, ebody')}; | TyAlias(tp, tdef, ebody) => let ebody' = append_exp(ebody, e2); - TermBase.UExp.{ - ids: e1.ids, - copied: false, - term: TyAlias(tp, tdef, ebody'), - }; + Exp.{ids: e1.ids, copied: false, term: TyAlias(tp, tdef, ebody')}; }; }; diff --git a/src/haz3lschool/Exercise.re b/src/haz3lschool/Exercise.re index b8e32fd122..afe538cc32 100644 --- a/src/haz3lschool/Exercise.re +++ b/src/haz3lschool/Exercise.re @@ -556,7 +556,7 @@ module F = (ExerciseEnv: ExerciseEnv) => { module TermItem = { type t = { - term: TermBase.UExp.t, + term: Exp.t, term_ranges: TermRanges.t, }; }; @@ -576,9 +576,9 @@ module F = (ExerciseEnv: ExerciseEnv) => { }; let wrap_filter = (act: FilterAction.action, term: UExp.t): UExp.t => - TermBase.UExp.{ + Exp.{ term: - TermBase.UExp.Filter( + Exp.Filter( Filter({ act: FilterAction.(act, One), pat: { @@ -760,7 +760,7 @@ module F = (ExerciseEnv: ExerciseEnv) => { module DynamicsItem = { type t = { - term: TermBase.UExp.t, + term: Exp.t, info_map: Statics.Map.t, result: ModelResult.t, }; diff --git a/src/haz3lweb/DebugConsole.re b/src/haz3lweb/DebugConsole.re index 4e825a27a6..6c31bbbc3c 100644 --- a/src/haz3lweb/DebugConsole.re +++ b/src/haz3lweb/DebugConsole.re @@ -13,7 +13,7 @@ let print = ({settings, editors, _}: Model.t, key: string): unit => { switch (key) { | "F1" => z |> Zipper.show |> print | "F2" => z |> Zipper.unselect_and_zip |> Segment.show |> print - | "F3" => z |> term |> TermBase.UExp.show |> print + | "F3" => z |> term |> Exp.show |> print | "F4" => z |> term diff --git a/src/haz3lweb/view/ExplainThis.re b/src/haz3lweb/view/ExplainThis.re index 149224989a..ef0b567d31 100644 --- a/src/haz3lweb/view/ExplainThis.re +++ b/src/haz3lweb/view/ExplainThis.re @@ -380,7 +380,7 @@ let example_view = ]; }; -let rec bypass_parens_and_annot_pat = (pat: TermBase.UPat.t) => { +let rec bypass_parens_and_annot_pat = (pat: Pat.t) => { switch (pat.term) { | Parens(p) | TypeAnn(p, _) => bypass_parens_and_annot_pat(p) @@ -388,21 +388,21 @@ let rec bypass_parens_and_annot_pat = (pat: TermBase.UPat.t) => { }; }; -let rec bypass_parens_pat = (pat: TermBase.UPat.t) => { +let rec bypass_parens_pat = (pat: Pat.t) => { switch (pat.term) { | Parens(p) => bypass_parens_pat(p) | _ => pat }; }; -let rec bypass_parens_exp = (exp: TermBase.UExp.t) => { +let rec bypass_parens_exp = (exp: Exp.t) => { switch (exp.term) { | Parens(e) => bypass_parens_exp(e) | _ => exp }; }; -let rec bypass_parens_typ = (typ: TermBase.UTyp.t) => { +let rec bypass_parens_typ = (typ: TypTerm.t) => { switch (typ.term) { | Parens(t) => bypass_parens_typ(t) | _ => typ @@ -520,8 +520,8 @@ let get_doc = let rec get_message_exp = (term) : (list(Node.t), (list(Node.t), ColorSteps.t), list(Node.t)) => - switch (term) { - | TermBase.UExp.Invalid(_) => simple("Not a valid expression") + switch ((term: Exp.term)) { + | Exp.Invalid(_) => simple("Not a valid expression") | DynamicErrorHole(_) | StaticErrorHole(_) | FailedCast(_) @@ -1881,7 +1881,7 @@ let get_doc = doc, ); switch (tl.term) { - | TermBase.UPat.Cons(hd2, tl2) => + | Pat.Cons(hd2, tl2) => if (ListPat.cons2_pat.id == get_specificity_level(ListPat.cons2)) { let hd2_id = List.nth(hd2.ids, 0); let tl2_id = List.nth(tl2.ids, 0); @@ -2068,7 +2068,7 @@ let get_doc = doc, ); switch (result.term) { - | TermBase.UTyp.Arrow(arg2, result2) => + | TypTerm.Arrow(arg2, result2) => if (ArrowTyp.arrow3_typ.id == get_specificity_level(ArrowTyp.arrow3)) { let arg2_id = List.nth(arg2.ids, 0); let result2_id = List.nth(result2.ids, 0); diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re index dbe1278e22..57b7fc5622 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re @@ -1,7 +1,7 @@ open Pretty; open Haz3lcore; -let precedence = (dp: TermBase.UPat.t) => +let precedence = (dp: Pat.t) => switch (DHPat.term_of(dp)) { | EmptyHole | MultiHole(_) @@ -26,7 +26,7 @@ let rec mk = ~infomap: Statics.Map.t, ~parenthesize=false, ~enforce_inline: bool, - dp: TermBase.UPat.t, + dp: Pat.t, ) : DHDoc.t => { let mk' = mk(~enforce_inline, ~infomap); diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.rei b/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.rei index 5eb43e15c8..a64fa9d575 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.rei +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.rei @@ -1,12 +1,12 @@ open Haz3lcore; -let precedence: TermBase.UPat.t => int; +let precedence: Pat.t => int; let mk: ( ~infomap: Statics.Map.t, ~parenthesize: bool=?, ~enforce_inline: bool, - TermBase.UPat.t + Pat.t ) => DHDoc.t; From 4474937672401f2697fdefae0dc9b4ded9154b64 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Tue, 5 Mar 2024 15:46:34 -0500 Subject: [PATCH 045/103] Tidy up elaboration --- src/haz3lcore/dynamics/DH.re | 87 ++------ src/haz3lcore/dynamics/Elaborator.re | 304 +++++++++++---------------- src/haz3lcore/lang/term/Exp.re | 2 + src/test/Test_Elaboration.re | 32 ++- 4 files changed, 158 insertions(+), 267 deletions(-) diff --git a/src/haz3lcore/dynamics/DH.re b/src/haz3lcore/dynamics/DH.re index 0f2c80b04f..5bc963faa6 100644 --- a/src/haz3lcore/dynamics/DH.re +++ b/src/haz3lcore/dynamics/DH.re @@ -56,7 +56,7 @@ module DExp: { (TermBase.StepperFilterKind.t, TermBase.StepperFilterKind.t) => bool; } = { [@deriving (show({with_path: false}), sexp, yojson)] - include TermBase.Exp; + include Exp; let rep_id = ({ids, _}) => List.hd(ids); let term_of = ({term, _}) => term; @@ -65,10 +65,6 @@ module DExp: { let fresh = term => { {ids: [Id.mk()], copied: false, term}; }; - let unwrap = ({ids, term, copied}) => ( - term, - term => {ids, term, copied}, - ); let mk = (ids, term) => { {ids, copied: true, term}; @@ -85,69 +81,26 @@ module DExp: { let apply_casts = (d: t, casts: list((Typ.t, Typ.t))): t => List.fold_left((d, (ty1, ty2)) => fresh_cast(d, ty1, ty2), d, casts); - // TODO: make this function emit a map of changes - let rec repair_ids = (require: bool, d: t) => { - let child_require = require || d.copied; - let repair_ids = repair_ids(child_require); - let term = term_of(d); - let rewrap = term => { - ids: - child_require - ? { - let id = Id.mk(); - [id]; - } - : d.ids, - copied: false, - term, - }; - ( - switch (term) { - | EmptyHole - | Invalid(_) - | Var(_) - | BuiltinFun(_) - | Bool(_) - | Int(_) - | Float(_) - | String(_) - | Constructor(_) => term - | StaticErrorHole(static_id, d1) => - StaticErrorHole(static_id, repair_ids(d1)) - | DynamicErrorHole(d1, x) => DynamicErrorHole(repair_ids(d1), x) - | FailedCast(d1, t1, t2) => FailedCast(repair_ids(d1), t1, t2) - | Closure(env, d1) => Closure(env, repair_ids(d1)) - | Filter(flt, d1) => Filter(flt, repair_ids(d1)) - | Seq(d1, d2) => Seq(repair_ids(d1), repair_ids(d2)) - | Let(dp, d1, d2) => Let(dp, repair_ids(d1), repair_ids(d2)) - | FixF(f, d1, env) => FixF(f, repair_ids(d1), env) - | TyAlias(tp, t, d) => TyAlias(tp, t, repair_ids(d)) - | Fun(dp, d1, env, f) => Fun(dp, repair_ids(d1), env, f) - | Ap(dir, d1, d2) => Ap(dir, repair_ids(d1), repair_ids(d2)) - | Test(d1) => Test(repair_ids(d1)) - | UnOp(op, d1) => UnOp(op, repair_ids(d1)) - | BinOp(op, d1, d2) => BinOp(op, repair_ids(d1), repair_ids(d2)) - | ListLit(ds) => ListLit(List.map(repair_ids, ds)) - | Cons(d1, d2) => Cons(repair_ids(d1), repair_ids(d2)) - | Parens(d1) => Parens(repair_ids(d1)) - | ListConcat(d1, d2) => ListConcat(repair_ids(d1), repair_ids(d2)) - | Tuple(ds) => Tuple(List.map(repair_ids, ds)) - // TODO: repair ids inside multihole - | MultiHole(ds) => MultiHole(ds) - | Match(d1, rls) => - Match( - repair_ids(d1), - List.map(((p, d)) => (p, repair_ids(d)), rls), - ) - | Cast(d1, t1, t2) => Cast(repair_ids(d1), t1, t2) - | If(d1, d2, d3) => - If(repair_ids(d1), repair_ids(d2), repair_ids(d3)) - } - ) - |> rewrap; - }; + let replace_all_ids = + map_term( + ~f_exp=(continue, exp) => {...exp, ids: [Id.mk()]} |> continue, + ~f_pat=(continue, exp) => {...exp, ids: [Id.mk()]} |> continue, + ~f_typ=(continue, exp) => {...exp, ids: [Id.mk()]} |> continue, + ~f_tpat=(continue, exp) => {...exp, ids: [Id.mk()]} |> continue, + ~f_rul=(continue, exp) => {...exp, ids: [Id.mk()]} |> continue, + ); - let repair_ids = repair_ids(false); + let repair_ids = + map_term( + ~f_exp= + (continue, exp) => + if (exp.copied) { + replace_all_ids(exp); + } else { + continue(exp); + }, + _, + ); // Also strips static error holes - kinda like unelaboration let rec strip_casts = d => { diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 2ca85be35c..098de1096f 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -1,21 +1,10 @@ -open Util; -open OptUtil.Syntax; - /* - Currently, Elaboration does the following things: - - Insert casts - - Insert non-empty hole wrappers - - Remove TyAlias [should we do this??] - - Annotate functions with types, and names - - Insert implicit fixpoints (in types and expressions) - - Remove parentheses - Going the other way: - - There's going to be a horrible case with implicit fixpoint shadowing + A nice property would be that elaboration is idempotent... + */ - A nice property would be that elaboration is idempotent... - */ +exception MissingTypeInfo; module Elaboration = { [@deriving (show({with_path: false}), sexp, yojson)] @@ -44,6 +33,9 @@ let fixed_pat_typ = (m: Statics.Map.t, p: UPat.t): option(Typ.t) => | _ => None }; +/* Adds casts if required. + + When adding a new construct, [TODO: write something helpful here] */ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DExp.t) => switch (mode) { | Syn => d @@ -145,7 +137,12 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DExp.t) => /* Handles cast insertion and non-empty-hole wrapping for elaborated expressions */ -let wrap = (ctx: Ctx.t, u: Id.t, mode: Mode.t, self, d: DExp.t): DExp.t => +let wrap = (m, exp: Exp.t): DExp.t => { + let (mode, self, ctx) = + switch (Id.Map.find_opt(Exp.rep_id(exp), m)) { + | Some(Info.InfoExp({mode, self, ctx, _})) => (mode, self, ctx) + | _ => raise(MissingTypeInfo) + }; switch (Info.status_exp(ctx, mode, self)) { | NotInHole(_) => let self_ty = @@ -153,188 +150,131 @@ let wrap = (ctx: Ctx.t, u: Id.t, mode: Mode.t, self, d: DExp.t): DExp.t => | Some(self_ty) => Typ.normalize(ctx, self_ty) | None => Unknown(Internal) }; - cast(ctx, mode, self_ty, d); + cast(ctx, mode, self_ty, exp); | InHole( FreeVariable(_) | Common(NoType(_)) | Common(Inconsistent(Internal(_))), - ) => d + ) => exp | InHole(Common(Inconsistent(Expectation(_) | WithArrow(_)))) => - DExp.fresh(StaticErrorHole(u, d)) + DExp.fresh(StaticErrorHole(Exp.rep_id(exp), exp)) }; +}; -let rec dhexp_of_uexp = - (m: Statics.Map.t, uexp: UExp.t, in_filter: bool): option(DExp.t) => { - let dhexp_of_uexp = (~in_filter=in_filter, m, uexp) => { - dhexp_of_uexp(m, uexp, in_filter); - }; - switch (Id.Map.find_opt(UExp.rep_id(uexp), m)) { - | Some(InfoExp({mode, self, ctx, _})) => - let err_status = Info.status_exp(ctx, mode, self); - let id = UExp.rep_id(uexp); /* NOTE: using term uids for hole ids */ - let rewrap = DExp.mk(uexp.ids); - let+ d: DExp.t = - switch (uexp.term) { - // TODO: make closure actually convert - | Closure(_, d) => dhexp_of_uexp(m, d) - | Cast(d1, t1, t2) => - let+ d1' = dhexp_of_uexp(m, d1); - Cast(d1', t1, t2) |> rewrap; - | Invalid(t) => Some(DExp.Invalid(t) |> rewrap) - | EmptyHole => Some(DExp.EmptyHole |> rewrap) - | MultiHole(_: list(TermBase.Any.t)) => Some(EmptyHole |> rewrap) - // switch ( - // us - // |> List.filter_map( - // fun - // | TermBase.Any.Exp(x) => Some(x) - // | _ => None, - // ) - // ) { - // | [] => Some(DExp.EmptyHole |> rewrap) - // | us => - // let+ ds = us |> List.map(dhexp_of_uexp(m)) |> OptUtil.sequence; - // DExp.MultiHole(ds) |> rewrap; - // } - | StaticErrorHole(_, e) => dhexp_of_uexp(m, e) - | DynamicErrorHole(e, err) => - let+ d1 = dhexp_of_uexp(m, e); - DExp.DynamicErrorHole(d1, err) |> rewrap; - | FailedCast(e, t1, t2) => - let+ d1 = dhexp_of_uexp(m, e); - DExp.FailedCast(d1, t1, t2) |> rewrap; - /* TODO: add a dhexp case and eval logic for multiholes. - Make sure new dhexp form is properly considered Indet - to avoid casting issues. */ - | Bool(_) - | Int(_) - | Float(_) - | String(_) => Some(uexp) - | ListLit(es) => - let+ ds = es |> List.map(dhexp_of_uexp(m)) |> OptUtil.sequence; - DExp.ListLit(ds) |> rewrap; - | Fun(p, body, _, _) => - let+ d1 = dhexp_of_uexp(m, body); - DExp.Fun(p, d1, None, None) |> rewrap; - | Tuple(es) => - let+ ds = es |> List.map(dhexp_of_uexp(m)) |> OptUtil.sequence; - DExp.Tuple(ds) |> rewrap; - | Cons(e1, e2) => - let* dc1 = dhexp_of_uexp(m, e1); - let+ dc2 = dhexp_of_uexp(m, e2); - DExp.Cons(dc1, dc2) |> rewrap; - | ListConcat(e1, e2) => - let* dc1 = dhexp_of_uexp(m, e1); - let+ dc2 = dhexp_of_uexp(m, e2); - DExp.ListConcat(dc1, dc2) |> rewrap; - | UnOp(Meta(Unquote), e) => - switch (e.term) { - | Var("e") when in_filter => Some(Constructor("$e") |> DExp.fresh) - | Var("v") when in_filter => Some(Constructor("$v") |> DExp.fresh) - | _ => Some(DExp.EmptyHole |> rewrap) - } - | UnOp(Int(Minus), e) => - let+ dc = dhexp_of_uexp(m, e); - DExp.UnOp(Int(Minus), dc) |> rewrap; - | UnOp(Bool(Not), e) => - let+ dc = dhexp_of_uexp(m, e); - DExp.UnOp(Bool(Not), dc) |> rewrap; - | BinOp(op, e1, e2) => - let* dc1 = dhexp_of_uexp(m, e1); - let+ dc2 = dhexp_of_uexp(m, e2); - DExp.BinOp(op, dc1, dc2) |> rewrap; - | BuiltinFun(name) => Some(DExp.BuiltinFun(name) |> rewrap) - | Parens(e) => dhexp_of_uexp(m, e) - | Seq(e1, e2) => - let* d1 = dhexp_of_uexp(m, e1); - let+ d2 = dhexp_of_uexp(m, e2); - DExp.Seq(d1, d2) |> rewrap; - | Test(test) => - let+ dtest = dhexp_of_uexp(m, test); - DExp.Test(dtest) |> rewrap; - | Filter(Filter({act, pat: cond}), body) => - let* dcond = dhexp_of_uexp(~in_filter=true, m, cond); - let+ dbody = dhexp_of_uexp(m, body); - DExp.Filter(Filter({act, pat: dcond}), dbody) |> rewrap; - | Filter(Residue(_) as residue, body) => - let+ dbody = dhexp_of_uexp(m, body); - DExp.Filter(residue, dbody) |> rewrap; - | Var(name) => Some(Var(name) |> rewrap) - | Constructor(name) => Some(Constructor(name) |> rewrap) - | Let(p, def, body) => - let add_name: (option(string), DExp.t) => DExp.t = ( - (name, d) => { - let (term, rewrap) = DExp.unwrap(d); - switch (term) { - | Fun(p, e, ctx, _) => DExp.Fun(p, e, ctx, name) |> rewrap - | _ => d - }; +/* + This function converts user-expressions (UExp.t) to dynamic expressions (DExp.t). They + have the same datatype but there are some small differences so that UExp.t can be edited + and DExp.t can be evaluated. + + Currently, Elaboration does the following things: + + - Insert casts + - Insert non-empty hole wrappers + - Annotate functions with names + - Insert implicit fixpoints + - Remove parentheses [not strictly necessary] + - Remove TyAlias [not strictly necessary] + + When adding a new construct you can probably just add it to the default cases. + */ +let rec dexp_of_uexp = (m, uexp, ~in_filter) => { + Exp.map_term( + ~f_exp= + (continue, exp) => { + let (term, rewrap) = Exp.unwrap(exp); + switch (term) { + // Default cases: do not need to change at elaboration + | Closure(_) + | Cast(_) + | Invalid(_) + | EmptyHole + | MultiHole(_) + | StaticErrorHole(_) + | DynamicErrorHole(_) + | FailedCast(_) + | Bool(_) + | Int(_) + | Float(_) + | String(_) + | ListLit(_) + | Tuple(_) + | Cons(_) + | ListConcat(_) + | UnOp(Int(_) | Bool(_), _) + | BinOp(_) + | BuiltinFun(_) + | Seq(_) + | Test(_) + | Filter(Residue(_), _) + | Var(_) + | Constructor(_) + | Ap(_) + | If(_) + | Fun(_) + | FixF(_) + | Match(_) => continue(exp) |> wrap(m) + + // Unquote operator: should be turned into constructor if inside filter body. + | UnOp(Meta(Unquote), e) => + switch (e.term) { + | Var("e") when in_filter => + Constructor("$e") |> DExp.fresh |> wrap(m) + | Var("v") when in_filter => + Constructor("$v") |> DExp.fresh |> wrap(m) + | _ => DExp.EmptyHole |> DHExp.fresh |> wrap(m) } - ); - let* ddef = dhexp_of_uexp(m, def); - let+ dbody = dhexp_of_uexp(m, body); - switch (UPat.get_recursive_bindings(p)) { - | None => - /* not recursive */ - DExp.Let(p, add_name(UPat.get_var(p), ddef), dbody) |> rewrap - | Some(b) => - DExp.Let( - p, - FixF(p, add_name(Some(String.concat(",", b)), ddef), None) - |> DExp.fresh, - dbody, + | Filter(Filter({act, pat}), body) => + Filter( + Filter({act, pat: dexp_of_uexp(m, pat, ~in_filter=true)}), + dexp_of_uexp(m, body, ~in_filter), ) |> rewrap + |> wrap(m) + + // Let bindings: insert implicit fixpoints and label functions with their names. + | Let(p, def, body) => + let add_name: (option(string), DExp.t) => DExp.t = ( + (name, d) => { + let (term, rewrap) = DExp.unwrap(d); + switch (term) { + | Fun(p, e, ctx, _) => DExp.Fun(p, e, ctx, name) |> rewrap + | _ => d + }; + } + ); + let ddef = dexp_of_uexp(m, def, ~in_filter); + let dbody = dexp_of_uexp(m, body, ~in_filter); + switch (UPat.get_recursive_bindings(p)) { + | None => + /* not recursive */ + DExp.Let(p, add_name(UPat.get_var(p), ddef), dbody) + |> rewrap + |> wrap(m) + | Some(b) => + DExp.Let( + p, + FixF(p, add_name(Some(String.concat(",", b)), ddef), None) + |> DExp.fresh, + dbody, + ) + |> rewrap + |> wrap(m) + }; + + // type alias and parentheses: remove during elaboration + | TyAlias(_, _, e) + | Parens(e) => dexp_of_uexp(m, e, ~in_filter) }; - | FixF(p, e, _) => - let+ de = dhexp_of_uexp(m, e); - DExp.FixF(p, de, None) |> rewrap; - | Ap(dir, fn, arg) => - let* c_fn = dhexp_of_uexp(m, fn); - let+ c_arg = dhexp_of_uexp(m, arg); - DExp.Ap(dir, c_fn, c_arg) |> rewrap; - | If(c, e1, e2) => - let* c' = dhexp_of_uexp(m, c); - let* d1 = dhexp_of_uexp(m, e1); - let+ d2 = dhexp_of_uexp(m, e2); - // Use tag to mark inconsistent branches - switch (err_status) { - | InHole(Common(Inconsistent(Internal(_)))) => - DExp.If(c', d1, d2) |> rewrap - | _ => DExp.If(c', d1, d2) |> rewrap - }; - | Match(scrut, rules) => - let* d_scrut = dhexp_of_uexp(m, scrut); - let+ d_rules = - List.map( - ((p, e)) => { - let+ d_e = dhexp_of_uexp(m, e); - (p, d_e); - }, - rules, - ) - |> OptUtil.sequence; - switch (err_status) { - | InHole(Common(Inconsistent(Internal(_)))) => - DExp.Match(d_scrut, d_rules) |> rewrap - | _ => DExp.Match(d_scrut, d_rules) |> rewrap - }; - | TyAlias(_, _, e) => dhexp_of_uexp(m, e) - }; - switch (uexp.term) { - | Parens(_) => d - | _ => wrap(ctx, id, mode, self, d) - }; - | Some(InfoPat(_) | InfoTyp(_) | InfoTPat(_) | Secondary(_)) - | None => None - }; + }, + uexp, + ); }; //let dhexp_of_uexp = Core.Memo.general(~cache_size_bound=1000, dhexp_of_uexp); let uexp_elab = (m: Statics.Map.t, uexp: UExp.t): ElaborationResult.t => - switch (dhexp_of_uexp(m, uexp, false)) { - | None => DoesNotElaborate - | Some(d) => + switch (dexp_of_uexp(m, uexp, ~in_filter=false)) { + | exception MissingTypeInfo => DoesNotElaborate + | d => //let d = uexp_elab_wrap_builtins(d); let ty = switch (fixed_exp_typ(m, uexp)) { diff --git a/src/haz3lcore/lang/term/Exp.re b/src/haz3lcore/lang/term/Exp.re index 7141cb41ab..1abe0d1b46 100644 --- a/src/haz3lcore/lang/term/Exp.re +++ b/src/haz3lcore/lang/term/Exp.re @@ -48,6 +48,8 @@ let rep_id = ({ids, _}) => { List.hd(ids); }; +let unwrap = ({ids, term, copied}) => (term, term => {ids, term, copied}); + let cls_of_term: term => cls = fun | Invalid(_) => Invalid diff --git a/src/test/Test_Elaboration.re b/src/test/Test_Elaboration.re index b70b2ace34..bf0694f7b8 100644 --- a/src/test/Test_Elaboration.re +++ b/src/test/Test_Elaboration.re @@ -21,20 +21,20 @@ let dhexp_typ = testable(Fmt.using(dhexp_print, Fmt.string), dhexp_eq); let ids = List.init(12, _ => Id.mk()); let id_at = x => x |> List.nth(ids); let mk_map = CoreSettings.on |> Interface.Statics.mk_map; -let dhexp_of_uexp = u => Elaborator.dhexp_of_uexp(mk_map(u), u, false); +let dexp_of_uexp = u => + switch (Elaborator.dexp_of_uexp(mk_map(u), u, ~in_filter=false)) { + | x => Some(x) + | exception Elaborator.MissingTypeInfo => None + }; let alco_check = dhexp_typ |> Alcotest.check; let u1: UExp.t = {ids: [id_at(0)], copied: false, term: Int(8)}; let single_integer = () => - alco_check( - "Integer literal 8", - Some(Int(8) |> fresh), - dhexp_of_uexp(u1), - ); + alco_check("Integer literal 8", Some(Int(8) |> fresh), dexp_of_uexp(u1)); let u2: UExp.t = {ids: [id_at(0)], copied: false, term: EmptyHole}; let empty_hole = () => - alco_check("Empty hole", Some(EmptyHole |> fresh), dhexp_of_uexp(u2)); + alco_check("Empty hole", Some(EmptyHole |> fresh), dexp_of_uexp(u2)); let u3: UExp.t = { ids: [id_at(0)], @@ -46,7 +46,7 @@ let free_var = () => alco_check( "Nonempty hole with free variable", Some(d3), - dhexp_of_uexp(u3), + dexp_of_uexp(u3), ); let u4: UExp.t = { @@ -91,11 +91,7 @@ let d4: DExp.t = ) |> fresh; let let_exp = () => - alco_check( - "Let expression for tuple (a, b)", - Some(d4), - dhexp_of_uexp(u4), - ); + alco_check("Let expression for tuple (a, b)", Some(d4), dexp_of_uexp(u4)); let u5: UExp.t = { ids: [id_at(0)], @@ -118,7 +114,7 @@ let bin_op = () => alco_check( "Inconsistent binary integer operation (plus)", Some(d5), - dhexp_of_uexp(u5), + dexp_of_uexp(u5), ); let u6: UExp.t = { @@ -137,7 +133,7 @@ let consistent_if = () => alco_check( "Consistent case with rules (BoolLit(true), IntLit(8)) and (BoolLit(false), IntLit(6))", Some(d6), - dhexp_of_uexp(u6), + dexp_of_uexp(u6), ); let u7: UExp.t = { @@ -191,7 +187,7 @@ let ap_fun = () => alco_check( "Application of a function of a free variable wrapped inside a nonempty hole constructor", Some(d7), - dhexp_of_uexp(u7), + dexp_of_uexp(u7), ); let u8: UExp.t = { @@ -234,7 +230,7 @@ let inconsistent_case = () => alco_check( "Inconsistent branches where the first branch is an integer and second branch is a boolean", Some(d8), - dhexp_of_uexp(u8), + dexp_of_uexp(u8), ); let u9: UExp.t = { @@ -303,7 +299,7 @@ let u9: UExp.t = { // alco_check( // "Let expression for function which wraps a fix point constructor around the function", // Some(d9), -// dhexp_of_uexp(u9), +// dexp_of_uexp(u9), // ); let elaboration_tests = [ From 3900782775800108558425934d6097611e5fde31 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 7 Mar 2024 11:11:43 -0500 Subject: [PATCH 046/103] Use map for replacing ids --- src/haz3lcore/dynamics/dterm/DExp.re | 90 ++++++++++------------------ 1 file changed, 30 insertions(+), 60 deletions(-) diff --git a/src/haz3lcore/dynamics/dterm/DExp.re b/src/haz3lcore/dynamics/dterm/DExp.re index 08e5f4f3e8..5f2f12aa2e 100644 --- a/src/haz3lcore/dynamics/dterm/DExp.re +++ b/src/haz3lcore/dynamics/dterm/DExp.re @@ -36,6 +36,8 @@ This module is specifically for dynamic expressions. They are stored using the same data structure as user expressions, but have a few important invariants. + + TODO[Matt]: Explain the invariants. */ include Exp; @@ -64,67 +66,35 @@ let apply_casts = (d: t, casts: list((Typ.t, Typ.t))): t => List.fold_left((d, (ty1, ty2)) => fresh_cast(d, ty1, ty2), d, casts); // TODO: make this function emit a map of changes -let rec repair_ids = (require: bool, d: t) => { - let child_require = require || d.copied; - let repair_ids = repair_ids(child_require); - let term = term_of(d); - let rewrap = term => { - ids: - child_require - ? { - let id = Id.mk(); - [id]; - } - : d.ids, - copied: false, - term, - }; - ( - switch (term) { - | EmptyHole - | Invalid(_) - | Var(_) - | BuiltinFun(_) - | Bool(_) - | Int(_) - | Float(_) - | String(_) - | Constructor(_) => term - | StaticErrorHole(static_id, d1) => - StaticErrorHole(static_id, repair_ids(d1)) - | DynamicErrorHole(d1, x) => DynamicErrorHole(repair_ids(d1), x) - | FailedCast(d1, t1, t2) => FailedCast(repair_ids(d1), t1, t2) - | Closure(env, d1) => Closure(env, repair_ids(d1)) - | Filter(flt, d1) => Filter(flt, repair_ids(d1)) - | Seq(d1, d2) => Seq(repair_ids(d1), repair_ids(d2)) - | Let(dp, d1, d2) => Let(dp, repair_ids(d1), repair_ids(d2)) - | FixF(f, d1, env) => FixF(f, repair_ids(d1), env) - | TyAlias(tp, t, d) => TyAlias(tp, t, repair_ids(d)) - | Fun(dp, d1, env, f) => Fun(dp, repair_ids(d1), env, f) - | Ap(dir, d1, d2) => Ap(dir, repair_ids(d1), repair_ids(d2)) - | Test(d1) => Test(repair_ids(d1)) - | UnOp(op, d1) => UnOp(op, repair_ids(d1)) - | BinOp(op, d1, d2) => BinOp(op, repair_ids(d1), repair_ids(d2)) - | ListLit(ds) => ListLit(List.map(repair_ids, ds)) - | Cons(d1, d2) => Cons(repair_ids(d1), repair_ids(d2)) - | Parens(d1) => Parens(repair_ids(d1)) - | ListConcat(d1, d2) => ListConcat(repair_ids(d1), repair_ids(d2)) - | Tuple(ds) => Tuple(List.map(repair_ids, ds)) - // TODO: repair ids inside multihole - | MultiHole(ds) => MultiHole(ds) - | Match(d1, rls) => - Match( - repair_ids(d1), - List.map(((p, d)) => (p, repair_ids(d)), rls), - ) - | Cast(d1, t1, t2) => Cast(repair_ids(d1), t1, t2) - | If(d1, d2, d3) => If(repair_ids(d1), repair_ids(d2), repair_ids(d3)) - } - ) - |> rewrap; -}; +let replace_all_ids = + map_term( + ~f_exp=(continue, exp) => {...exp, ids: [Id.mk()]} |> continue, + ~f_pat=(continue, exp) => {...exp, ids: [Id.mk()]} |> continue, + ~f_typ=(continue, exp) => {...exp, ids: [Id.mk()]} |> continue, + ~f_tpat=(continue, exp) => {...exp, ids: [Id.mk()]} |> continue, + ~f_rul=(continue, exp) => {...exp, ids: [Id.mk()]} |> continue, + ); -let repair_ids = repair_ids(false); +// TODO: make this function emit a map of changes +let repair_ids = + map_term( + ~f_exp= + (continue, exp) => + if (exp.copied) { + replace_all_ids(exp); + } else { + continue(exp); + }, + _, + ); + +let strip_casts = + map_term(~f_exp=(continue, exp) => { + let (term, rewrap) = unwrap(exp); + switch (term) { + | Closure(_) => continue(exp) + }; + }); // Also strips static error holes - kinda like unelaboration let rec strip_casts = d => { From 6ffc0829187212b4e17c6b658e4524a520ec8a0e Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 7 Mar 2024 11:52:40 -0500 Subject: [PATCH 047/103] Remove DHExp, DHPat (replaced with DExp, DPat) --- docs/overview.md | 2 +- docs/stepper-and-filter.md | 2 +- src/haz3lcore/dynamics/DH.re | 277 ------------------ src/haz3lcore/dynamics/DHExp.re | 1 - src/haz3lcore/dynamics/Elaborator.re | 2 +- src/haz3lcore/dynamics/EvalCtx.re | 1 - src/haz3lcore/dynamics/FilterMatcher.re | 2 +- src/haz3lcore/dynamics/MetaVarInst.re | 2 +- src/haz3lcore/dynamics/MetaVarInst.rei | 2 +- src/haz3lcore/dynamics/PatternMatch.re | 10 +- src/haz3lcore/dynamics/Substitution.re | 8 +- src/haz3lcore/dynamics/Transition.re | 5 +- src/haz3lcore/dynamics/dterm/DExp.re | 102 +++---- .../dynamics/{DHPat.re => dterm/DPat.re} | 58 +--- src/haz3lcore/lang/term/Pat.re | 11 +- src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 18 +- src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re | 6 +- src/test/Test_Elaboration.re | 8 +- 18 files changed, 87 insertions(+), 430 deletions(-) delete mode 100644 src/haz3lcore/dynamics/DH.re delete mode 100644 src/haz3lcore/dynamics/DHExp.re rename src/haz3lcore/dynamics/{DHPat.re => dterm/DPat.re} (52%) diff --git a/docs/overview.md b/docs/overview.md index 56c20771cb..e991e24c2b 100644 --- a/docs/overview.md +++ b/docs/overview.md @@ -44,7 +44,7 @@ of type `Typ.t`. - `IDGen` - `TextShape` - dynamics - - internal syntax: `DExp`, `DHPat` + - internal syntax: `DExp`, `DPat` - external expressions are for editing - need to elaborate external expressions to internal in order to insert casts and closure information diff --git a/docs/stepper-and-filter.md b/docs/stepper-and-filter.md index d2057fcfda..43cc192e87 100644 --- a/docs/stepper-and-filter.md +++ b/docs/stepper-and-filter.md @@ -109,7 +109,7 @@ program, issue command for change the evaluation mode (big-step or small-step, lazy or eager), and a narrower filter has a higher priority. For the matching part, I choose the Hazel language it's self as the -pattern language. `UPat` and `DHPat` won't work since they only matches +pattern language. `UPat` and `DPat` won't work since they only matches against *values*, indicating I have to extend them somehow so that they can match against *expressions*. The empty hole is take as the match all filter, i.e. `*` in many other matching languages. It will diff --git a/src/haz3lcore/dynamics/DH.re b/src/haz3lcore/dynamics/DH.re deleted file mode 100644 index 5bc963faa6..0000000000 --- a/src/haz3lcore/dynamics/DH.re +++ /dev/null @@ -1,277 +0,0 @@ -/* - To discuss: - - 1. putting info inside expressions - 2. The issue with recursion capture - - - */ - -/* - DExps that can appear during evaluation, and thus won't have static information. - - - Closure - - Var [for mutual recursion; could probably get rid of if needed...] - - Let [for mutual recursion] - - Tuple([]) - - Cast - - Ap [in the casting rules for functions & in builtins] - - DynamicErrorHole - - FailedCast - - Int - - Bool - - Float - - String - - ListLit - - BuiltinFun - - It is important that the following do not appear during evaluation, because they - (theoretically) require static information: - - - Fun - - FixF - - */ - -module DExp: { - include (module type of TermBase.Exp); - - let rep_id: t => Id.t; - let term_of: t => term; - let fast_copy: (Id.t, t) => t; - // All children of term must have expression-unique ids. - let fresh: term => t; - let mk: (list(Id.t), term) => t; - let unwrap: t => (term, term => t); - - let fresh_cast: (t, Typ.t, Typ.t) => t; - - let apply_casts: (t, list((Typ.t, Typ.t))) => t; - let strip_casts: t => t; - - let repair_ids: t => t; - - let fast_equal: (t, t) => bool; - let filter_fast_equal: - (TermBase.StepperFilterKind.t, TermBase.StepperFilterKind.t) => bool; -} = { - [@deriving (show({with_path: false}), sexp, yojson)] - include Exp; - - let rep_id = ({ids, _}) => List.hd(ids); - let term_of = ({term, _}) => term; - let fast_copy = (id, {term, _}) => {ids: [id], term, copied: true}; - // All children of term must have expression-unique ids. - let fresh = term => { - {ids: [Id.mk()], copied: false, term}; - }; - - let mk = (ids, term) => { - {ids, copied: true, term}; - }; - - // All children of d must have expression-unique ids. - let fresh_cast = (d: t, t1: Typ.t, t2: Typ.t): t => - if (Typ.eq(t1, t2) || t2 == Unknown(SynSwitch)) { - d; - } else { - fresh(Cast(d, t1, t2)); - }; - - let apply_casts = (d: t, casts: list((Typ.t, Typ.t))): t => - List.fold_left((d, (ty1, ty2)) => fresh_cast(d, ty1, ty2), d, casts); - - let replace_all_ids = - map_term( - ~f_exp=(continue, exp) => {...exp, ids: [Id.mk()]} |> continue, - ~f_pat=(continue, exp) => {...exp, ids: [Id.mk()]} |> continue, - ~f_typ=(continue, exp) => {...exp, ids: [Id.mk()]} |> continue, - ~f_tpat=(continue, exp) => {...exp, ids: [Id.mk()]} |> continue, - ~f_rul=(continue, exp) => {...exp, ids: [Id.mk()]} |> continue, - ); - - let repair_ids = - map_term( - ~f_exp= - (continue, exp) => - if (exp.copied) { - replace_all_ids(exp); - } else { - continue(exp); - }, - _, - ); - - // Also strips static error holes - kinda like unelaboration - let rec strip_casts = d => { - let (term, rewrap) = unwrap(d); - switch (term) { - | Closure(ei, d) => Closure(ei, strip_casts(d)) |> rewrap - | Cast(d, _, _) => strip_casts(d) - | FailedCast(d, _, _) => strip_casts(d) - | Tuple(ds) => Tuple(ds |> List.map(strip_casts)) |> rewrap - | Cons(d1, d2) => Cons(strip_casts(d1), strip_casts(d2)) |> rewrap - | ListConcat(d1, d2) => - ListConcat(strip_casts(d1), strip_casts(d2)) |> rewrap - | ListLit(ds) => ListLit(List.map(strip_casts, ds)) |> rewrap - // TODO[Matt]: Strip multihole casts - | MultiHole(ds) => MultiHole(ds) |> rewrap - | StaticErrorHole(_, d) => strip_casts(d) - | Seq(a, b) => Seq(strip_casts(a), strip_casts(b)) |> rewrap - | Filter(f, b) => - Filter(strip_filter_casts(f), strip_casts(b)) |> rewrap - | Let(dp, b, c) => Let(dp, strip_casts(b), strip_casts(c)) |> rewrap - | FixF(a, c, env) => FixF(a, strip_casts(c), env) |> rewrap - | TyAlias(tp, t, d) => TyAlias(tp, t, strip_casts(d)) |> rewrap - | Fun(a, c, e, d) => Fun(a, strip_casts(c), e, d) |> rewrap - | Ap(dir, a, b) => Ap(dir, strip_casts(a), strip_casts(b)) |> rewrap - | Test(a) => Test(strip_casts(a)) |> rewrap - | BuiltinFun(fn) => BuiltinFun(fn) |> rewrap - | UnOp(op, d) => UnOp(op, strip_casts(d)) |> rewrap - | BinOp(a, b, c) => BinOp(a, strip_casts(b), strip_casts(c)) |> rewrap - | Match(a, rules) => - Match( - strip_casts(a), - List.map(((k, v)) => (k, strip_casts(v)), rules), - ) - |> rewrap - | Parens(d1) => Parens(strip_casts(d1)) |> rewrap - | EmptyHole as d - | Invalid(_) as d - | Var(_) as d - | Bool(_) as d - | Int(_) as d - | Float(_) as d - | String(_) as d - | Constructor(_) as d - | DynamicErrorHole(_) as d => d |> rewrap - | If(c, d1, d2) => - If(strip_casts(c), strip_casts(d1), strip_casts(d2)) |> rewrap - }; - } - and strip_filter_casts = f => { - switch (f) { - | Filter({act, pat}) => Filter({act, pat: pat |> strip_casts}) - | Residue(idx, act) => Residue(idx, act) - }; - }; - - let rec fast_equal = - ({term: d1, _} as d1exp, {term: d2, _} as d2exp): bool => { - switch (d1, d2) { - /* Primitive forms: regular structural equality */ - | (Var(_), _) - /* TODO: Not sure if this is right... */ - | (Bool(_), _) - | (Int(_), _) - | (Float(_), _) - | (Constructor(_), _) => d1 == d2 - | (String(s1), String(s2)) => String.equal(s1, s2) - | (String(_), _) => false - - | (Parens(x), _) => fast_equal(x, d2exp) - | (_, Parens(x)) => fast_equal(d1exp, x) - - /* Non-hole forms: recurse */ - | (Test(d1), Test(d2)) => fast_equal(d1, d2) - | (Seq(d11, d21), Seq(d12, d22)) => - fast_equal(d11, d12) && fast_equal(d21, d22) - | (Filter(f1, d1), Filter(f2, d2)) => - filter_fast_equal(f1, f2) && fast_equal(d1, d2) - | (Let(dp1, d11, d21), Let(dp2, d12, d22)) => - dp1 == dp2 && fast_equal(d11, d12) && fast_equal(d21, d22) - | (FixF(f1, d1, sigma1), FixF(f2, d2, sigma2)) => - f1 == f2 - && fast_equal(d1, d2) - && Option.equal(ClosureEnvironment.id_equal, sigma1, sigma2) - | (Fun(dp1, d1, None, s1), Fun(dp2, d2, None, s2)) => - dp1 == dp2 && fast_equal(d1, d2) && s1 == s2 - | (Fun(dp1, d1, Some(env1), s1), Fun(dp2, d2, Some(env2), s2)) => - dp1 == dp2 - && fast_equal(d1, d2) - && ClosureEnvironment.id_equal(env1, env2) - && s1 == s2 - | (Ap(dir1, d11, d21), Ap(dir2, d12, d22)) => - dir1 == dir2 && fast_equal(d11, d12) && fast_equal(d21, d22) - | (Cons(d11, d21), Cons(d12, d22)) => - fast_equal(d11, d12) && fast_equal(d21, d22) - | (ListConcat(d11, d21), ListConcat(d12, d22)) => - fast_equal(d11, d12) && fast_equal(d21, d22) - | (Tuple(ds1), Tuple(ds2)) => - List.length(ds1) == List.length(ds2) - && List.for_all2(fast_equal, ds1, ds2) - | (BuiltinFun(f1), BuiltinFun(f2)) => f1 == f2 - | (ListLit(ds1), ListLit(ds2)) => - List.length(ds1) == List.length(ds2) - && List.for_all2(fast_equal, ds1, ds2) - | (UnOp(op1, d1), UnOp(op2, d2)) => op1 == op2 && fast_equal(d1, d2) - | (BinOp(op1, d11, d21), BinOp(op2, d12, d22)) => - op1 == op2 && fast_equal(d11, d12) && fast_equal(d21, d22) - | (TyAlias(tp1, ut1, d1), TyAlias(tp2, ut2, d2)) => - tp1 == tp2 && ut1 == ut2 && fast_equal(d1, d2) - | (Cast(d1, ty11, ty21), Cast(d2, ty12, ty22)) - | (FailedCast(d1, ty11, ty21), FailedCast(d2, ty12, ty22)) => - fast_equal(d1, d2) && ty11 == ty12 && ty21 == ty22 - | (DynamicErrorHole(d1, reason1), DynamicErrorHole(d2, reason2)) => - fast_equal(d1, d2) && reason1 == reason2 - | (Match(s1, rs1), Match(s2, rs2)) => - fast_equal(s1, s2) - && List.length(rs2) == List.length(rs2) - && List.for_all2( - ((k1, v1), (k2, v2)) => k1 == k2 && fast_equal(v1, v2), - rs1, - rs2, - ) - | (If(d11, d12, d13), If(d21, d22, d23)) => - fast_equal(d11, d21) && fast_equal(d12, d22) && fast_equal(d13, d23) - /* We can group these all into a `_ => false` clause; separating - these so that we get exhaustiveness checking. */ - | (Seq(_), _) - | (Filter(_), _) - | (Let(_), _) - | (FixF(_), _) - | (Fun(_), _) - | (Test(_), _) - | (Ap(_), _) - | (BuiltinFun(_), _) - | (Cons(_), _) - | (ListConcat(_), _) - | (ListLit(_), _) - | (Tuple(_), _) - | (UnOp(_), _) - | (BinOp(_), _) - | (Cast(_), _) - | (FailedCast(_), _) - | (TyAlias(_), _) - | (DynamicErrorHole(_), _) - | (If(_), _) - | (Match(_), _) => false - - /* Hole forms: when checking environments, only check that - environment ID's are equal, don't check structural equality. - - (This resolves a performance issue with many nested holes.) */ - | (EmptyHole, EmptyHole) => true - | (MultiHole(_), MultiHole(_)) => rep_id(d1exp) == rep_id(d2exp) - | (StaticErrorHole(sid1, d1), StaticErrorHole(sid2, d2)) => - sid1 == sid2 && d1 == d2 - | (Invalid(text1), Invalid(text2)) => text1 == text2 - | (Closure(sigma1, d1), Closure(sigma2, d2)) => - ClosureEnvironment.id_equal(sigma1, sigma2) && fast_equal(d1, d2) - | (EmptyHole, _) - | (MultiHole(_), _) - | (StaticErrorHole(_), _) - | (Invalid(_), _) - | (Closure(_), _) => false - }; - } - and filter_fast_equal = (f1, f2) => { - switch (f1, f2) { - | (Filter(f1), Filter(f2)) => - fast_equal(f1.pat, f2.pat) && f1.act == f2.act - | (Residue(idx1, act1), Residue(idx2, act2)) => - idx1 == idx2 && act1 == act2 - | _ => false - }; - }; -}; diff --git a/src/haz3lcore/dynamics/DHExp.re b/src/haz3lcore/dynamics/DHExp.re deleted file mode 100644 index 9a2863aa97..0000000000 --- a/src/haz3lcore/dynamics/DHExp.re +++ /dev/null @@ -1 +0,0 @@ -include DH.DExp; diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 098de1096f..7241be8303 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -220,7 +220,7 @@ let rec dexp_of_uexp = (m, uexp, ~in_filter) => { Constructor("$e") |> DExp.fresh |> wrap(m) | Var("v") when in_filter => Constructor("$v") |> DExp.fresh |> wrap(m) - | _ => DExp.EmptyHole |> DHExp.fresh |> wrap(m) + | _ => DExp.EmptyHole |> DExp.fresh |> wrap(m) } | Filter(Filter({act, pat}), body) => Filter( diff --git a/src/haz3lcore/dynamics/EvalCtx.re b/src/haz3lcore/dynamics/EvalCtx.re index b7758de80f..ed2a4271a6 100644 --- a/src/haz3lcore/dynamics/EvalCtx.re +++ b/src/haz3lcore/dynamics/EvalCtx.re @@ -1,6 +1,5 @@ open Sexplib.Std; open Util; -open DH; [@deriving (show({with_path: false}), sexp, yojson)] type term = diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index fbdb152e71..40ccf2d945 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -169,7 +169,7 @@ let rec matches_exp = }; } and matches_pat = (d: Pat.t, f: Pat.t): bool => { - switch (d |> DHPat.term_of, f |> DHPat.term_of) { + switch (d |> DPat.term_of, f |> DPat.term_of) { // Matt: I'm not sure what the exact semantics of matching should be here. | (Parens(x), _) => matches_pat(x, f) | (_, Parens(x)) => matches_pat(d, x) diff --git a/src/haz3lcore/dynamics/MetaVarInst.re b/src/haz3lcore/dynamics/MetaVarInst.re index bb3c1bd31c..f87d0fb752 100644 --- a/src/haz3lcore/dynamics/MetaVarInst.re +++ b/src/haz3lcore/dynamics/MetaVarInst.re @@ -1,7 +1,7 @@ open Sexplib.Std; /** - * Hole instance index in DHPat and DExp + * Hole instance index in DPat and DExp */ [@deriving (show({with_path: false}), sexp, yojson)] type t = int; diff --git a/src/haz3lcore/dynamics/MetaVarInst.rei b/src/haz3lcore/dynamics/MetaVarInst.rei index 40b35d61ca..d9f02e6b73 100644 --- a/src/haz3lcore/dynamics/MetaVarInst.rei +++ b/src/haz3lcore/dynamics/MetaVarInst.rei @@ -1,5 +1,5 @@ /** - * Hole instance index in DHPat and DExp + * Hole instance index in DPat and DExp */ [@deriving (show({with_path: false}), sexp, yojson)] type t = int; diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index 09eea52cb2..87c42490fa 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -29,7 +29,7 @@ let cast_sum_maps = }; let rec matches = (dp: Pat.t, d: DExp.t): match_result => - switch (DHPat.term_of(dp), DExp.term_of(d)) { + switch (DPat.term_of(dp), DExp.term_of(d)) { | (Parens(x), _) => matches(x, d) | (TypeAnn(x, _), _) => matches(x, d) | (_, Var(_)) => DoesNotMatch @@ -359,12 +359,12 @@ and matches_cast_Cons = switch (DExp.term_of(d)) { | Parens(d) => matches_cast_Cons(dp, d, elt_casts) | ListLit([]) => - switch (DHPat.term_of(dp)) { + switch (DPat.term_of(dp)) { | ListLit([]) => Matches(Environment.empty) | _ => DoesNotMatch } | ListLit([dhd, ...dtl] as ds) => - switch (DHPat.term_of(dp)) { + switch (DPat.term_of(dp)) { | Cons(dp1, dp2) => switch (matches(dp1, DExp.apply_casts(dhd, elt_casts))) { | DoesNotMatch => DoesNotMatch @@ -409,7 +409,7 @@ and matches_cast_Cons = | _ => failwith("called matches_cast_Cons with non-list pattern") } | Cons(d1, d2) => - switch (DHPat.term_of(dp)) { + switch (DPat.term_of(dp)) { | Cons(dp1, dp2) => switch (matches(dp1, DExp.apply_casts(d1, elt_casts))) { | DoesNotMatch => DoesNotMatch @@ -443,7 +443,7 @@ and matches_cast_Cons = }, elt_casts, ); - let dp2 = Pat.ListLit(dptl) |> DHPat.fresh; + let dp2 = Pat.ListLit(dptl) |> DPat.fresh; switch (matches(dp2, DExp.apply_casts(d2, list_casts))) { | DoesNotMatch => DoesNotMatch | IndetMatch => IndetMatch diff --git a/src/haz3lcore/dynamics/Substitution.re b/src/haz3lcore/dynamics/Substitution.re index 42fa93a803..d3a54d1c2f 100644 --- a/src/haz3lcore/dynamics/Substitution.re +++ b/src/haz3lcore/dynamics/Substitution.re @@ -20,7 +20,7 @@ let rec subst_var = (m, d1: DExp.t, x: Var.t, d2: DExp.t): DExp.t => { | Let(dp, d3, d4) => let d3 = subst_var(m, d1, x, d3); let d4 = - if (DHPat.binds_var(m, x, dp)) { + if (DPat.binds_var(m, x, dp)) { d4; } else { subst_var(m, d1, x, d4); @@ -29,7 +29,7 @@ let rec subst_var = (m, d1: DExp.t, x: Var.t, d2: DExp.t): DExp.t => { | FixF(y, d3, env) => let env' = Option.map(subst_var_env(m, d1, x), env); let d3 = - if (DHPat.binds_var(m, x, y)) { + if (DPat.binds_var(m, x, y)) { d3; } else { subst_var(m, d1, x, d3); @@ -39,7 +39,7 @@ let rec subst_var = (m, d1: DExp.t, x: Var.t, d2: DExp.t): DExp.t => { /* Function closure shouldn't appear during substitution (which only is called from elaboration currently) */ let env' = Option.map(subst_var_env(m, d1, x), env); - if (DHPat.binds_var(m, x, dp)) { + if (DPat.binds_var(m, x, dp)) { Fun(dp, d3, env', s) |> rewrap; } else { let d3 = subst_var(m, d1, x, d3); @@ -84,7 +84,7 @@ let rec subst_var = (m, d1: DExp.t, x: Var.t, d2: DExp.t): DExp.t => { let rules = List.map( ((p, v)) => - if (DHPat.binds_var(m, x, p)) { + if (DPat.binds_var(m, x, p)) { (p, v); } else { (p, subst_var(m, d1, x, v)); diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index 135e06ac3c..4a42522131 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -1,7 +1,6 @@ open Sexplib.Std; open Util; open PatternMatch; -open DH; /* Transition.re @@ -274,7 +273,7 @@ module Transition = (EV: EV_MODE) => { value: false, }); | FixF(dp, d1, Some(env)) => - switch (DHPat.get_var(dp)) { + switch (DPat.get_var(dp)) { // Simple Recursion case | Some(f) => let. _ = otherwise(env, d); @@ -291,7 +290,7 @@ module Transition = (EV: EV_MODE) => { // Mutual Recursion case | None => let. _ = otherwise(env, d); - let bindings = DHPat.bound_vars(info_map, dp); + let bindings = DPat.bound_vars(info_map, dp); let substitutions = List.map( binding => diff --git a/src/haz3lcore/dynamics/dterm/DExp.re b/src/haz3lcore/dynamics/dterm/DExp.re index 5f2f12aa2e..4f75ce1648 100644 --- a/src/haz3lcore/dynamics/dterm/DExp.re +++ b/src/haz3lcore/dynamics/dterm/DExp.re @@ -88,66 +88,50 @@ let repair_ids = _, ); -let strip_casts = - map_term(~f_exp=(continue, exp) => { - let (term, rewrap) = unwrap(exp); - switch (term) { - | Closure(_) => continue(exp) - }; - }); - // Also strips static error holes - kinda like unelaboration -let rec strip_casts = d => { - let (term, rewrap) = unwrap(d); - switch (term) { - | Closure(ei, d) => Closure(ei, strip_casts(d)) |> rewrap - | Cast(d, _, _) => strip_casts(d) - | FailedCast(d, _, _) => strip_casts(d) - | Tuple(ds) => Tuple(ds |> List.map(strip_casts)) |> rewrap - | Cons(d1, d2) => Cons(strip_casts(d1), strip_casts(d2)) |> rewrap - | ListConcat(d1, d2) => - ListConcat(strip_casts(d1), strip_casts(d2)) |> rewrap - | ListLit(ds) => ListLit(List.map(strip_casts, ds)) |> rewrap - // TODO[Matt]: Strip multihole casts - | MultiHole(ds) => MultiHole(ds) |> rewrap - | StaticErrorHole(_, d) => strip_casts(d) - | Seq(a, b) => Seq(strip_casts(a), strip_casts(b)) |> rewrap - | Filter(f, b) => Filter(strip_filter_casts(f), strip_casts(b)) |> rewrap - | Let(dp, b, c) => Let(dp, strip_casts(b), strip_casts(c)) |> rewrap - | FixF(a, c, env) => FixF(a, strip_casts(c), env) |> rewrap - | TyAlias(tp, t, d) => TyAlias(tp, t, strip_casts(d)) |> rewrap - | Fun(a, c, e, d) => Fun(a, strip_casts(c), e, d) |> rewrap - | Ap(dir, a, b) => Ap(dir, strip_casts(a), strip_casts(b)) |> rewrap - | Test(a) => Test(strip_casts(a)) |> rewrap - | BuiltinFun(fn) => BuiltinFun(fn) |> rewrap - | UnOp(op, d) => UnOp(op, strip_casts(d)) |> rewrap - | BinOp(a, b, c) => BinOp(a, strip_casts(b), strip_casts(c)) |> rewrap - | Match(a, rules) => - Match( - strip_casts(a), - List.map(((k, v)) => (k, strip_casts(v)), rules), - ) - |> rewrap - | Parens(d1) => Parens(strip_casts(d1)) |> rewrap - | EmptyHole as d - | Invalid(_) as d - | Var(_) as d - | Bool(_) as d - | Int(_) as d - | Float(_) as d - | String(_) as d - | Constructor(_) as d - | DynamicErrorHole(_) as d => d |> rewrap - | If(c, d1, d2) => - If(strip_casts(c), strip_casts(d1), strip_casts(d2)) |> rewrap - }; -} -and strip_filter_casts = f => { - switch (f) { - | Filter({act, pat}) => Filter({act, pat: pat |> strip_casts}) - | Residue(idx, act) => Residue(idx, act) - }; -}; +let rec strip_casts = + map_term( + ~f_exp= + (continue, exp) => { + switch (term_of(exp)) { + /* Leave non-casts unchanged */ + | Tuple(_) + | Cons(_) + | ListConcat(_) + | ListLit(_) + | MultiHole(_) + | Seq(_) + | Filter(_) + | Let(_) + | FixF(_) + | TyAlias(_) + | Fun(_) + | Ap(_) + | Test(_) + | BuiltinFun(_) + | UnOp(_) + | BinOp(_) + | Match(_) + | Parens(_) + | EmptyHole + | Invalid(_) + | Var(_) + | Bool(_) + | Int(_) + | Float(_) + | String(_) + | Constructor(_) + | DynamicErrorHole(_) + | Closure(_) + | If(_) => continue(exp) + /* Remove casts*/ + | StaticErrorHole(_, d) + | FailedCast(d, _, _) + | Cast(d, _, _) => strip_casts(d) + } + }, + _, + ); let rec fast_equal = ({term: d1, _} as d1exp, {term: d2, _} as d2exp): bool => { switch (d1, d2) { diff --git a/src/haz3lcore/dynamics/DHPat.re b/src/haz3lcore/dynamics/dterm/DPat.re similarity index 52% rename from src/haz3lcore/dynamics/DHPat.re rename to src/haz3lcore/dynamics/dterm/DPat.re index 814c439552..19d0026634 100644 --- a/src/haz3lcore/dynamics/DHPat.re +++ b/src/haz3lcore/dynamics/dterm/DPat.re @@ -1,39 +1,4 @@ -open TermBase.Pat; - -// [@deriving (show({with_path: false}), sexp, yojson)] -// type term = -// | Invalid(string) -// | EmptyHole -// // TODO: Multihole -// | Wild -// | Int(int) -// | Float(float) -// | Bool(bool) -// | String(string) -// // TODO: Remove Triv from UPat -// | ListLit(list(t)) -// | Constructor(string) -// | Cons(t, t) -// | Var(Var.t) -// | Tuple(list(t)) -// // TODO: parens -// | Ap(t, t) -// // TODO: Add Type Annotations??? -// // TODO: Work out what to do with invalids -// | NonEmptyHole(ErrStatus.HoleReason.t, MetaVar.t, MetaVarInst.t, t) -// | BadConstructor(MetaVar.t, MetaVarInst.t, string) -// and t = { -// ids: list(Id.t), -// term, -// }; - -let rep_id = ({ids, _}) => List.hd(ids); -let term_of = ({term, _}) => term; -// All children of term must have expression-unique ids. -let unwrap = ({ids, term}) => (term, term => {ids, term}); -let fresh = term => { - {ids: [Id.mk()], term}; -}; +include Pat; /** * Whether dp contains the variable x outside of a hole. @@ -87,24 +52,3 @@ let rec bound_vars = (m, dp: t): list(Var.t) => | Ap(_, dp1) => bound_vars(m, dp1) } }; - -let rec get_var = (pat: t) => { - switch (pat |> term_of) { - | Var(x) => Some(x) - | Parens(x) => get_var(x) - | TypeAnn(x, _) => get_var(x) - | Wild - | Int(_) - | Float(_) - | Bool(_) - | String(_) - | ListLit(_) - | Cons(_, _) - | Tuple(_) - | Constructor(_) - | EmptyHole - | Invalid(_) - | MultiHole(_) - | Ap(_) => None - }; -}; diff --git a/src/haz3lcore/lang/term/Pat.re b/src/haz3lcore/lang/term/Pat.re index 48218b1afd..3fd6462914 100644 --- a/src/haz3lcore/lang/term/Pat.re +++ b/src/haz3lcore/lang/term/Pat.re @@ -24,6 +24,15 @@ let rep_id = ({ids, _}: t) => { List.hd(ids); }; +let term_of = ({term, _}) => term; +// All children of term must have expression-unique ids. + +let unwrap = ({ids, term}) => (term, term => {ids, term}); + +let fresh = term => { + {ids: [Id.mk()], term}; +}; + let hole = (tms: list(TermBase.Any.t)) => switch (tms) { | [] => EmptyHole @@ -137,7 +146,7 @@ let rec get_var = (pat: t) => { switch (pat.term) { | Parens(pat) => get_var(pat) | Var(x) => Some(x) - | TypeAnn(_) + | TypeAnn(x, _) => get_var(x) | Invalid(_) | EmptyHole | MultiHole(_) diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index dd5d3cb09a..d1a6de8533 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -140,13 +140,13 @@ let mk = switch (ps.knd, DExp.term_of(ps.d_loc)) { | (FunAp, Ap(_, d2, _)) => switch (DExp.term_of(d2)) { - | Fun(p, _, _, _) => DHPat.bound_vars(infomap, p) + | Fun(p, _, _, _) => DPat.bound_vars(infomap, p) | _ => [] } | (FunAp, _) => [] - | (LetBind, Let(p, _, _)) => DHPat.bound_vars(infomap, p) + | (LetBind, Let(p, _, _)) => DPat.bound_vars(infomap, p) | (LetBind, _) => [] - | (FixUnwrap, FixF(p, _, _)) => DHPat.bound_vars(infomap, p) + | (FixUnwrap, FixF(p, _, _)) => DPat.bound_vars(infomap, p) | (FixUnwrap, _) => [] | (InvalidStep, _) | (VarLookup, _) @@ -406,7 +406,7 @@ let mk = if (enforce_inline) { fail(); } else { - let bindings = DHPat.bound_vars(infomap, dp); + let bindings = DPat.bound_vars(infomap, dp); let def_doc = go_formattable(ddef); vseps([ hcats([ @@ -486,7 +486,7 @@ let mk = ]); | Fun(dp, d, Some(env'), s) => if (settings.show_fn_bodies) { - let bindings = DHPat.bound_vars(infomap, dp); + let bindings = DPat.bound_vars(infomap, dp); let body_doc = go_formattable( Closure( @@ -496,7 +496,7 @@ let mk = |> DExp.fresh, ~env= ClosureEnvironment.without_keys( - DHPat.bound_vars(infomap, dp) @ Option.to_list(s), + DPat.bound_vars(infomap, dp) @ Option.to_list(s), env, ), ~recent_subst= @@ -525,7 +525,7 @@ let mk = } | Fun(dp, dbody, None, s) => if (settings.show_fn_bodies) { - let bindings = DHPat.bound_vars(infomap, dp); + let bindings = DPat.bound_vars(infomap, dp); let body_doc = go_formattable( dbody, @@ -561,7 +561,7 @@ let mk = dbody, ~env= ClosureEnvironment.without_keys( - DHPat.bound_vars(infomap, dp), + DPat.bound_vars(infomap, dp), env, ), ); @@ -581,7 +581,7 @@ let mk = go'( ~env= ClosureEnvironment.without_keys( - DHPat.bound_vars(infomap, dp), + DPat.bound_vars(infomap, dp), env, ), d, diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re index 57b7fc5622..2388af7f4c 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re @@ -2,7 +2,7 @@ open Pretty; open Haz3lcore; let precedence = (dp: Pat.t) => - switch (DHPat.term_of(dp)) { + switch (DPat.term_of(dp)) { | EmptyHole | MultiHole(_) | Wild @@ -39,7 +39,7 @@ let rec mk = mk'(~parenthesize=precedence(dp2) > precedence_op, dp2), ); let doc = - switch (DHPat.term_of(dp)) { + switch (DPat.term_of(dp)) { | MultiHole(_) | EmptyHole => DHDoc_common.mk_EmptyHole(ClosureEnvironment.empty) | Invalid(t) => DHDoc_common.mk_InvalidText(t) @@ -68,7 +68,7 @@ let rec mk = DHDoc_common.mk_Ap(doc1, doc2); }; let doc = - switch (Statics.get_pat_error_at(infomap, DHPat.rep_id(dp))) { + switch (Statics.get_pat_error_at(infomap, DPat.rep_id(dp))) { | Some(_) => Doc.annot(DHAnnot.NonEmptyHole, doc) | None => doc }; diff --git a/src/test/Test_Elaboration.re b/src/test/Test_Elaboration.re index bf0694f7b8..d338b2ffbb 100644 --- a/src/test/Test_Elaboration.re +++ b/src/test/Test_Elaboration.re @@ -85,7 +85,7 @@ let u4: UExp.t = { }; let d4: DExp.t = Let( - Tuple([Var("a") |> DHPat.fresh, Var("b") |> DHPat.fresh]) |> DHPat.fresh, + Tuple([Var("a") |> DPat.fresh, Var("b") |> DPat.fresh]) |> DPat.fresh, Tuple([Int(4) |> fresh, Int(6) |> fresh]) |> fresh, BinOp(Int(Minus), Var("a") |> fresh, Var("b") |> fresh) |> fresh, ) @@ -169,7 +169,7 @@ let d7: DExp.t = Ap( Forward, Fun( - Var("x") |> DHPat.fresh, + Var("x") |> DPat.fresh, BinOp( Int(Plus), Int(4) |> fresh, @@ -221,8 +221,8 @@ let d8scrut: DExp.t = BinOp(Int(Equals), Int(4) |> fresh, Int(3) |> fresh) |> fresh; let d8rules = DExp.[ - (Bool(true) |> DHPat.fresh, Int(24) |> fresh), - (Bool(false) |> DHPat.fresh, Bool(false) |> fresh), + (Bool(true) |> DPat.fresh, Int(24) |> fresh), + (Bool(false) |> DPat.fresh, Bool(false) |> fresh), ]; let d8a: DExp.t = Match(d8scrut, d8rules) |> fresh; let d8: DExp.t = StaticErrorHole(id_at(0), d8a) |> fresh; From c7637d6a9e4c1b8f90f5afc04605a2aa3e3e4481 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 7 Mar 2024 12:01:45 -0500 Subject: [PATCH 048/103] Delete unused files --- src/haz3lcore/dynamics/HoleInstance.re | 7 --- src/haz3lcore/dynamics/HoleInstance.rei | 23 ------- src/haz3lcore/dynamics/HoleInstanceId.re | 4 -- src/haz3lcore/dynamics/HoleInstanceId.rei | 6 -- src/haz3lcore/dynamics/HoleInstanceInfo.re | 38 ------------ src/haz3lcore/dynamics/HoleInstanceInfo.rei | 33 ---------- src/haz3lcore/dynamics/HoleInstanceInfo_.re | 61 ------------------- src/haz3lcore/dynamics/HoleInstanceInfo_.rei | 29 --------- src/haz3lcore/dynamics/HoleInstanceParents.re | 13 ---- .../dynamics/HoleInstanceParents.rei | 13 ---- src/haz3lcore/dynamics/InjSide.re | 15 ----- src/haz3lcore/dynamics/InstancePath.re | 4 -- src/haz3lcore/dynamics/InstancePath.rei | 2 - src/haz3lcore/dynamics/TypeAssignment.re | 1 + src/haz3lweb/view/dhcode/layout/DHAnnot.re | 4 +- 15 files changed, 3 insertions(+), 250 deletions(-) delete mode 100644 src/haz3lcore/dynamics/HoleInstance.re delete mode 100644 src/haz3lcore/dynamics/HoleInstance.rei delete mode 100644 src/haz3lcore/dynamics/HoleInstanceId.re delete mode 100644 src/haz3lcore/dynamics/HoleInstanceId.rei delete mode 100644 src/haz3lcore/dynamics/HoleInstanceInfo.re delete mode 100644 src/haz3lcore/dynamics/HoleInstanceInfo.rei delete mode 100644 src/haz3lcore/dynamics/HoleInstanceInfo_.re delete mode 100644 src/haz3lcore/dynamics/HoleInstanceInfo_.rei delete mode 100644 src/haz3lcore/dynamics/HoleInstanceParents.re delete mode 100644 src/haz3lcore/dynamics/HoleInstanceParents.rei delete mode 100644 src/haz3lcore/dynamics/InjSide.re delete mode 100644 src/haz3lcore/dynamics/InstancePath.re delete mode 100644 src/haz3lcore/dynamics/InstancePath.rei diff --git a/src/haz3lcore/dynamics/HoleInstance.re b/src/haz3lcore/dynamics/HoleInstance.re deleted file mode 100644 index 5925bf6ae8..0000000000 --- a/src/haz3lcore/dynamics/HoleInstance.re +++ /dev/null @@ -1,7 +0,0 @@ -[@deriving (show({with_path: false}), sexp, yojson)] -type t = (MetaVar.t, HoleInstanceId.t); - -let u_of = ((u, _): t): MetaVar.t => u; -let i_of = ((_, i): t): HoleInstanceId.t => i; - -let result: t = (Id.invalid, 0); diff --git a/src/haz3lcore/dynamics/HoleInstance.rei b/src/haz3lcore/dynamics/HoleInstance.rei deleted file mode 100644 index 1e1c40bbd6..0000000000 --- a/src/haz3lcore/dynamics/HoleInstance.rei +++ /dev/null @@ -1,23 +0,0 @@ -/** - Representation of a unique hole instantiation (the set of hole instances with - the same hole number and environment). - */ -[@deriving (show({with_path: false}), sexp, yojson)] -type t = (MetaVar.t, HoleInstanceId.t); - -/** - [u_of (u, i)] is [u], where [u] is the hole metavariable. - */ -let u_of: t => MetaVar.t; - -/** - [i_of (u, i)] is [i], where [i] is the hole instance id. - */ -let i_of: t => HoleInstanceId.t; - -/** - [result] is the special instance used to represent the parent "hole instance" - of the result; that is to say, if a hole instance has this value as its - parent, then it is directly in the result. - */ -let result: t; diff --git a/src/haz3lcore/dynamics/HoleInstanceId.re b/src/haz3lcore/dynamics/HoleInstanceId.re deleted file mode 100644 index 6db122bfcf..0000000000 --- a/src/haz3lcore/dynamics/HoleInstanceId.re +++ /dev/null @@ -1,4 +0,0 @@ -open Sexplib.Std; - -[@deriving (show({with_path: false}), sexp, yojson)] -type t = int; diff --git a/src/haz3lcore/dynamics/HoleInstanceId.rei b/src/haz3lcore/dynamics/HoleInstanceId.rei deleted file mode 100644 index 2093b1dcd5..0000000000 --- a/src/haz3lcore/dynamics/HoleInstanceId.rei +++ /dev/null @@ -1,6 +0,0 @@ -/** - Identifier for a unique hole closure/instantiation (unique among hole - closures for a given hole number). - */ -[@deriving (show({with_path: false}), sexp, yojson)] -type t = int; diff --git a/src/haz3lcore/dynamics/HoleInstanceInfo.re b/src/haz3lcore/dynamics/HoleInstanceInfo.re deleted file mode 100644 index f63e70a762..0000000000 --- a/src/haz3lcore/dynamics/HoleInstanceInfo.re +++ /dev/null @@ -1,38 +0,0 @@ -open Sexplib.Std; - -[@deriving (show({with_path: false}), sexp, yojson)] -type t = MetaVarMap.t(list((ClosureEnvironment.t, HoleInstanceParents.t))); - -let empty: t = MetaVarMap.empty; - -let num_instances = (hii: t, u: MetaVar.t): int => - hii - |> MetaVarMap.find_opt(u) - |> Option.map(his => List.length(his)) - |> Option.value(~default=0); - -let find_instance = - (hii: t, u: MetaVar.t, i: HoleInstanceId.t) - : option((ClosureEnvironment.t, HoleInstanceParents.t)) => { - switch (hii |> MetaVarMap.find_opt(u)) { - | Some(his) => List.nth_opt(his, i) - | None => None - }; -}; - -let add_parent = - ((u, i): HoleInstance.t, parent: HoleInstanceParents.t_, hii: t): t => { - let u_instances = hii |> MetaVarMap.find(u); - hii - |> MetaVarMap.add( - u, - u_instances - |> List.mapi((i', (env, parents)) => - if (i' == i) { - (env, parent |> HoleInstanceParents.add_parent(parents)); - } else { - (env, parents); - } - ), - ); -}; diff --git a/src/haz3lcore/dynamics/HoleInstanceInfo.rei b/src/haz3lcore/dynamics/HoleInstanceInfo.rei deleted file mode 100644 index e7477ff995..0000000000 --- a/src/haz3lcore/dynamics/HoleInstanceInfo.rei +++ /dev/null @@ -1,33 +0,0 @@ -/** - Stores information about all hole instances reachable by a program's - evaluation result. Used in the context inspector. - - Constructed using {!val:HoleInstanceInfo_.to_hole_instance_info}. - */ -[@deriving (show({with_path: false}), sexp, yojson)] -type t = MetaVarMap.t(list((ClosureEnvironment.t, HoleInstanceParents.t))); - -/** - [empty] is the empty info map. - */ -let empty: t; - -/** - [num_unique_his hii u] is the number of unique hole instances for a given - hole (given by the id [u]). - */ -let num_instances: (t, MetaVar.t) => int; - -/** - [find_instance hii u i] is the information for the given hole and hole - instance id, if found. - */ -let find_instance: - (t, MetaVar.t, HoleInstanceId.t) => - option((ClosureEnvironment.t, HoleInstanceParents.t)); - -/** - [add_parent (u, i) hip hii] adds the parent [hip] to the hole given by [(u, - i)]. Assumes both the parent and the hole exist in [hii]. - */ -let add_parent: (HoleInstance.t, HoleInstanceParents.t_, t) => t; diff --git a/src/haz3lcore/dynamics/HoleInstanceInfo_.re b/src/haz3lcore/dynamics/HoleInstanceInfo_.re deleted file mode 100644 index bee03aa10f..0000000000 --- a/src/haz3lcore/dynamics/HoleInstanceInfo_.re +++ /dev/null @@ -1,61 +0,0 @@ -/* - Variable names: - [hii] => "hole instance info" - [his] => "hole instances" - [hip] => "hole instance parents" - - TODO: Clear explanation of namings, probably in overall doc. - */ - -/** - Map associates a hole id to a hole instance id, hole closure environment, and - hole instance parents. - */ -[@deriving sexp] -type t = - MetaVarMap.t( - EnvironmentIdMap.t( - (HoleInstanceId.t, ClosureEnvironment.t, HoleInstanceParents.t), - ), - ); - -let empty: t = MetaVarMap.empty; - -let add_instance = - (hii: t, u: MetaVar.t, env: ClosureEnvironment.t): (t, HoleInstanceId.t) => { - let ei = env |> ClosureEnvironment.id_of; - switch (hii |> MetaVarMap.find_opt(u)) { - /* Hole already exists in the map. */ - | Some(his) => - switch (his |> EnvironmentIdMap.find_opt(ei)) { - /* Hole instance already exists in the map, simply return the hole instance - * id. */ - | Some((i, _, _)) => (hii, i) - /* Hole exists in the info map, but instance doesn't; create a new hole - * instance with next unique instance id. */ - | None => - let i = his |> EnvironmentIdMap.cardinal; - let his = his |> EnvironmentIdMap.add(ei, (i, env, [])); - let hii = hii |> MetaVarMap.add(u, his); - (hii, i); - } - /* Hole doesn't exist in the map. */ - | None => - let i = 0; - let his = EnvironmentIdMap.singleton(ei, (0, env, [])); - let hii = hii |> MetaVarMap.add(u, his); - (hii, i); - }; -}; - -let to_hole_instance_info = (hii: t): HoleInstanceInfo.t => - /* For each hole, arrange instances in order of increasing hole instance id. */ - hii - |> MetaVarMap.map(his => - his - |> EnvironmentIdMap.bindings - |> List.sort(((_, (i1, _, _)), (_, (i2, _, _))) => - compare(i1, i2) - ) - |> List.map(((_, (_, env, hip))) => (env, hip)) - ); diff --git a/src/haz3lcore/dynamics/HoleInstanceInfo_.rei b/src/haz3lcore/dynamics/HoleInstanceInfo_.rei deleted file mode 100644 index 8877f4da71..0000000000 --- a/src/haz3lcore/dynamics/HoleInstanceInfo_.rei +++ /dev/null @@ -1,29 +0,0 @@ -/** - Auxiliary data structure for constructing a {!type:HoleInstanceInfo.t}. - */ - -/* FIXME: Make this abstract. */ -[@deriving sexp] -type t; - -/** - [empty] is the empty info map. - */ -let empty: t; - -/** - [add_instance hii u env] binds a unique hole instance id for the - [(u, env)] pair representing a hole instance, assocating it in [hii] and - returning [(map', i)], where [map'] is the augmented [map] and [i] is the - hole instance id. - - If the pair already exists in [hii], the existing id is returned as [i]; - otherwise, a unique id is assigned and returned as [i]. - */ -let add_instance: - (t, MetaVar.t, ClosureEnvironment.t) => (t, HoleInstanceId.t); - -/** - [to_hole_instance_info hii] converts [hii] into {!type:HoleInstanceInfo.t}. - */ -let to_hole_instance_info: t => HoleInstanceInfo.t; diff --git a/src/haz3lcore/dynamics/HoleInstanceParents.re b/src/haz3lcore/dynamics/HoleInstanceParents.re deleted file mode 100644 index 3935a3b8c8..0000000000 --- a/src/haz3lcore/dynamics/HoleInstanceParents.re +++ /dev/null @@ -1,13 +0,0 @@ -open Sexplib.Std; - -[@deriving (show({with_path: false}), sexp, yojson)] -type t_ = (Var.t, HoleInstance.t) -and t = list(t_); - -let to_list = (hcp: t): list(t_) => hcp; -let singleton = (parent: t_) => [parent]; - -let add_parent = (hcp: t, new_parent: t_) => [ - new_parent, - ...List.filter(p => p != new_parent, hcp), -]; diff --git a/src/haz3lcore/dynamics/HoleInstanceParents.rei b/src/haz3lcore/dynamics/HoleInstanceParents.rei deleted file mode 100644 index 96b43acc95..0000000000 --- a/src/haz3lcore/dynamics/HoleInstanceParents.rei +++ /dev/null @@ -1,13 +0,0 @@ -/** - List of hole instance parents. A single hole instance (set of closures with - the same environment) may have multiple parents. - */ - -[@deriving (show({with_path: false}), sexp, yojson)] -type t_ = (Var.t, HoleInstance.t) -and t = list(t_); - -let to_list: t => list(t_); -let singleton: t_ => t; - -let add_parent: (t, t_) => t; diff --git a/src/haz3lcore/dynamics/InjSide.re b/src/haz3lcore/dynamics/InjSide.re deleted file mode 100644 index 690f23871d..0000000000 --- a/src/haz3lcore/dynamics/InjSide.re +++ /dev/null @@ -1,15 +0,0 @@ -[@deriving (show({with_path: false}), sexp, yojson)] -type t = - | L - | R; - -let to_string = - fun - | L => "L" - | R => "R"; - -let pick = (side, l, r) => - switch (side) { - | L => l - | R => r - }; diff --git a/src/haz3lcore/dynamics/InstancePath.re b/src/haz3lcore/dynamics/InstancePath.re deleted file mode 100644 index 117a03806e..0000000000 --- a/src/haz3lcore/dynamics/InstancePath.re +++ /dev/null @@ -1,4 +0,0 @@ -open Sexplib.Std; - -[@deriving sexp] -type t = list((HoleInstance.t, Var.t)); diff --git a/src/haz3lcore/dynamics/InstancePath.rei b/src/haz3lcore/dynamics/InstancePath.rei deleted file mode 100644 index 8e205a0052..0000000000 --- a/src/haz3lcore/dynamics/InstancePath.rei +++ /dev/null @@ -1,2 +0,0 @@ -[@deriving sexp] -type t = list((HoleInstance.t, Var.t)); diff --git a/src/haz3lcore/dynamics/TypeAssignment.re b/src/haz3lcore/dynamics/TypeAssignment.re index 0a6a1e3d90..6e167a8480 100644 --- a/src/haz3lcore/dynamics/TypeAssignment.re +++ b/src/haz3lcore/dynamics/TypeAssignment.re @@ -1,3 +1,4 @@ +// TODO[Matt]: uncomment or remove // open Util; // open OptUtil.Syntax; // /* diff --git a/src/haz3lweb/view/dhcode/layout/DHAnnot.re b/src/haz3lweb/view/dhcode/layout/DHAnnot.re index f6cfcf36f3..71f650fb50 100644 --- a/src/haz3lweb/view/dhcode/layout/DHAnnot.re +++ b/src/haz3lweb/view/dhcode/layout/DHAnnot.re @@ -10,8 +10,8 @@ type t = | Delim | EmptyHole(bool, ClosureEnvironment.t) | NonEmptyHole - | VarHole(VarErrStatus.HoleReason.t, HoleInstance.t) - | InconsistentBranches(HoleInstance.t) + | VarHole(VarErrStatus.HoleReason.t, Id.t) + | InconsistentBranches(Id.t) | Invalid | FailedCastDelim | FailedCastDecoration From 69d5dba524396ba86e913df9a9cf1f12359042e8 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 7 Mar 2024 12:06:33 -0500 Subject: [PATCH 049/103] Fix hidden steps always showing --- src/haz3lweb/view/StepperView.re | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/src/haz3lweb/view/StepperView.re b/src/haz3lweb/view/StepperView.re index b7ef8b707a..f250dd2ba7 100644 --- a/src/haz3lweb/view/StepperView.re +++ b/src/haz3lweb/view/StepperView.re @@ -171,9 +171,11 @@ let stepper_view = let rec previous_step = (~hidden: bool, step: Stepper.step_info): list(Node.t) => { let hidden_steps = - Stepper.hidden_steps_of_info(step) - |> List.rev_map(previous_step(~hidden=true)) - |> List.flatten; + settings.show_hidden_steps + ? Stepper.hidden_steps_of_info(step) + |> List.rev_map(previous_step(~hidden=true)) + |> List.flatten + : []; [ div( ~attr= @@ -202,10 +204,12 @@ let stepper_view = |> List.rev_append( _, ( - hd - |> Stepper.hidden_steps_of_info - |> List.map(previous_step(~hidden=true)) - |> List.flatten + settings.show_hidden_steps + ? hd + |> Stepper.hidden_steps_of_info + |> List.map(previous_step(~hidden=true)) + |> List.flatten + : [] ) @ [current], ) From 424c7c0fc178624aaa914ed95a771727ae398c75 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 7 Mar 2024 14:54:20 -0500 Subject: [PATCH 050/103] Move some functions, add some comments --- src/haz3lcore/dynamics/TypeAssignment.re | 31 ++++++++++-------------- src/haz3lcore/dynamics/dterm/DExp.re | 14 ++--------- src/haz3lcore/dynamics/dterm/DPat.re | 4 +++ src/haz3lcore/lang/term/Exp.re | 4 +++ src/haz3lcore/lang/term/TermBase.re | 5 +++- 5 files changed, 27 insertions(+), 31 deletions(-) diff --git a/src/haz3lcore/dynamics/TypeAssignment.re b/src/haz3lcore/dynamics/TypeAssignment.re index 6e167a8480..4e76eeb2b1 100644 --- a/src/haz3lcore/dynamics/TypeAssignment.re +++ b/src/haz3lcore/dynamics/TypeAssignment.re @@ -1,10 +1,5 @@ -// TODO[Matt]: uncomment or remove // open Util; // open OptUtil.Syntax; -// /* -// This module is currently unused, but we still theoretically want to be able to do it, particularly for -// when we have property-based testing around elaboration. -// */ // let equal_typ_case = (l: list(Typ.t)): option(Typ.t) => { // switch (l) { // | [] => None @@ -43,7 +38,7 @@ // }; // }; // let rec dhpat_extend_ctx = -// (dhpat: TermBase.UPat.t, ty: Typ.t, ctx: Ctx.t): Ctx.t => { +// (m: Statics.Map.t, dhpat: DPat.t, ty: Typ.t, ctx: Ctx.t): Ctx.t => { // switch (dhpat.term, ty) { // | (Var(name), _) => // let entry = Ctx.VarEntry({name, id: Id.invalid, typ: ty}); @@ -51,7 +46,7 @@ // | (Tuple(l1), Prod(l2)) => // if (List.length(l1) == List.length(l2)) { // List.fold_left2( -// (acc, dhp, typ) => {dhpat_extend_ctx(dhp, typ, acc)}, +// (acc, dhp, typ) => {dhpat_extend_ctx(m, dhp, typ, acc)}, // ctx, // l1, // l2, @@ -60,18 +55,18 @@ // ctx; // } // | (Cons(dhp1, dhp2), List(typ)) => -// ctx |> dhpat_extend_ctx(dhp1, typ) |> dhpat_extend_ctx(dhp2, ty) +// ctx |> dhpat_extend_ctx(m, dhp1, typ) |> dhpat_extend_ctx(m, dhp2, ty) // | (ListLit(l), List(typ2)) => -// let typ1 = Typ.matched_list(fixed_pat_typ(m, upat)) -// if (Typ.eq(typ1, typ2)) { -// List.fold_left( -// (acc, dhp) => {dhpat_extend_ctx(dhp, typ1, acc)}, -// ctx, -// l, -// ); -// } else { -// ctx; -// }; +// let typ1 = Typ.matched_list(fixed_pat_typ(m, upat)); +// if (Typ.eq(typ1, typ2)) { +// List.fold_left( +// (acc, dhp) => {dhpat_extend_ctx(m, dhp, typ1, acc)}, +// ctx, +// l, +// ); +// } else { +// ctx; +// }; // (); // | (Ap(Constructor(_, typ), dhp), _) => // let (ty1, ty2) = Typ.matched_arrow(ctx, typ); diff --git a/src/haz3lcore/dynamics/dterm/DExp.re b/src/haz3lcore/dynamics/dterm/DExp.re index 4f75ce1648..8ba9284799 100644 --- a/src/haz3lcore/dynamics/dterm/DExp.re +++ b/src/haz3lcore/dynamics/dterm/DExp.re @@ -23,12 +23,6 @@ - ListLit - BuiltinFun - It is important that the following do not appear during evaluation, because they - (theoretically) require static information: - - - Fun - - FixF - */ /* DExp.re @@ -37,6 +31,8 @@ using the same data structure as user expressions, but have a few important invariants. + + TODO[Matt]: Explain the invariants. */ @@ -44,17 +40,11 @@ include Exp; let term_of = ({term, _}) => term; let fast_copy = (id, {term, _}) => {ids: [id], term, copied: true}; -// All children of term must have expression-unique ids. -let fresh = term => { - {ids: [Id.mk()], copied: false, term}; -}; -let unwrap = ({ids, term, copied}) => (term, term => {ids, term, copied}); let mk = (ids, term) => { {ids, copied: true, term}; }; -// All children of d must have expression-unique ids. let fresh_cast = (d: t, t1: Typ.t, t2: Typ.t): t => if (Typ.eq(t1, t2) || t2 == Unknown(SynSwitch)) { d; diff --git a/src/haz3lcore/dynamics/dterm/DPat.re b/src/haz3lcore/dynamics/dterm/DPat.re index 19d0026634..c12d1560fa 100644 --- a/src/haz3lcore/dynamics/dterm/DPat.re +++ b/src/haz3lcore/dynamics/dterm/DPat.re @@ -1,5 +1,9 @@ include Pat; +/* A Dynamic Pattern (DPat) is a pattern that is part of an expression + that has been type-checked. Hence why these functions take both a + pattern, dp, and an info map, m, with type information. */ + /** * Whether dp contains the variable x outside of a hole. */ diff --git a/src/haz3lcore/lang/term/Exp.re b/src/haz3lcore/lang/term/Exp.re index 1abe0d1b46..86d3082c4d 100644 --- a/src/haz3lcore/lang/term/Exp.re +++ b/src/haz3lcore/lang/term/Exp.re @@ -48,6 +48,10 @@ let rep_id = ({ids, _}) => { List.hd(ids); }; +let fresh = term => { + {ids: [Id.mk()], copied: false, term}; +}; + let unwrap = ({ids, term, copied}) => (term, term => {ids, term, copied}); let cls_of_term: term => cls = diff --git a/src/haz3lcore/lang/term/TermBase.re b/src/haz3lcore/lang/term/TermBase.re index bd5cad1648..634888d48a 100644 --- a/src/haz3lcore/lang/term/TermBase.re +++ b/src/haz3lcore/lang/term/TermBase.re @@ -119,8 +119,11 @@ and Exp: { | Match(t, list((Pat.t, t))) | Cast(t, Typ.t, Typ.t) and t = { - // invariant: nonempty + // invariant: ids should be nonempty ids: list(Id.t), + /* UExp invariant: copied should always be false, and the id should be unique + DExp invariant: if copied is true, then this term and its children may not + have unique ids. */ copied: bool, term, }; From 8ec663c0f940b99d5c7def5970bc9fec84b190e9 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 7 Mar 2024 15:00:24 -0500 Subject: [PATCH 051/103] Revert DPat and DExp --- docs/overview.md | 4 +- docs/stepper-and-filter.md | 2 +- src/haz3lcore/dynamics/Builtins.re | 54 +++++++------- .../dynamics/{dterm/DExp.re => DHExp.re} | 4 +- .../dynamics/{dterm/DPat.re => DHPat.re} | 2 +- src/haz3lcore/dynamics/Elaborator.re | 60 ++++++++-------- src/haz3lcore/dynamics/EvalCtx.re | 46 ++++++------ src/haz3lcore/dynamics/Evaluator.re | 20 +++--- src/haz3lcore/dynamics/Evaluator.rei | 12 ++-- src/haz3lcore/dynamics/EvaluatorError.re | 18 ++--- src/haz3lcore/dynamics/EvaluatorError.rei | 18 ++--- src/haz3lcore/dynamics/EvaluatorResult.re | 6 +- src/haz3lcore/dynamics/EvaluatorResult.rei | 10 +-- src/haz3lcore/dynamics/EvaluatorStep.re | 28 ++++---- src/haz3lcore/dynamics/FilterMatcher.re | 16 ++--- src/haz3lcore/dynamics/MetaVarInst.re | 2 +- src/haz3lcore/dynamics/MetaVarInst.rei | 2 +- src/haz3lcore/dynamics/PatternMatch.re | 46 ++++++------ src/haz3lcore/dynamics/PatternMatch.rei | 2 +- src/haz3lcore/dynamics/Stepper.re | 16 ++--- src/haz3lcore/dynamics/Substitution.re | 25 +++---- src/haz3lcore/dynamics/Substitution.rei | 4 +- src/haz3lcore/dynamics/TestMap.re | 2 +- src/haz3lcore/dynamics/Transition.re | 72 ++++++++++--------- src/haz3lcore/dynamics/TypeAssignment.re | 6 +- src/haz3lcore/dynamics/ValueChecker.re | 4 +- src/haz3lcore/lang/term/TermBase.re | 2 +- src/haz3lcore/prog/Interface.re | 4 +- src/haz3lcore/prog/ModelResult.re | 2 +- src/haz3lcore/tiles/Id.re | 2 +- src/haz3lweb/view/Cell.re | 2 +- src/haz3lweb/view/StepperView.re | 2 +- src/haz3lweb/view/dhcode/DHCode.re | 2 +- src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 50 ++++++------- src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re | 6 +- src/test/Test_Elaboration.re | 38 +++++----- 36 files changed, 298 insertions(+), 293 deletions(-) rename src/haz3lcore/dynamics/{dterm/DExp.re => DHExp.re} (98%) rename src/haz3lcore/dynamics/{dterm/DPat.re => DHPat.re} (95%) diff --git a/docs/overview.md b/docs/overview.md index e991e24c2b..1a3299cc2d 100644 --- a/docs/overview.md +++ b/docs/overview.md @@ -14,7 +14,7 @@ Code in `hazelcore`should be pure OCaml. ## Module Organization Users edit external expressions, of type `UHExp.t`, via edit actions. External -expressions are elaborated to internal expressions, of type `DExp.t`, for +expressions are elaborated to internal expressions, of type `DHExp.t`, for evaluation. The external and internal languages share a type system. Types are of type `Typ.t`. @@ -44,7 +44,7 @@ of type `Typ.t`. - `IDGen` - `TextShape` - dynamics - - internal syntax: `DExp`, `DPat` + - internal syntax: `DHExp`, `DHPat` - external expressions are for editing - need to elaborate external expressions to internal in order to insert casts and closure information diff --git a/docs/stepper-and-filter.md b/docs/stepper-and-filter.md index 43cc192e87..d2057fcfda 100644 --- a/docs/stepper-and-filter.md +++ b/docs/stepper-and-filter.md @@ -109,7 +109,7 @@ program, issue command for change the evaluation mode (big-step or small-step, lazy or eager), and a narrower filter has a higher priority. For the matching part, I choose the Hazel language it's self as the -pattern language. `UPat` and `DPat` won't work since they only matches +pattern language. `UPat` and `DHPat` won't work since they only matches against *values*, indicating I have to extend them somehow so that they can match against *expressions*. The empty hole is take as the match all filter, i.e. `*` in many other matching languages. It will diff --git a/src/haz3lcore/dynamics/Builtins.re b/src/haz3lcore/dynamics/Builtins.re index d6f12d8d79..11c93f4133 100644 --- a/src/haz3lcore/dynamics/Builtins.re +++ b/src/haz3lcore/dynamics/Builtins.re @@ -1,4 +1,4 @@ -open DExp; +open DHExp; /* Built-in functions for Hazel. @@ -11,43 +11,43 @@ open DExp; [@deriving (show({with_path: false}), sexp, yojson)] type builtin = - | Const(Typ.t, DExp.t) - | Fn(Typ.t, Typ.t, DExp.t => DExp.t); + | Const(Typ.t, DHExp.t) + | Fn(Typ.t, Typ.t, DHExp.t => DHExp.t); [@deriving (show({with_path: false}), sexp, yojson)] type t = VarMap.t_(builtin); [@deriving (show({with_path: false}), sexp, yojson)] -type forms = VarMap.t_(DExp.t => DExp.t); +type forms = VarMap.t_(DHExp.t => DHExp.t); -type result = Result.t(DExp.t, EvaluatorError.t); +type result = Result.t(DHExp.t, EvaluatorError.t); -let const = (name: Var.t, typ: Typ.t, v: DExp.t, builtins: t): t => +let const = (name: Var.t, typ: Typ.t, v: DHExp.t, builtins: t): t => VarMap.extend(builtins, (name, Const(typ, v))); let fn = - (name: Var.t, t1: Typ.t, t2: Typ.t, impl: DExp.t => DExp.t, builtins: t) + (name: Var.t, t1: Typ.t, t2: Typ.t, impl: DHExp.t => DHExp.t, builtins: t) : t => VarMap.extend(builtins, (name, Fn(t1, t2, impl))); module Pervasives = { module Impls = { /* constants */ - let infinity = DExp.Float(Float.infinity) |> fresh; - let neg_infinity = DExp.Float(Float.neg_infinity) |> fresh; - let nan = DExp.Float(Float.nan) |> fresh; - let epsilon_float = DExp.Float(epsilon_float) |> fresh; - let pi = DExp.Float(Float.pi) |> fresh; - let max_int = DExp.Int(Int.max_int) |> fresh; - let min_int = DExp.Int(Int.min_int) |> fresh; - - let unary = (f: DExp.t => result, d: DExp.t) => { + let infinity = DHExp.Float(Float.infinity) |> fresh; + let neg_infinity = DHExp.Float(Float.neg_infinity) |> fresh; + let nan = DHExp.Float(Float.nan) |> fresh; + let epsilon_float = DHExp.Float(epsilon_float) |> fresh; + let pi = DHExp.Float(Float.pi) |> fresh; + let max_int = DHExp.Int(Int.max_int) |> fresh; + let min_int = DHExp.Int(Int.min_int) |> fresh; + + let unary = (f: DHExp.t => result, d: DHExp.t) => { switch (f(d)) { | Ok(r') => r' | Error(e) => EvaluatorError.Exception(e) |> raise }; }; - let binary = (f: (DExp.t, DExp.t) => result, d: DExp.t) => { + let binary = (f: (DHExp.t, DHExp.t) => result, d: DHExp.t) => { switch (term_of(d)) { | Tuple([d1, d2]) => switch (f(d1, d2)) { @@ -58,7 +58,7 @@ module Pervasives = { }; }; - let ternary = (f: (DExp.t, DExp.t, DExp.t) => result, d: DExp.t) => { + let ternary = (f: (DHExp.t, DHExp.t, DHExp.t) => result, d: DHExp.t) => { switch (term_of(d)) { | Tuple([d1, d2, d3]) => switch (f(d1, d2, d3)) { @@ -164,16 +164,16 @@ module Pervasives = { let atan = float_op(atan); let of_string = - (convert: string => option('a), wrap: 'a => DExp.t, name: string) => + (convert: string => option('a), wrap: 'a => DHExp.t, name: string) => unary(d => switch (term_of(d)) { | String(s) => switch (convert(s)) { | Some(n) => Ok(wrap(n)) | None => - let d' = DExp.BuiltinFun(name) |> DExp.fresh; - let d' = DExp.Ap(Forward, d', d) |> DExp.fresh; - let d' = DynamicErrorHole(d', InvalidOfString) |> DExp.fresh; + let d' = DHExp.BuiltinFun(name) |> DHExp.fresh; + let d' = DHExp.Ap(Forward, d', d) |> DHExp.fresh; + let d' = DynamicErrorHole(d', InvalidOfString) |> DHExp.fresh; Ok(d'); } | _ => Error(InvalidBoxedStringLit(d)) @@ -181,11 +181,11 @@ module Pervasives = { ); let int_of_string = - of_string(int_of_string_opt, n => Int(n) |> DExp.fresh); + of_string(int_of_string_opt, n => Int(n) |> DHExp.fresh); let float_of_string = - of_string(float_of_string_opt, f => Float(f) |> DExp.fresh); + of_string(float_of_string_opt, f => Float(f) |> DHExp.fresh); let bool_of_string = - of_string(bool_of_string_opt, b => Bool(b) |> DExp.fresh); + of_string(bool_of_string_opt, b => Bool(b) |> DHExp.fresh); let int_mod = (name, d1) => binary( @@ -195,7 +195,7 @@ module Pervasives = { Ok( fresh( DynamicErrorHole( - DExp.Ap(Forward, DExp.BuiltinFun(name) |> fresh, d1) + DHExp.Ap(Forward, DHExp.BuiltinFun(name) |> fresh, d1) |> fresh, DivideByZero, ), @@ -236,7 +236,7 @@ module Pervasives = { } ); - let string_of: DExp.t => option(string) = + let string_of: DHExp.t => option(string) = d => switch (term_of(d)) { | String(s) => Some(s) diff --git a/src/haz3lcore/dynamics/dterm/DExp.re b/src/haz3lcore/dynamics/DHExp.re similarity index 98% rename from src/haz3lcore/dynamics/dterm/DExp.re rename to src/haz3lcore/dynamics/DHExp.re index 8ba9284799..f1e8f16ef2 100644 --- a/src/haz3lcore/dynamics/dterm/DExp.re +++ b/src/haz3lcore/dynamics/DHExp.re @@ -6,7 +6,7 @@ */ /* - DExps that can appear during evaluation, and thus won't have static information. + DHExps that can appear during evaluation, and thus won't have static information. - Closure - Var [for mutual recursion; could probably get rid of if needed...] @@ -25,7 +25,7 @@ */ -/* DExp.re +/* DHExp.re This module is specifically for dynamic expressions. They are stored using the same data structure as user expressions, but have a few diff --git a/src/haz3lcore/dynamics/dterm/DPat.re b/src/haz3lcore/dynamics/DHPat.re similarity index 95% rename from src/haz3lcore/dynamics/dterm/DPat.re rename to src/haz3lcore/dynamics/DHPat.re index c12d1560fa..45829b6a1a 100644 --- a/src/haz3lcore/dynamics/dterm/DPat.re +++ b/src/haz3lcore/dynamics/DHPat.re @@ -1,6 +1,6 @@ include Pat; -/* A Dynamic Pattern (DPat) is a pattern that is part of an expression +/* A Dynamic Pattern (DHPat) is a pattern that is part of an expression that has been type-checked. Hence why these functions take both a pattern, dp, and an info map, m, with type information. */ diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 7241be8303..bfedb405d4 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -9,7 +9,7 @@ exception MissingTypeInfo; module Elaboration = { [@deriving (show({with_path: false}), sexp, yojson)] type t = { - d: DExp.t, + d: DHExp.t, info_map: Statics.Map.t, }; }; @@ -17,7 +17,7 @@ module Elaboration = { module ElaborationResult = { [@deriving sexp] type t = - | Elaborates(DExp.t, Typ.t, Delta.t) + | Elaborates(DHExp.t, Typ.t, Delta.t) | DoesNotElaborate; }; @@ -36,13 +36,13 @@ let fixed_pat_typ = (m: Statics.Map.t, p: UPat.t): option(Typ.t) => /* Adds casts if required. When adding a new construct, [TODO: write something helpful here] */ -let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DExp.t) => +let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => switch (mode) { | Syn => d | SynFun => switch (self_ty) { | Unknown(prov) => - DExp.fresh_cast( + DHExp.fresh_cast( d, Unknown(prov), Arrow(Unknown(prov), Unknown(prov)), @@ -53,55 +53,55 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DExp.t) => | Ana(ana_ty) => let ana_ty = Typ.normalize(ctx, ana_ty); /* Forms with special ana rules get cast from their appropriate Matched types */ - switch (DExp.term_of(d)) { + switch (DHExp.term_of(d)) { | ListLit(_) | ListConcat(_) | Cons(_) => switch (ana_ty) { | Unknown(prov) => - DExp.fresh_cast(d, List(Unknown(prov)), Unknown(prov)) + DHExp.fresh_cast(d, List(Unknown(prov)), Unknown(prov)) | _ => d } | Fun(_) => /* See regression tests in Documentation/Dynamics */ let (_, ana_out) = Typ.matched_arrow(ctx, ana_ty); let (self_in, _) = Typ.matched_arrow(ctx, self_ty); - DExp.fresh_cast(d, Arrow(self_in, ana_out), ana_ty); + DHExp.fresh_cast(d, Arrow(self_in, ana_out), ana_ty); | Tuple(ds) => switch (ana_ty) { | Unknown(prov) => let us = List.init(List.length(ds), _ => Typ.Unknown(prov)); - DExp.fresh_cast(d, Prod(us), Unknown(prov)); + DHExp.fresh_cast(d, Prod(us), Unknown(prov)); | _ => d } | Constructor(_) => switch (ana_ty, self_ty) { | (Unknown(prov), Rec(_, Sum(_))) | (Unknown(prov), Sum(_)) => - DExp.fresh_cast(d, self_ty, Unknown(prov)) + DHExp.fresh_cast(d, self_ty, Unknown(prov)) | _ => d } | Ap(_, f, _) => - switch (DExp.term_of(f)) { + switch (DHExp.term_of(f)) { | Constructor(_) => switch (ana_ty, self_ty) { | (Unknown(prov), Rec(_, Sum(_))) | (Unknown(prov), Sum(_)) => - DExp.fresh_cast(d, self_ty, Unknown(prov)) + DHExp.fresh_cast(d, self_ty, Unknown(prov)) | _ => d } | StaticErrorHole(_, g) => - switch (DExp.term_of(g)) { + switch (DHExp.term_of(g)) { | Constructor(_) => switch (ana_ty, self_ty) { | (Unknown(prov), Rec(_, Sum(_))) | (Unknown(prov), Sum(_)) => - DExp.fresh_cast(d, self_ty, Unknown(prov)) + DHExp.fresh_cast(d, self_ty, Unknown(prov)) | _ => d } - | _ => DExp.fresh_cast(d, self_ty, ana_ty) + | _ => DHExp.fresh_cast(d, self_ty, ana_ty) } - | _ => DExp.fresh_cast(d, self_ty, ana_ty) + | _ => DHExp.fresh_cast(d, self_ty, ana_ty) } /* Forms with special ana rules but no particular typing requirements */ | Match(_) @@ -114,7 +114,7 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DExp.t) => | EmptyHole | MultiHole(_) | StaticErrorHole(_) => d - /* DExp-specific forms: Don't cast */ + /* DHExp-specific forms: Don't cast */ | Cast(_) | Closure(_) | Filter(_) @@ -131,13 +131,13 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DExp.t) => | UnOp(_) | BinOp(_) | TyAlias(_) - | Test(_) => DExp.fresh_cast(d, self_ty, ana_ty) + | Test(_) => DHExp.fresh_cast(d, self_ty, ana_ty) }; }; /* Handles cast insertion and non-empty-hole wrapping for elaborated expressions */ -let wrap = (m, exp: Exp.t): DExp.t => { +let wrap = (m, exp: Exp.t): DHExp.t => { let (mode, self, ctx) = switch (Id.Map.find_opt(Exp.rep_id(exp), m)) { | Some(Info.InfoExp({mode, self, ctx, _})) => (mode, self, ctx) @@ -156,14 +156,14 @@ let wrap = (m, exp: Exp.t): DExp.t => { Common(Inconsistent(Internal(_))), ) => exp | InHole(Common(Inconsistent(Expectation(_) | WithArrow(_)))) => - DExp.fresh(StaticErrorHole(Exp.rep_id(exp), exp)) + DHExp.fresh(StaticErrorHole(Exp.rep_id(exp), exp)) }; }; /* - This function converts user-expressions (UExp.t) to dynamic expressions (DExp.t). They + This function converts user-expressions (UExp.t) to dynamic expressions (DHExp.t). They have the same datatype but there are some small differences so that UExp.t can be edited - and DExp.t can be evaluated. + and DHExp.t can be evaluated. Currently, Elaboration does the following things: @@ -217,10 +217,10 @@ let rec dexp_of_uexp = (m, uexp, ~in_filter) => { | UnOp(Meta(Unquote), e) => switch (e.term) { | Var("e") when in_filter => - Constructor("$e") |> DExp.fresh |> wrap(m) + Constructor("$e") |> DHExp.fresh |> wrap(m) | Var("v") when in_filter => - Constructor("$v") |> DExp.fresh |> wrap(m) - | _ => DExp.EmptyHole |> DExp.fresh |> wrap(m) + Constructor("$v") |> DHExp.fresh |> wrap(m) + | _ => DHExp.EmptyHole |> DHExp.fresh |> wrap(m) } | Filter(Filter({act, pat}), body) => Filter( @@ -232,11 +232,11 @@ let rec dexp_of_uexp = (m, uexp, ~in_filter) => { // Let bindings: insert implicit fixpoints and label functions with their names. | Let(p, def, body) => - let add_name: (option(string), DExp.t) => DExp.t = ( + let add_name: (option(string), DHExp.t) => DHExp.t = ( (name, d) => { - let (term, rewrap) = DExp.unwrap(d); + let (term, rewrap) = DHExp.unwrap(d); switch (term) { - | Fun(p, e, ctx, _) => DExp.Fun(p, e, ctx, name) |> rewrap + | Fun(p, e, ctx, _) => DHExp.Fun(p, e, ctx, name) |> rewrap | _ => d }; } @@ -246,14 +246,14 @@ let rec dexp_of_uexp = (m, uexp, ~in_filter) => { switch (UPat.get_recursive_bindings(p)) { | None => /* not recursive */ - DExp.Let(p, add_name(UPat.get_var(p), ddef), dbody) + DHExp.Let(p, add_name(UPat.get_var(p), ddef), dbody) |> rewrap |> wrap(m) | Some(b) => - DExp.Let( + DHExp.Let( p, FixF(p, add_name(Some(String.concat(",", b)), ddef), None) - |> DExp.fresh, + |> DHExp.fresh, dbody, ) |> rewrap diff --git a/src/haz3lcore/dynamics/EvalCtx.re b/src/haz3lcore/dynamics/EvalCtx.re index ed2a4271a6..5365cc4b2e 100644 --- a/src/haz3lcore/dynamics/EvalCtx.re +++ b/src/haz3lcore/dynamics/EvalCtx.re @@ -5,38 +5,38 @@ open Util; type term = | Closure([@show.opaque] ClosureEnvironment.t, t) | Filter(TermBase.StepperFilterKind.t, t) - | Seq1(t, DExp.t) - | Seq2(DExp.t, t) - | Let1(Pat.t, t, DExp.t) - | Let2(Pat.t, DExp.t, t) + | Seq1(t, DHExp.t) + | Seq2(DHExp.t, t) + | Let1(Pat.t, t, DHExp.t) + | Let2(Pat.t, DHExp.t, t) | Fun(Pat.t, t, option(ClosureEnvironment.t), option(Var.t)) | FixF(Pat.t, t, option(ClosureEnvironment.t)) - | Ap1(Operators.ap_direction, t, DExp.t) - | Ap2(Operators.ap_direction, DExp.t, t) - | If1(t, DExp.t, DExp.t) - | If2(DExp.t, t, DExp.t) - | If3(DExp.t, DExp.t, t) + | Ap1(Operators.ap_direction, t, DHExp.t) + | Ap2(Operators.ap_direction, DHExp.t, t) + | If1(t, DHExp.t, DHExp.t) + | If2(DHExp.t, t, DHExp.t) + | If3(DHExp.t, DHExp.t, t) | UnOp(Operators.op_un, t) - | BinOp1(Operators.op_bin, t, DExp.t) - | BinOp2(Operators.op_bin, DExp.t, t) - | Tuple(t, (list(DExp.t), list(DExp.t))) + | BinOp1(Operators.op_bin, t, DHExp.t) + | BinOp2(Operators.op_bin, DHExp.t, t) + | Tuple(t, (list(DHExp.t), list(DHExp.t))) | Test(t) - | ListLit(t, (list(DExp.t), list(DExp.t))) + | ListLit(t, (list(DHExp.t), list(DHExp.t))) | MultiHole(t, (list(Any.t), list(Any.t))) - | Cons1(t, DExp.t) - | Cons2(DExp.t, t) - | ListConcat1(t, DExp.t) - | ListConcat2(DExp.t, t) + | Cons1(t, DHExp.t) + | Cons2(DHExp.t, t) + | ListConcat1(t, DHExp.t) + | ListConcat2(DHExp.t, t) | StaticErrorHole(Id.t, t) | Cast(t, Typ.t, Typ.t) | FailedCast(t, Typ.t, Typ.t) | DynamicErrorHole(t, InvalidOperationError.t) - | MatchScrut(t, list((UPat.t, DExp.t))) + | MatchScrut(t, list((UPat.t, DHExp.t))) | MatchRule( - DExp.t, + DHExp.t, UPat.t, t, - (list((UPat.t, DExp.t)), list((UPat.t, DExp.t))), + (list((UPat.t, DHExp.t)), list((UPat.t, DHExp.t))), ) and t = | Mark @@ -45,12 +45,12 @@ and t = ids: list(Id.t), }); -let rec compose = (ctx: t, d: DExp.t): DExp.t => { +let rec compose = (ctx: t, d: DHExp.t): DHExp.t => { switch (ctx) { | Mark => d | Term({term, ids}) => - let wrap = DExp.mk(ids); - DExp.( + let wrap = DHExp.mk(ids); + DHExp.( switch (term) { | Closure(env, ctx) => let d = compose(ctx, d); diff --git a/src/haz3lcore/dynamics/Evaluator.re b/src/haz3lcore/dynamics/Evaluator.re index 7c69c715fb..eb9d885628 100644 --- a/src/haz3lcore/dynamics/Evaluator.re +++ b/src/haz3lcore/dynamics/Evaluator.re @@ -3,10 +3,10 @@ open Transition; module EvaluatorEVMode: { type result_unfinished = - | BoxedValue(DExp.t) - | Indet(DExp.t) - | Uneval(DExp.t); - let unbox: result_unfinished => DExp.t; + | BoxedValue(DHExp.t) + | Indet(DHExp.t) + | Uneval(DHExp.t); + let unbox: result_unfinished => DHExp.t; include EV_MODE with @@ -37,9 +37,9 @@ module EvaluatorEVMode: { let get_info_map = (state: state) => EvaluatorState.get_info_map(state^); type result_unfinished = - | BoxedValue(DExp.t) - | Indet(DExp.t) - | Uneval(DExp.t); + | BoxedValue(DHExp.t) + | Indet(DHExp.t) + | Uneval(DHExp.t); type result = result_unfinished; @@ -121,9 +121,9 @@ let evaluate = (env, {d, info_map}: Elaborator.Elaboration.t) => { let result = evaluate(state, env, d); let result = switch (result) { - | BoxedValue(x) => BoxedValue(x |> DExp.repair_ids) - | Indet(x) => Indet(x |> DExp.repair_ids) - | Uneval(x) => Indet(x |> DExp.repair_ids) + | BoxedValue(x) => BoxedValue(x |> DHExp.repair_ids) + | Indet(x) => Indet(x |> DHExp.repair_ids) + | Uneval(x) => Indet(x |> DHExp.repair_ids) }; (state^, result); }; diff --git a/src/haz3lcore/dynamics/Evaluator.rei b/src/haz3lcore/dynamics/Evaluator.rei index 26e1a723d5..e505c371af 100644 --- a/src/haz3lcore/dynamics/Evaluator.rei +++ b/src/haz3lcore/dynamics/Evaluator.rei @@ -11,11 +11,11 @@ let evaluate: module EvaluatorEVMode: { type result_unfinished = - | BoxedValue(DExp.t) - | Indet(DExp.t) - | Uneval(DExp.t); + | BoxedValue(DHExp.t) + | Indet(DHExp.t) + | Uneval(DHExp.t); - let unbox: result_unfinished => DExp.t; + let unbox: result_unfinished => DHExp.t; include EV_MODE with @@ -25,11 +25,11 @@ module EvaluatorEVMode: { module Eval: { let transition: ( - (EvaluatorEVMode.state, ClosureEnvironment.t, DExp.t) => + (EvaluatorEVMode.state, ClosureEnvironment.t, DHExp.t) => EvaluatorEVMode.result_unfinished, EvaluatorEVMode.state, ClosureEnvironment.t, - DExp.t + DHExp.t ) => EvaluatorEVMode.result_unfinished; }; diff --git a/src/haz3lcore/dynamics/EvaluatorError.re b/src/haz3lcore/dynamics/EvaluatorError.re index 981b7d4c82..7cd750d1bc 100644 --- a/src/haz3lcore/dynamics/EvaluatorError.re +++ b/src/haz3lcore/dynamics/EvaluatorError.re @@ -6,16 +6,16 @@ type t = | StepDoesNotMatch | FreeInvalidVar(Var.t) | BadPatternMatch - | CastBVHoleGround(DExp.t) - | InvalidBoxedFun(DExp.t) - | InvalidBoxedBoolLit(DExp.t) - | InvalidBoxedIntLit(DExp.t) - | InvalidBoxedFloatLit(DExp.t) - | InvalidBoxedListLit(DExp.t) - | InvalidBoxedStringLit(DExp.t) - | InvalidBoxedTuple(DExp.t) + | CastBVHoleGround(DHExp.t) + | InvalidBoxedFun(DHExp.t) + | InvalidBoxedBoolLit(DHExp.t) + | InvalidBoxedIntLit(DHExp.t) + | InvalidBoxedFloatLit(DHExp.t) + | InvalidBoxedListLit(DHExp.t) + | InvalidBoxedStringLit(DHExp.t) + | InvalidBoxedTuple(DHExp.t) | InvalidBuiltin(string) - | BadBuiltinAp(string, list(DExp.t)) + | BadBuiltinAp(string, list(DHExp.t)) | InvalidProjection(int); exception Exception(t); diff --git a/src/haz3lcore/dynamics/EvaluatorError.rei b/src/haz3lcore/dynamics/EvaluatorError.rei index e7c0421163..e5a07fe847 100644 --- a/src/haz3lcore/dynamics/EvaluatorError.rei +++ b/src/haz3lcore/dynamics/EvaluatorError.rei @@ -4,16 +4,16 @@ type t = | StepDoesNotMatch | FreeInvalidVar(Var.t) | BadPatternMatch - | CastBVHoleGround(DExp.t) - | InvalidBoxedFun(DExp.t) - | InvalidBoxedBoolLit(DExp.t) - | InvalidBoxedIntLit(DExp.t) - | InvalidBoxedFloatLit(DExp.t) - | InvalidBoxedListLit(DExp.t) - | InvalidBoxedStringLit(DExp.t) - | InvalidBoxedTuple(DExp.t) + | CastBVHoleGround(DHExp.t) + | InvalidBoxedFun(DHExp.t) + | InvalidBoxedBoolLit(DHExp.t) + | InvalidBoxedIntLit(DHExp.t) + | InvalidBoxedFloatLit(DHExp.t) + | InvalidBoxedListLit(DHExp.t) + | InvalidBoxedStringLit(DHExp.t) + | InvalidBoxedTuple(DHExp.t) | InvalidBuiltin(string) - | BadBuiltinAp(string, list(DExp.t)) + | BadBuiltinAp(string, list(DHExp.t)) | InvalidProjection(int); [@deriving (show({with_path: false}), sexp, yojson)] diff --git a/src/haz3lcore/dynamics/EvaluatorResult.re b/src/haz3lcore/dynamics/EvaluatorResult.re index 13d8d06d88..73628a7c89 100644 --- a/src/haz3lcore/dynamics/EvaluatorResult.re +++ b/src/haz3lcore/dynamics/EvaluatorResult.re @@ -1,7 +1,7 @@ [@deriving (show({with_path: false}), sexp, yojson)] type t = - | BoxedValue(DExp.t) - | Indet(DExp.t); + | BoxedValue(DHExp.t) + | Indet(DHExp.t); let unbox = fun @@ -11,6 +11,6 @@ let unbox = let fast_equal = (r1, r2) => switch (r1, r2) { | (BoxedValue(d1), BoxedValue(d2)) - | (Indet(d1), Indet(d2)) => DExp.fast_equal(d1, d2) + | (Indet(d1), Indet(d2)) => DHExp.fast_equal(d1, d2) | _ => false }; diff --git a/src/haz3lcore/dynamics/EvaluatorResult.rei b/src/haz3lcore/dynamics/EvaluatorResult.rei index 2443977eba..350c3cec62 100644 --- a/src/haz3lcore/dynamics/EvaluatorResult.rei +++ b/src/haz3lcore/dynamics/EvaluatorResult.rei @@ -3,20 +3,20 @@ */ /** - The type for the evaluation result, a {!type:DExp.t} wrapped in its {v final + The type for the evaluation result, a {!type:DHExp.t} wrapped in its {v final v} judgment (boxed value or indeterminate). */ [@deriving (show({with_path: false}), sexp, yojson)] type t = - | BoxedValue(DExp.t) - | Indet(DExp.t); + | BoxedValue(DHExp.t) + | Indet(DHExp.t); /** [unbox r] is the inner expression. */ -let unbox: t => DExp.t; +let unbox: t => DHExp.t; /** - See {!val:DExp.fast_equal}. + See {!val:DHExp.fast_equal}. */ let fast_equal: (t, t) => bool; diff --git a/src/haz3lcore/dynamics/EvaluatorStep.re b/src/haz3lcore/dynamics/EvaluatorStep.re index 5084d7cff7..2d7d82669e 100644 --- a/src/haz3lcore/dynamics/EvaluatorStep.re +++ b/src/haz3lcore/dynamics/EvaluatorStep.re @@ -2,10 +2,10 @@ open Transition; [@deriving (show({with_path: false}), sexp, yojson)] type step = { - d: DExp.t, // technically can be calculated from d_loc and ctx + d: DHExp.t, // technically can be calculated from d_loc and ctx state: EvaluatorState.t, - d_loc: DExp.t, // the expression at the location given by ctx - d_loc': DExp.t, + d_loc: DHExp.t, // the expression at the location given by ctx + d_loc': DHExp.t, ctx: EvalCtx.t, knd: step_kind, }; @@ -14,7 +14,7 @@ module EvalObj = { [@deriving (show({with_path: false}), sexp, yojson)] type t = { env: ClosureEnvironment.t, // technically can be calculated from ctx - d_loc: DExp.t, + d_loc: DHExp.t, ctx: EvalCtx.t, knd: step_kind, }; @@ -129,7 +129,7 @@ module Decompose = { req_all_final'(cont, wr, [], ds); }; - let (let.): (requirements('a, DExp.t), 'a => rule) => result = + let (let.): (requirements('a, DHExp.t), 'a => rule) => result = (rq, rl) => switch (rq) { | (_, Result.Indet, _, _) => Result.Indet @@ -155,16 +155,18 @@ module Decompose = { module Decomp = Transition(DecomposeEVMode); let rec decompose = (state, env, exp) => { - let (term, rewrap) = DExp.unwrap(exp); + let (term, rewrap) = DHExp.unwrap(exp); switch (term) { - | DExp.Filter(flt, d1) => + | DHExp.Filter(flt, d1) => DecomposeEVMode.( { - let. _ = otherwise(env, (d1) => (Filter(flt, d1) |> rewrap: DExp.t)) + let. _ = + otherwise(env, (d1) => (Filter(flt, d1) |> rewrap: DHExp.t)) and. d1 = req_final( decompose(state, env), - d1 => Term({term: Filter(flt, d1), ids: [DExp.rep_id(exp)]}), + d1 => + Term({term: Filter(flt, d1), ids: [DHExp.rep_id(exp)]}), d1, ); Step({apply: () => d1, kind: CompleteFilter, value: true}); @@ -179,12 +181,12 @@ module TakeStep = { module TakeStepEVMode: { include EV_MODE with - type result = option(DExp.t) and type state = ref(EvaluatorState.t); + type result = option(DHExp.t) and type state = ref(EvaluatorState.t); } = { type state = ref(EvaluatorState.t); type requirement('a) = 'a; type requirements('a, 'b) = 'a; - type result = option(DExp.t); + type result = option(DHExp.t); // Assume that everything is either value or final as required. let req_value = (_, _, d) => d; @@ -194,7 +196,7 @@ module TakeStep = { let req_final_or_value = (_, _, d) => (d, true); - let (let.) = (rq: requirements('a, DExp.t), rl: 'a => rule) => + let (let.) = (rq: requirements('a, DHExp.t), rl: 'a => rule) => switch (rl(rq)) { | Step({apply, _}) => Some(apply()) | Constructor @@ -218,7 +220,7 @@ module TakeStep = { let take_step = TakeStep.take_step; -let decompose = (d: DExp.t, es: EvaluatorState.t) => { +let decompose = (d: DHExp.t, es: EvaluatorState.t) => { let env = ClosureEnvironment.of_environment(Builtins.env_init); let rs = Decompose.decompose(ref(es), env, d); Decompose.Result.unbox(rs); diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index 40ccf2d945..5197d34498 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -2,12 +2,12 @@ let rec matches_exp = ( info_map: Statics.Map.t, env: ClosureEnvironment.t, - d: DExp.t, - f: DExp.t, + d: DHExp.t, + f: DHExp.t, ) : bool => { let matches_exp = matches_exp(info_map); - switch (DExp.term_of(d), DExp.term_of(f)) { + switch (DHExp.term_of(d), DHExp.term_of(f)) { | (Parens(x), _) => matches_exp(env, x, f) | (_, Parens(x)) => matches_exp(env, d, x) | (Constructor("$e"), _) => failwith("$e in matched expression") @@ -48,7 +48,7 @@ let rec matches_exp = | (EmptyHole, _) => false | (Filter(df, dd), Filter(ff, fd)) => - DExp.filter_fast_equal(df, ff) && matches_exp(env, dd, fd) + DHExp.filter_fast_equal(df, ff) && matches_exp(env, dd, fd) | (Filter(_), _) => false | (Bool(dv), Bool(fv)) => dv == fv @@ -64,7 +64,7 @@ let rec matches_exp = | (String(_), _) => false | (Constructor(_), Ap(_, d1, d2)) => - switch (DExp.term_of(d1), DExp.term_of(d2)) { + switch (DHExp.term_of(d1), DHExp.term_of(d2)) { | (Constructor("~MVal"), Tuple([])) => true | _ => false } @@ -169,7 +169,7 @@ let rec matches_exp = }; } and matches_pat = (d: Pat.t, f: Pat.t): bool => { - switch (d |> DPat.term_of, f |> DPat.term_of) { + switch (d |> DHPat.term_of, f |> DHPat.term_of) { // Matt: I'm not sure what the exact semantics of matching should be here. | (Parens(x), _) => matches_pat(x, f) | (_, Parens(x)) => matches_pat(d, x) @@ -228,7 +228,7 @@ let matches = ( info_map, ~env: ClosureEnvironment.t, - ~exp: DExp.t, + ~exp: DHExp.t, ~flt: TermBase.StepperFilterKind.filter, ) : option(FilterAction.t) => @@ -241,7 +241,7 @@ let matches = let matches = ( ~env: ClosureEnvironment.t, - ~exp: DExp.t, + ~exp: DHExp.t, ~exp_info_map: Statics.Map.t, ~act: FilterAction.t, flt_env, diff --git a/src/haz3lcore/dynamics/MetaVarInst.re b/src/haz3lcore/dynamics/MetaVarInst.re index f87d0fb752..9b410f2e61 100644 --- a/src/haz3lcore/dynamics/MetaVarInst.re +++ b/src/haz3lcore/dynamics/MetaVarInst.re @@ -1,7 +1,7 @@ open Sexplib.Std; /** - * Hole instance index in DPat and DExp + * Hole instance index in DHPat and DHExp */ [@deriving (show({with_path: false}), sexp, yojson)] type t = int; diff --git a/src/haz3lcore/dynamics/MetaVarInst.rei b/src/haz3lcore/dynamics/MetaVarInst.rei index d9f02e6b73..89692b7bed 100644 --- a/src/haz3lcore/dynamics/MetaVarInst.rei +++ b/src/haz3lcore/dynamics/MetaVarInst.rei @@ -1,5 +1,5 @@ /** - * Hole instance index in DPat and DExp + * Hole instance index in DHPat and DHExp */ [@deriving (show({with_path: false}), sexp, yojson)] type t = int; diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index 87c42490fa..49d4dbc927 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -28,8 +28,8 @@ let cast_sum_maps = }; }; -let rec matches = (dp: Pat.t, d: DExp.t): match_result => - switch (DPat.term_of(dp), DExp.term_of(d)) { +let rec matches = (dp: Pat.t, d: DHExp.t): match_result => + switch (DHPat.term_of(dp), DHExp.term_of(d)) { | (Parens(x), _) => matches(x, d) | (TypeAnn(x, _), _) => matches(x, d) | (_, Var(_)) => DoesNotMatch @@ -203,11 +203,11 @@ and matches_cast_Sum = ( ctr: string, dp: option(Pat.t), - d: DExp.t, + d: DHExp.t, castmaps: list(ConstructorMap.t((Typ.t, Typ.t))), ) : match_result => - switch (DExp.term_of(d)) { + switch (DHExp.term_of(d)) { | Parens(d) => matches_cast_Sum(ctr, dp, d, castmaps) | Constructor(ctr') => switch ( @@ -219,7 +219,7 @@ and matches_cast_Sum = | _ => DoesNotMatch } | Ap(_, d1, d2) => - switch (DExp.term_of(d1)) { + switch (DHExp.term_of(d1)) { | Constructor(ctr') => switch ( dp, @@ -228,7 +228,7 @@ and matches_cast_Sum = |> OptUtil.sequence, ) { | (Some(dp), Some(side_casts)) => - matches(dp, DExp.apply_casts(d2, side_casts)) + matches(dp, DHExp.apply_casts(d2, side_casts)) | _ => DoesNotMatch } | _ => IndetMatch @@ -272,9 +272,9 @@ and matches_cast_Sum = | ListConcat(_) => DoesNotMatch } and matches_cast_Tuple = - (dps: list(Pat.t), d: DExp.t, elt_casts: list(list((Typ.t, Typ.t)))) + (dps: list(Pat.t), d: DHExp.t, elt_casts: list(list((Typ.t, Typ.t)))) : match_result => - switch (DExp.term_of(d)) { + switch (DHExp.term_of(d)) { | Parens(d) => matches_cast_Tuple(dps, d, elt_casts) | Tuple(ds) => if (List.length(dps) != List.length(ds)) { @@ -287,7 +287,7 @@ and matches_cast_Tuple = | DoesNotMatch | IndetMatch => result | Matches(env) => - switch (matches(dp, DExp.apply_casts(d, casts))) { + switch (matches(dp, DHExp.apply_casts(d, casts))) { | DoesNotMatch => DoesNotMatch | IndetMatch => IndetMatch | Matches(env') => Matches(Environment.union(env, env')) @@ -355,18 +355,18 @@ and matches_cast_Tuple = | If(_) => IndetMatch } and matches_cast_Cons = - (dp: Pat.t, d: DExp.t, elt_casts: list((Typ.t, Typ.t))): match_result => - switch (DExp.term_of(d)) { + (dp: Pat.t, d: DHExp.t, elt_casts: list((Typ.t, Typ.t))): match_result => + switch (DHExp.term_of(d)) { | Parens(d) => matches_cast_Cons(dp, d, elt_casts) | ListLit([]) => - switch (DPat.term_of(dp)) { + switch (DHPat.term_of(dp)) { | ListLit([]) => Matches(Environment.empty) | _ => DoesNotMatch } | ListLit([dhd, ...dtl] as ds) => - switch (DPat.term_of(dp)) { + switch (DHPat.term_of(dp)) { | Cons(dp1, dp2) => - switch (matches(dp1, DExp.apply_casts(dhd, elt_casts))) { + switch (matches(dp1, DHExp.apply_casts(dhd, elt_casts))) { | DoesNotMatch => DoesNotMatch | IndetMatch => IndetMatch | Matches(env1) => @@ -378,8 +378,8 @@ and matches_cast_Cons = }, elt_casts, ); - let d2 = DExp.ListLit(dtl) |> DExp.fresh; - switch (matches(dp2, DExp.apply_casts(d2, list_casts))) { + let d2 = DHExp.ListLit(dtl) |> DHExp.fresh; + switch (matches(dp2, DHExp.apply_casts(d2, list_casts))) { | DoesNotMatch => DoesNotMatch | IndetMatch => IndetMatch | Matches(env2) => Matches(Environment.union(env1, env2)) @@ -391,7 +391,7 @@ and matches_cast_Cons = | Some(lst) => lst |> List.map(((dp, d)) => - matches(dp, DExp.apply_casts(d, elt_casts)) + matches(dp, DHExp.apply_casts(d, elt_casts)) ) |> List.fold_left( (match1, match2) => @@ -409,9 +409,9 @@ and matches_cast_Cons = | _ => failwith("called matches_cast_Cons with non-list pattern") } | Cons(d1, d2) => - switch (DPat.term_of(dp)) { + switch (DHPat.term_of(dp)) { | Cons(dp1, dp2) => - switch (matches(dp1, DExp.apply_casts(d1, elt_casts))) { + switch (matches(dp1, DHExp.apply_casts(d1, elt_casts))) { | DoesNotMatch => DoesNotMatch | IndetMatch => IndetMatch | Matches(env1) => @@ -423,7 +423,7 @@ and matches_cast_Cons = }, elt_casts, ); - switch (matches(dp2, DExp.apply_casts(d2, list_casts))) { + switch (matches(dp2, DHExp.apply_casts(d2, list_casts))) { | DoesNotMatch => DoesNotMatch | IndetMatch => IndetMatch | Matches(env2) => Matches(Environment.union(env1, env2)) @@ -431,7 +431,7 @@ and matches_cast_Cons = } | ListLit([]) => DoesNotMatch | ListLit([dphd, ...dptl]) => - switch (matches(dphd, DExp.apply_casts(d1, elt_casts))) { + switch (matches(dphd, DHExp.apply_casts(d1, elt_casts))) { | DoesNotMatch => DoesNotMatch | IndetMatch => IndetMatch | Matches(env1) => @@ -443,8 +443,8 @@ and matches_cast_Cons = }, elt_casts, ); - let dp2 = Pat.ListLit(dptl) |> DPat.fresh; - switch (matches(dp2, DExp.apply_casts(d2, list_casts))) { + let dp2 = Pat.ListLit(dptl) |> DHPat.fresh; + switch (matches(dp2, DHExp.apply_casts(d2, list_casts))) { | DoesNotMatch => DoesNotMatch | IndetMatch => IndetMatch | Matches(env2) => Matches(Environment.union(env1, env2)) diff --git a/src/haz3lcore/dynamics/PatternMatch.rei b/src/haz3lcore/dynamics/PatternMatch.rei index b2d3dd08aa..2cba4e6681 100644 --- a/src/haz3lcore/dynamics/PatternMatch.rei +++ b/src/haz3lcore/dynamics/PatternMatch.rei @@ -3,4 +3,4 @@ type match_result = | DoesNotMatch | IndetMatch; -let matches: (Pat.t, DExp.t) => match_result; +let matches: (Pat.t, DHExp.t) => match_result; diff --git a/src/haz3lcore/dynamics/Stepper.re b/src/haz3lcore/dynamics/Stepper.re index 9cdbccdb5d..9be6e0a4aa 100644 --- a/src/haz3lcore/dynamics/Stepper.re +++ b/src/haz3lcore/dynamics/Stepper.re @@ -13,7 +13,7 @@ type stepper_state = | StepTimeout(EvalObj.t); [@deriving (show({with_path: false}), sexp, yojson)] -type history = Aba.t((DExp.t, EvaluatorState.t), step); +type history = Aba.t((DHExp.t, EvaluatorState.t), step); [@deriving (show({with_path: false}), sexp, yojson)] type t = { @@ -27,7 +27,7 @@ let rec matches = env: ClosureEnvironment.t, flt: FilterEnvironment.t, ctx: EvalCtx.t, - exp: DExp.t, + exp: DHExp.t, exp_info_map: Statics.Map.t, act: FilterAction.t, idx: int, @@ -283,7 +283,7 @@ let rec evaluate_pending = (~settings, s: t) => { | None => raise(Exception) } ) - |> DExp.repair_ids; + |> DHExp.repair_ids; let d' = EvalCtx.compose(eo.ctx, d_loc'); let new_step = { d, @@ -383,7 +383,7 @@ let get_justification: step_kind => string = | UnOp(Meta(Unquote)) => failwith("INVALID STEP"); type step_info = { - d: DExp.t, + d: DHExp.t, chosen_step: option(step), // The step that was taken next hidden_steps: list((step, Id.t)), // The hidden steps between previous_step and the current one (an Id in included because it may have changed since the step was taken) previous_step: option((step, Id.t)) // The step that will be displayed above this one (an Id in included because it may have changed since the step was taken) @@ -408,7 +408,7 @@ let get_history = (~settings, stepper) => { ( ( chosen_step: option(step), - (d: DExp.t, hidden_steps: list(step)), + (d: DHExp.t, hidden_steps: list(step)), previous_step: option(step), ), ) => { @@ -416,13 +416,13 @@ let get_history = (~settings, stepper) => { List.fold_left( ((ps, hs), h: step) => { let replacement = - replace_id(h.d_loc |> DExp.rep_id, h.d_loc' |> DExp.rep_id); + replace_id(h.d_loc |> DHExp.rep_id, h.d_loc' |> DHExp.rep_id); ( Option.map(replacement, ps), - [(h, h.d_loc' |> DExp.rep_id), ...List.map(replacement, hs)], + [(h, h.d_loc' |> DHExp.rep_id), ...List.map(replacement, hs)], ); }, - (Option.map(x => (x, x.d_loc' |> DExp.rep_id), previous_step), []), + (Option.map(x => (x, x.d_loc' |> DHExp.rep_id), previous_step), []), hidden_steps, ); {d, previous_step, hidden_steps, chosen_step}; diff --git a/src/haz3lcore/dynamics/Substitution.re b/src/haz3lcore/dynamics/Substitution.re index d3a54d1c2f..e829c22c3c 100644 --- a/src/haz3lcore/dynamics/Substitution.re +++ b/src/haz3lcore/dynamics/Substitution.re @@ -1,6 +1,6 @@ /* closed substitution [d1/x]d2 */ -let rec subst_var = (m, d1: DExp.t, x: Var.t, d2: DExp.t): DExp.t => { - let (term, rewrap) = DExp.unwrap(d2); +let rec subst_var = (m, d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => { + let (term, rewrap) = DHExp.unwrap(d2); switch (term) { | Var(y) => if (Var.eq(x, y)) { @@ -20,7 +20,7 @@ let rec subst_var = (m, d1: DExp.t, x: Var.t, d2: DExp.t): DExp.t => { | Let(dp, d3, d4) => let d3 = subst_var(m, d1, x, d3); let d4 = - if (DPat.binds_var(m, x, dp)) { + if (DHPat.binds_var(m, x, dp)) { d4; } else { subst_var(m, d1, x, d4); @@ -29,7 +29,7 @@ let rec subst_var = (m, d1: DExp.t, x: Var.t, d2: DExp.t): DExp.t => { | FixF(y, d3, env) => let env' = Option.map(subst_var_env(m, d1, x), env); let d3 = - if (DPat.binds_var(m, x, y)) { + if (DHPat.binds_var(m, x, y)) { d3; } else { subst_var(m, d1, x, d3); @@ -39,7 +39,7 @@ let rec subst_var = (m, d1: DExp.t, x: Var.t, d2: DExp.t): DExp.t => { /* Function closure shouldn't appear during substitution (which only is called from elaboration currently) */ let env' = Option.map(subst_var_env(m, d1, x), env); - if (DPat.binds_var(m, x, dp)) { + if (DHPat.binds_var(m, x, dp)) { Fun(dp, d3, env', s) |> rewrap; } else { let d3 = subst_var(m, d1, x, d3); @@ -84,7 +84,7 @@ let rec subst_var = (m, d1: DExp.t, x: Var.t, d2: DExp.t): DExp.t => { let rules = List.map( ((p, v)) => - if (DPat.binds_var(m, x, p)) { + if (DHPat.binds_var(m, x, p)) { (p, v); } else { (p, subst_var(m, d1, x, v)); @@ -122,15 +122,16 @@ let rec subst_var = (m, d1: DExp.t, x: Var.t, d2: DExp.t): DExp.t => { } and subst_var_env = - (m, d1: DExp.t, x: Var.t, env: ClosureEnvironment.t): ClosureEnvironment.t => { + (m, d1: DHExp.t, x: Var.t, env: ClosureEnvironment.t) + : ClosureEnvironment.t => { let id = env |> ClosureEnvironment.id_of; let map = env |> ClosureEnvironment.map_of |> Environment.foldo( - ((x', d': DExp.t), map) => { + ((x', d': DHExp.t), map) => { let d' = - switch (DExp.term_of(d')) { + switch (DHExp.term_of(d')) { /* Substitute each previously substituted binding into the * fixpoint. */ | FixF(_) => @@ -153,15 +154,15 @@ and subst_var_env = } and subst_var_filter = - (m, d1: DExp.t, x: Var.t, flt: TermBase.StepperFilterKind.t) + (m, d1: DHExp.t, x: Var.t, flt: TermBase.StepperFilterKind.t) : TermBase.StepperFilterKind.t => { flt |> TermBase.StepperFilterKind.map(subst_var(m, d1, x)); }; -let subst = (m, env: Environment.t, d: DExp.t): DExp.t => +let subst = (m, env: Environment.t, d: DHExp.t): DHExp.t => env |> Environment.foldo( - (xd: (Var.t, DExp.t), d2) => { + (xd: (Var.t, DHExp.t), d2) => { let (x, d1) = xd; subst_var(m, d1, x, d2); }, diff --git a/src/haz3lcore/dynamics/Substitution.rei b/src/haz3lcore/dynamics/Substitution.rei index 35eb631b77..49b1e2e92f 100644 --- a/src/haz3lcore/dynamics/Substitution.rei +++ b/src/haz3lcore/dynamics/Substitution.rei @@ -1,3 +1,3 @@ /* closed substitution [d1/x]d2 */ -let subst_var: (Statics.Map.t, DExp.t, Var.t, DExp.t) => DExp.t; -let subst: (Statics.Map.t, Environment.t, DExp.t) => DExp.t; +let subst_var: (Statics.Map.t, DHExp.t, Var.t, DHExp.t) => DHExp.t; +let subst: (Statics.Map.t, Environment.t, DHExp.t) => DHExp.t; diff --git a/src/haz3lcore/dynamics/TestMap.re b/src/haz3lcore/dynamics/TestMap.re index 57064a44c9..8592e0e546 100644 --- a/src/haz3lcore/dynamics/TestMap.re +++ b/src/haz3lcore/dynamics/TestMap.re @@ -2,7 +2,7 @@ open Sexplib.Std; /* FIXME: Make more obvious names. */ [@deriving (show({with_path: false}), sexp, yojson)] -type instance_report = (DExp.t, Statics.Map.t, TestStatus.t); +type instance_report = (DHExp.t, Statics.Map.t, TestStatus.t); let joint_status: list(instance_report) => TestStatus.t = reports => TestStatus.join_all(List.map(((_, _, x)) => x, reports)); diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index 4a42522131..a90d00f3ed 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -141,7 +141,7 @@ let evaluate_extend_env = type rule = | Step({ - apply: unit => DExp.t, + apply: unit => DHExp.t, kind: step_kind, value: bool, }) @@ -155,28 +155,30 @@ module type EV_MODE = { type requirements('a, 'b); let req_value: - (DExp.t => result, EvalCtx.t => EvalCtx.t, DExp.t) => requirement(DExp.t); + (DHExp.t => result, EvalCtx.t => EvalCtx.t, DHExp.t) => + requirement(DHExp.t); let req_all_value: ( - DExp.t => result, - (EvalCtx.t, (list(DExp.t), list(DExp.t))) => EvalCtx.t, - list(DExp.t) + DHExp.t => result, + (EvalCtx.t, (list(DHExp.t), list(DHExp.t))) => EvalCtx.t, + list(DHExp.t) ) => - requirement(list(DExp.t)); + requirement(list(DHExp.t)); let req_final: - (DExp.t => result, EvalCtx.t => EvalCtx.t, DExp.t) => requirement(DExp.t); + (DHExp.t => result, EvalCtx.t => EvalCtx.t, DHExp.t) => + requirement(DHExp.t); let req_all_final: ( - DExp.t => result, - (EvalCtx.t, (list(DExp.t), list(DExp.t))) => EvalCtx.t, - list(DExp.t) + DHExp.t => result, + (EvalCtx.t, (list(DHExp.t), list(DHExp.t))) => EvalCtx.t, + list(DHExp.t) ) => - requirement(list(DExp.t)); + requirement(list(DHExp.t)); let req_final_or_value: - (DExp.t => result, EvalCtx.t => EvalCtx.t, DExp.t) => - requirement((DExp.t, bool)); + (DHExp.t => result, EvalCtx.t => EvalCtx.t, DHExp.t) => + requirement((DHExp.t, bool)); - let (let.): (requirements('a, DExp.t), 'a => rule) => result; + let (let.): (requirements('a, DHExp.t), 'a => rule) => result; let (and.): (requirements('a, 'c => 'b), requirement('c)) => requirements(('a, 'c), 'b); @@ -189,7 +191,7 @@ module type EV_MODE = { module Transition = (EV: EV_MODE) => { open EV; - open DExp; + open DHExp; let (let.match) = ((env, match_result), r) => switch (match_result) { | IndetMatch @@ -204,7 +206,7 @@ module Transition = (EV: EV_MODE) => { let transition = (req, state, env, d): 'a => { // If there is an error at this location, swap out the rule for indet. let info_map = get_info_map(state); - let err_info = Statics.get_error_at(info_map, DExp.rep_id(d)); + let err_info = Statics.get_error_at(info_map, DHExp.rep_id(d)); let (let.) = switch (err_info) { | Some( @@ -219,8 +221,8 @@ module Transition = (EV: EV_MODE) => { | None => (let.) }; - // Split DExp into term and id information - let (term, rewrap) = DExp.unwrap(d); + // Split DHExp into term and id information + let (term, rewrap) = DHExp.unwrap(d); let wrap_ctx = (term): EvalCtx.t => Term({term, ids: [rep_id(d)]}); // Transition rules @@ -273,7 +275,7 @@ module Transition = (EV: EV_MODE) => { value: false, }); | FixF(dp, d1, Some(env)) => - switch (DPat.get_var(dp)) { + switch (DHPat.get_var(dp)) { // Simple Recursion case | Some(f) => let. _ = otherwise(env, d); @@ -290,7 +292,7 @@ module Transition = (EV: EV_MODE) => { // Mutual Recursion case | None => let. _ = otherwise(env, d); - let bindings = DPat.bound_vars(info_map, dp); + let bindings = DHPat.bound_vars(info_map, dp); let substitutions = List.map( binding => @@ -318,16 +320,16 @@ module Transition = (EV: EV_MODE) => { and. d' = req_final(req(state, env), d => Test(d) |> wrap_ctx, d); Step({ apply: () => - switch (DExp.term_of(d')) { + switch (DHExp.term_of(d')) { | Bool(true) => - update_test(state, DExp.rep_id(d), (d', info_map, Pass)); + update_test(state, DHExp.rep_id(d), (d', info_map, Pass)); Tuple([]) |> fresh; | Bool(false) => - update_test(state, DExp.rep_id(d), (d', info_map, Fail)); + update_test(state, DHExp.rep_id(d), (d', info_map, Fail)); Tuple([]) |> fresh; /* Hack: assume if final and not Bool, then Indet; this won't catch errors in statics */ | _ => - update_test(state, DExp.rep_id(d), (d', info_map, Indet)); + update_test(state, DHExp.rep_id(d), (d', info_map, Indet)); Tuple([]) |> fresh; }, kind: UpdateTest, @@ -343,7 +345,7 @@ module Transition = (EV: EV_MODE) => { d2 => Ap2(dir, d1, d2) |> wrap_ctx, d2, ); - switch (DExp.term_of(d1')) { + switch (DHExp.term_of(d1')) { | Constructor(_) => Constructor | Fun(dp, d3, Some(env'), _) => let.match env'' = (env', matches(dp, d2')); @@ -402,7 +404,7 @@ module Transition = (EV: EV_MODE) => { let. _ = otherwise(env, c => If(c, d1, d2) |> rewrap) and. c' = req_value(req(state, env), c => If1(c, d1, d2) |> wrap_ctx, c); - switch (DExp.term_of(c')) { + switch (DHExp.term_of(c')) { | Bool(b) => Step({ apply: () => { @@ -435,7 +437,7 @@ module Transition = (EV: EV_MODE) => { ); Step({ apply: () => - switch (DExp.term_of(d1')) { + switch (DHExp.term_of(d1')) { | Int(n) => Int(- n) |> fresh | _ => raise(EvaluatorError.Exception(InvalidBoxedIntLit(d1'))) }, @@ -452,7 +454,7 @@ module Transition = (EV: EV_MODE) => { ); Step({ apply: () => - switch (DExp.term_of(d1')) { + switch (DHExp.term_of(d1')) { | Bool(b) => Bool(!b) |> fresh | _ => raise(EvaluatorError.Exception(InvalidBoxedIntLit(d1'))) }, @@ -469,7 +471,7 @@ module Transition = (EV: EV_MODE) => { ); Step({ apply: () => - switch (DExp.term_of(d1')) { + switch (DHExp.term_of(d1')) { | Bool(true) => d2 | Bool(false) => Bool(false) |> fresh | _ => raise(EvaluatorError.Exception(InvalidBoxedBoolLit(d1'))) @@ -487,7 +489,7 @@ module Transition = (EV: EV_MODE) => { ); Step({ apply: () => - switch (DExp.term_of(d1')) { + switch (DHExp.term_of(d1')) { | Bool(true) => Bool(true) |> fresh | Bool(false) => d2 | _ => raise(EvaluatorError.Exception(InvalidBoxedBoolLit(d2))) @@ -511,7 +513,7 @@ module Transition = (EV: EV_MODE) => { ); Step({ apply: () => - switch (DExp.term_of(d1'), DExp.term_of(d2')) { + switch (DHExp.term_of(d1'), DHExp.term_of(d2')) { | (Int(n1), Int(n2)) => ( switch (op) { @@ -564,7 +566,7 @@ module Transition = (EV: EV_MODE) => { ); Step({ apply: () => - switch (DExp.term_of(d1'), DExp.term_of(d2')) { + switch (DHExp.term_of(d1'), DHExp.term_of(d2')) { | (Float(n1), Float(n2)) => ( switch (op) { @@ -606,7 +608,7 @@ module Transition = (EV: EV_MODE) => { ); Step({ apply: () => - switch (DExp.term_of(d1'), DExp.term_of(d2')) { + switch (DHExp.term_of(d1'), DHExp.term_of(d2')) { | (String(s1), String(s2)) => switch (op) { | Concat => String(s1 ++ s2) |> fresh @@ -768,7 +770,7 @@ module Transition = (EV: EV_MODE) => { /* ITExpand rule */ Step({ apply: () => - DExp.Cast(Cast(d', t1, t2_grounded) |> fresh, t2_grounded, t2) + DHExp.Cast(Cast(d', t1, t2_grounded) |> fresh, t2_grounded, t2) |> fresh, kind: Cast, value: false, @@ -777,7 +779,7 @@ module Transition = (EV: EV_MODE) => { /* ITGround rule */ Step({ apply: () => - DExp.Cast(Cast(d', t1, t1_grounded) |> fresh, t1_grounded, t2) + DHExp.Cast(Cast(d', t1, t1_grounded) |> fresh, t1_grounded, t2) |> fresh, kind: Cast, value: false, diff --git a/src/haz3lcore/dynamics/TypeAssignment.re b/src/haz3lcore/dynamics/TypeAssignment.re index 4e76eeb2b1..81f489d8fe 100644 --- a/src/haz3lcore/dynamics/TypeAssignment.re +++ b/src/haz3lcore/dynamics/TypeAssignment.re @@ -38,7 +38,7 @@ // }; // }; // let rec dhpat_extend_ctx = -// (m: Statics.Map.t, dhpat: DPat.t, ty: Typ.t, ctx: Ctx.t): Ctx.t => { +// (m: Statics.Map.t, dhpat: DHPat.t, ty: Typ.t, ctx: Ctx.t): Ctx.t => { // switch (dhpat.term, ty) { // | (Var(name), _) => // let entry = Ctx.VarEntry({name, id: Id.invalid, typ: ty}); @@ -79,7 +79,7 @@ // }; // }; // let rec typ_of_dhexp = -// (ctx: Ctx.t, m: Statics.Map.t, dh: DExp.t): option(Typ.t) => { +// (ctx: Ctx.t, m: Statics.Map.t, dh: DHExp.t): option(Typ.t) => { // switch (dh) { // | EmptyHole(id, _) => delta_ty(id, m) // | NonEmptyHole(_, id, _, d) => @@ -262,7 +262,7 @@ // }; // }; // }; -// let property_test = (uexp_typ: Typ.t, dhexp: DExp.t, m: Statics.Map.t): bool => { +// let property_test = (uexp_typ: Typ.t, dhexp: DHExp.t, m: Statics.Map.t): bool => { // let dhexp_typ = typ_of_dhexp(Builtins.ctx_init, m, dhexp); // print_endline(Typ.show(uexp_typ)); // switch (dhexp_typ) { diff --git a/src/haz3lcore/dynamics/ValueChecker.re b/src/haz3lcore/dynamics/ValueChecker.re index 1842bfcfca..f8f73c7536 100644 --- a/src/haz3lcore/dynamics/ValueChecker.re +++ b/src/haz3lcore/dynamics/ValueChecker.re @@ -1,4 +1,4 @@ -open DExp; +open DHExp; open Transition; open Util; @@ -88,7 +88,7 @@ let rec check_value = (state, env, d) => CV.transition(check_value, state, env, d); let rec check_value_mod_ctx = (info_map: Statics.Map.t, env, d) => - switch (DExp.term_of(d)) { + switch (DHExp.term_of(d)) { | Var(x) => check_value_mod_ctx( info_map, diff --git a/src/haz3lcore/lang/term/TermBase.re b/src/haz3lcore/lang/term/TermBase.re index 634888d48a..753fa797fd 100644 --- a/src/haz3lcore/lang/term/TermBase.re +++ b/src/haz3lcore/lang/term/TermBase.re @@ -122,7 +122,7 @@ and Exp: { // invariant: ids should be nonempty ids: list(Id.t), /* UExp invariant: copied should always be false, and the id should be unique - DExp invariant: if copied is true, then this term and its children may not + DHExp invariant: if copied is true, then this term and its children may not have unique ids. */ copied: bool, term, diff --git a/src/haz3lcore/prog/Interface.re b/src/haz3lcore/prog/Interface.re index 3c352cedb2..b47008640b 100644 --- a/src/haz3lcore/prog/Interface.re +++ b/src/haz3lcore/prog/Interface.re @@ -34,13 +34,13 @@ module Statics = { core.statics ? mk_map_ctx(ctx, exp) : Id.Map.empty; }; -let dh_err = (error: string): DExp.t => Var(error) |> DExp.fresh; +let dh_err = (error: string): DHExp.t => Var(error) |> DHExp.fresh; let elaborate = Core.Memo.general(~cache_size_bound=1000, Elaborator.uexp_elab); exception DoesNotElaborate; -let elaborate = (~settings: CoreSettings.t, map, term): DExp.t => +let elaborate = (~settings: CoreSettings.t, map, term): DHExp.t => switch () { | _ when !settings.statics => dh_err("Statics disabled") | _ when !settings.dynamics && !settings.elaborate => diff --git a/src/haz3lcore/prog/ModelResult.re b/src/haz3lcore/prog/ModelResult.re index 52c992d264..25cee41b13 100644 --- a/src/haz3lcore/prog/ModelResult.re +++ b/src/haz3lcore/prog/ModelResult.re @@ -20,7 +20,7 @@ let update_elab = elab => Evaluation({elab, evaluation: ResultPending, previous: ResultPending}) | Evaluation({evaluation, _}) => Evaluation({elab, evaluation: ResultPending, previous: evaluation}) - | Stepper(s) as s' when DExp.fast_equal(elab.d, Stepper.get_elab(s).d) => s' + | Stepper(s) as s' when DHExp.fast_equal(elab.d, Stepper.get_elab(s).d) => s' | Stepper(_) => Stepper(Stepper.init(elab)); let update_stepper = f => diff --git a/src/haz3lcore/tiles/Id.re b/src/haz3lcore/tiles/Id.re index bc992204a4..b377ca02b0 100644 --- a/src/haz3lcore/tiles/Id.re +++ b/src/haz3lcore/tiles/Id.re @@ -23,7 +23,7 @@ CAN I USE IDS IN DYNAMICS? - Currently, DExps (as produced by the elaborator and produced/consumed + Currently, DHExps (as produced by the elaborator and produced/consumed by the evaluator) do not in general persist ids; the exceptions are things like holes and tests which have additional metadata which is accumulated duting evaluation. There are many use cases for tracking diff --git a/src/haz3lweb/view/Cell.re b/src/haz3lweb/view/Cell.re index 05f22a25f2..9edb5f0b40 100644 --- a/src/haz3lweb/view/Cell.re +++ b/src/haz3lweb/view/Cell.re @@ -397,7 +397,7 @@ let locked = statics.info_map, editor.state.meta.view_term, ) - : DExp.Bool(true) |> DExp.fresh; + : DHExp.Bool(true) |> DHExp.fresh; let elab: Elaborator.Elaboration.t = {d: elab, info_map: statics.info_map}; let result: ModelResult.t = settings.core.dynamics diff --git a/src/haz3lweb/view/StepperView.re b/src/haz3lweb/view/StepperView.re index f250dd2ba7..9cd98fd9d1 100644 --- a/src/haz3lweb/view/StepperView.re +++ b/src/haz3lweb/view/StepperView.re @@ -156,7 +156,7 @@ let stepper_view = ~next_steps= List.mapi( (i, x: EvaluatorStep.EvalObj.t) => - (i, x.d_loc |> DExp.rep_id), + (i, x.d_loc |> DHExp.rep_id), Stepper.get_next_steps(stepper), ), hd, diff --git a/src/haz3lweb/view/dhcode/DHCode.re b/src/haz3lweb/view/dhcode/DHCode.re index bf856f7dc2..b6f87322c3 100644 --- a/src/haz3lweb/view/dhcode/DHCode.re +++ b/src/haz3lweb/view/dhcode/DHCode.re @@ -144,7 +144,7 @@ let view = ~next_steps: list((int, Id.t))=[], ~result_key: string, ~infomap, - d: DExp.t, + d: DHExp.t, ) : Node.t => { DHDoc_Exp.mk( diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index d1a6de8533..4daaa9f3cb 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -42,9 +42,9 @@ let precedence_bin_string_op = (bso: Operators.op_bin_string) => | Concat => DHDoc_common.precedence_Plus | Equals => DHDoc_common.precedence_Equals }; -let rec precedence = (~show_casts: bool, d: DExp.t) => { +let rec precedence = (~show_casts: bool, d: DHExp.t) => { let precedence' = precedence(~show_casts); - switch (DExp.term_of(d)) { + switch (DHExp.term_of(d)) { | Var(_) | Invalid(_) | Bool(_) @@ -110,7 +110,7 @@ let mk = ~next_steps: list((int, Id.t)), // The options for the next step, if it hasn't been chosen yet ~env: ClosureEnvironment.t, ~infomap: Statics.Map.t, - d: DExp.t, + d: DHExp.t, ) : DHDoc.t => { // // print_endline(""); @@ -126,7 +126,7 @@ let mk = let precedence = precedence(~show_casts=settings.show_casts); let rec go = ( - d: DExp.t, + d: DHExp.t, env: ClosureEnvironment.t, enforce_inline: bool, recent_subst: list(Var.t), @@ -136,17 +136,17 @@ let mk = open Doc; let recent_subst = switch (previous_step) { - | Some((ps, id)) when id == DExp.rep_id(d) => - switch (ps.knd, DExp.term_of(ps.d_loc)) { + | Some((ps, id)) when id == DHExp.rep_id(d) => + switch (ps.knd, DHExp.term_of(ps.d_loc)) { | (FunAp, Ap(_, d2, _)) => - switch (DExp.term_of(d2)) { - | Fun(p, _, _, _) => DPat.bound_vars(infomap, p) + switch (DHExp.term_of(d2)) { + | Fun(p, _, _, _) => DHPat.bound_vars(infomap, p) | _ => [] } | (FunAp, _) => [] - | (LetBind, Let(p, _, _)) => DPat.bound_vars(infomap, p) + | (LetBind, Let(p, _, _)) => DHPat.bound_vars(infomap, p) | (LetBind, _) => [] - | (FixUnwrap, FixF(p, _, _)) => DPat.bound_vars(infomap, p) + | (FixUnwrap, FixF(p, _, _)) => DHPat.bound_vars(infomap, p) | (FixUnwrap, _) => [] | (InvalidStep, _) | (VarLookup, _) @@ -248,7 +248,7 @@ let mk = go_formattable(d2) |> parenthesize(precedence(d2) > precedence_op), ); let doc = { - switch (DExp.term_of(d)) { + switch (DHExp.term_of(d)) { | Parens(d') => go'(d') | Closure(env', d') => go'(d', ~env=env') | Filter(flt, d') => @@ -284,13 +284,13 @@ let mk = the postprocessed result */ | EmptyHole => DHDoc_common.mk_EmptyHole( - ~selected=Some(DExp.rep_id(d)) == selected_hole_instance, + ~selected=Some(DHExp.rep_id(d)) == selected_hole_instance, env, ) | MultiHole(_ds) => //ds |> List.map(go') |> Doc.hcats DHDoc_common.mk_EmptyHole( - ~selected=Some(DExp.rep_id(d)) == selected_hole_instance, + ~selected=Some(DHExp.rep_id(d)) == selected_hole_instance, env, ) | StaticErrorHole(_, d') => go'(d') |> annot(DHAnnot.NonEmptyHole) @@ -406,7 +406,7 @@ let mk = if (enforce_inline) { fail(); } else { - let bindings = DPat.bound_vars(infomap, dp); + let bindings = DHPat.bound_vars(infomap, dp); let def_doc = go_formattable(ddef); vseps([ hcats([ @@ -434,7 +434,7 @@ let mk = ]); } | FailedCast(d1, ty2', ty3) => - switch (DExp.term_of(d1)) { + switch (DHExp.term_of(d1)) { | Cast(d, ty1, ty2) when Typ.eq(ty2, ty2') => let d_doc = go'(d); let cast_decoration = @@ -486,17 +486,17 @@ let mk = ]); | Fun(dp, d, Some(env'), s) => if (settings.show_fn_bodies) { - let bindings = DPat.bound_vars(infomap, dp); + let bindings = DHPat.bound_vars(infomap, dp); let body_doc = go_formattable( Closure( ClosureEnvironment.without_keys(Option.to_list(s), env'), d, ) - |> DExp.fresh, + |> DHExp.fresh, ~env= ClosureEnvironment.without_keys( - DPat.bound_vars(infomap, dp) @ Option.to_list(s), + DHPat.bound_vars(infomap, dp) @ Option.to_list(s), env, ), ~recent_subst= @@ -525,7 +525,7 @@ let mk = } | Fun(dp, dbody, None, s) => if (settings.show_fn_bodies) { - let bindings = DPat.bound_vars(infomap, dp); + let bindings = DHPat.bound_vars(infomap, dp); let body_doc = go_formattable( dbody, @@ -561,7 +561,7 @@ let mk = dbody, ~env= ClosureEnvironment.without_keys( - DPat.bound_vars(infomap, dp), + DHPat.bound_vars(infomap, dp), env, ), ); @@ -581,7 +581,7 @@ let mk = go'( ~env= ClosureEnvironment.without_keys( - DPat.bound_vars(infomap, dp), + DHPat.bound_vars(infomap, dp), env, ), d, @@ -589,22 +589,22 @@ let mk = }; }; let steppable = - next_steps |> List.find_opt(((_, id)) => id == DExp.rep_id(d)); + next_steps |> List.find_opt(((_, id)) => id == DHExp.rep_id(d)); let stepped = chosen_step - |> Option.map(x => DExp.rep_id(x.d_loc) == DExp.rep_id(d)) + |> Option.map(x => DHExp.rep_id(x.d_loc) == DHExp.rep_id(d)) |> Option.value(~default=false); let substitution = hidden_steps |> List.find_opt(((step, id)) => step.knd == VarLookup // HACK[Matt]: to prevent substitutions hiding inside casts - && id == DExp.rep_id(d) + && id == DHExp.rep_id(d) ); let doc = switch (substitution) { | Some((step, _)) => - switch (DExp.term_of(step.d_loc)) { + switch (DHExp.term_of(step.d_loc)) { | Var(v) when List.mem(v, recent_subst) => hcats([text(v) |> annot(DHAnnot.Substituted), doc]) | _ => doc diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re index 2388af7f4c..57b7fc5622 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re @@ -2,7 +2,7 @@ open Pretty; open Haz3lcore; let precedence = (dp: Pat.t) => - switch (DPat.term_of(dp)) { + switch (DHPat.term_of(dp)) { | EmptyHole | MultiHole(_) | Wild @@ -39,7 +39,7 @@ let rec mk = mk'(~parenthesize=precedence(dp2) > precedence_op, dp2), ); let doc = - switch (DPat.term_of(dp)) { + switch (DHPat.term_of(dp)) { | MultiHole(_) | EmptyHole => DHDoc_common.mk_EmptyHole(ClosureEnvironment.empty) | Invalid(t) => DHDoc_common.mk_InvalidText(t) @@ -68,7 +68,7 @@ let rec mk = DHDoc_common.mk_Ap(doc1, doc2); }; let doc = - switch (Statics.get_pat_error_at(infomap, DPat.rep_id(dp))) { + switch (Statics.get_pat_error_at(infomap, DHPat.rep_id(dp))) { | Some(_) => Doc.annot(DHAnnot.NonEmptyHole, doc) | None => doc }; diff --git a/src/test/Test_Elaboration.re b/src/test/Test_Elaboration.re index d338b2ffbb..2d4349f2e2 100644 --- a/src/test/Test_Elaboration.re +++ b/src/test/Test_Elaboration.re @@ -1,17 +1,17 @@ open Alcotest; open Haz3lcore; -open DExp; +open DHExp; -let dhexp_eq = (d1: option(DExp.t), d2: option(DExp.t)): bool => +let dhexp_eq = (d1: option(DHExp.t), d2: option(DHExp.t)): bool => switch (d1, d2) { - | (Some(d1), Some(d2)) => DExp.fast_equal(d1, d2) + | (Some(d1), Some(d2)) => DHExp.fast_equal(d1, d2) | _ => false }; -let dhexp_print = (d: option(DExp.t)): string => +let dhexp_print = (d: option(DHExp.t)): string => switch (d) { | None => "None" - | Some(d) => DExp.show(d) + | Some(d) => DHExp.show(d) }; /*Create a testable type for dhexp which requires @@ -41,7 +41,7 @@ let u3: UExp.t = { copied: false, term: Parens({ids: [id_at(1)], copied: false, term: Var("y")}), }; -let d3: DExp.t = StaticErrorHole(id_at(1), Var("y") |> fresh) |> fresh; +let d3: DHExp.t = StaticErrorHole(id_at(1), Var("y") |> fresh) |> fresh; let free_var = () => alco_check( "Nonempty hole with free variable", @@ -83,9 +83,9 @@ let u4: UExp.t = { }, ), }; -let d4: DExp.t = +let d4: DHExp.t = Let( - Tuple([Var("a") |> DPat.fresh, Var("b") |> DPat.fresh]) |> DPat.fresh, + Tuple([Var("a") |> DHPat.fresh, Var("b") |> DHPat.fresh]) |> DHPat.fresh, Tuple([Int(4) |> fresh, Int(6) |> fresh]) |> fresh, BinOp(Int(Minus), Var("a") |> fresh, Var("b") |> fresh) |> fresh, ) @@ -103,7 +103,7 @@ let u5: UExp.t = { {ids: [id_at(2)], copied: false, term: Var("y")}, ), }; -let d5: DExp.t = +let d5: DHExp.t = BinOp( Int(Plus), StaticErrorHole(id_at(1), Bool(false) |> fresh) |> fresh, @@ -127,7 +127,7 @@ let u6: UExp.t = { {ids: [id_at(3)], copied: false, term: Int(6)}, ), }; -let d6: DExp.t = +let d6: DHExp.t = If(Bool(false) |> fresh, Int(8) |> fresh, Int(6) |> fresh) |> fresh; let consistent_if = () => alco_check( @@ -165,11 +165,11 @@ let u7: UExp.t = { {ids: [id_at(6)], copied: false, term: Var("y")}, ), }; -let d7: DExp.t = +let d7: DHExp.t = Ap( Forward, Fun( - Var("x") |> DPat.fresh, + Var("x") |> DHPat.fresh, BinOp( Int(Plus), Int(4) |> fresh, @@ -217,15 +217,15 @@ let u8: UExp.t = { ], ), }; -let d8scrut: DExp.t = +let d8scrut: DHExp.t = BinOp(Int(Equals), Int(4) |> fresh, Int(3) |> fresh) |> fresh; let d8rules = - DExp.[ - (Bool(true) |> DPat.fresh, Int(24) |> fresh), - (Bool(false) |> DPat.fresh, Bool(false) |> fresh), + DHExp.[ + (Bool(true) |> DHPat.fresh, Int(24) |> fresh), + (Bool(false) |> DHPat.fresh, Bool(false) |> fresh), ]; -let d8a: DExp.t = Match(d8scrut, d8rules) |> fresh; -let d8: DExp.t = StaticErrorHole(id_at(0), d8a) |> fresh; +let d8a: DHExp.t = Match(d8scrut, d8rules) |> fresh; +let d8: DHExp.t = StaticErrorHole(id_at(0), d8a) |> fresh; let inconsistent_case = () => alco_check( "Inconsistent branches where the first branch is an integer and second branch is a boolean", @@ -276,7 +276,7 @@ let u9: UExp.t = { {ids: [id_at(11)], copied: false, term: Int(55)}, ), }; -// let d9: DExp.t = +// let d9: DHExp.t = // Let( // Var("f"), // FixF( From dc8719f62d61e5a12136447c1c09b34058970b1f Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 7 Mar 2024 15:18:05 -0500 Subject: [PATCH 052/103] Move UTerms back --- src/haz3lcore/lang/term/Any.re | 46 +- src/haz3lcore/lang/term/Exp.re | 210 +----- src/haz3lcore/lang/term/Pat.re | 228 +----- src/haz3lcore/lang/term/Rul.re | 26 +- src/haz3lcore/lang/term/TPat.re | 34 +- src/haz3lcore/lang/term/TypTerm.re | 128 +--- src/haz3lcore/statics/Term.re | 688 ++++++++++++++++++ .../{lang/term => statics}/TermBase.re | 0 8 files changed, 694 insertions(+), 666 deletions(-) create mode 100644 src/haz3lcore/statics/Term.re rename src/haz3lcore/{lang/term => statics}/TermBase.re (100%) diff --git a/src/haz3lcore/lang/term/Any.re b/src/haz3lcore/lang/term/Any.re index 4e5905f4d0..b759e67fc9 100644 --- a/src/haz3lcore/lang/term/Any.re +++ b/src/haz3lcore/lang/term/Any.re @@ -1,45 +1 @@ -include TermBase.Any; - -let is_exp: t => option(TermBase.Exp.t) = - fun - | Exp(e) => Some(e) - | _ => None; -let is_pat: t => option(TermBase.Pat.t) = - fun - | Pat(p) => Some(p) - | _ => None; -let is_typ: t => option(TermBase.TypTerm.t) = - fun - | Typ(t) => Some(t) - | _ => None; - -let rec ids = - fun - | Exp(tm) => tm.ids - | Pat(tm) => tm.ids - | Typ(tm) => tm.ids - | TPat(tm) => tm.ids - | Rul(tm) => Rul.ids(~any_ids=ids, tm) - | Nul () - | Any () => []; - -// Terms may consist of multiple tiles, eg the commas in an n-tuple, -// the rules of a case expression + the surrounding case-end tile, -// the list brackets tile coupled with the elem-separating commas. -// The _representative id_ is the canonical tile id used to identify -// and look up info about a term. -// -// In instances like case expressions and list literals, where a parent -// tile surrounds the other tiles, the representative id is the parent tile's. -// In other instances like n-tuples, where the commas are all siblings, -// the representative id is one of the comma ids, unspecified which one. -// (This would change for n-tuples if we decided parentheses are necessary.) -let rep_id = - fun - | Exp(tm) => Exp.rep_id(tm) - | Pat(tm) => Pat.rep_id(tm) - | Typ(tm) => TypTerm.rep_id(tm) - | TPat(tm) => TPat.rep_id(tm) - | Rul(tm) => Rul.rep_id(~any_ids=ids, tm) - | Nul () - | Any () => raise(Invalid_argument("Term.rep_id")); +include Term.Any; diff --git a/src/haz3lcore/lang/term/Exp.re b/src/haz3lcore/lang/term/Exp.re index 86d3082c4d..ff620a0166 100644 --- a/src/haz3lcore/lang/term/Exp.re +++ b/src/haz3lcore/lang/term/Exp.re @@ -1,209 +1 @@ -include TermBase.Exp; - -[@deriving (show({with_path: false}), sexp, yojson)] -type cls = - | Invalid - | EmptyHole - | MultiHole - | StaticErrorHole - | DynamicErrorHole - | FailedCast - | Bool - | Int - | Float - | String - | ListLit - | Constructor - | Fun - | Tuple - | Var - | MetaVar - | Let - | FixF - | TyAlias - | Ap - | Pipeline - | If - | Seq - | Test - | Filter - | Closure - | Parens - | Cons - | UnOp(Operators.op_un) - | BinOp(Operators.op_bin) - | BuiltinFun - | Match - | Cast - | ListConcat; - -let hole = (tms: list(TermBase.Any.t)): term => - switch (tms) { - | [] => EmptyHole - | [_, ..._] => MultiHole(tms) - }; - -let rep_id = ({ids, _}) => { - assert(ids != []); - List.hd(ids); -}; - -let fresh = term => { - {ids: [Id.mk()], copied: false, term}; -}; - -let unwrap = ({ids, term, copied}) => (term, term => {ids, term, copied}); - -let cls_of_term: term => cls = - fun - | Invalid(_) => Invalid - | EmptyHole => EmptyHole - | MultiHole(_) => MultiHole - | StaticErrorHole(_) => StaticErrorHole - | DynamicErrorHole(_) => DynamicErrorHole - | FailedCast(_) => FailedCast - | Bool(_) => Bool - | Int(_) => Int - | Float(_) => Float - | String(_) => String - | ListLit(_) => ListLit - | Constructor(_) => Constructor - | Fun(_) => Fun - | Tuple(_) => Tuple - | Var(_) => Var - | Let(_) => Let - | FixF(_) => FixF - | TyAlias(_) => TyAlias - | Ap(_) => Ap - | If(_) => If - | Seq(_) => Seq - | Test(_) => Test - | Filter(_) => Filter - | Closure(_) => Closure - | Parens(_) => Parens - | Cons(_) => Cons - | ListConcat(_) => ListConcat - | UnOp(op, _) => UnOp(op) - | BinOp(op, _, _) => BinOp(op) - | BuiltinFun(_) => BuiltinFun - | Match(_) => Match - | Cast(_) => Cast; - -let show_cls: cls => string = - fun - | Invalid => "Invalid expression" - | MultiHole => "Broken expression" - | EmptyHole => "Empty expression hole" - | StaticErrorHole => "Static error hole" - | DynamicErrorHole => "Dynamic error hole" - | FailedCast => "Failed cast" - | Bool => "Boolean literal" - | Int => "Integer literal" - | Float => "Float literal" - | String => "String literal" - | ListLit => "List literal" - | Constructor => "Constructor" - | Fun => "Function literal" - | Tuple => "Tuple literal" - | Var => "Variable reference" - | MetaVar => "Meta variable reference" - | Let => "Let expression" - | FixF => "Fixpoint operator" - | TyAlias => "Type Alias definition" - | Ap => "Application" - | Pipeline => "Pipeline expression" - | If => "If expression" - | Seq => "Sequence expression" - | Test => "Test" - | Filter => "Filter" - | Closure => "Closure" - | Parens => "Parenthesized expression" - | Cons => "Cons" - | ListConcat => "List Concatenation" - | BinOp(op) => Operators.show_binop(op) - | UnOp(op) => Operators.show_unop(op) - | BuiltinFun => "Built-in Function" - | Match => "Case expression" - | Cast => "Cast expression"; - -let rec is_fun = (e: t) => { - switch (e.term) { - | Parens(e) => is_fun(e) - | Cast(e, _, _) => is_fun(e) - | Fun(_) - | BuiltinFun(_) => true - | Invalid(_) - | EmptyHole - | MultiHole(_) - | StaticErrorHole(_) - | DynamicErrorHole(_) - | FailedCast(_) - | Bool(_) - | Int(_) - | Float(_) - | String(_) - | ListLit(_) - | Tuple(_) - | Var(_) - | Let(_) - | FixF(_) - | TyAlias(_) - | Ap(_) - | If(_) - | Seq(_) - | Test(_) - | Filter(_) - | Cons(_) - | ListConcat(_) - | Closure(_) - | UnOp(_) - | BinOp(_) - | Match(_) - | Constructor(_) => false - }; -}; - -let rec is_tuple_of_functions = (e: t) => - is_fun(e) - || ( - switch (e.term) { - | Cast(e, _, _) - | Parens(e) => is_tuple_of_functions(e) - | Tuple(es) => es |> List.for_all(is_fun) - | Invalid(_) - | EmptyHole - | MultiHole(_) - | StaticErrorHole(_) - | DynamicErrorHole(_) - | FailedCast(_) - | Bool(_) - | Int(_) - | Float(_) - | String(_) - | ListLit(_) - | Fun(_) - | Closure(_) - | BuiltinFun(_) - | Var(_) - | Let(_) - | FixF(_) - | TyAlias(_) - | Ap(_) - | If(_) - | Seq(_) - | Test(_) - | Filter(_) - | Cons(_) - | ListConcat(_) - | UnOp(_) - | BinOp(_) - | Match(_) - | Constructor(_) => false - } - ); - -let ctr_name = (e: t): option(Constructor.t) => - switch (e.term) { - | Constructor(name) => Some(name) - | _ => None - }; +include Term.Exp; diff --git a/src/haz3lcore/lang/term/Pat.re b/src/haz3lcore/lang/term/Pat.re index 3fd6462914..b4bb875bdd 100644 --- a/src/haz3lcore/lang/term/Pat.re +++ b/src/haz3lcore/lang/term/Pat.re @@ -1,227 +1 @@ -[@deriving (show({with_path: false}), sexp, yojson)] -type cls = - | Invalid - | EmptyHole - | MultiHole - | Wild - | Int - | Float - | Bool - | String - | ListLit - | Constructor - | Cons - | Var - | Tuple - | Parens - | Ap - | TypeAnn; - -include TermBase.Pat; - -let rep_id = ({ids, _}: t) => { - assert(ids != []); - List.hd(ids); -}; - -let term_of = ({term, _}) => term; -// All children of term must have expression-unique ids. - -let unwrap = ({ids, term}) => (term, term => {ids, term}); - -let fresh = term => { - {ids: [Id.mk()], term}; -}; - -let hole = (tms: list(TermBase.Any.t)) => - switch (tms) { - | [] => EmptyHole - | [_, ..._] => MultiHole(tms) - }; - -let cls_of_term: term => cls = - fun - | Invalid(_) => Invalid - | EmptyHole => EmptyHole - | MultiHole(_) => MultiHole - | Wild => Wild - | Int(_) => Int - | Float(_) => Float - | Bool(_) => Bool - | String(_) => String - | ListLit(_) => ListLit - | Constructor(_) => Constructor - | Cons(_) => Cons - | Var(_) => Var - | Tuple(_) => Tuple - | Parens(_) => Parens - | Ap(_) => Ap - | TypeAnn(_) => TypeAnn; - -let show_cls: cls => string = - fun - | Invalid => "Invalid pattern" - | MultiHole => "Broken pattern" - | EmptyHole => "Empty pattern hole" - | Wild => "Wildcard" - | Int => "Integer literal" - | Float => "Float literal" - | Bool => "Boolean literal" - | String => "String literal" - | ListLit => "List literal" - | Constructor => "Constructor" - | Cons => "Cons" - | Var => "Variable binding" - | Tuple => "Tuple" - | Parens => "Parenthesized pattern" - | Ap => "Constructor application" - | TypeAnn => "Annotation"; - -let rec is_var = (pat: t) => { - switch (pat.term) { - | Parens(pat) => is_var(pat) - | Var(_) => true - | TypeAnn(_) - | Invalid(_) - | EmptyHole - | MultiHole(_) - | Wild - | Int(_) - | Float(_) - | Bool(_) - | String(_) - | ListLit(_) - | Cons(_, _) - | Tuple(_) - | Constructor(_) - | Ap(_) => false - }; -}; - -let rec is_fun_var = (pat: t) => { - switch (pat.term) { - | Parens(pat) => is_fun_var(pat) - | TypeAnn(pat, typ) => is_var(pat) && UTyp.is_arrow(typ) - | Invalid(_) - | EmptyHole - | MultiHole(_) - | Wild - | Int(_) - | Float(_) - | Bool(_) - | String(_) - | ListLit(_) - | Cons(_, _) - | Var(_) - | Tuple(_) - | Constructor(_) - | Ap(_) => false - }; -}; - -let rec is_tuple_of_arrows = (pat: t) => - is_fun_var(pat) - || ( - switch (pat.term) { - | Parens(pat) => is_tuple_of_arrows(pat) - | Tuple(pats) => pats |> List.for_all(is_fun_var) - | Invalid(_) - | EmptyHole - | MultiHole(_) - | Wild - | Int(_) - | Float(_) - | Bool(_) - | String(_) - | ListLit(_) - | Cons(_, _) - | Var(_) - | TypeAnn(_) - | Constructor(_) - | Ap(_) => false - } - ); - -let rec get_var = (pat: t) => { - switch (pat.term) { - | Parens(pat) => get_var(pat) - | Var(x) => Some(x) - | TypeAnn(x, _) => get_var(x) - | Invalid(_) - | EmptyHole - | MultiHole(_) - | Wild - | Int(_) - | Float(_) - | Bool(_) - | String(_) - | ListLit(_) - | Cons(_, _) - | Tuple(_) - | Constructor(_) - | Ap(_) => None - }; -}; - -let rec get_fun_var = (pat: t) => { - switch (pat.term) { - | Parens(pat) => get_fun_var(pat) - | TypeAnn(pat, typ) => - if (UTyp.is_arrow(typ)) { - get_var(pat) |> Option.map(var => var); - } else { - None; - } - | Invalid(_) - | EmptyHole - | MultiHole(_) - | Wild - | Int(_) - | Float(_) - | Bool(_) - | String(_) - | ListLit(_) - | Cons(_, _) - | Var(_) - | Tuple(_) - | Constructor(_) - | Ap(_) => None - }; -}; - -let rec get_recursive_bindings = (pat: t) => { - switch (get_fun_var(pat)) { - | Some(x) => Some([x]) - | None => - switch (pat.term) { - | Parens(pat) => get_recursive_bindings(pat) - | Tuple(pats) => - let fun_vars = pats |> List.map(get_fun_var); - if (List.exists(Option.is_none, fun_vars)) { - None; - } else { - Some(List.map(Option.get, fun_vars)); - }; - | Invalid(_) - | EmptyHole - | MultiHole(_) - | Wild - | Int(_) - | Float(_) - | Bool(_) - | String(_) - | ListLit(_) - | Cons(_, _) - | Var(_) - | TypeAnn(_) - | Constructor(_) - | Ap(_) => None - } - }; -}; - -let ctr_name = (p: t): option(Constructor.t) => - switch (p.term) { - | Constructor(name) => Some(name) - | _ => None - }; +include Term.Pat; diff --git a/src/haz3lcore/lang/term/Rul.re b/src/haz3lcore/lang/term/Rul.re index b9183e667d..9a293a4270 100644 --- a/src/haz3lcore/lang/term/Rul.re +++ b/src/haz3lcore/lang/term/Rul.re @@ -1,25 +1 @@ -include TermBase.Rul; - -[@deriving (show({with_path: false}), sexp, yojson)] -type cls = - | Rule; - -// example of awkwardness induced by having forms like rules -// that may have a different-sorted child with no delimiters -// (eg scrut with no rules) -let ids = (~any_ids, {ids, term}: t) => - switch (ids) { - | [_, ..._] => ids - | [] => - switch (term) { - | Hole([tm, ..._]) => any_ids(tm) - | Rules(scrut, []) => scrut.ids - | _ => [] - } - }; - -let rep_id = (~any_ids, tm) => - switch (ids(~any_ids, tm)) { - | [] => raise(Invalid_argument("UExp.rep_id")) - | [id, ..._] => id - }; +include Term.Rul; diff --git a/src/haz3lcore/lang/term/TPat.re b/src/haz3lcore/lang/term/TPat.re index abc0a79891..744964b9df 100644 --- a/src/haz3lcore/lang/term/TPat.re +++ b/src/haz3lcore/lang/term/TPat.re @@ -1,33 +1 @@ -[@deriving (show({with_path: false}), sexp, yojson)] -type cls = - | Invalid - | EmptyHole - | MultiHole - | Var; - -include TermBase.TPat; - -let rep_id = ({ids, _}) => { - assert(ids != []); - List.hd(ids); -}; - -let hole = (tms: list(TermBase.Any.t)) => - switch (tms) { - | [] => EmptyHole - | [_, ..._] => MultiHole(tms) - }; - -let cls_of_term: term => cls = - fun - | Invalid(_) => Invalid - | EmptyHole => EmptyHole - | MultiHole(_) => MultiHole - | Var(_) => Var; - -let show_cls: cls => string = - fun - | Invalid => "Invalid type alias" - | MultiHole => "Broken type alias" - | EmptyHole => "Empty type alias hole" - | Var => "Type alias"; +include Term.TPat; diff --git a/src/haz3lcore/lang/term/TypTerm.re b/src/haz3lcore/lang/term/TypTerm.re index abcf6a601a..457472f4b9 100644 --- a/src/haz3lcore/lang/term/TypTerm.re +++ b/src/haz3lcore/lang/term/TypTerm.re @@ -1,127 +1 @@ -[@deriving (show({with_path: false}), sexp, yojson)] -type cls = - | Invalid - | EmptyHole - | MultiHole - | Int - | Float - | Bool - | String - | Arrow - | Tuple - | Sum - | List - | Var - | Constructor - | Parens - | Ap; - -include TermBase.TypTerm; - -let rep_id = ({ids, _}: t) => { - assert(ids != []); - List.hd(ids); -}; - -let hole = (tms: list(TermBase.Any.t)) => - switch (tms) { - | [] => EmptyHole - | [_, ..._] => MultiHole(tms) - }; - -let cls_of_term: term => cls = - fun - | Invalid(_) => Invalid - | EmptyHole => EmptyHole - | MultiHole(_) => MultiHole - | Int => Int - | Float => Float - | Bool => Bool - | String => String - | List(_) => List - | Arrow(_) => Arrow - | Var(_) => Var - | Constructor(_) => Constructor - | Tuple(_) => Tuple - | Parens(_) => Parens - | Ap(_) => Ap - | Sum(_) => Sum; - -let show_cls: cls => string = - fun - | Invalid => "Invalid type" - | MultiHole => "Broken type" - | EmptyHole => "Empty type hole" - | Int - | Float - | String - | Bool => "Base type" - | Var => "Type variable" - | Constructor => "Sum constructor" - | List => "List type" - | Arrow => "Function type" - | Tuple => "Product type" - | Sum => "Sum type" - | Parens => "Parenthesized type" - | Ap => "Constructor application"; - -let rec is_arrow = (typ: t) => { - switch (typ.term) { - | Parens(typ) => is_arrow(typ) - | Arrow(_) => true - | Invalid(_) - | EmptyHole - | MultiHole(_) - | Int - | Float - | Bool - | String - | List(_) - | Tuple(_) - | Var(_) - | Constructor(_) - | Ap(_) - | Sum(_) => false - }; -}; - -/* Converts a syntactic type into a semantic type */ -let rec to_typ: (Ctx.t, t) => Typ.t = - (ctx, utyp) => - switch (utyp.term) { - | Invalid(_) - | MultiHole(_) => Unknown(Internal) - | EmptyHole => Unknown(TypeHole) - | Bool => Bool - | Int => Int - | Float => Float - | String => String - | Var(name) => - switch (Ctx.lookup_tvar(ctx, name)) { - | Some(_) => Var(name) - | None => Unknown(Free(name)) - } - | Arrow(u1, u2) => Arrow(to_typ(ctx, u1), to_typ(ctx, u2)) - | Tuple(us) => Prod(List.map(to_typ(ctx), us)) - | Sum(uts) => Sum(to_ctr_map(ctx, uts)) - | List(u) => List(to_typ(ctx, u)) - | Parens(u) => to_typ(ctx, u) - /* The below cases should occur only inside sums */ - | Constructor(_) - | Ap(_) => Unknown(Internal) - } -and to_variant: - (Ctx.t, variant) => option(ConstructorMap.binding(option(Typ.t))) = - ctx => - fun - | Variant(ctr, _, u) => Some((ctr, Option.map(to_typ(ctx), u))) - | BadEntry(_) => None -and to_ctr_map = (ctx: Ctx.t, uts: list(variant)): Typ.sum_map => { - List.fold_left( - (acc, ut) => - List.find_opt(((ctr, _)) => ctr == fst(ut), acc) == None - ? acc @ [ut] : acc, - [], - List.filter_map(to_variant(ctx), uts), - ); -}; +include Term.TypTerm; diff --git a/src/haz3lcore/statics/Term.re b/src/haz3lcore/statics/Term.re new file mode 100644 index 0000000000..b8697b7025 --- /dev/null +++ b/src/haz3lcore/statics/Term.re @@ -0,0 +1,688 @@ +module TypTerm = { + include TermBase.TypTerm; + + [@deriving (show({with_path: false}), sexp, yojson)] + type cls = + | Invalid + | EmptyHole + | MultiHole + | Int + | Float + | Bool + | String + | Arrow + | Tuple + | Sum + | List + | Var + | Constructor + | Parens + | Ap; + + include TermBase.TypTerm; + + let rep_id = ({ids, _}: t) => { + assert(ids != []); + List.hd(ids); + }; + + let hole = (tms: list(TermBase.Any.t)) => + switch (tms) { + | [] => EmptyHole + | [_, ..._] => MultiHole(tms) + }; + + let cls_of_term: term => cls = + fun + | Invalid(_) => Invalid + | EmptyHole => EmptyHole + | MultiHole(_) => MultiHole + | Int => Int + | Float => Float + | Bool => Bool + | String => String + | List(_) => List + | Arrow(_) => Arrow + | Var(_) => Var + | Constructor(_) => Constructor + | Tuple(_) => Tuple + | Parens(_) => Parens + | Ap(_) => Ap + | Sum(_) => Sum; + + let show_cls: cls => string = + fun + | Invalid => "Invalid type" + | MultiHole => "Broken type" + | EmptyHole => "Empty type hole" + | Int + | Float + | String + | Bool => "Base type" + | Var => "Type variable" + | Constructor => "Sum constructor" + | List => "List type" + | Arrow => "Function type" + | Tuple => "Product type" + | Sum => "Sum type" + | Parens => "Parenthesized type" + | Ap => "Constructor application"; + + let rec is_arrow = (typ: t) => { + switch (typ.term) { + | Parens(typ) => is_arrow(typ) + | Arrow(_) => true + | Invalid(_) + | EmptyHole + | MultiHole(_) + | Int + | Float + | Bool + | String + | List(_) + | Tuple(_) + | Var(_) + | Constructor(_) + | Ap(_) + | Sum(_) => false + }; + }; + + /* Converts a syntactic type into a semantic type */ + let rec to_typ: (Ctx.t, t) => Typ.t = + (ctx, utyp) => + switch (utyp.term) { + | Invalid(_) + | MultiHole(_) => Unknown(Internal) + | EmptyHole => Unknown(TypeHole) + | Bool => Bool + | Int => Int + | Float => Float + | String => String + | Var(name) => + switch (Ctx.lookup_tvar(ctx, name)) { + | Some(_) => Var(name) + | None => Unknown(Free(name)) + } + | Arrow(u1, u2) => Arrow(to_typ(ctx, u1), to_typ(ctx, u2)) + | Tuple(us) => Prod(List.map(to_typ(ctx), us)) + | Sum(uts) => Sum(to_ctr_map(ctx, uts)) + | List(u) => List(to_typ(ctx, u)) + | Parens(u) => to_typ(ctx, u) + /* The below cases should occur only inside sums */ + | Constructor(_) + | Ap(_) => Unknown(Internal) + } + and to_variant: + (Ctx.t, variant) => option(ConstructorMap.binding(option(Typ.t))) = + ctx => + fun + | Variant(ctr, _, u) => Some((ctr, Option.map(to_typ(ctx), u))) + | BadEntry(_) => None + and to_ctr_map = (ctx: Ctx.t, uts: list(variant)): Typ.sum_map => { + List.fold_left( + (acc, ut) => + List.find_opt(((ctr, _)) => ctr == fst(ut), acc) == None + ? acc @ [ut] : acc, + [], + List.filter_map(to_variant(ctx), uts), + ); + }; +}; + +module TPat = { + [@deriving (show({with_path: false}), sexp, yojson)] + type cls = + | Invalid + | EmptyHole + | MultiHole + | Var; + + include TermBase.TPat; + + let rep_id = ({ids, _}) => { + assert(ids != []); + List.hd(ids); + }; + + let hole = (tms: list(TermBase.Any.t)) => + switch (tms) { + | [] => EmptyHole + | [_, ..._] => MultiHole(tms) + }; + + let cls_of_term: term => cls = + fun + | Invalid(_) => Invalid + | EmptyHole => EmptyHole + | MultiHole(_) => MultiHole + | Var(_) => Var; + + let show_cls: cls => string = + fun + | Invalid => "Invalid type alias" + | MultiHole => "Broken type alias" + | EmptyHole => "Empty type alias hole" + | Var => "Type alias"; +}; + +module Pat = { + [@deriving (show({with_path: false}), sexp, yojson)] + type cls = + | Invalid + | EmptyHole + | MultiHole + | Wild + | Int + | Float + | Bool + | String + | ListLit + | Constructor + | Cons + | Var + | Tuple + | Parens + | Ap + | TypeAnn; + + include TermBase.Pat; + + let rep_id = ({ids, _}: t) => { + assert(ids != []); + List.hd(ids); + }; + + let term_of = ({term, _}) => term; + // All children of term must have expression-unique ids. + + let unwrap = ({ids, term}) => (term, term => {ids, term}); + + let fresh = term => { + {ids: [Id.mk()], term}; + }; + + let hole = (tms: list(TermBase.Any.t)) => + switch (tms) { + | [] => EmptyHole + | [_, ..._] => MultiHole(tms) + }; + + let cls_of_term: term => cls = + fun + | Invalid(_) => Invalid + | EmptyHole => EmptyHole + | MultiHole(_) => MultiHole + | Wild => Wild + | Int(_) => Int + | Float(_) => Float + | Bool(_) => Bool + | String(_) => String + | ListLit(_) => ListLit + | Constructor(_) => Constructor + | Cons(_) => Cons + | Var(_) => Var + | Tuple(_) => Tuple + | Parens(_) => Parens + | Ap(_) => Ap + | TypeAnn(_) => TypeAnn; + + let show_cls: cls => string = + fun + | Invalid => "Invalid pattern" + | MultiHole => "Broken pattern" + | EmptyHole => "Empty pattern hole" + | Wild => "Wildcard" + | Int => "Integer literal" + | Float => "Float literal" + | Bool => "Boolean literal" + | String => "String literal" + | ListLit => "List literal" + | Constructor => "Constructor" + | Cons => "Cons" + | Var => "Variable binding" + | Tuple => "Tuple" + | Parens => "Parenthesized pattern" + | Ap => "Constructor application" + | TypeAnn => "Annotation"; + + let rec is_var = (pat: t) => { + switch (pat.term) { + | Parens(pat) => is_var(pat) + | Var(_) => true + | TypeAnn(_) + | Invalid(_) + | EmptyHole + | MultiHole(_) + | Wild + | Int(_) + | Float(_) + | Bool(_) + | String(_) + | ListLit(_) + | Cons(_, _) + | Tuple(_) + | Constructor(_) + | Ap(_) => false + }; + }; + + let rec is_fun_var = (pat: t) => { + switch (pat.term) { + | Parens(pat) => is_fun_var(pat) + | TypeAnn(pat, typ) => is_var(pat) && TypTerm.is_arrow(typ) + | Invalid(_) + | EmptyHole + | MultiHole(_) + | Wild + | Int(_) + | Float(_) + | Bool(_) + | String(_) + | ListLit(_) + | Cons(_, _) + | Var(_) + | Tuple(_) + | Constructor(_) + | Ap(_) => false + }; + }; + + let rec is_tuple_of_arrows = (pat: t) => + is_fun_var(pat) + || ( + switch (pat.term) { + | Parens(pat) => is_tuple_of_arrows(pat) + | Tuple(pats) => pats |> List.for_all(is_fun_var) + | Invalid(_) + | EmptyHole + | MultiHole(_) + | Wild + | Int(_) + | Float(_) + | Bool(_) + | String(_) + | ListLit(_) + | Cons(_, _) + | Var(_) + | TypeAnn(_) + | Constructor(_) + | Ap(_) => false + } + ); + + let rec get_var = (pat: t) => { + switch (pat.term) { + | Parens(pat) => get_var(pat) + | Var(x) => Some(x) + | TypeAnn(x, _) => get_var(x) + | Invalid(_) + | EmptyHole + | MultiHole(_) + | Wild + | Int(_) + | Float(_) + | Bool(_) + | String(_) + | ListLit(_) + | Cons(_, _) + | Tuple(_) + | Constructor(_) + | Ap(_) => None + }; + }; + + let rec get_fun_var = (pat: t) => { + switch (pat.term) { + | Parens(pat) => get_fun_var(pat) + | TypeAnn(pat, typ) => + if (TypTerm.is_arrow(typ)) { + get_var(pat) |> Option.map(var => var); + } else { + None; + } + | Invalid(_) + | EmptyHole + | MultiHole(_) + | Wild + | Int(_) + | Float(_) + | Bool(_) + | String(_) + | ListLit(_) + | Cons(_, _) + | Var(_) + | Tuple(_) + | Constructor(_) + | Ap(_) => None + }; + }; + + let rec get_recursive_bindings = (pat: t) => { + switch (get_fun_var(pat)) { + | Some(x) => Some([x]) + | None => + switch (pat.term) { + | Parens(pat) => get_recursive_bindings(pat) + | Tuple(pats) => + let fun_vars = pats |> List.map(get_fun_var); + if (List.exists(Option.is_none, fun_vars)) { + None; + } else { + Some(List.map(Option.get, fun_vars)); + }; + | Invalid(_) + | EmptyHole + | MultiHole(_) + | Wild + | Int(_) + | Float(_) + | Bool(_) + | String(_) + | ListLit(_) + | Cons(_, _) + | Var(_) + | TypeAnn(_) + | Constructor(_) + | Ap(_) => None + } + }; + }; + + let ctr_name = (p: t): option(Constructor.t) => + switch (p.term) { + | Constructor(name) => Some(name) + | _ => None + }; +}; + +module Exp = { + include TermBase.Exp; + + [@deriving (show({with_path: false}), sexp, yojson)] + type cls = + | Invalid + | EmptyHole + | MultiHole + | StaticErrorHole + | DynamicErrorHole + | FailedCast + | Bool + | Int + | Float + | String + | ListLit + | Constructor + | Fun + | Tuple + | Var + | MetaVar + | Let + | FixF + | TyAlias + | Ap + | Pipeline + | If + | Seq + | Test + | Filter + | Closure + | Parens + | Cons + | UnOp(Operators.op_un) + | BinOp(Operators.op_bin) + | BuiltinFun + | Match + | Cast + | ListConcat; + + let hole = (tms: list(TermBase.Any.t)): term => + switch (tms) { + | [] => EmptyHole + | [_, ..._] => MultiHole(tms) + }; + + let rep_id = ({ids, _}) => { + assert(ids != []); + List.hd(ids); + }; + + let fresh = term => { + {ids: [Id.mk()], copied: false, term}; + }; + + let unwrap = ({ids, term, copied}) => ( + term, + term => {ids, term, copied}, + ); + + let cls_of_term: term => cls = + fun + | Invalid(_) => Invalid + | EmptyHole => EmptyHole + | MultiHole(_) => MultiHole + | StaticErrorHole(_) => StaticErrorHole + | DynamicErrorHole(_) => DynamicErrorHole + | FailedCast(_) => FailedCast + | Bool(_) => Bool + | Int(_) => Int + | Float(_) => Float + | String(_) => String + | ListLit(_) => ListLit + | Constructor(_) => Constructor + | Fun(_) => Fun + | Tuple(_) => Tuple + | Var(_) => Var + | Let(_) => Let + | FixF(_) => FixF + | TyAlias(_) => TyAlias + | Ap(_) => Ap + | If(_) => If + | Seq(_) => Seq + | Test(_) => Test + | Filter(_) => Filter + | Closure(_) => Closure + | Parens(_) => Parens + | Cons(_) => Cons + | ListConcat(_) => ListConcat + | UnOp(op, _) => UnOp(op) + | BinOp(op, _, _) => BinOp(op) + | BuiltinFun(_) => BuiltinFun + | Match(_) => Match + | Cast(_) => Cast; + + let show_cls: cls => string = + fun + | Invalid => "Invalid expression" + | MultiHole => "Broken expression" + | EmptyHole => "Empty expression hole" + | StaticErrorHole => "Static error hole" + | DynamicErrorHole => "Dynamic error hole" + | FailedCast => "Failed cast" + | Bool => "Boolean literal" + | Int => "Integer literal" + | Float => "Float literal" + | String => "String literal" + | ListLit => "List literal" + | Constructor => "Constructor" + | Fun => "Function literal" + | Tuple => "Tuple literal" + | Var => "Variable reference" + | MetaVar => "Meta variable reference" + | Let => "Let expression" + | FixF => "Fixpoint operator" + | TyAlias => "Type Alias definition" + | Ap => "Application" + | Pipeline => "Pipeline expression" + | If => "If expression" + | Seq => "Sequence expression" + | Test => "Test" + | Filter => "Filter" + | Closure => "Closure" + | Parens => "Parenthesized expression" + | Cons => "Cons" + | ListConcat => "List Concatenation" + | BinOp(op) => Operators.show_binop(op) + | UnOp(op) => Operators.show_unop(op) + | BuiltinFun => "Built-in Function" + | Match => "Case expression" + | Cast => "Cast expression"; + + let rec is_fun = (e: t) => { + switch (e.term) { + | Parens(e) => is_fun(e) + | Cast(e, _, _) => is_fun(e) + | Fun(_) + | BuiltinFun(_) => true + | Invalid(_) + | EmptyHole + | MultiHole(_) + | StaticErrorHole(_) + | DynamicErrorHole(_) + | FailedCast(_) + | Bool(_) + | Int(_) + | Float(_) + | String(_) + | ListLit(_) + | Tuple(_) + | Var(_) + | Let(_) + | FixF(_) + | TyAlias(_) + | Ap(_) + | If(_) + | Seq(_) + | Test(_) + | Filter(_) + | Cons(_) + | ListConcat(_) + | Closure(_) + | UnOp(_) + | BinOp(_) + | Match(_) + | Constructor(_) => false + }; + }; + + let rec is_tuple_of_functions = (e: t) => + is_fun(e) + || ( + switch (e.term) { + | Cast(e, _, _) + | Parens(e) => is_tuple_of_functions(e) + | Tuple(es) => es |> List.for_all(is_fun) + | Invalid(_) + | EmptyHole + | MultiHole(_) + | StaticErrorHole(_) + | DynamicErrorHole(_) + | FailedCast(_) + | Bool(_) + | Int(_) + | Float(_) + | String(_) + | ListLit(_) + | Fun(_) + | Closure(_) + | BuiltinFun(_) + | Var(_) + | Let(_) + | FixF(_) + | TyAlias(_) + | Ap(_) + | If(_) + | Seq(_) + | Test(_) + | Filter(_) + | Cons(_) + | ListConcat(_) + | UnOp(_) + | BinOp(_) + | Match(_) + | Constructor(_) => false + } + ); + + let ctr_name = (e: t): option(Constructor.t) => + switch (e.term) { + | Constructor(name) => Some(name) + | _ => None + }; +}; + +module Rul = { + include TermBase.Rul; + + [@deriving (show({with_path: false}), sexp, yojson)] + type cls = + | Rule; + + // example of awkwardness induced by having forms like rules + // that may have a different-sorted child with no delimiters + // (eg scrut with no rules) + let ids = (~any_ids, {ids, term}: t) => + switch (ids) { + | [_, ..._] => ids + | [] => + switch (term) { + | Hole([tm, ..._]) => any_ids(tm) + | Rules(scrut, []) => scrut.ids + | _ => [] + } + }; + + let rep_id = (~any_ids, tm) => + switch (ids(~any_ids, tm)) { + | [] => raise(Invalid_argument("UExp.rep_id")) + | [id, ..._] => id + }; +}; + +module Any = { + include TermBase.Any; + + let is_exp: t => option(TermBase.Exp.t) = + fun + | Exp(e) => Some(e) + | _ => None; + let is_pat: t => option(TermBase.Pat.t) = + fun + | Pat(p) => Some(p) + | _ => None; + let is_typ: t => option(TermBase.TypTerm.t) = + fun + | Typ(t) => Some(t) + | _ => None; + + let rec ids = + fun + | Exp(tm) => tm.ids + | Pat(tm) => tm.ids + | Typ(tm) => tm.ids + | TPat(tm) => tm.ids + | Rul(tm) => Rul.ids(~any_ids=ids, tm) + | Nul () + | Any () => []; + + // Terms may consist of multiple tiles, eg the commas in an n-tuple, + // the rules of a case expression + the surrounding case-end tile, + // the list brackets tile coupled with the elem-separating commas. + // The _representative id_ is the canonical tile id used to identify + // and look up info about a term. + // + // In instances like case expressions and list literals, where a parent + // tile surrounds the other tiles, the representative id is the parent tile's. + // In other instances like n-tuples, where the commas are all siblings, + // the representative id is one of the comma ids, unspecified which one. + // (This would change for n-tuples if we decided parentheses are necessary.) + let rep_id = + fun + | Exp(tm) => Exp.rep_id(tm) + | Pat(tm) => Pat.rep_id(tm) + | Typ(tm) => TypTerm.rep_id(tm) + | TPat(tm) => TPat.rep_id(tm) + | Rul(tm) => Rul.rep_id(~any_ids=ids, tm) + | Nul () + | Any () => raise(Invalid_argument("Term.rep_id")); +}; diff --git a/src/haz3lcore/lang/term/TermBase.re b/src/haz3lcore/statics/TermBase.re similarity index 100% rename from src/haz3lcore/lang/term/TermBase.re rename to src/haz3lcore/statics/TermBase.re From d0d8c10ad5ca0fb21c097b6089975a28a6ec012a Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Fri, 8 Mar 2024 11:22:35 -0500 Subject: [PATCH 053/103] Update comments --- src/haz3lcore/dynamics/DHExp.re | 35 ++------------------------------- 1 file changed, 2 insertions(+), 33 deletions(-) diff --git a/src/haz3lcore/dynamics/DHExp.re b/src/haz3lcore/dynamics/DHExp.re index f1e8f16ef2..9eed696bc3 100644 --- a/src/haz3lcore/dynamics/DHExp.re +++ b/src/haz3lcore/dynamics/DHExp.re @@ -1,39 +1,8 @@ -/* - To discuss: - - 1. putting info inside expressions - - - */ -/* - DHExps that can appear during evaluation, and thus won't have static information. - - - Closure - - Var [for mutual recursion; could probably get rid of if needed...] - - Let [for mutual recursion] - - Tuple([]) - - Cast - - Ap [in the casting rules for functions & in builtins] - - DynamicErrorHole - - FailedCast - - Int - - Bool - - Float - - String - - ListLit - - BuiltinFun - - */ - /* DHExp.re This module is specifically for dynamic expressions. They are stored - using the same data structure as user expressions, but have a few - important invariants. - - - - TODO[Matt]: Explain the invariants. + using the same data structure as user expressions, but dynamic + expressions are specifically paired with a `Satic.Map.t`. */ include Exp; From 46c7caf2d78eb027874547a4135f2132341b7a5a Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Tue, 19 Mar 2024 17:02:18 -0400 Subject: [PATCH 054/103] Add rec to UTyp (by copying from poly-adt-after2) --- src/haz3lcore/dynamics/DHExp.re | 2 +- src/haz3lcore/dynamics/Evaluator.rei | 5 -- src/haz3lcore/dynamics/EvaluatorStep.re | 2 +- src/haz3lcore/lang/Form.re | 1 + src/haz3lcore/statics/MakeTerm.re | 2 + src/haz3lcore/statics/Statics.re | 23 +++++ src/haz3lcore/statics/Term.re | 94 ++++++++++++--------- src/haz3lcore/statics/TermBase.re | 21 +++-- src/haz3lschool/Gradescope.re | 1 - src/haz3lweb/explainthis/Example.re | 1 + src/haz3lweb/explainthis/ExplainThisForm.re | 3 + src/haz3lweb/explainthis/data/RecTyp.re | 28 ++++++ src/haz3lweb/view/ExplainThis.re | 16 ++++ 13 files changed, 143 insertions(+), 56 deletions(-) create mode 100644 src/haz3lweb/explainthis/data/RecTyp.re diff --git a/src/haz3lcore/dynamics/DHExp.re b/src/haz3lcore/dynamics/DHExp.re index 9eed696bc3..eb09f3bcfc 100644 --- a/src/haz3lcore/dynamics/DHExp.re +++ b/src/haz3lcore/dynamics/DHExp.re @@ -2,7 +2,7 @@ This module is specifically for dynamic expressions. They are stored using the same data structure as user expressions, but dynamic - expressions are specifically paired with a `Satic.Map.t`. + expressions are specifically paired with a `Satic.Map.t`. */ include Exp; diff --git a/src/haz3lcore/dynamics/Evaluator.rei b/src/haz3lcore/dynamics/Evaluator.rei index e505c371af..5e720a0205 100644 --- a/src/haz3lcore/dynamics/Evaluator.rei +++ b/src/haz3lcore/dynamics/Evaluator.rei @@ -1,8 +1,3 @@ -/** - // TODO[Matt]: find where this comment belongs - [evaluate builtins env d] is [(es, r)], where [r] is the result of evaluating [d] and - [es] is the accumulated state. - */ open Transition; let evaluate: diff --git a/src/haz3lcore/dynamics/EvaluatorStep.re b/src/haz3lcore/dynamics/EvaluatorStep.re index 2d7d82669e..2ad3738cca 100644 --- a/src/haz3lcore/dynamics/EvaluatorStep.re +++ b/src/haz3lcore/dynamics/EvaluatorStep.re @@ -53,7 +53,7 @@ module Decompose = { EV_MODE with type result = Result.t and type state = ref(EvaluatorState.t); } = { - type state = ref(EvaluatorState.t); // TODO[Matt]: Make sure this gets passed around correctly + type state = ref(EvaluatorState.t); type requirement('a) = (Result.t, 'a); type requirements('a, 'b) = ('b, Result.t, ClosureEnvironment.t, 'a); type result = Result.t; diff --git a/src/haz3lcore/lang/Form.re b/src/haz3lcore/lang/Form.re index 53b5e5d617..4549b79e39 100644 --- a/src/haz3lcore/lang/Form.re +++ b/src/haz3lcore/lang/Form.re @@ -302,6 +302,7 @@ let forms: list((string, t)) = [ ("test", mk(ds, ["test", "end"], mk_op(Exp, [Exp]))), ("fun_", mk(ds, ["fun", "->"], mk_pre(P.fun_, Exp, [Pat]))), ("fix", mk(ds, ["fix", "->"], mk_pre(P.fun_, Exp, [Pat]))), + ("rec", mk(ds, ["rec", "->"], mk_pre(P.fun_, Typ, [TPat]))), ( "rule", mk(ds, ["|", "=>"], mk_bin'(P.rule_sep, Rul, Exp, [Pat], Exp)), diff --git a/src/haz3lcore/statics/MakeTerm.re b/src/haz3lcore/statics/MakeTerm.re index b179752a45..21ad618a99 100644 --- a/src/haz3lcore/statics/MakeTerm.re +++ b/src/haz3lcore/statics/MakeTerm.re @@ -368,6 +368,8 @@ and typ_term: unsorted => (UTyp.term, list(Id.t)) = { | ([(_, (["(", ")"], [Typ(typ)]))], []) => ret(Ap(t, typ)) | _ => ret(hole(tm)) } + | Pre(([(_id, (["rec", "->"], [TPat(tpat)]))], []), Typ(t)) => + ret(Rec(tpat, t)) | Pre(tiles, Typ({term: Sum(t0), ids})) as tm => /* Case for leading prefix + preceeding a sum */ switch (tiles) { diff --git a/src/haz3lcore/statics/Statics.re b/src/haz3lcore/statics/Statics.re index a0bc6f7651..ea6662edb9 100644 --- a/src/haz3lcore/statics/Statics.re +++ b/src/haz3lcore/statics/Statics.re @@ -609,6 +609,29 @@ and utyp_to_info_map = variants, ); add(m); + | Rec({term: Var(name), _} as utpat, tbody) => + let body_ctx = + Ctx.extend_tvar( + ctx, + {name, id: Term.TPat.rep_id(utpat), kind: Abstract}, + ); + let m = + utyp_to_info_map( + tbody, + ~ctx=body_ctx, + ~ancestors, + ~expects=TypeExpected, + m, + ) + |> snd; + let m = utpat_to_info_map(~ctx, ~ancestors, utpat, m) |> snd; + add(m); // TODO: check with andrew + | Rec(utpat, tbody) => + let m = + utyp_to_info_map(tbody, ~ctx, ~ancestors, ~expects=TypeExpected, m) + |> snd; + let m = utpat_to_info_map(~ctx, ~ancestors, utpat, m) |> snd; + add(m); // TODO: check with andrew }; } and utpat_to_info_map = diff --git a/src/haz3lcore/statics/Term.re b/src/haz3lcore/statics/Term.re index b8697b7025..9be286ea3e 100644 --- a/src/haz3lcore/statics/Term.re +++ b/src/haz3lcore/statics/Term.re @@ -1,3 +1,39 @@ +module TPat = { + [@deriving (show({with_path: false}), sexp, yojson)] + type cls = + | Invalid + | EmptyHole + | MultiHole + | Var; + + include TermBase.TPat; + + let rep_id = ({ids, _}) => { + assert(ids != []); + List.hd(ids); + }; + + let hole = (tms: list(TermBase.Any.t)) => + switch (tms) { + | [] => EmptyHole + | [_, ..._] => MultiHole(tms) + }; + + let cls_of_term: term => cls = + fun + | Invalid(_) => Invalid + | EmptyHole => EmptyHole + | MultiHole(_) => MultiHole + | Var(_) => Var; + + let show_cls: cls => string = + fun + | Invalid => "Invalid type alias" + | MultiHole => "Broken type alias" + | EmptyHole => "Empty type alias hole" + | Var => "Type alias"; +}; + module TypTerm = { include TermBase.TypTerm; @@ -17,7 +53,8 @@ module TypTerm = { | Var | Constructor | Parens - | Ap; + | Ap + | Rec; include TermBase.TypTerm; @@ -48,7 +85,8 @@ module TypTerm = { | Tuple(_) => Tuple | Parens(_) => Parens | Ap(_) => Ap - | Sum(_) => Sum; + | Sum(_) => Sum + | Rec(_) => Rec; let show_cls: cls => string = fun @@ -66,7 +104,8 @@ module TypTerm = { | Tuple => "Product type" | Sum => "Sum type" | Parens => "Parenthesized type" - | Ap => "Constructor application"; + | Ap => "Constructor application" + | Rec => "Recursive Type"; let rec is_arrow = (typ: t) => { switch (typ.term) { @@ -84,7 +123,8 @@ module TypTerm = { | Var(_) | Constructor(_) | Ap(_) - | Sum(_) => false + | Sum(_) + | Rec(_) => false }; }; @@ -112,6 +152,16 @@ module TypTerm = { /* The below cases should occur only inside sums */ | Constructor(_) | Ap(_) => Unknown(Internal) + | Rec({term: Invalid(_), _}, tbody) + | Rec({term: EmptyHole, _}, tbody) + | Rec({term: MultiHole(_), _}, tbody) => Rec("?", to_typ(ctx, tbody)) + | Rec({term: Var(name), _} as utpat, tbody) => + let ctx = + Ctx.extend_tvar( + ctx, + {name, id: TPat.rep_id(utpat), kind: Abstract}, + ); + Rec(name, to_typ(ctx, tbody)); } and to_variant: (Ctx.t, variant) => option(ConstructorMap.binding(option(Typ.t))) = @@ -130,42 +180,6 @@ module TypTerm = { }; }; -module TPat = { - [@deriving (show({with_path: false}), sexp, yojson)] - type cls = - | Invalid - | EmptyHole - | MultiHole - | Var; - - include TermBase.TPat; - - let rep_id = ({ids, _}) => { - assert(ids != []); - List.hd(ids); - }; - - let hole = (tms: list(TermBase.Any.t)) => - switch (tms) { - | [] => EmptyHole - | [_, ..._] => MultiHole(tms) - }; - - let cls_of_term: term => cls = - fun - | Invalid(_) => Invalid - | EmptyHole => EmptyHole - | MultiHole(_) => MultiHole - | Var(_) => Var; - - let show_cls: cls => string = - fun - | Invalid => "Invalid type alias" - | MultiHole => "Broken type alias" - | EmptyHole => "Empty type alias hole" - | Var => "Type alias"; -}; - module Pat = { [@deriving (show({with_path: false}), sexp, yojson)] type cls = diff --git a/src/haz3lcore/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index 753fa797fd..3296336de6 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -3,7 +3,7 @@ open Sexplib.Std; let continue = x => x; let stop = (_, x) => x; -/* TODO: Explain map_term */ +/* TODO[Matt]: Explain map_term */ module rec Any: { [@deriving (show({with_path: false}), sexp, yojson)] @@ -143,11 +143,11 @@ and Exp: { [@deriving (show({with_path: false}), sexp, yojson)] type term = | Invalid(string) - | EmptyHole + | EmptyHole // Combine the problems into one construct | MultiHole(list(Any.t)) | StaticErrorHole(Id.t, t) | DynamicErrorHole(t, InvalidOperationError.t) - | FailedCast(t, Typ.t, Typ.t) + | FailedCast(t, Typ.t, Typ.t) // TODO: get rid of failedcast | Bool(bool) | Int(int) | Float(float) @@ -163,25 +163,25 @@ and Exp: { | Tuple(list(t)) | Var(Var.t) | Let(Pat.t, t, t) - | FixF(Pat.t, t, [@show.opaque] option(ClosureEnvironment.t)) // TODO[Matt]: CHECK WITH SOMEONE THAT I GOT THE STATIC SEMANTICS RIGHT + | FixF(Pat.t, t, [@show.opaque] option(ClosureEnvironment.t)) | TyAlias(TPat.t, TypTerm.t, t) | Ap(Operators.ap_direction, t, t) // note: function is always first then argument; even in pipe mode | If(t, t, t) | Seq(t, t) | Test(t) - | Filter(StepperFilterKind.t, t) // TODO: Change to reflect Exp + | Filter(StepperFilterKind.t, t) | Closure([@show.opaque] ClosureEnvironment.t, t) | Parens(t) | Cons(t, t) | ListConcat(t, t) | UnOp(Operators.op_un, t) | BinOp(Operators.op_bin, t, t) - | BuiltinFun(string) /// Doesn't currently have a distinguishable syntax... - | Match(t, list((Pat.t, t))) // Why doesn't this use list(Rul.t)? + | BuiltinFun(string) /// Doesn't currently have a distinguishable syntax + | Match(t, list((Pat.t, t))) | Cast(t, Typ.t, Typ.t) and t = { // invariant: nonempty - ids: list(Id.t), // > DHEXP // Multiple ids?? // Add source?? + ids: list(Id.t), copied: bool, term, }; @@ -387,6 +387,7 @@ and TypTerm: { | Parens(t) | Ap(t, t) | Sum(list(variant)) + | Rec(TPat.t, t) and variant = | Variant(Constructor.t, list(Id.t), option(t)) // What are the ids for? | BadEntry(t) @@ -424,6 +425,7 @@ and TypTerm: { | Parens(t) | Ap(t, t) | Sum(list(variant)) + | Rec(TPat.t, t) and variant = | Variant(Constructor.t, list(Id.t), option(t)) | BadEntry(t) @@ -446,6 +448,8 @@ and TypTerm: { TypTerm.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); let any_map_term = Any.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); + let tpat_map_term = + TPat.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); let rec_call = ({term, _} as exp) => { ...exp, term: @@ -474,6 +478,7 @@ and TypTerm: { variants, ), ) + | Rec(tp, t) => Rec(tpat_map_term(tp), typ_map_term(t)) }, }; x |> f_typ(rec_call); diff --git a/src/haz3lschool/Gradescope.re b/src/haz3lschool/Gradescope.re index c3bb2a0001..df49da1e72 100644 --- a/src/haz3lschool/Gradescope.re +++ b/src/haz3lschool/Gradescope.re @@ -69,7 +69,6 @@ module Main = { let model_results = spliced_elabs(settings, exercise) |> ModelResults.init_eval - //TODO[Matt]: Make sure this times out correctly |> ModelResults.run_pending(~settings); let stitched_dynamics = stitch_dynamic(settings, exercise, Some(model_results)); diff --git a/src/haz3lweb/explainthis/Example.re b/src/haz3lweb/explainthis/Example.re index 4a76d4a55d..a6c58eaf5d 100644 --- a/src/haz3lweb/explainthis/Example.re +++ b/src/haz3lweb/explainthis/Example.re @@ -77,6 +77,7 @@ let mk_parens_typ = mk_tile(Form.get("parens_typ")); let mk_list_exp = mk_tile(Form.get("list_lit_exp")); let mk_list_pat = mk_tile(Form.get("list_lit_pat")); let mk_list_typ = mk_tile(Form.get("list_typ")); +let mk_rec = mk_tile(Form.get("rec")); let arrow = () => mk_monotile(Form.get("type-arrow")); let unary_minus = () => mk_monotile(Form.get("unary_minus")); let unary_not = () => mk_monotile(Form.get("not")); diff --git a/src/haz3lweb/explainthis/ExplainThisForm.re b/src/haz3lweb/explainthis/ExplainThisForm.re index 7d68fe73cb..b5e0dbd03b 100644 --- a/src/haz3lweb/explainthis/ExplainThisForm.re +++ b/src/haz3lweb/explainthis/ExplainThisForm.re @@ -72,6 +72,7 @@ type numeric_bin_op_examples = [@deriving (show({with_path: false}), sexp, yojson)] type example_id = + | RecTyp | List(list_examples) | Fun(fun_examples) | Fix1 @@ -191,6 +192,7 @@ type form_id = | StrTyp | VarTyp | ListTyp + | RecTyp | ArrowTyp | Arrow3Typ | TupleTyp @@ -278,6 +280,7 @@ type group_id = | StrTyp | VarTyp | ListTyp + | RecTyp | ArrowTyp | Arrow3Typ | TupleTyp diff --git a/src/haz3lweb/explainthis/data/RecTyp.re b/src/haz3lweb/explainthis/data/RecTyp.re new file mode 100644 index 0000000000..601f081602 --- /dev/null +++ b/src/haz3lweb/explainthis/data/RecTyp.re @@ -0,0 +1,28 @@ +open Haz3lcore; +open Example; +open ExplainThisForm; + +let _tpat = tpat("t_var"); +let _typ_arg = typ("ty_arg"); +let rec_typ_coloring_ids = + (~tpat_id: Id.t, ~tbody_id: Id.t): list((Id.t, Id.t)) => [ + (Piece.id(_tpat), tpat_id), + (Piece.id(_typ_arg), tbody_id), +]; +let peano_ex = { + sub_id: RecTyp, + term: mk_example("type Peano = \n rec P -> Z + S(P) \n in S(S(S(Z)))"), + message: "The type of the Peano numbers and the representation of the number 3.", +}; +let rec_typ: form = { + let explanation = "This recursive type classifies the least fixed point of the polymorphic type over the [*type variable*](%s) of body [*instantiated type*](%s)."; + { + id: RecTyp, + syntactic_form: [mk_rec([[space(), _tpat, space()]]), _typ_arg], + expandable_id: Some((Piece.id(_tpat), [_typ_arg])), + explanation, + examples: [peano_ex], + }; +}; + +let rec_: group = {id: RecTyp, forms: [rec_typ]}; diff --git a/src/haz3lweb/view/ExplainThis.re b/src/haz3lweb/view/ExplainThis.re index ef0b567d31..1cabe3e04b 100644 --- a/src/haz3lweb/view/ExplainThis.re +++ b/src/haz3lweb/view/ExplainThis.re @@ -2050,6 +2050,22 @@ let get_doc = ), ListTyp.list, ); + | Rec(tpat, typ) => + let tpat_id = List.nth(tpat.ids, 0); + let tbody_id = List.nth(typ.ids, 0); + get_message( + ~colorings=RecTyp.rec_typ_coloring_ids(~tpat_id, ~tbody_id), + ~format= + Some( + msg => + Printf.sprintf( + Scanf.format_from_string(msg, "%s%s"), + Id.to_string(tpat_id), + Id.to_string(tbody_id), + ), + ), + RecTyp.rec_, + ); | Arrow(arg, result) => let arg_id = List.nth(arg.ids, 0); let result_id = List.nth(result.ids, 0); From 1cfdd943999e8e06bac2ddde8972cfbf6f29912d Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Tue, 19 Mar 2024 17:19:56 -0400 Subject: [PATCH 055/103] Begin Typ UTyp merge --- src/haz3lcore/statics/Info.re | 8 ++--- src/haz3lcore/statics/MakeTerm.re | 4 +-- src/haz3lcore/statics/Statics.re | 2 +- src/haz3lcore/statics/Term.re | 10 +++--- src/haz3lcore/statics/TermBase.re | 26 +++++++------- src/haz3lcore/statics/TypBase.re | 59 ++++++++++++++++--------------- src/haz3lcore/statics/TypVar.re | 6 ---- src/haz3lweb/view/ExplainThis.re | 2 +- 8 files changed, 57 insertions(+), 60 deletions(-) delete mode 100644 src/haz3lcore/statics/TypVar.re diff --git a/src/haz3lcore/statics/Info.re b/src/haz3lcore/statics/Info.re index 7a176b8daa..e729b50008 100644 --- a/src/haz3lcore/statics/Info.re +++ b/src/haz3lcore/statics/Info.re @@ -137,7 +137,7 @@ type typ_expects = [@deriving (show({with_path: false}), sexp, yojson)] type error_typ = | BadToken(Token.t) /* Invalid token, treated as type hole */ - | FreeTypeVariable(TypVar.t) /* Free type variable */ + | FreeTypeVariable(string) /* Free type variable */ | DuplicateConstructor(Constructor.t) /* Duplicate ctr in same sum */ | WantTypeFoundAp | WantConstructorFoundType(Typ.t) @@ -148,7 +148,7 @@ type error_typ = type ok_typ = | Variant(Constructor.t, Typ.t) | VariantIncomplete(Typ.t) - | TypeAlias(TypVar.t, Typ.t) + | TypeAlias(string, Typ.t) | Type(Typ.t); [@deriving (show({with_path: false}), sexp, yojson)] @@ -164,14 +164,14 @@ type type_var_err = /* Type pattern term errors */ [@deriving (show({with_path: false}), sexp, yojson)] type error_tpat = - | ShadowsType(TypVar.t) + | ShadowsType(string) | NotAVar(type_var_err); /* Type pattern ok statuses for cursor inspector */ [@deriving (show({with_path: false}), sexp, yojson)] type ok_tpat = | Empty - | Var(TypVar.t); + | Var(string); [@deriving (show({with_path: false}), sexp, yojson)] type status_tpat = diff --git a/src/haz3lcore/statics/MakeTerm.re b/src/haz3lcore/statics/MakeTerm.re index 21ad618a99..a7b171d595 100644 --- a/src/haz3lcore/statics/MakeTerm.re +++ b/src/haz3lcore/statics/MakeTerm.re @@ -348,7 +348,7 @@ and typ_term: unsorted => (UTyp.term, list(Id.t)) = { | ([(_id, tile)], []) => ret( switch (tile) { - | ([t], []) when Form.is_empty_tuple(t) => Tuple([]) + | ([t], []) when Form.is_empty_tuple(t) => Prod([]) | (["Bool"], []) => Bool | (["Int"], []) => Int | (["Float"], []) => Float @@ -389,7 +389,7 @@ and typ_term: unsorted => (UTyp.term, list(Id.t)) = { } | Bin(Typ(l), tiles, Typ(r)) as tm => switch (is_tuple_typ(tiles)) { - | Some(between_kids) => ret(Tuple([l] @ between_kids @ [r])) + | Some(between_kids) => ret(Prod([l] @ between_kids @ [r])) | None => switch (tiles) { | ([(_id, (["->"], []))], []) => ret(Arrow(l, r)) diff --git a/src/haz3lcore/statics/Statics.re b/src/haz3lcore/statics/Statics.re index ea6662edb9..69484a84d8 100644 --- a/src/haz3lcore/statics/Statics.re +++ b/src/haz3lcore/statics/Statics.re @@ -586,7 +586,7 @@ and utyp_to_info_map = let m = go(t1, m) |> snd; let m = go(t2, m) |> snd; add(m); - | Tuple(ts) => + | Prod(ts) => let m = map_m(go, ts, m) |> snd; add(m); | Ap(t1, t2) => diff --git a/src/haz3lcore/statics/Term.re b/src/haz3lcore/statics/Term.re index 9be286ea3e..4a20581d10 100644 --- a/src/haz3lcore/statics/Term.re +++ b/src/haz3lcore/statics/Term.re @@ -47,7 +47,7 @@ module TypTerm = { | Bool | String | Arrow - | Tuple + | Prod | Sum | List | Var @@ -82,7 +82,7 @@ module TypTerm = { | Arrow(_) => Arrow | Var(_) => Var | Constructor(_) => Constructor - | Tuple(_) => Tuple + | Prod(_) => Prod | Parens(_) => Parens | Ap(_) => Ap | Sum(_) => Sum @@ -101,7 +101,7 @@ module TypTerm = { | Constructor => "Sum constructor" | List => "List type" | Arrow => "Function type" - | Tuple => "Product type" + | Prod => "Product type" | Sum => "Sum type" | Parens => "Parenthesized type" | Ap => "Constructor application" @@ -119,7 +119,7 @@ module TypTerm = { | Bool | String | List(_) - | Tuple(_) + | Prod(_) | Var(_) | Constructor(_) | Ap(_) @@ -145,7 +145,7 @@ module TypTerm = { | None => Unknown(Free(name)) } | Arrow(u1, u2) => Arrow(to_typ(ctx, u1), to_typ(ctx, u2)) - | Tuple(us) => Prod(List.map(to_typ(ctx), us)) + | Prod(us) => Prod(List.map(to_typ(ctx), us)) | Sum(uts) => Sum(to_ctr_map(ctx, uts)) | List(u) => List(to_typ(ctx, u)) | Parens(u) => to_typ(ctx, u) diff --git a/src/haz3lcore/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index 3296336de6..f53556393d 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -372,21 +372,21 @@ and Pat: { and TypTerm: { [@deriving (show({with_path: false}), sexp, yojson)] type term = - | Invalid(string) - | EmptyHole - | MultiHole(list(Any.t)) + | Invalid(string) // TODO: Switch to unknown + | EmptyHole // TODO: Switch to unknown + | MultiHole(list(Any.t)) // TODO: Switch to unknown | Int | Float | Bool | String - | List(t) | Var(string) - | Constructor(string) + | List(t) + | Constructor(string) // TODO: Add to TypBase (?) or remove(?) | Arrow(t, t) - | Tuple(list(t)) + | Sum(list(variant)) + | Prod(list(t)) | Parens(t) | Ap(t, t) - | Sum(list(variant)) | Rec(TPat.t, t) and variant = | Variant(Constructor.t, list(Id.t), option(t)) // What are the ids for? @@ -417,14 +417,14 @@ and TypTerm: { | Float | Bool | String - | List(t) | Var(string) + | List(t) | Constructor(string) | Arrow(t, t) - | Tuple(list(t)) + | Sum(list(variant)) + | Prod(list(t)) | Parens(t) | Ap(t, t) - | Sum(list(variant)) | Rec(TPat.t, t) and variant = | Variant(Constructor.t, list(Id.t), option(t)) @@ -465,7 +465,7 @@ and TypTerm: { | List(t) => List(typ_map_term(t)) | MultiHole(things) => MultiHole(List.map(any_map_term, things)) | Ap(e1, e2) => Ap(typ_map_term(e1), typ_map_term(e2)) - | Tuple(xs) => Tuple(List.map(typ_map_term, xs)) + | Prod(xs) => Prod(List.map(typ_map_term, xs)) | Parens(e) => Parens(typ_map_term(e)) | Arrow(t1, t2) => Arrow(typ_map_term(t1), typ_map_term(t2)) | Sum(variants) => @@ -490,7 +490,7 @@ and TPat: { | Invalid(string) | EmptyHole | MultiHole(list(Any.t)) - | Var(TypVar.t) + | Var(string) and t = { ids: list(Id.t), term, @@ -513,7 +513,7 @@ and TPat: { | Invalid(string) | EmptyHole | MultiHole(list(Any.t)) - | Var(TypVar.t) + | Var(string) and t = { ids: list(Id.t), term, diff --git a/src/haz3lcore/statics/TypBase.re b/src/haz3lcore/statics/TypBase.re index 15620b1ac9..1a9f0e9cbb 100644 --- a/src/haz3lcore/statics/TypBase.re +++ b/src/haz3lcore/statics/TypBase.re @@ -16,23 +16,26 @@ module rec Typ: { type type_provenance = | SynSwitch | TypeHole - | Free(TypVar.t) + | Free(string) | Internal; /* TYP.T: Hazel types */ [@deriving (show({with_path: false}), sexp, yojson)] type t = - | Unknown(type_provenance) + | Unknown(type_provenance) // Add to TypTerm | Int | Float | Bool | String - | Var(TypVar.t) + | Var(string) | List(t) + // Add Constructor? | Arrow(t, t) | Sum(sum_map) | Prod(list(t)) - | Rec(TypVar.t, t) + // Add Parens + // Add Ap? + | Rec(string, t) and sum_map = ConstructorMap.t(option(t)); [@deriving (show({with_path: false}), sexp, yojson)] @@ -55,7 +58,7 @@ module rec Typ: { let matched_prod: (Ctx.t, int, t) => list(t); let matched_list: (Ctx.t, t) => t; let precedence: t => int; - let subst: (t, TypVar.t, t) => t; + let subst: (t, string, t) => t; let unroll: t => t; let eq: (t, t) => bool; let free_vars: (~bound: list(Var.t)=?, t) => list(Var.t); @@ -73,7 +76,7 @@ module rec Typ: { type type_provenance = | SynSwitch | TypeHole - | Free(TypVar.t) + | Free(string) | Internal; /* TYP.T: Hazel types */ @@ -84,12 +87,12 @@ module rec Typ: { | Float | Bool | String - | Var(TypVar.t) + | Var(string) | List(t) | Arrow(t, t) | Sum(sum_map) | Prod(list(t)) - | Rec(TypVar.t, t) + | Rec(string, t) and sum_map = ConstructorMap.t(option(t)); [@deriving (show({with_path: false}), sexp, yojson)] @@ -111,7 +114,7 @@ module rec Typ: { let join_type_provenance = (p1: type_provenance, p2: type_provenance): type_provenance => switch (p1, p2) { - | (Free(tv1), Free(tv2)) when TypVar.eq(tv1, tv2) => Free(tv1) + | (Free(tv1), Free(tv2)) when tv1 == tv2 => Free(tv1) | (TypeHole, TypeHole | SynSwitch) | (SynSwitch, TypeHole) => TypeHole | (SynSwitch, Internal) @@ -136,7 +139,7 @@ module rec Typ: { | Arrow(_, _) => precedence_Arrow }; - let rec subst = (s: t, x: TypVar.t, ty: t) => { + let rec subst = (s: t, x: string, ty: t) => { switch (ty) { | Int => Int | Float => Float @@ -146,10 +149,10 @@ module rec Typ: { | Arrow(ty1, ty2) => Arrow(subst(s, x, ty1), subst(s, x, ty2)) | Prod(tys) => Prod(List.map(subst(s, x), tys)) | Sum(sm) => Sum(ConstructorMap.map(Option.map(subst(s, x)), sm)) - | Rec(y, ty) when TypVar.eq(x, y) => Rec(y, ty) + | Rec(y, ty) when x == y => Rec(y, ty) | Rec(y, ty) => Rec(y, subst(s, x, ty)) | List(ty) => List(subst(s, x, ty)) - | Var(y) => TypVar.eq(x, y) ? s : Var(y) + | Var(y) => x == y ? s : Var(y) }; }; @@ -435,7 +438,7 @@ and Ctx: { [@deriving (show({with_path: false}), sexp, yojson)] type tvar_entry = { - name: TypVar.t, + name: string, id: Id.t, kind: Kind.t, }; @@ -451,19 +454,19 @@ and Ctx: { let extend: (t, entry) => t; let extend_tvar: (t, tvar_entry) => t; - let extend_alias: (t, TypVar.t, Id.t, Typ.t) => t; - let extend_dummy_tvar: (t, TypVar.t) => t; - let lookup_tvar: (t, TypVar.t) => option(tvar_entry); - let lookup_alias: (t, TypVar.t) => option(Typ.t); + let extend_alias: (t, string, Id.t, Typ.t) => t; + let extend_dummy_tvar: (t, string) => t; + let lookup_tvar: (t, string) => option(tvar_entry); + let lookup_alias: (t, string) => option(Typ.t); let get_id: entry => Id.t; let lookup_var: (t, string) => option(var_entry); let lookup_ctr: (t, string) => option(var_entry); - let is_alias: (t, TypVar.t) => bool; - let add_ctrs: (t, TypVar.t, Id.t, Typ.sum_map) => t; + let is_alias: (t, string) => bool; + let add_ctrs: (t, string, Id.t, Typ.sum_map) => t; let subtract_prefix: (t, t) => option(t); let added_bindings: (t, t) => t; let filter_duplicates: t => t; - let shadows_typ: (t, TypVar.t) => bool; + let shadows_typ: (t, string) => bool; } = { [@deriving (show({with_path: false}), sexp, yojson)] type var_entry = { @@ -474,7 +477,7 @@ and Ctx: { [@deriving (show({with_path: false}), sexp, yojson)] type tvar_entry = { - name: TypVar.t, + name: string, id: Id.t, kind: Kind.t, }; @@ -493,13 +496,13 @@ and Ctx: { let extend_tvar = (ctx: t, tvar_entry: tvar_entry): t => extend(ctx, TVarEntry(tvar_entry)); - let extend_alias = (ctx: t, name: TypVar.t, id: Id.t, ty: Typ.t): t => + let extend_alias = (ctx: t, name: string, id: Id.t, ty: Typ.t): t => extend_tvar(ctx, {name, id, kind: Singleton(ty)}); - let extend_dummy_tvar = (ctx: t, name: TypVar.t) => + let extend_dummy_tvar = (ctx: t, name: string) => extend_tvar(ctx, {kind: Abstract, name, id: Id.invalid}); - let lookup_tvar = (ctx: t, name: TypVar.t): option(tvar_entry) => + let lookup_tvar = (ctx: t, name: string): option(tvar_entry) => List.find_map( fun | TVarEntry(v) when v.name == name => Some(v) @@ -507,7 +510,7 @@ and Ctx: { ctx, ); - let lookup_alias = (ctx: t, t: TypVar.t): option(Typ.t) => + let lookup_alias = (ctx: t, t: string): option(Typ.t) => switch (lookup_tvar(ctx, t)) { | Some({kind: Singleton(ty), _}) => Some(ty) | Some({kind: Abstract, _}) @@ -536,13 +539,13 @@ and Ctx: { ctx, ); - let is_alias = (ctx: t, name: TypVar.t): bool => + let is_alias = (ctx: t, name: string): bool => switch (lookup_alias(ctx, name)) { | Some(_) => true | None => false }; - let add_ctrs = (ctx: t, name: TypVar.t, id: Id.t, ctrs: Typ.sum_map): t => + let add_ctrs = (ctx: t, name: string, id: Id.t, ctrs: Typ.sum_map): t => List.map( ((ctr, typ)) => ConstructorEntry({ @@ -605,7 +608,7 @@ and Ctx: { ) |> (((ctx, _, _)) => List.rev(ctx)); - let shadows_typ = (ctx: t, name: TypVar.t): bool => + let shadows_typ = (ctx: t, name: string): bool => Form.is_base_typ(name) || lookup_alias(ctx, name) != None; } and Kind: { diff --git a/src/haz3lcore/statics/TypVar.re b/src/haz3lcore/statics/TypVar.re deleted file mode 100644 index 7b4f4d4ef2..0000000000 --- a/src/haz3lcore/statics/TypVar.re +++ /dev/null @@ -1,6 +0,0 @@ -open Sexplib.Std; - -[@deriving (show({with_path: false}), sexp, yojson)] -type t = string; - -let eq = String.equal; diff --git a/src/haz3lweb/view/ExplainThis.re b/src/haz3lweb/view/ExplainThis.re index 1cabe3e04b..6b8612ab62 100644 --- a/src/haz3lweb/view/ExplainThis.re +++ b/src/haz3lweb/view/ExplainThis.re @@ -2112,7 +2112,7 @@ let get_doc = } | _ => basic(ArrowTyp.arrow) }; - | Tuple(elements) => + | Prod(elements) => let basic = group => get_message( ~format= From af061eef90281cb08741399cc260d77c042a0e82 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 21 Mar 2024 13:45:23 -0400 Subject: [PATCH 056/103] Add comments --- src/haz3lcore/statics/TermBase.re | 6 +++--- src/haz3lcore/statics/TypBase.re | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/haz3lcore/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index f53556393d..2e6dc6f5f9 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -372,9 +372,9 @@ and Pat: { and TypTerm: { [@deriving (show({with_path: false}), sexp, yojson)] type term = - | Invalid(string) // TODO: Switch to unknown - | EmptyHole // TODO: Switch to unknown - | MultiHole(list(Any.t)) // TODO: Switch to unknown + | Invalid(string) // TODO[Matt]: Switch to unknown + | EmptyHole // TODO[Matt]: Switch to unknown + | MultiHole(list(Any.t)) // TODO[Matt]: Switch to unknown | Int | Float | Bool diff --git a/src/haz3lcore/statics/TypBase.re b/src/haz3lcore/statics/TypBase.re index 1a9f0e9cbb..d199e97bfe 100644 --- a/src/haz3lcore/statics/TypBase.re +++ b/src/haz3lcore/statics/TypBase.re @@ -29,12 +29,12 @@ module rec Typ: { | String | Var(string) | List(t) - // Add Constructor? + // TODO[Matt]: Add Constructor? | Arrow(t, t) | Sum(sum_map) | Prod(list(t)) - // Add Parens - // Add Ap? + // TODO[Matt]: Add Parens + // TODO[Matt]: Add Ap? | Rec(string, t) and sum_map = ConstructorMap.t(option(t)); From 63c7d9c6fe531ce763cb9c87698d1f6f8900e6df Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Mon, 25 Mar 2024 17:29:51 -0400 Subject: [PATCH 057/103] Remove Constructor from type --- src/haz3lcore/statics/Info.re | 14 ++++++++++---- src/haz3lcore/statics/Statics.re | 5 ++--- src/haz3lcore/statics/Term.re | 3 --- src/haz3lcore/statics/TermBase.re | 3 --- src/haz3lcore/statics/TypBase.re | 1 - src/haz3lweb/view/ExplainThis.re | 8 +++----- 6 files changed, 15 insertions(+), 19 deletions(-) diff --git a/src/haz3lcore/statics/Info.re b/src/haz3lcore/statics/Info.re index e729b50008..cbf1f3a78e 100644 --- a/src/haz3lcore/statics/Info.re +++ b/src/haz3lcore/statics/Info.re @@ -390,8 +390,7 @@ let status_typ = switch (term.term) { | Invalid(token) => InHole(BadToken(token)) | EmptyHole => NotInHole(Type(ty)) - | Var(name) - | Constructor(name) => + | Var(name) => switch (expects) { | VariantExpected(Unique, sum_ty) | ConstructorExpected(Unique, sum_ty) => @@ -410,7 +409,7 @@ let status_typ = | VariantExpected(status_variant, ty_variant) => let ty_in = UTyp.to_typ(ctx, t2); switch (status_variant, t1.term) { - | (Unique, Var(name) | Constructor(name)) => + | (Unique, Var(name)) => NotInHole(Variant(name, Arrow(ty_in, ty_variant))) | _ => NotInHole(VariantIncomplete(Arrow(ty_in, ty_variant))) }; @@ -507,7 +506,8 @@ let derived_typ = (~utyp: UTyp.t, ~ctx, ~ancestors, ~expects): typ => { let cls: Cls.t = /* Hack to improve CI display */ switch (expects, UTyp.cls_of_term(utyp.term)) { - | (VariantExpected(_), Var) => Cls.Typ(Constructor) + | (VariantExpected(_) | ConstructorExpected(_), Var) => + Cls.Typ(Constructor) | (_, cls) => Cls.Typ(cls) }; let ty = UTyp.to_typ(ctx, utyp); @@ -539,3 +539,9 @@ let get_binding_site = (info: t): option(Id.t) => { | _ => None }; }; + +let typ_is_constructor_expected = t => + switch (t) { + | {expects: ConstructorExpected(_) | VariantExpected(_), _} => true + | _ => false + }; diff --git a/src/haz3lcore/statics/Statics.re b/src/haz3lcore/statics/Statics.re index 69484a84d8..ea94ac22e4 100644 --- a/src/haz3lcore/statics/Statics.re +++ b/src/haz3lcore/statics/Statics.re @@ -576,8 +576,7 @@ and utyp_to_info_map = | Float | Bool | String => add(m) - | Var(_) - | Constructor(_) => + | Var(_) => /* Names are resolved in Info.status_typ */ add(m) | List(t) @@ -665,7 +664,7 @@ and variant_to_info_map = List.mem(ctr, ctrs) ? Duplicate : Unique, ty_sum, ), - {term: Constructor(ctr), ids}, + {term: Var(ctr), ids}, m, ) |> snd; diff --git a/src/haz3lcore/statics/Term.re b/src/haz3lcore/statics/Term.re index 4a20581d10..c07c3fc7e1 100644 --- a/src/haz3lcore/statics/Term.re +++ b/src/haz3lcore/statics/Term.re @@ -81,7 +81,6 @@ module TypTerm = { | List(_) => List | Arrow(_) => Arrow | Var(_) => Var - | Constructor(_) => Constructor | Prod(_) => Prod | Parens(_) => Parens | Ap(_) => Ap @@ -121,7 +120,6 @@ module TypTerm = { | List(_) | Prod(_) | Var(_) - | Constructor(_) | Ap(_) | Sum(_) | Rec(_) => false @@ -150,7 +148,6 @@ module TypTerm = { | List(u) => List(to_typ(ctx, u)) | Parens(u) => to_typ(ctx, u) /* The below cases should occur only inside sums */ - | Constructor(_) | Ap(_) => Unknown(Internal) | Rec({term: Invalid(_), _}, tbody) | Rec({term: EmptyHole, _}, tbody) diff --git a/src/haz3lcore/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index 2e6dc6f5f9..c52a482210 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -381,7 +381,6 @@ and TypTerm: { | String | Var(string) | List(t) - | Constructor(string) // TODO: Add to TypBase (?) or remove(?) | Arrow(t, t) | Sum(list(variant)) | Prod(list(t)) @@ -419,7 +418,6 @@ and TypTerm: { | String | Var(string) | List(t) - | Constructor(string) | Arrow(t, t) | Sum(list(variant)) | Prod(list(t)) @@ -459,7 +457,6 @@ and TypTerm: { | Bool | Int | Float - | Constructor(_) | String | Var(_) => term | List(t) => List(typ_map_term(t)) diff --git a/src/haz3lcore/statics/TypBase.re b/src/haz3lcore/statics/TypBase.re index d199e97bfe..6f7591bb78 100644 --- a/src/haz3lcore/statics/TypBase.re +++ b/src/haz3lcore/statics/TypBase.re @@ -29,7 +29,6 @@ module rec Typ: { | String | Var(string) | List(t) - // TODO[Matt]: Add Constructor? | Arrow(t, t) | Sum(sum_map) | Prod(list(t)) diff --git a/src/haz3lweb/view/ExplainThis.re b/src/haz3lweb/view/ExplainThis.re index 6b8612ab62..9318146de9 100644 --- a/src/haz3lweb/view/ExplainThis.re +++ b/src/haz3lweb/view/ExplainThis.re @@ -2028,7 +2028,7 @@ let get_doc = // Shouldn't be hit? default } - | Some(InfoTyp({term, cls, _})) => + | Some(InfoTyp({term, _} as typ_info)) => switch (bypass_parens_typ(term).term) { | EmptyHole => get_message(HoleTyp.empty_hole) | MultiHole(_) => get_message(HoleTyp.multi_hole) @@ -2185,9 +2185,7 @@ let get_doc = } | _ => basic(TupleTyp.tuple) }; - | Constructor(c) => - get_message(SumTyp.sum_typ_nullary_constructor_defs(c)) - | Var(c) when cls == Typ(Constructor) => + | Var(c) when Info.typ_is_constructor_expected(typ_info) => get_message(SumTyp.sum_typ_nullary_constructor_defs(c)) | Var(v) => get_message( @@ -2198,7 +2196,7 @@ let get_doc = TerminalTyp.var(v), ) | Sum(_) => get_message(SumTyp.labelled_sum_typs) - | Ap({term: Constructor(c), _}, _) => + | Ap({term: Var(c), _}, _) => get_message(SumTyp.sum_typ_unary_constructor_defs(c)) | Invalid(_) => simple("Not a type or type operator") | Ap(_) From ab743029d8809b0b64601111310be0e973009f5e Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Mon, 25 Mar 2024 17:46:31 -0400 Subject: [PATCH 058/103] Add parens to Typ --- src/haz3lcore/dynamics/Transition.re | 1 + src/haz3lcore/statics/TypBase.re | 11 ++++++++++- src/haz3lweb/view/Type.re | 1 + src/haz3lweb/view/dhcode/layout/HTypDoc.re | 1 + 4 files changed, 13 insertions(+), 1 deletion(-) diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index a90d00f3ed..ac3d37794e 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -110,6 +110,7 @@ module CastHelpers = { | Rec(_) | Arrow(Unknown(_), Unknown(_)) | List(Unknown(_)) => Ground + | Parens(ty) => ground_cases_of(ty) | Prod(tys) => if (List.for_all( fun diff --git a/src/haz3lcore/statics/TypBase.re b/src/haz3lcore/statics/TypBase.re index 6f7591bb78..a3b3ec6797 100644 --- a/src/haz3lcore/statics/TypBase.re +++ b/src/haz3lcore/statics/TypBase.re @@ -32,7 +32,7 @@ module rec Typ: { | Arrow(t, t) | Sum(sum_map) | Prod(list(t)) - // TODO[Matt]: Add Parens + | Parens(t) // TODO[Matt]: Add Ap? | Rec(string, t) and sum_map = ConstructorMap.t(option(t)); @@ -91,6 +91,7 @@ module rec Typ: { | Arrow(t, t) | Sum(sum_map) | Prod(list(t)) + | Parens(t) | Rec(string, t) and sum_map = ConstructorMap.t(option(t)); @@ -136,6 +137,7 @@ module rec Typ: { | List(_) => precedence_Const | Prod(_) => precedence_Prod | Arrow(_, _) => precedence_Arrow + | Parens(_) => precedence_Const }; let rec subst = (s: t, x: string, ty: t) => { @@ -152,6 +154,7 @@ module rec Typ: { | Rec(y, ty) => Rec(y, subst(s, x, ty)) | List(ty) => List(subst(s, x, ty)) | Var(y) => x == y ? s : Var(y) + | Parens(ty) => Parens(subst(s, x, ty)) }; }; @@ -165,6 +168,8 @@ module rec Typ: { but this will change when polymorphic types are implemented */ let rec eq = (t1: t, t2: t): bool => { switch (t1, t2) { + | (Parens(t1), t2) => eq(t1, t2) + | (t1, Parens(t2)) => eq(t1, t2) | (Rec(x1, t1), Rec(x2, t2)) => eq(t1, subst(Var(x1), x2, t2)) | (Rec(_), _) => false | (Int, Int) => true @@ -199,6 +204,7 @@ module rec Typ: { | Bool | String => [] | Var(v) => List.mem(v, bound) ? [] : [v] + | Parens(ty) | List(ty) => free_vars(~bound, ty) | Arrow(t1, t2) => free_vars(~bound, t1) @ free_vars(~bound, t2) | Sum(sm) => @@ -221,6 +227,8 @@ module rec Typ: { (~resolve=false, ~fix, ctx: Ctx.t, ty1: t, ty2: t): option(t) => { let join' = join(~resolve, ~fix, ctx); switch (ty1, ty2) { + | (ty1, Parens(ty2)) + | (Parens(ty1), ty2) => join'(ty1, ty2) | (_, Unknown(TypeHole | Free(_)) as ty) when fix => /* NOTE(andrew): This is load bearing for ensuring that function literals get appropriate @@ -348,6 +356,7 @@ module rec Typ: { | Float | Bool | String => ty + | Parens(t) => t | List(t) => List(normalize(ctx, t)) | Arrow(t1, t2) => Arrow(normalize(ctx, t1), normalize(ctx, t2)) | Prod(ts) => Prod(List.map(normalize(ctx), ts)) diff --git a/src/haz3lweb/view/Type.re b/src/haz3lweb/view/Type.re index ae88419f0e..6af1da4851 100644 --- a/src/haz3lweb/view/Type.re +++ b/src/haz3lweb/view/Type.re @@ -29,6 +29,7 @@ let rec view_ty = (ty: Haz3lcore.Typ.t): Node.t => ]), [text("?") /*, prov_view(prov)*/], ) + | Parens(ty) => view_ty(ty) | Int => ty_view("Int", "Int") | Float => ty_view("Float", "Float") | String => ty_view("String", "String") diff --git a/src/haz3lweb/view/dhcode/layout/HTypDoc.re b/src/haz3lweb/view/dhcode/layout/HTypDoc.re index 8acbc0455f..08186c27b2 100644 --- a/src/haz3lweb/view/dhcode/layout/HTypDoc.re +++ b/src/haz3lweb/view/dhcode/layout/HTypDoc.re @@ -42,6 +42,7 @@ let rec mk = (~parenthesize=false, ~enforce_inline: bool, ty: Typ.t): t => { ); let (doc, parenthesize) = switch (ty) { + | Parens(ty) => (mk(~parenthesize=true, ~enforce_inline, ty), false) | Unknown(_) => ( annot(HTypAnnot.Delim, annot(HTypAnnot.HoleLabel, text("?"))), parenthesize, From 6a6fa38287f4b7a790da1af8d7e830bef9ba8aa4 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Wed, 27 Mar 2024 14:42:50 -0400 Subject: [PATCH 059/103] Add ids to Typ --- src/haz3lcore/assistant/AssistantCtx.re | 24 ++- src/haz3lcore/assistant/AssistantForms.re | 25 +-- src/haz3lcore/dynamics/Builtins.re | 39 +++- src/haz3lcore/dynamics/DHExp.re | 2 +- src/haz3lcore/dynamics/Elaborator.re | 49 ++--- src/haz3lcore/dynamics/PatternMatch.re | 147 ++++++++++---- src/haz3lcore/dynamics/Transition.re | 34 ++-- src/haz3lcore/statics/CoCtx.re | 6 +- src/haz3lcore/statics/Info.re | 23 ++- src/haz3lcore/statics/Mode.re | 22 ++- src/haz3lcore/statics/Self.re | 8 +- src/haz3lcore/statics/Statics.re | 118 +++++++---- src/haz3lcore/statics/Term.re | 32 +-- src/haz3lcore/statics/TypBase.re | 218 +++++++++++++-------- src/haz3lweb/view/CursorInspector.re | 23 ++- src/haz3lweb/view/Type.re | 17 +- src/haz3lweb/view/dhcode/layout/HTypDoc.re | 6 +- src/test/Test_Elaboration.re | 7 +- 18 files changed, 511 insertions(+), 289 deletions(-) diff --git a/src/haz3lcore/assistant/AssistantCtx.re b/src/haz3lcore/assistant/AssistantCtx.re index 1697229700..1c12a86557 100644 --- a/src/haz3lcore/assistant/AssistantCtx.re +++ b/src/haz3lcore/assistant/AssistantCtx.re @@ -50,7 +50,7 @@ let bound_constructors = let bound_aps = (ty_expect: Typ.t, ctx: Ctx.t): list(Suggestion.t) => List.filter_map( fun - | Ctx.VarEntry({typ: Arrow(_, ty_out) as ty_arr, name, _}) + | Ctx.VarEntry({typ: {term: Arrow(_, ty_out), _} as ty_arr, name, _}) when Typ.is_consistent(ctx, ty_expect, ty_out) && !Typ.is_consistent(ctx, ty_expect, ty_arr) => { @@ -66,7 +66,11 @@ let bound_aps = (ty_expect: Typ.t, ctx: Ctx.t): list(Suggestion.t) => let bound_constructor_aps = (wrap, ty: Typ.t, ctx: Ctx.t): list(Suggestion.t) => List.filter_map( fun - | Ctx.ConstructorEntry({typ: Arrow(_, ty_out) as ty_arr, name, _}) + | Ctx.ConstructorEntry({ + typ: {term: Arrow(_, ty_out), _} as ty_arr, + name, + _, + }) when Typ.is_consistent(ctx, ty, ty_out) && !Typ.is_consistent(ctx, ty, ty_arr) => @@ -141,7 +145,7 @@ let suggest_lookahead_variable = (ci: Info.t): list(Suggestion.t) => { let exp_aps = ty => bound_aps(ty, ctx) @ bound_constructor_aps(x => Exp(Common(x)), ty, ctx); - switch (Mode.ty_of(mode)) { + switch (Mode.ty_of(mode) |> Typ.term_of) { | List(ty) => List.map(restrategize(" )::"), exp_aps(ty)) @ List.map(restrategize("::"), exp_refs(ty)) @@ -152,12 +156,12 @@ let suggest_lookahead_variable = (ci: Info.t): list(Suggestion.t) => { @ List.map(restrategize(commas), exp_refs(ty)); | Bool => /* TODO: Find a UI to make these less confusing */ - exp_refs(Int) - @ exp_refs(Float) - @ exp_refs(String) - @ exp_aps(Int) - @ exp_aps(Float) - @ exp_aps(String) + exp_refs(Int |> Typ.fresh) + @ exp_refs(Float |> Typ.fresh) + @ exp_refs(String |> Typ.fresh) + @ exp_aps(Int |> Typ.fresh) + @ exp_aps(Float |> Typ.fresh) + @ exp_aps(String |> Typ.fresh) | _ => [] }; | InfoPat({mode, co_ctx, _}) => @@ -165,7 +169,7 @@ let suggest_lookahead_variable = (ci: Info.t): list(Suggestion.t) => { free_variables(ty, ctx, co_ctx) @ bound_constructors(x => Pat(Common(x)), ty, ctx); let pat_aps = ty => bound_constructor_aps(x => Pat(Common(x)), ty, ctx); - switch (Mode.ty_of(mode)) { + switch (Mode.ty_of(mode) |> Typ.term_of) { | List(ty) => List.map(restrategize(" )::"), pat_aps(ty)) @ List.map(restrategize("::"), pat_refs(ty)) diff --git a/src/haz3lcore/assistant/AssistantForms.re b/src/haz3lcore/assistant/AssistantForms.re index b9fb8bffa8..01229b0807 100644 --- a/src/haz3lcore/assistant/AssistantForms.re +++ b/src/haz3lcore/assistant/AssistantForms.re @@ -11,32 +11,32 @@ let leading_expander = " " ++ AssistantExpander.c; * running Statics, but for now, new forms e.g. operators must be added * below manually. */ module Typ = { - let unk: Typ.t = Unknown(Internal); + let unk: Typ.t = Unknown(Internal) |> Typ.fresh; let of_const_mono_delim: list((Token.t, Typ.t)) = [ - ("true", Bool), - ("false", Bool), + ("true", Bool |> Typ.fresh), + ("false", Bool |> Typ.fresh), //("[]", List(unk)), / *NOTE: would need to refactor buffer for this to show up */ //("()", Prod([])), /* NOTE: would need to refactor buffer for this to show up */ - ("\"\"", String), /* NOTE: Irrelevent as second quote appears automatically */ + ("\"\"", String |> Typ.fresh), /* NOTE: Irrelevent as second quote appears automatically */ ("_", unk), ]; let of_leading_delim: list((Token.t, Typ.t)) = [ ("case" ++ leading_expander, unk), - ("fun" ++ leading_expander, Arrow(unk, unk)), + ("fun" ++ leading_expander, Arrow(unk, unk) |> Typ.fresh), ("if" ++ leading_expander, unk), ("let" ++ leading_expander, unk), - ("test" ++ leading_expander, Prod([])), + ("test" ++ leading_expander, Prod([]) |> Typ.fresh), ("type" ++ leading_expander, unk), ]; - let of_infix_delim: list((Token.t, Typ.t)) = [ - ("|>", unk), /* */ + let of_infix_delim: list((Token.t, Typ.term)) = [ + ("|>", Unknown(Internal)), /* */ (",", Prod([unk, unk])), /* NOTE: Current approach doesn't work for this, but irrelevant as 1-char */ ("::", List(unk)), ("@", List(unk)), - (";", unk), + (";", Unknown(Internal)), ("&&", Bool), ("\\/", Bool), ("||", Bool), @@ -71,7 +71,7 @@ module Typ = { fun | InfoExp({mode, _}) | InfoPat({mode, _}) => Mode.ty_of(mode) - | _ => Unknown(Internal); + | _ => Unknown(Internal) |> Typ.fresh; let filter_by = ( @@ -193,7 +193,10 @@ let suggest_form = (ty_map, delims_of_sort, ci: Info.t): list(Suggestion.t) => { }; let suggest_operator: Info.t => list(Suggestion.t) = - suggest_form(Typ.of_infix_delim, Delims.infix); + suggest_form( + List.map(((a, b)) => (a, TypBase.Typ.fresh(b)), Typ.of_infix_delim), + Delims.infix, + ); let suggest_operand: Info.t => list(Suggestion.t) = suggest_form(Typ.of_const_mono_delim, Delims.const_mono); diff --git a/src/haz3lcore/dynamics/Builtins.re b/src/haz3lcore/dynamics/Builtins.re index 11c93f4133..78ee208b5b 100644 --- a/src/haz3lcore/dynamics/Builtins.re +++ b/src/haz3lcore/dynamics/Builtins.re @@ -22,12 +22,21 @@ type forms = VarMap.t_(DHExp.t => DHExp.t); type result = Result.t(DHExp.t, EvaluatorError.t); -let const = (name: Var.t, typ: Typ.t, v: DHExp.t, builtins: t): t => - VarMap.extend(builtins, (name, Const(typ, v))); +let const = (name: Var.t, typ: Typ.term, v: DHExp.t, builtins: t): t => + VarMap.extend(builtins, (name, Const(typ |> Typ.fresh, v))); let fn = - (name: Var.t, t1: Typ.t, t2: Typ.t, impl: DHExp.t => DHExp.t, builtins: t) + ( + name: Var.t, + t1: Typ.term, + t2: Typ.term, + impl: DHExp.t => DHExp.t, + builtins: t, + ) : t => - VarMap.extend(builtins, (name, Fn(t1, t2, impl))); + VarMap.extend( + builtins, + (name, Fn(t1 |> Typ.fresh, t2 |> Typ.fresh, impl)), + ); module Pervasives = { module Impls = { @@ -312,19 +321,29 @@ module Pervasives = { |> fn("asin", Float, Float, asin) |> fn("acos", Float, Float, acos) |> fn("atan", Float, Float, atan) - |> fn("mod", Prod([Int, Int]), Int, int_mod("mod")) + |> fn( + "mod", + Prod([Int |> Typ.fresh, Int |> Typ.fresh]), + Int, + int_mod("mod"), + ) |> fn("string_length", String, Int, string_length) - |> fn("string_compare", Prod([String, String]), Int, string_compare) + |> fn( + "string_compare", + Prod([String |> Typ.fresh, String |> Typ.fresh]), + Int, + string_compare, + ) |> fn("string_trim", String, String, string_trim) |> fn( "string_concat", - Prod([String, List(String)]), + Prod([String |> Typ.fresh, List(String |> Typ.fresh) |> Typ.fresh]), String, string_concat, ) |> fn( "string_sub", - Prod([String, Int, Int]), + Prod([String |> Typ.fresh, Int |> Typ.fresh, Int |> Typ.fresh]), String, string_sub("string_sub"), ); @@ -336,13 +355,13 @@ let ctx_init: Ctx.t = { Ctx.TVarEntry({ name: "$Meta", id: Id.invalid, - kind: Kind.Singleton(Sum(meta_cons_map)), + kind: Kind.Singleton(Sum(meta_cons_map) |> Typ.fresh), }); List.map( fun | (name, Const(typ, _)) => Ctx.VarEntry({name, typ, id: Id.invalid}) | (name, Fn(t1, t2, _)) => - Ctx.VarEntry({name, typ: Arrow(t1, t2), id: Id.invalid}), + Ctx.VarEntry({name, typ: Arrow(t1, t2) |> Typ.fresh, id: Id.invalid}), Pervasives.builtins, ) |> Ctx.extend(_, meta) diff --git a/src/haz3lcore/dynamics/DHExp.re b/src/haz3lcore/dynamics/DHExp.re index eb09f3bcfc..7f5dadb028 100644 --- a/src/haz3lcore/dynamics/DHExp.re +++ b/src/haz3lcore/dynamics/DHExp.re @@ -15,7 +15,7 @@ let mk = (ids, term) => { }; let fresh_cast = (d: t, t1: Typ.t, t2: Typ.t): t => - if (Typ.eq(t1, t2) || t2 == Unknown(SynSwitch)) { + if (Typ.eq(t1, t2) || Typ.term_of(t2) == Unknown(SynSwitch)) { d; } else { fresh(Cast(d, t1, t2)); diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index bfedb405d4..5291147699 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -40,13 +40,9 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => switch (mode) { | Syn => d | SynFun => - switch (self_ty) { - | Unknown(prov) => - DHExp.fresh_cast( - d, - Unknown(prov), - Arrow(Unknown(prov), Unknown(prov)), - ) + switch (Typ.term_of(self_ty)) { + | Unknown(_) => + DHExp.fresh_cast(d, self_ty, Arrow(self_ty, self_ty) |> Typ.fresh) | Arrow(_) => d | _ => failwith("Elaborator.wrap: SynFun non-arrow-type") } @@ -57,46 +53,43 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => | ListLit(_) | ListConcat(_) | Cons(_) => - switch (ana_ty) { - | Unknown(prov) => - DHExp.fresh_cast(d, List(Unknown(prov)), Unknown(prov)) + switch (Typ.term_of(ana_ty)) { + | Unknown(_) => DHExp.fresh_cast(d, List(ana_ty) |> Typ.fresh, ana_ty) | _ => d } | Fun(_) => /* See regression tests in Documentation/Dynamics */ let (_, ana_out) = Typ.matched_arrow(ctx, ana_ty); let (self_in, _) = Typ.matched_arrow(ctx, self_ty); - DHExp.fresh_cast(d, Arrow(self_in, ana_out), ana_ty); + DHExp.fresh_cast(d, Arrow(self_in, ana_out) |> Typ.fresh, ana_ty); | Tuple(ds) => - switch (ana_ty) { + switch (Typ.term_of(ana_ty)) { | Unknown(prov) => - let us = List.init(List.length(ds), _ => Typ.Unknown(prov)); - DHExp.fresh_cast(d, Prod(us), Unknown(prov)); + let us = + List.init(List.length(ds), _ => Typ.Unknown(prov) |> Typ.fresh); + DHExp.fresh_cast(d, Prod(us) |> Typ.fresh, ana_ty); | _ => d } | Constructor(_) => - switch (ana_ty, self_ty) { - | (Unknown(prov), Rec(_, Sum(_))) - | (Unknown(prov), Sum(_)) => - DHExp.fresh_cast(d, self_ty, Unknown(prov)) + switch (ana_ty |> Typ.term_of, self_ty |> Typ.term_of) { + | (Unknown(_), Rec(_, {term: Sum(_), _})) + | (Unknown(_), Sum(_)) => DHExp.fresh_cast(d, self_ty, ana_ty) | _ => d } | Ap(_, f, _) => switch (DHExp.term_of(f)) { | Constructor(_) => - switch (ana_ty, self_ty) { - | (Unknown(prov), Rec(_, Sum(_))) - | (Unknown(prov), Sum(_)) => - DHExp.fresh_cast(d, self_ty, Unknown(prov)) + switch (ana_ty |> Typ.term_of, self_ty |> Typ.term_of) { + | (Unknown(_), Rec(_, {term: Sum(_), _})) + | (Unknown(_), Sum(_)) => DHExp.fresh_cast(d, self_ty, ana_ty) | _ => d } | StaticErrorHole(_, g) => switch (DHExp.term_of(g)) { | Constructor(_) => - switch (ana_ty, self_ty) { - | (Unknown(prov), Rec(_, Sum(_))) - | (Unknown(prov), Sum(_)) => - DHExp.fresh_cast(d, self_ty, Unknown(prov)) + switch (ana_ty |> Typ.term_of, self_ty |> Typ.term_of) { + | (Unknown(_), Rec(_, {term: Sum(_), _})) + | (Unknown(_), Sum(_)) => DHExp.fresh_cast(d, self_ty, ana_ty) | _ => d } | _ => DHExp.fresh_cast(d, self_ty, ana_ty) @@ -148,7 +141,7 @@ let wrap = (m, exp: Exp.t): DHExp.t => { let self_ty = switch (Self.typ_of_exp(ctx, self)) { | Some(self_ty) => Typ.normalize(ctx, self_ty) - | None => Unknown(Internal) + | None => Unknown(Internal) |> Typ.fresh }; cast(ctx, mode, self_ty, exp); | InHole( @@ -279,7 +272,7 @@ let uexp_elab = (m: Statics.Map.t, uexp: UExp.t): ElaborationResult.t => let ty = switch (fixed_exp_typ(m, uexp)) { | Some(ty) => ty - | None => Typ.Unknown(Internal) + | None => Typ.Unknown(Internal) |> Typ.fresh }; Elaborates(d, ty, Delta.empty); }; diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index 49d4dbc927..1a2b43dfe7 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -5,7 +5,7 @@ type match_result = | DoesNotMatch | IndetMatch; -let const_unknown: 'a => Typ.t = _ => Unknown(Internal); +let const_unknown: 'a => Typ.t = _ => Unknown(Internal) |> Typ.fresh; let cast_sum_maps = (sm1: Typ.sum_map, sm2: Typ.sum_map) @@ -62,8 +62,10 @@ let rec matches = (dp: Pat.t, d: DHExp.t): match_result => } else { DoesNotMatch; } - | (Bool(_), Cast(d, Bool, Unknown(_))) => matches(dp, d) - | (Bool(_), Cast(d, Unknown(_), Bool)) => matches(dp, d) + | (Bool(_), Cast(d, {term: Bool, _}, {term: Unknown(_), _})) => + matches(dp, d) + | (Bool(_), Cast(d, {term: Unknown(_), _}, {term: Bool, _})) => + matches(dp, d) | (Bool(_), _) => DoesNotMatch | (Int(n1), Int(n2)) => if (n1 == n2) { @@ -71,8 +73,10 @@ let rec matches = (dp: Pat.t, d: DHExp.t): match_result => } else { DoesNotMatch; } - | (Int(_), Cast(d, Int, Unknown(_))) => matches(dp, d) - | (Int(_), Cast(d, Unknown(_), Int)) => matches(dp, d) + | (Int(_), Cast(d, {term: Int, _}, {term: Unknown(_), _})) => + matches(dp, d) + | (Int(_), Cast(d, {term: Unknown(_), _}, {term: Int, _})) => + matches(dp, d) | (Int(_), _) => DoesNotMatch | (Float(n1), Float(n2)) => if (n1 == n2) { @@ -80,8 +84,10 @@ let rec matches = (dp: Pat.t, d: DHExp.t): match_result => } else { DoesNotMatch; } - | (Float(_), Cast(d, Float, Unknown(_))) => matches(dp, d) - | (Float(_), Cast(d, Unknown(_), Float)) => matches(dp, d) + | (Float(_), Cast(d, {term: Float, _}, {term: Unknown(_), _})) => + matches(dp, d) + | (Float(_), Cast(d, {term: Unknown(_), _}, {term: Float, _})) => + matches(dp, d) | (Float(_), _) => DoesNotMatch | (String(s1), String(s2)) => if (s1 == s2) { @@ -89,8 +95,10 @@ let rec matches = (dp: Pat.t, d: DHExp.t): match_result => } else { DoesNotMatch; } - | (String(_), Cast(d, String, Unknown(_))) => matches(dp, d) - | (String(_), Cast(d, Unknown(_), String)) => matches(dp, d) + | (String(_), Cast(d, {term: String, _}, {term: Unknown(_), _})) => + matches(dp, d) + | (String(_), Cast(d, {term: Unknown(_), _}, {term: String, _})) => + matches(dp, d) | (String(_), _) => DoesNotMatch | (Ap(dp1, dp2), Ap(_, d1, d2)) => @@ -111,15 +119,33 @@ let rec matches = (dp: Pat.t, d: DHExp.t): match_result => } | ( Ap({term: Constructor(ctr), _}, dp_opt), - Cast(d, Sum(sm1) | Rec(_, Sum(sm1)), Sum(sm2) | Rec(_, Sum(sm2))), + Cast( + d, + {term: Sum(sm1) | Rec(_, {term: Sum(sm1), _}), _}, + {term: Sum(sm2) | Rec(_, {term: Sum(sm2), _}), _}, + ), ) => switch (cast_sum_maps(sm1, sm2)) { | Some(castmap) => matches_cast_Sum(ctr, Some(dp_opt), d, [castmap]) | None => DoesNotMatch } - | (Ap(_, _), Cast(d, Sum(_) | Rec(_, Sum(_)), Unknown(_))) - | (Ap(_, _), Cast(d, Unknown(_), Sum(_) | Rec(_, Sum(_)))) => + | ( + Ap(_, _), + Cast( + d, + {term: Sum(_) | Rec(_, {term: Sum(_), _}), _}, + {term: Unknown(_), _}, + ), + ) + | ( + Ap(_, _), + Cast( + d, + {term: Unknown(_), _}, + {term: Sum(_) | Rec(_, {term: Sum(_), _}), _}, + ), + ) => matches(dp, d) | (Ap(_, _), _) => DoesNotMatch @@ -127,15 +153,33 @@ let rec matches = (dp: Pat.t, d: DHExp.t): match_result => ctr == ctr' ? Matches(Environment.empty) : DoesNotMatch | ( Constructor(ctr), - Cast(d, Sum(sm1) | Rec(_, Sum(sm1)), Sum(sm2) | Rec(_, Sum(sm2))), + Cast( + d, + {term: Sum(sm1) | Rec(_, {term: Sum(sm1), _}), _}, + {term: Sum(sm2) | Rec(_, {term: Sum(sm2), _}), _}, + ), ) => switch (cast_sum_maps(sm1, sm2)) { | Some(castmap) => matches_cast_Sum(ctr, None, d, [castmap]) | None => DoesNotMatch } - | (Constructor(_), Cast(d, Sum(_) | Rec(_, Sum(_)), Unknown(_))) => + | ( + Constructor(_), + Cast( + d, + {term: Sum(_) | Rec(_, {term: Sum(_), _}), _}, + {term: Unknown(_), _}, + ), + ) => matches(dp, d) - | (Constructor(_), Cast(d, Unknown(_), Sum(_) | Rec(_, Sum(_)))) => + | ( + Constructor(_), + Cast( + d, + {term: Unknown(_), _}, + {term: Sum(_) | Rec(_, {term: Sum(_), _}), _}, + ), + ) => matches(dp, d) | (Constructor(_), _) => DoesNotMatch @@ -160,14 +204,14 @@ let rec matches = (dp: Pat.t, d: DHExp.t): match_result => ds, ); } - | (Tuple(dps), Cast(d, Prod(tys), Prod(tys'))) => + | (Tuple(dps), Cast(d, {term: Prod(tys), _}, {term: Prod(tys'), _})) => assert(List.length(tys) == List.length(tys')); matches_cast_Tuple( dps, d, List.map(p => [p], List.combine(tys, tys')), ); - | (Tuple(dps), Cast(d, Prod(tys), Unknown(_))) => + | (Tuple(dps), Cast(d, {term: Prod(tys), _}, {term: Unknown(_), _})) => matches_cast_Tuple( dps, d, @@ -176,7 +220,7 @@ let rec matches = (dp: Pat.t, d: DHExp.t): match_result => List.combine(tys, List.init(List.length(tys), const_unknown)), ), ) - | (Tuple(dps), Cast(d, Unknown(_), Prod(tys'))) => + | (Tuple(dps), Cast(d, {term: Unknown(_), _}, {term: Prod(tys'), _})) => matches_cast_Tuple( dps, d, @@ -187,12 +231,21 @@ let rec matches = (dp: Pat.t, d: DHExp.t): match_result => ) | (Tuple(_), Cast(_)) => DoesNotMatch | (Tuple(_), _) => DoesNotMatch - | (Cons(_) | ListLit(_), Cast(d, List(ty1), List(ty2))) => + | ( + Cons(_) | ListLit(_), + Cast(d, {term: List(ty1), _}, {term: List(ty2), _}), + ) => matches_cast_Cons(dp, d, [(ty1, ty2)]) - | (Cons(_) | ListLit(_), Cast(d, Unknown(_), List(ty2))) => - matches_cast_Cons(dp, d, [(Unknown(Internal), ty2)]) - | (Cons(_) | ListLit(_), Cast(d, List(ty1), Unknown(_))) => - matches_cast_Cons(dp, d, [(ty1, Unknown(Internal))]) + | ( + Cons(_) | ListLit(_), + Cast(d, {term: Unknown(_), _}, {term: List(ty2), _}), + ) => + matches_cast_Cons(dp, d, [(Unknown(Internal) |> Typ.fresh, ty2)]) + | ( + Cons(_) | ListLit(_), + Cast(d, {term: List(ty1), _}, {term: Unknown(_), _}), + ) => + matches_cast_Cons(dp, d, [(ty1, Unknown(Internal) |> Typ.fresh)]) | (Cons(_, _), Cons(_, _)) | (ListLit(_), Cons(_, _)) | (Cons(_, _), ListLit(_)) @@ -233,13 +286,25 @@ and matches_cast_Sum = } | _ => IndetMatch } - | Cast(d', Sum(sm1) | Rec(_, Sum(sm1)), Sum(sm2) | Rec(_, Sum(sm2))) => + | Cast( + d', + {term: Sum(sm1) | Rec(_, {term: Sum(sm1), _}), _}, + {term: Sum(sm2) | Rec(_, {term: Sum(sm2), _}), _}, + ) => switch (cast_sum_maps(sm1, sm2)) { | Some(castmap) => matches_cast_Sum(ctr, dp, d', [castmap, ...castmaps]) | None => DoesNotMatch } - | Cast(d', Sum(_) | Rec(_, Sum(_)), Unknown(_)) - | Cast(d', Unknown(_), Sum(_) | Rec(_, Sum(_))) => + | Cast( + d', + {term: Sum(_) | Rec(_, {term: Sum(_), _}), _}, + {term: Unknown(_), _}, + ) + | Cast( + d', + {term: Unknown(_), _}, + {term: Sum(_) | Rec(_, {term: Sum(_), _}), _}, + ) => matches_cast_Sum(ctr, dp, d', castmaps) | Invalid(_) | Let(_) @@ -298,7 +363,7 @@ and matches_cast_Tuple = Matches(Environment.empty), ); } - | Cast(d', Prod(tys), Prod(tys')) => + | Cast(d', {term: Prod(tys), _}, {term: Prod(tys'), _}) => if (List.length(dps) != List.length(tys)) { DoesNotMatch; } else { @@ -309,14 +374,14 @@ and matches_cast_Tuple = List.map2(List.cons, List.combine(tys, tys'), elt_casts), ); } - | Cast(d', Prod(tys), Unknown(_)) => + | Cast(d', {term: Prod(tys), _}, {term: Unknown(_), _}) => let tys' = List.init(List.length(tys), const_unknown); matches_cast_Tuple( dps, d', List.map2(List.cons, List.combine(tys, tys'), elt_casts), ); - | Cast(d', Unknown(_), Prod(tys')) => + | Cast(d', {term: Unknown(_), _}, {term: Prod(tys'), _}) => let tys = List.init(List.length(tys'), const_unknown); matches_cast_Tuple( dps, @@ -374,7 +439,7 @@ and matches_cast_Cons = List.map( (c: (Typ.t, Typ.t)) => { let (ty1, ty2) = c; - (Typ.List(ty1), Typ.List(ty2)); + (Typ.List(ty1) |> Typ.fresh, Typ.List(ty2) |> Typ.fresh); }, elt_casts, ); @@ -419,7 +484,7 @@ and matches_cast_Cons = List.map( (c: (Typ.t, Typ.t)) => { let (ty1, ty2) = c; - (Typ.List(ty1), Typ.List(ty2)); + (Typ.List(ty1) |> Typ.fresh, Typ.List(ty2) |> Typ.fresh); }, elt_casts, ); @@ -439,7 +504,7 @@ and matches_cast_Cons = List.map( (c: (Typ.t, Typ.t)) => { let (ty1, ty2) = c; - (Typ.List(ty1), Typ.List(ty2)); + (Typ.List(ty1) |> Typ.fresh, Typ.List(ty2) |> Typ.fresh); }, elt_casts, ); @@ -452,12 +517,20 @@ and matches_cast_Cons = } | _ => failwith("called matches_cast_Cons with non-list pattern") } - | Cast(d', List(ty1), List(ty2)) => + | Cast(d', {term: List(ty1), _}, {term: List(ty2), _}) => matches_cast_Cons(dp, d', [(ty1, ty2), ...elt_casts]) - | Cast(d', List(ty1), Unknown(_)) => - matches_cast_Cons(dp, d', [(ty1, Unknown(Internal)), ...elt_casts]) - | Cast(d', Unknown(_), List(ty2)) => - matches_cast_Cons(dp, d', [(Unknown(Internal), ty2), ...elt_casts]) + | Cast(d', {term: List(ty1), _}, {term: Unknown(_), _}) => + matches_cast_Cons( + dp, + d', + [(ty1, Unknown(Internal) |> Typ.fresh), ...elt_casts], + ) + | Cast(d', {term: Unknown(_), _}, {term: List(ty2), _}) => + matches_cast_Cons( + dp, + d', + [(Unknown(Internal) |> Typ.fresh, ty2), ...elt_casts], + ) | Cast(_, _, _) => DoesNotMatch | Var(_) => DoesNotMatch | Invalid(_) => IndetMatch diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index ac3d37794e..c9dba7aeed 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -80,27 +80,32 @@ module CastHelpers = { | Ground | NotGroundOrHole(Typ.t) /* the argument is the corresponding ground type */; - let const_unknown: 'a => Typ.t = _ => Unknown(Internal); + let const_unknown: 'a => Typ.t = _ => Unknown(Internal) |> Typ.fresh; let grounded_Arrow = - NotGroundOrHole(Arrow(Unknown(Internal), Unknown(Internal))); + NotGroundOrHole( + Arrow(Unknown(Internal) |> Typ.fresh, Unknown(Internal) |> Typ.fresh) + |> Typ.fresh, + ); let grounded_Prod = length => NotGroundOrHole( - Prod(ListUtil.replicate(length, Typ.Unknown(Internal))), + Prod(ListUtil.replicate(length, Typ.Unknown(Internal) |> Typ.fresh)) + |> Typ.fresh, ); let grounded_Sum = (sm: Typ.sum_map): ground_cases => { let sm' = sm |> ConstructorMap.map(Option.map(const_unknown)); - NotGroundOrHole(Sum(sm')); + NotGroundOrHole(Sum(sm') |> Typ.fresh); }; - let grounded_List = NotGroundOrHole(List(Unknown(Internal))); + let grounded_List = + NotGroundOrHole(List(Unknown(Internal) |> Typ.fresh) |> Typ.fresh); let rec ground_cases_of = (ty: Typ.t): ground_cases => { let is_ground_arg: option(Typ.t) => bool = fun | None - | Some(Typ.Unknown(_)) => true + | Some({term: Typ.Unknown(_), _}) => true | Some(ty) => ground_cases_of(ty) == Ground; - switch (ty) { + switch (Typ.term_of(ty)) { | Unknown(_) => Hole | Bool | Int @@ -108,13 +113,13 @@ module CastHelpers = { | String | Var(_) | Rec(_) - | Arrow(Unknown(_), Unknown(_)) - | List(Unknown(_)) => Ground + | Arrow({term: Unknown(_), _}, {term: Unknown(_), _}) + | List({term: Unknown(_), _}) => Ground | Parens(ty) => ground_cases_of(ty) | Prod(tys) => if (List.for_all( fun - | Typ.Unknown(_) => true + | ({term: Typ.Unknown(_), _}: Typ.t) => true | _ => false, tys, )) { @@ -127,6 +132,7 @@ module CastHelpers = { ? Ground : grounded_Sum(sm) | Arrow(_, _) => grounded_Arrow | List(_) => grounded_List + | Ap(_) => failwith("type application in dynamics") }; }; }; @@ -355,7 +361,11 @@ module Transition = (EV: EV_MODE) => { kind: FunAp, value: false, }); - | Cast(d3', Arrow(ty1, ty2), Arrow(ty1', ty2')) => + | Cast( + d3', + {term: Arrow(ty1, ty2), _}, + {term: Arrow(ty1', ty2'), _}, + ) => Step({ apply: () => Cast( @@ -754,7 +764,7 @@ module Transition = (EV: EV_MODE) => { Constructor | (Hole, Ground) => switch (term_of(d')) { - | Cast(d2, t3, Unknown(_)) => + | Cast(d2, t3, {term: Unknown(_), _}) => /* by canonical forms, d1' must be of the form d ?> */ if (Typ.eq(t3, t2)) { Step({apply: () => d2, kind: Cast, value: true}); diff --git a/src/haz3lcore/statics/CoCtx.re b/src/haz3lcore/statics/CoCtx.re index f25981c622..b6e4753d5c 100644 --- a/src/haz3lcore/statics/CoCtx.re +++ b/src/haz3lcore/statics/CoCtx.re @@ -63,8 +63,10 @@ let singleton = (name, id, expected_ty): t => [ let join: (Ctx.t, list(entry)) => Typ.t = (ctx, entries) => { let expected_tys = List.map(entry => entry.expected_ty, entries); - switch (Typ.join_all(~empty=Unknown(Internal), ctx, expected_tys)) { - | None => Unknown(Internal) + switch ( + Typ.join_all(~empty=Unknown(Internal) |> Typ.fresh, ctx, expected_tys) + ) { + | None => Unknown(Internal) |> Typ.fresh | Some(ty) => ty }; }; diff --git a/src/haz3lcore/statics/Info.re b/src/haz3lcore/statics/Info.re index cbf1f3a78e..ef8be7e488 100644 --- a/src/haz3lcore/statics/Info.re +++ b/src/haz3lcore/statics/Info.re @@ -316,7 +316,15 @@ let rec status_common = } | (Just(syn), SynFun) => switch ( - Typ.join_fix(ctx, Arrow(Unknown(Internal), Unknown(Internal)), syn) + Typ.join_fix( + ctx, + Arrow( + Unknown(Internal) |> Typ.fresh, + Unknown(Internal) |> Typ.fresh, + ) + |> Typ.fresh, + syn, + ) ) { | None => InHole(Inconsistent(WithArrow(syn))) | Some(_) => NotInHole(Syn(syn)) @@ -333,9 +341,9 @@ let rec status_common = } | (BadToken(name), _) => InHole(NoType(BadToken(name))) | (BadTrivAp(ty), _) => InHole(NoType(BadTrivAp(ty))) - | (IsMulti, _) => NotInHole(Syn(Unknown(Internal))) + | (IsMulti, _) => NotInHole(Syn(Unknown(Internal) |> Typ.fresh)) | (NoJoin(wrap, tys), Ana(ana)) => - let syn: Typ.t = Self.join_of(wrap, Unknown(Internal)); + let syn: Typ.t = Self.join_of(wrap, Unknown(Internal) |> Typ.fresh); switch (Typ.join_fix(ctx, ana, syn)) { | None => InHole(Inconsistent(Expectation({ana, syn}))) | Some(_) => @@ -410,8 +418,9 @@ let status_typ = let ty_in = UTyp.to_typ(ctx, t2); switch (status_variant, t1.term) { | (Unique, Var(name)) => - NotInHole(Variant(name, Arrow(ty_in, ty_variant))) - | _ => NotInHole(VariantIncomplete(Arrow(ty_in, ty_variant))) + NotInHole(Variant(name, Arrow(ty_in, ty_variant) |> Typ.fresh)) + | _ => + NotInHole(VariantIncomplete(Arrow(ty_in, ty_variant) |> Typ.fresh)) }; | ConstructorExpected(_) => InHole(WantConstructorFoundAp) | TypeExpected => InHole(WantTypeFoundAp) @@ -473,13 +482,13 @@ let fixed_typ_ok: ok_pat => Typ.t = let fixed_typ_pat = (ctx, mode: Mode.t, self: Self.pat): Typ.t => switch (status_pat(ctx, mode, self)) { - | InHole(_) => Unknown(Internal) + | InHole(_) => Unknown(Internal) |> Typ.fresh | NotInHole(ok) => fixed_typ_ok(ok) }; let fixed_typ_exp = (ctx, mode: Mode.t, self: Self.exp): Typ.t => switch (status_exp(ctx, mode, self)) { - | InHole(_) => Unknown(Internal) + | InHole(_) => Unknown(Internal) |> Typ.fresh | NotInHole(ok) => fixed_typ_ok(ok) }; diff --git a/src/haz3lcore/statics/Mode.re b/src/haz3lcore/statics/Mode.re index f8dc127b9f..c9911ec411 100644 --- a/src/haz3lcore/statics/Mode.re +++ b/src/haz3lcore/statics/Mode.re @@ -29,8 +29,10 @@ let ana: Typ.t => t = ty => Ana(ty); let ty_of: t => Typ.t = fun | Ana(ty) => ty - | Syn => Unknown(SynSwitch) - | SynFun => Arrow(Unknown(SynSwitch), Unknown(SynSwitch)); + | Syn => Unknown(SynSwitch) |> Typ.fresh + | SynFun => + Arrow(Unknown(SynSwitch) |> Typ.fresh, Unknown(SynSwitch) |> Typ.fresh) + |> Typ.fresh; let of_arrow = (ctx: Ctx.t, mode: t): (t, t) => switch (mode) { @@ -56,8 +58,8 @@ let of_cons_hd = (ctx: Ctx.t, mode: t): t => let of_cons_tl = (ctx: Ctx.t, mode: t, hd_ty: Typ.t): t => switch (mode) { | Syn - | SynFun => Ana(List(hd_ty)) - | Ana(ty) => Ana(List(Typ.matched_list(ctx, ty))) + | SynFun => Ana(List(hd_ty) |> Typ.fresh) + | Ana(ty) => Ana(List(Typ.matched_list(ctx, ty)) |> Typ.fresh) }; let of_list = (ctx: Ctx.t, mode: t): t => @@ -70,8 +72,8 @@ let of_list = (ctx: Ctx.t, mode: t): t => let of_list_concat = (ctx: Ctx.t, mode: t): t => switch (mode) { | Syn - | SynFun => Ana(List(Unknown(SynSwitch))) - | Ana(ty) => Ana(List(Typ.matched_list(ctx, ty))) + | SynFun => Ana(List(Unknown(SynSwitch) |> Typ.fresh) |> Typ.fresh) + | Ana(ty) => Ana(List(Typ.matched_list(ctx, ty)) |> Typ.fresh) }; let of_list_lit = (ctx: Ctx.t, length, mode: t): list(t) => @@ -82,13 +84,13 @@ let ctr_ana_typ = (ctx: Ctx.t, mode: t, ctr: Constructor.t): option(Typ.t) => { a sum type having that ctr as a variant, we consider the ctr's type to be determined by the sum type */ switch (mode) { - | Ana(Arrow(_, ty_ana)) + | Ana({term: Arrow(_, ty_ana), _}) | Ana(ty_ana) => let* ctrs = Typ.get_sum_constructors(ctx, ty_ana); let+ (_, ty_entry) = Typ.sum_entry(ctr, ctrs); switch (ty_entry) { | None => ty_ana - | Some(ty_in) => Arrow(ty_in, ty_ana) + | Some(ty_in) => Arrow(ty_in, ty_ana) |> Typ.fresh }; | _ => None }; @@ -96,14 +98,14 @@ let ctr_ana_typ = (ctx: Ctx.t, mode: t, ctr: Constructor.t): option(Typ.t) => { let of_ctr_in_ap = (ctx: Ctx.t, mode: t, ctr: Constructor.t): option(t) => switch (ctr_ana_typ(ctx, mode, ctr)) { - | Some(Arrow(_) as ty_ana) => Some(Ana(ty_ana)) + | Some({term: Arrow(_), _} as ty_ana) => Some(Ana(ty_ana)) | Some(ty_ana) => /* Consider for example "let _ : +Yo = Yo("lol") in..." Here, the 'Yo' constructor should be in a hole, as it is nullary but used as unary; we reflect this by analyzing against an arrow type. Since we can't guess at what the parameter type might have be, we use Unknown. */ - Some(Ana(Arrow(Unknown(Internal), ty_ana))) + Some(Ana(Arrow(Unknown(Internal) |> Typ.fresh, ty_ana) |> Typ.fresh)) | None => None }; diff --git a/src/haz3lcore/statics/Self.re b/src/haz3lcore/statics/Self.re index 7ad63c5cae..bf5270ead4 100644 --- a/src/haz3lcore/statics/Self.re +++ b/src/haz3lcore/statics/Self.re @@ -50,7 +50,7 @@ type pat = let join_of = (j: join_type, ty: Typ.t): Typ.t => switch (j) { | Id => ty - | List => List(ty) + | List => List(ty) |> Typ.fresh }; /* What the type would be if the position had been @@ -101,7 +101,7 @@ let of_ctr = (ctx: Ctx.t, name: Constructor.t): t => let add_source = List.map2((id, ty) => Typ.{id, ty}); let match = (ctx: Ctx.t, tys: list(Typ.t), ids: list(Id.t)): t => - switch (Typ.join_all(~empty=Unknown(Internal), ctx, tys)) { + switch (Typ.join_all(~empty=Unknown(Internal) |> Typ.fresh, ctx, tys)) { | None => NoJoin(Id, add_source(ids, tys)) | Some(ty) => Just(ty) }; @@ -109,11 +109,11 @@ let match = (ctx: Ctx.t, tys: list(Typ.t), ids: list(Id.t)): t => let listlit = (~empty, ctx: Ctx.t, tys: list(Typ.t), ids: list(Id.t)): t => switch (Typ.join_all(~empty, ctx, tys)) { | None => NoJoin(List, add_source(ids, tys)) - | Some(ty) => Just(List(ty)) + | Some(ty) => Just(List(ty) |> Typ.fresh) }; let list_concat = (ctx: Ctx.t, tys: list(Typ.t), ids: list(Id.t)): t => - switch (Typ.join_all(~empty=Unknown(Internal), ctx, tys)) { + switch (Typ.join_all(~empty=Unknown(Internal) |> Typ.fresh, ctx, tys)) { | None => NoJoin(List, add_source(ids, tys)) | Some(ty) => Just(ty) }; diff --git a/src/haz3lcore/statics/Statics.re b/src/haz3lcore/statics/Statics.re index ea94ac22e4..60b42c6e6b 100644 --- a/src/haz3lcore/statics/Statics.re +++ b/src/haz3lcore/statics/Statics.re @@ -72,39 +72,58 @@ let extend_let_def_ctx = let typ_exp_binop_bin_int: Operators.op_bin_int => Typ.t = fun - | (Plus | Minus | Times | Power | Divide) as _op => Int + | (Plus | Minus | Times | Power | Divide) as _op => Int |> Typ.fresh | ( LessThan | GreaterThan | LessThanOrEqual | GreaterThanOrEqual | Equals | NotEquals ) as _op => - Bool; + Bool |> Typ.fresh; let typ_exp_binop_bin_float: Operators.op_bin_float => Typ.t = fun - | (Plus | Minus | Times | Power | Divide) as _op => Float + | (Plus | Minus | Times | Power | Divide) as _op => Float |> Typ.fresh | ( LessThan | GreaterThan | LessThanOrEqual | GreaterThanOrEqual | Equals | NotEquals ) as _op => - Bool; + Bool |> Typ.fresh; let typ_exp_binop_bin_string: Operators.op_bin_string => Typ.t = fun - | Concat => String - | Equals => Bool; + | Concat => String |> Typ.fresh + | Equals => Bool |> Typ.fresh; let typ_exp_binop: Operators.op_bin => (Typ.t, Typ.t, Typ.t) = fun - | Bool(And | Or) => (Bool, Bool, Bool) - | Int(op) => (Int, Int, typ_exp_binop_bin_int(op)) - | Float(op) => (Float, Float, typ_exp_binop_bin_float(op)) - | String(op) => (String, String, typ_exp_binop_bin_string(op)); + | Bool(And | Or) => ( + Bool |> Typ.fresh, + Bool |> Typ.fresh, + Bool |> Typ.fresh, + ) + | Int(op) => ( + Int |> Typ.fresh, + Int |> Typ.fresh, + typ_exp_binop_bin_int(op), + ) + | Float(op) => ( + Float |> Typ.fresh, + Float |> Typ.fresh, + typ_exp_binop_bin_float(op), + ) + | String(op) => ( + String |> Typ.fresh, + String |> Typ.fresh, + typ_exp_binop_bin_string(op), + ); let typ_exp_unop: Operators.op_un => (Typ.t, Typ.t) = fun - | Meta(Unquote) => (Var("$Meta"), Unknown(Free("$Meta"))) - | Bool(Not) => (Bool, Bool) - | Int(Minus) => (Int, Int); + | Meta(Unquote) => ( + Var("$Meta") |> Typ.fresh, + Unknown(Internal) |> Typ.fresh, + ) + | Bool(Not) => (Bool |> Typ.fresh, Bool |> Typ.fresh) + | Int(Minus) => (Int |> Typ.fresh, Int |> Typ.fresh); let rec any_to_info_map = (~ctx: Ctx.t, ~ancestors, any: Any.t, m: Map.t): (CoCtx.t, Map.t) => @@ -159,7 +178,7 @@ and uexp_to_info_map = /* Maybe switch mode to syn */ let mode = switch (mode) { - | Ana(Unknown(SynSwitch)) => Mode.Syn + | Ana({term: Unknown(SynSwitch), _}) => Mode.Syn | _ => mode }; let add' = (~self, ~co_ctx, m) => { @@ -203,18 +222,19 @@ and uexp_to_info_map = let (e, m) = go(~mode=Ana(t1), e, m); add(~self=Just(t2), ~co_ctx=e.co_ctx, m); | Invalid(token) => atomic(BadToken(token)) - | EmptyHole => atomic(Just(Unknown(Internal))) - | Bool(_) => atomic(Just(Bool)) - | Int(_) => atomic(Just(Int)) - | Float(_) => atomic(Just(Float)) - | String(_) => atomic(Just(String)) + | EmptyHole => atomic(Just(Unknown(Internal) |> Typ.fresh)) + | Bool(_) => atomic(Just(Bool |> Typ.fresh)) + | Int(_) => atomic(Just(Int |> Typ.fresh)) + | Float(_) => atomic(Just(Float |> Typ.fresh)) + | String(_) => atomic(Just(String |> Typ.fresh)) | ListLit(es) => let ids = List.map(UExp.rep_id, es); let modes = Mode.of_list_lit(ctx, List.length(es), mode); let (es, m) = map_m_go(m, modes, es); let tys = List.map(Info.exp_ty, es); add( - ~self=Self.listlit(~empty=Unknown(Internal), ctx, tys, ids), + ~self= + Self.listlit(~empty=Unknown(Internal) |> Typ.fresh, ctx, tys, ids), ~co_ctx=CoCtx.union(List.map(Info.exp_co_ctx, es)), m, ); @@ -222,7 +242,7 @@ and uexp_to_info_map = let (hd, m) = go(~mode=Mode.of_cons_hd(ctx, mode), hd, m); let (tl, m) = go(~mode=Mode.of_cons_tl(ctx, mode, hd.ty), tl, m); add( - ~self=Just(List(hd.ty)), + ~self=Just(List(hd.ty) |> Typ.fresh), ~co_ctx=CoCtx.union([hd.co_ctx, tl.co_ctx]), m, ); @@ -258,8 +278,8 @@ and uexp_to_info_map = | _ => e.term }, }; - let ty_in = Typ.Var("$Meta"); - let ty_out = Typ.Unknown(Internal); + let ty_in = Typ.Var("$Meta") |> Typ.fresh; + let ty_out = Typ.Unknown(Internal) |> Typ.fresh; let (e, m) = go(~mode=Ana(ty_in), e, m); add(~self=Just(ty_out), ~co_ctx=e.co_ctx, m); | UnOp(op, e) => @@ -281,13 +301,13 @@ and uexp_to_info_map = let modes = Mode.of_prod(ctx, mode, List.length(es)); let (es, m) = map_m_go(m, modes, es); add( - ~self=Just(Prod(List.map(Info.exp_ty, es))), + ~self=Just(Prod(List.map(Info.exp_ty, es)) |> Typ.fresh), ~co_ctx=CoCtx.union(List.map(Info.exp_co_ctx, es)), m, ); | Test(e) => - let (e, m) = go(~mode=Ana(Bool), e, m); - add(~self=Just(Prod([])), ~co_ctx=e.co_ctx, m); + let (e, m) = go(~mode=Ana(Bool |> Typ.fresh), e, m); + add(~self=Just(Prod([]) |> Typ.fresh), ~co_ctx=e.co_ctx, m); | Filter(Filter({pat: cond, _}), body) => let (cond, m) = go(~mode, cond, m, ~is_in_filter=true); let (body, m) = go(~mode, body, m); @@ -311,7 +331,7 @@ and uexp_to_info_map = let (arg, m) = go(~mode=Ana(ty_in), arg, m); let self: Self.t = Id.is_nullary_ap_flag(arg.term.ids) - && !Typ.is_consistent(ctx, ty_in, Prod([])) + && !Typ.is_consistent(ctx, ty_in, Prod([]) |> Typ.fresh) ? BadTrivAp(ty_in) : Just(ty_out); add(~self, ~co_ctx=CoCtx.union([fn.co_ctx, arg.co_ctx]), m); | Fun(p, e, _, _) => @@ -323,7 +343,7 @@ and uexp_to_info_map = let (p, m) = go_pat(~is_synswitch=false, ~co_ctx=e.co_ctx, ~mode=mode_pat, p, m); add( - ~self=Just(Arrow(p.ty, e.ty)), + ~self=Just(Arrow(p.ty, e.ty) |> Typ.fresh), ~co_ctx=CoCtx.mk(ctx, p.ctx, e.co_ctx), m, ); @@ -370,7 +390,7 @@ and uexp_to_info_map = ); | If(e0, e1, e2) => let branch_ids = List.map(UExp.rep_id, [e1, e2]); - let (cond, m) = go(~mode=Ana(Bool), e0, m); + let (cond, m) = go(~mode=Ana(Bool |> Typ.fresh), e0, m); let (cons, m) = go(~mode, e1, m); let (alt, m) = go(~mode, e2, m); add( @@ -435,7 +455,7 @@ and uexp_to_info_map = /* NOTE: When debugging type system issues it may be beneficial to use a different name than the alias for the recursive parameter */ //let ty_rec = Typ.Rec("α", Typ.subst(Var("α"), name, ty_pre)); - let ty_rec = Typ.Rec(name, ty_pre); + let ty_rec = Typ.Rec(name, ty_pre) |> Typ.fresh; let ctx_def = Ctx.extend_alias(ctx, name, TPat.rep_id(typat), ty_rec); (ty_rec, ctx_def, ctx_def); @@ -505,34 +525,42 @@ and upat_to_info_map = let (_, m) = multi(~ctx, ~ancestors, m, tms); add(~self=IsMulti, ~ctx, m); | Invalid(token) => atomic(BadToken(token)) - | EmptyHole => atomic(Just(unknown)) - | Int(_) => atomic(Just(Int)) - | Float(_) => atomic(Just(Float)) - | Bool(_) => atomic(Just(Bool)) - | String(_) => atomic(Just(String)) + | EmptyHole => atomic(Just(unknown |> Typ.fresh)) + | Int(_) => atomic(Just(Int |> Typ.fresh)) + | Float(_) => atomic(Just(Float |> Typ.fresh)) + | Bool(_) => atomic(Just(Bool |> Typ.fresh)) + | String(_) => atomic(Just(String |> Typ.fresh)) | ListLit(ps) => let ids = List.map(UPat.rep_id, ps); let modes = Mode.of_list_lit(ctx, List.length(ps), mode); let (ctx, tys, m) = ctx_fold(ctx, m, ps, modes); - add(~self=Self.listlit(~empty=unknown, ctx, tys, ids), ~ctx, m); + add( + ~self=Self.listlit(~empty=unknown |> Typ.fresh, ctx, tys, ids), + ~ctx, + m, + ); | Cons(hd, tl) => let (hd, m) = go(~ctx, ~mode=Mode.of_cons_hd(ctx, mode), hd, m); let (tl, m) = go(~ctx=hd.ctx, ~mode=Mode.of_cons_tl(ctx, mode, hd.ty), tl, m); - add(~self=Just(List(hd.ty)), ~ctx=tl.ctx, m); - | Wild => atomic(Just(unknown)) + add(~self=Just(List(hd.ty) |> Typ.fresh), ~ctx=tl.ctx, m); + | Wild => atomic(Just(unknown |> Typ.fresh)) | Var(name) => /* NOTE: The self type assigned to pattern variables (Unknown) may be SynSwitch, but SynSwitch is never added to the context; Unknown(Internal) is used in this case */ let ctx_typ = - Info.fixed_typ_pat(ctx, mode, Common(Just(Unknown(Internal)))); + Info.fixed_typ_pat( + ctx, + mode, + Common(Just(Unknown(Internal) |> Typ.fresh)), + ); let entry = Ctx.VarEntry({name, id: UPat.rep_id(upat), typ: ctx_typ}); - add(~self=Just(unknown), ~ctx=Ctx.extend(ctx, entry), m); + add(~self=Just(unknown |> Typ.fresh), ~ctx=Ctx.extend(ctx, entry), m); | Tuple(ps) => let modes = Mode.of_prod(ctx, mode, List.length(ps)); let (ctx, tys, m) = ctx_fold(ctx, m, ps, modes); - add(~self=Just(Prod(tys)), ~ctx, m); + add(~self=Just(Prod(tys) |> Typ.fresh), ~ctx, m); | Parens(p) => let (p, m) = go(~ctx, ~mode, p, m); add(~self=Just(p.ty), ~ctx=p.ctx, m); @@ -593,8 +621,12 @@ and utyp_to_info_map = let t1_mode: Info.typ_expects = switch (expects) { | VariantExpected(m, sum_ty) => - ConstructorExpected(m, Arrow(ty_in, sum_ty)) - | _ => ConstructorExpected(Unique, Arrow(ty_in, Unknown(Internal))) + ConstructorExpected(m, Arrow(ty_in, sum_ty) |> Typ.fresh) + | _ => + ConstructorExpected( + Unique, + Arrow(ty_in, Unknown(Internal) |> Typ.fresh) |> Typ.fresh, + ) }; let m = go'(~expects=t1_mode, t1, m) |> snd; let m = go'(~expects=TypeExpected, t2, m) |> snd; diff --git a/src/haz3lcore/statics/Term.re b/src/haz3lcore/statics/Term.re index c07c3fc7e1..98339de3a9 100644 --- a/src/haz3lcore/statics/Term.re +++ b/src/haz3lcore/statics/Term.re @@ -131,34 +131,36 @@ module TypTerm = { (ctx, utyp) => switch (utyp.term) { | Invalid(_) - | MultiHole(_) => Unknown(Internal) - | EmptyHole => Unknown(TypeHole) - | Bool => Bool - | Int => Int - | Float => Float - | String => String + | MultiHole(_) => Unknown(Internal) |> Typ.fresh + | EmptyHole => Unknown(Hole(EmptyHole)) |> Typ.fresh + | Bool => Bool |> Typ.fresh + | Int => Int |> Typ.fresh + | Float => Float |> Typ.fresh + | String => String |> Typ.fresh | Var(name) => switch (Ctx.lookup_tvar(ctx, name)) { - | Some(_) => Var(name) - | None => Unknown(Free(name)) + | Some(_) => Var(name) |> Typ.fresh + | None => Unknown(Hole(Invalid(name))) |> Typ.fresh } - | Arrow(u1, u2) => Arrow(to_typ(ctx, u1), to_typ(ctx, u2)) - | Prod(us) => Prod(List.map(to_typ(ctx), us)) - | Sum(uts) => Sum(to_ctr_map(ctx, uts)) - | List(u) => List(to_typ(ctx, u)) + | Arrow(u1, u2) => + Arrow(to_typ(ctx, u1), to_typ(ctx, u2)) |> Typ.fresh + | Prod(us) => Prod(List.map(to_typ(ctx), us)) |> Typ.fresh + | Sum(uts) => Sum(to_ctr_map(ctx, uts)) |> Typ.fresh + | List(u) => List(to_typ(ctx, u)) |> Typ.fresh | Parens(u) => to_typ(ctx, u) /* The below cases should occur only inside sums */ - | Ap(_) => Unknown(Internal) + | Ap(_) => Unknown(Internal) |> Typ.fresh | Rec({term: Invalid(_), _}, tbody) | Rec({term: EmptyHole, _}, tbody) - | Rec({term: MultiHole(_), _}, tbody) => Rec("?", to_typ(ctx, tbody)) + | Rec({term: MultiHole(_), _}, tbody) => + Rec("?", to_typ(ctx, tbody)) |> Typ.fresh | Rec({term: Var(name), _} as utpat, tbody) => let ctx = Ctx.extend_tvar( ctx, {name, id: TPat.rep_id(utpat), kind: Abstract}, ); - Rec(name, to_typ(ctx, tbody)); + Rec(name, to_typ(ctx, tbody)) |> Typ.fresh; } and to_variant: (Ctx.t, variant) => option(ConstructorMap.binding(option(Typ.t))) = diff --git a/src/haz3lcore/statics/TypBase.re b/src/haz3lcore/statics/TypBase.re index a3b3ec6797..dca08452a2 100644 --- a/src/haz3lcore/statics/TypBase.re +++ b/src/haz3lcore/statics/TypBase.re @@ -5,9 +5,16 @@ open OptUtil.Syntax; let precedence_Prod = 1; let precedence_Arrow = 2; let precedence_Sum = 3; -let precedence_Const = 4; +let precedence_Ap = 4; +let precedence_Const = 5; module rec Typ: { + [@deriving (show({with_path: false}), sexp, yojson)] + type type_hole = + | Invalid(string) + | EmptyHole + | MultiHole(list(string)); + /* TYPE_PROVENANCE: From whence does an unknown type originate? Is it generated from an unannotated pattern variable (SynSwitch), a pattern variable annotated with a type hole (TypeHole), or @@ -15,13 +22,12 @@ module rec Typ: { [@deriving (show({with_path: false}), sexp, yojson)] type type_provenance = | SynSwitch - | TypeHole - | Free(string) + | Hole(type_hole) | Internal; /* TYP.T: Hazel types */ [@deriving (show({with_path: false}), sexp, yojson)] - type t = + type term = | Unknown(type_provenance) // Add to TypTerm | Int | Float @@ -33,9 +39,13 @@ module rec Typ: { | Sum(sum_map) | Prod(list(t)) | Parens(t) - // TODO[Matt]: Add Ap? + | Ap(t, t) | Rec(string, t) - and sum_map = ConstructorMap.t(option(t)); + and sum_map = ConstructorMap.t(option(t)) + and t = { + ids: list(Id.t), + term, + }; [@deriving (show({with_path: false}), sexp, yojson)] type sum_entry = ConstructorMap.binding(option(t)); @@ -50,6 +60,10 @@ module rec Typ: { ty: t, }; + let term_of: t => term; + let unwrap: t => (term, term => t); + let fresh: term => t; + let of_source: list(source) => list(t); let join_type_provenance: (type_provenance, type_provenance) => type_provenance; @@ -71,16 +85,21 @@ module rec Typ: { let get_sum_constructors: (Ctx.t, t) => option(sum_map); let is_unknown: t => bool; } = { + [@deriving (show({with_path: false}), sexp, yojson)] + type type_hole = + | Invalid(string) + | EmptyHole + | MultiHole(list(string)); + [@deriving (show({with_path: false}), sexp, yojson)] type type_provenance = | SynSwitch - | TypeHole - | Free(string) + | Hole(type_hole) | Internal; /* TYP.T: Hazel types */ [@deriving (show({with_path: false}), sexp, yojson)] - type t = + type term = | Unknown(type_provenance) | Int | Float @@ -92,8 +111,22 @@ module rec Typ: { | Sum(sum_map) | Prod(list(t)) | Parens(t) + | Ap(t, t) | Rec(string, t) - and sum_map = ConstructorMap.t(option(t)); + and sum_map = ConstructorMap.t(option(t)) + and t = { + ids: list(Id.t), + term, + }; + + let term_of = ({term, _}) => term; + // All children of term must have expression-unique ids. + + let unwrap = ({ids, term}) => (term, term => {ids, term}); + + let fresh = term => { + {ids: [Id.mk()], term}; + }; [@deriving (show({with_path: false}), sexp, yojson)] type sum_entry = ConstructorMap.binding(option(t)); @@ -114,18 +147,18 @@ module rec Typ: { let join_type_provenance = (p1: type_provenance, p2: type_provenance): type_provenance => switch (p1, p2) { - | (Free(tv1), Free(tv2)) when tv1 == tv2 => Free(tv1) - | (TypeHole, TypeHole | SynSwitch) - | (SynSwitch, TypeHole) => TypeHole + | (Hole(h1), Hole(h2)) when h1 == h2 => Hole(h1) + | (Hole(EmptyHole), Hole(EmptyHole) | SynSwitch) + | (SynSwitch, Hole(EmptyHole)) => Hole(EmptyHole) | (SynSwitch, Internal) | (Internal, SynSwitch) => SynSwitch - | (Internal | Free(_), _) - | (_, Internal | Free(_)) => Internal + | (Internal | Hole(_), _) + | (_, Hole(_)) => Internal | (SynSwitch, SynSwitch) => SynSwitch }; let precedence = (ty: t): int => - switch (ty) { + switch (term_of(ty)) { | Int | Float | Bool @@ -138,28 +171,33 @@ module rec Typ: { | Prod(_) => precedence_Prod | Arrow(_, _) => precedence_Arrow | Parens(_) => precedence_Const + | Ap(_) => precedence_Ap }; let rec subst = (s: t, x: string, ty: t) => { - switch (ty) { - | Int => Int - | Float => Float - | Bool => Bool - | String => String - | Unknown(prov) => Unknown(prov) - | Arrow(ty1, ty2) => Arrow(subst(s, x, ty1), subst(s, x, ty2)) - | Prod(tys) => Prod(List.map(subst(s, x), tys)) - | Sum(sm) => Sum(ConstructorMap.map(Option.map(subst(s, x)), sm)) - | Rec(y, ty) when x == y => Rec(y, ty) - | Rec(y, ty) => Rec(y, subst(s, x, ty)) - | List(ty) => List(subst(s, x, ty)) - | Var(y) => x == y ? s : Var(y) - | Parens(ty) => Parens(subst(s, x, ty)) + let (term, rewrap) = unwrap(ty); + switch (term) { + | Int => Int |> rewrap + | Float => Float |> rewrap + | Bool => Bool |> rewrap + | String => String |> rewrap + | Unknown(prov) => Unknown(prov) |> rewrap + | Arrow(ty1, ty2) => + Arrow(subst(s, x, ty1), subst(s, x, ty2)) |> rewrap + | Prod(tys) => Prod(List.map(subst(s, x), tys)) |> rewrap + | Sum(sm) => + Sum(ConstructorMap.map(Option.map(subst(s, x)), sm)) |> rewrap + | Rec(y, ty) when x == y => Rec(y, ty) |> rewrap + | Rec(y, ty) => Rec(y, subst(s, x, ty)) |> rewrap + | List(ty) => List(subst(s, x, ty)) |> rewrap + | Var(y) => x == y ? s : Var(y) |> rewrap + | Parens(ty) => Parens(subst(s, x, ty)) |> rewrap + | Ap(t1, t2) => Ap(subst(s, x, t1), subst(s, x, t2)) |> rewrap }; }; let unroll = (ty: t): t => - switch (ty) { + switch (term_of(ty)) { | Rec(x, ty_body) => subst(ty, x, ty_body) | _ => ty }; @@ -167,10 +205,11 @@ module rec Typ: { /* Type Equality: At the moment, this coincides with alpha equivalence, but this will change when polymorphic types are implemented */ let rec eq = (t1: t, t2: t): bool => { - switch (t1, t2) { - | (Parens(t1), t2) => eq(t1, t2) - | (t1, Parens(t2)) => eq(t1, t2) - | (Rec(x1, t1), Rec(x2, t2)) => eq(t1, subst(Var(x1), x2, t2)) + switch (term_of(t1), term_of(t2)) { + | (Parens(t1), _) => eq(t1, t2) + | (_, Parens(t2)) => eq(t1, t2) + | (Rec(x1, t1), Rec(x2, t2)) => + eq(t1, subst(fresh(Var(x1)), x2, t2)) | (Rec(_), _) => false | (Int, Int) => true | (Int, _) => false @@ -193,11 +232,13 @@ module rec Typ: { | (Sum(_), _) => false | (Var(n1), Var(n2)) => n1 == n2 | (Var(_), _) => false + | (Ap(t1, t2), Ap(t3, t4)) => eq(t1, t3) && eq(t2, t4) + | (Ap(_), _) => false }; }; let rec free_vars = (~bound=[], ty: t): list(Var.t) => - switch (ty) { + switch (term_of(ty)) { | Unknown(_) | Int | Float @@ -206,6 +247,7 @@ module rec Typ: { | Var(v) => List.mem(v, bound) ? [] : [v] | Parens(ty) | List(ty) => free_vars(~bound, ty) + | Ap(t1, t2) | Arrow(t1, t2) => free_vars(~bound, t1) @ free_vars(~bound, t2) | Sum(sm) => ListUtil.flat_map( @@ -226,32 +268,35 @@ module rec Typ: { let rec join = (~resolve=false, ~fix, ctx: Ctx.t, ty1: t, ty2: t): option(t) => { let join' = join(~resolve, ~fix, ctx); - switch (ty1, ty2) { - | (ty1, Parens(ty2)) - | (Parens(ty1), ty2) => join'(ty1, ty2) - | (_, Unknown(TypeHole | Free(_)) as ty) when fix => + switch (term_of(ty1), term_of(ty2)) { + | (_, Parens(ty2)) => join'(ty1, ty2) + | (Parens(ty1), _) => join'(ty1, ty2) + | (_, Unknown(Hole(_))) when fix => /* NOTE(andrew): This is load bearing for ensuring that function literals get appropriate casts. Documentation/Dynamics has regression tests */ - Some(ty) + Some(ty2) | (Unknown(p1), Unknown(p2)) => - Some(Unknown(join_type_provenance(p1, p2))) - | (Unknown(_), ty) - | (ty, Unknown(Internal | SynSwitch)) => Some(ty) + Some(Unknown(join_type_provenance(p1, p2)) |> fresh) + | (Unknown(_), _) => Some(ty2) + | (_, Unknown(Internal | SynSwitch)) => Some(ty1) | (Var(n1), Var(n2)) => if (n1 == n2) { - Some(Var(n1)); + Some(ty1); } else { let* ty1 = Ctx.lookup_alias(ctx, n1); let* ty2 = Ctx.lookup_alias(ctx, n2); let+ ty_join = join'(ty1, ty2); - !resolve && eq(ty1, ty_join) ? Var(n1) : ty_join; + !resolve && eq(ty1, ty_join) ? ty1 : ty_join; } - | (Var(name), ty) - | (ty, Var(name)) => + | (Var(name), _) => let* ty_name = Ctx.lookup_alias(ctx, name); - let+ ty_join = join'(ty_name, ty); - !resolve && eq(ty_name, ty_join) ? Var(name) : ty_join; + let+ ty_join = join'(ty_name, ty2); + !resolve && eq(ty_name, ty_join) ? ty1 : ty_join; + | (_, Var(name)) => + let* ty_name = Ctx.lookup_alias(ctx, name); + let+ ty_join = join'(ty_name, ty1); + !resolve && eq(ty_name, ty_join) ? ty2 : ty_join; /* Note: Ordering of Unknown, Var, and Rec above is load-bearing! */ | (Rec(x1, ty1), Rec(x2, ty2)) => /* TODO: @@ -263,26 +308,26 @@ module rec Typ: { */ let ctx = Ctx.extend_dummy_tvar(ctx, x1); let+ ty_body = - join(~resolve, ~fix, ctx, ty1, subst(Var(x1), x2, ty2)); - Rec(x1, ty_body); + join(~resolve, ~fix, ctx, ty1, subst(Var(x1) |> fresh, x2, ty2)); + Rec(x1, ty_body) |> fresh; | (Rec(_), _) => None - | (Int, Int) => Some(Int) + | (Int, Int) => Some(Int |> fresh) | (Int, _) => None - | (Float, Float) => Some(Float) + | (Float, Float) => Some(Float |> fresh) | (Float, _) => None - | (Bool, Bool) => Some(Bool) + | (Bool, Bool) => Some(Bool |> fresh) | (Bool, _) => None - | (String, String) => Some(String) + | (String, String) => Some(String |> fresh) | (String, _) => None | (Arrow(ty1, ty2), Arrow(ty1', ty2')) => let* ty1 = join'(ty1, ty1'); let+ ty2 = join'(ty2, ty2'); - Arrow(ty1, ty2); + Arrow(ty1, ty2) |> fresh; | (Arrow(_), _) => None | (Prod(tys1), Prod(tys2)) => let* tys = ListUtil.map2_opt(join', tys1, tys2); let+ tys = OptUtil.sequence(tys); - Prod(tys); + Prod(tys) |> fresh; | (Prod(_), _) => None | (Sum(sm1), Sum(sm2)) => let (sorted1, sorted2) = @@ -297,12 +342,13 @@ module rec Typ: { sorted2, ); let+ ty = OptUtil.sequence(ty); - Sum(ty); + Sum(ty) |> fresh; | (Sum(_), _) => None | (List(ty1), List(ty2)) => let+ ty = join'(ty1, ty2); - List(ty); + List(ty) |> fresh; | (List(_), _) => None + | (Ap(_), _) => failwith("Type join of ap") }; } and join_sum_entries = @@ -335,7 +381,7 @@ module rec Typ: { join(~fix=false, ctx, ty1, ty2) != None; let rec weak_head_normalize = (ctx: Ctx.t, ty: t): t => - switch (ty) { + switch (term_of(ty)) { | Var(x) => switch (Ctx.lookup_alias(ctx, x)) { | Some(ty) => weak_head_normalize(ctx, ty) @@ -345,7 +391,8 @@ module rec Typ: { }; let rec normalize = (ctx: Ctx.t, ty: t): t => { - switch (ty) { + let (term, rewrap) = unwrap(ty); + switch (term) { | Var(x) => switch (Ctx.lookup_alias(ctx, x)) { | Some(ty) => normalize(ctx, ty) @@ -357,37 +404,44 @@ module rec Typ: { | Bool | String => ty | Parens(t) => t - | List(t) => List(normalize(ctx, t)) - | Arrow(t1, t2) => Arrow(normalize(ctx, t1), normalize(ctx, t2)) - | Prod(ts) => Prod(List.map(normalize(ctx), ts)) - | Sum(ts) => Sum(ConstructorMap.map(Option.map(normalize(ctx)), ts)) + | List(t) => List(normalize(ctx, t)) |> rewrap + | Ap(t1, t2) => Ap(normalize(ctx, t1), normalize(ctx, t2)) |> rewrap + | Arrow(t1, t2) => + Arrow(normalize(ctx, t1), normalize(ctx, t2)) |> rewrap + | Prod(ts) => Prod(List.map(normalize(ctx), ts)) |> rewrap + | Sum(ts) => + Sum(ConstructorMap.map(Option.map(normalize(ctx)), ts)) |> rewrap | Rec(name, ty) => /* NOTE: Dummy tvar added has fake id but shouldn't matter as in current implementation Recs do not occur in the surface syntax, so we won't try to jump to them. */ - Rec(name, normalize(Ctx.extend_dummy_tvar(ctx, name), ty)) + Rec(name, normalize(Ctx.extend_dummy_tvar(ctx, name), ty)) |> rewrap }; }; let matched_arrow = (ctx, ty) => - switch (weak_head_normalize(ctx, ty)) { + switch (term_of(weak_head_normalize(ctx, ty))) { | Arrow(ty_in, ty_out) => (ty_in, ty_out) - | Unknown(SynSwitch) => (Unknown(SynSwitch), Unknown(SynSwitch)) - | _ => (Unknown(Internal), Unknown(Internal)) + | Unknown(SynSwitch) => ( + Unknown(SynSwitch) |> fresh, + Unknown(SynSwitch) |> fresh, + ) + | _ => (Unknown(Internal) |> fresh, Unknown(Internal) |> fresh) }; let matched_prod = (ctx, length, ty) => - switch (weak_head_normalize(ctx, ty)) { + switch (term_of(weak_head_normalize(ctx, ty))) { | Prod(tys) when List.length(tys) == length => tys - | Unknown(SynSwitch) => List.init(length, _ => Unknown(SynSwitch)) - | _ => List.init(length, _ => Unknown(Internal)) + | Unknown(SynSwitch) => + List.init(length, _ => Unknown(SynSwitch) |> fresh) + | _ => List.init(length, _ => Unknown(Internal) |> fresh) }; let matched_list = (ctx, ty) => - switch (weak_head_normalize(ctx, ty)) { + switch (term_of(weak_head_normalize(ctx, ty))) { | List(ty) => ty - | Unknown(SynSwitch) => Unknown(SynSwitch) - | _ => Unknown(Internal) + | Unknown(SynSwitch) => Unknown(SynSwitch) |> fresh + | _ => Unknown(Internal) |> fresh }; let sum_entry = (ctr: Constructor.t, ctrs: sum_map): option(sum_entry) => @@ -400,7 +454,7 @@ module rec Typ: { let get_sum_constructors = (ctx: Ctx.t, ty: t): option(sum_map) => { let ty = weak_head_normalize(ctx, ty); - switch (ty) { + switch (term_of(ty)) { | Sum(sm) => Some(sm) | Rec(_) => /* Note: We must unroll here to get right ctr types; @@ -414,7 +468,7 @@ module rec Typ: { is bound. If either of the above assumptions become invalid, the below code will be incorrect! */ let ty = - switch (ty) { + switch (ty |> term_of) { | Rec(x, ty_body) => switch (Ctx.lookup_alias(ctx, x)) { | None => unroll(ty) @@ -422,7 +476,7 @@ module rec Typ: { } | _ => ty }; - switch (ty) { + switch (ty |> term_of) { | Sum(sm) => Some(sm) | _ => None }; @@ -431,7 +485,7 @@ module rec Typ: { }; let is_unknown = (ty: t): bool => - switch (ty) { + switch (ty |> term_of) { | Unknown(_) => true | _ => false }; @@ -561,8 +615,8 @@ and Ctx: { id, typ: switch (typ) { - | None => Var(name) - | Some(typ) => Arrow(typ, Var(name)) + | None => Var(name) |> Typ.fresh + | Some(typ) => Arrow(typ, Var(name) |> Typ.fresh) |> Typ.fresh }, }), ctrs, diff --git a/src/haz3lweb/view/CursorInspector.re b/src/haz3lweb/view/CursorInspector.re index 22112a3e08..d7b11840a0 100644 --- a/src/haz3lweb/view/CursorInspector.re +++ b/src/haz3lweb/view/CursorInspector.re @@ -74,7 +74,7 @@ let common_err_view = (cls: Cls.t, err: Info.error_common) => text("Function argument type"), Type.view(ty), text("inconsistent with"), - Type.view(Prod([])), + Type.view(Prod([]) |> Typ.fresh), ] | NoType(FreeConstructor(name)) => [code_err(name), text("not found")] | Inconsistent(WithArrow(typ)) => [ @@ -139,17 +139,20 @@ let typ_ok_view = (cls: Cls.t, ok: Info.ok_typ) => | Type(_) when cls == Typ(EmptyHole) => [text("Fillable by any type")] | Type(ty) => [Type.view(ty)] | TypeAlias(name, ty_lookup) => [ - Type.view(Var(name)), + Type.view(Var(name) |> Typ.fresh), text("is an alias for"), Type.view(ty_lookup), ] - | Variant(name, _sum_ty) => [Type.view(Var(name))] + | Variant(name, _sum_ty) => [Type.view(Var(name) |> Typ.fresh)] | VariantIncomplete(_sum_ty) => [text("is incomplete")] }; let typ_err_view = (ok: Info.error_typ) => switch (ok) { - | FreeTypeVariable(name) => [Type.view(Var(name)), text("not found")] + | FreeTypeVariable(name) => [ + Type.view(Var(name) |> Typ.fresh), + text("not found"), + ] | BadToken(token) => [ code_err(token), text("not a type or type operator"), @@ -158,7 +161,7 @@ let typ_err_view = (ok: Info.error_typ) => | WantConstructorFoundType(_) => [text("Expected a constructor")] | WantTypeFoundAp => [text("Must be part of a sum type")] | DuplicateConstructor(name) => [ - Type.view(Var(name)), + Type.view(Var(name) |> Typ.fresh), text("already used in this sum"), ] }; @@ -192,9 +195,15 @@ let tpat_view = (_: Cls.t, status: Info.status_tpat) => div_err([text("Must begin with a capital letter")]) | InHole(NotAVar(_)) => div_err([text("Expected an alias")]) | InHole(ShadowsType(name)) when Form.is_base_typ(name) => - div_err([text("Can't shadow base type"), Type.view(Var(name))]) + div_err([ + text("Can't shadow base type"), + Type.view(Var(name) |> Typ.fresh), + ]) | InHole(ShadowsType(name)) => - div_err([text("Can't shadow existing alias"), Type.view(Var(name))]) + div_err([ + text("Can't shadow existing alias"), + Type.view(Var(name) |> Typ.fresh), + ]) }; let secondary_view = (cls: Cls.t) => div_ok([text(cls |> Cls.show)]); diff --git a/src/haz3lweb/view/Type.re b/src/haz3lweb/view/Type.re index 6af1da4851..b4f5dad06e 100644 --- a/src/haz3lweb/view/Type.re +++ b/src/haz3lweb/view/Type.re @@ -9,17 +9,17 @@ let ty_view = (cls: string, s: string): Node.t => let alias_view = (s: string): Node.t => div(~attr=clss(["typ-alias-view"]), [text(s)]); -let prov_view: Typ.type_provenance => Node.t = - fun - | Internal => div([]) - | Free(name) => - div(~attr=clss(["typ-mod", "free-type-var"]), [text(name)]) - | TypeHole => div(~attr=clss(["typ-mod", "type-hole"]), [text("𝜏")]) - | SynSwitch => div(~attr=clss(["typ-mod", "syn-switch"]), [text("⇒")]); +// let prov_view: Typ.type_provenance => Node.t = +// fun +// | Internal => div([]) +// | Free(name) => +// div(~attr=clss(["typ-mod", "free-type-var"]), [text(name)]) +// | TypeHole => div(~attr=clss(["typ-mod", "type-hole"]), [text("𝜏")]) +// | SynSwitch => div(~attr=clss(["typ-mod", "syn-switch"]), [text("⇒")]); let rec view_ty = (ty: Haz3lcore.Typ.t): Node.t => //TODO: parens on ops when ambiguous - switch (ty) { + switch (Typ.term_of(ty)) { | Unknown(prov) => div( ~attr= @@ -78,6 +78,7 @@ let rec view_ty = (ty: Haz3lcore.Typ.t): Node.t => ctr_view(t0) @ ts_views; }, ) + | Ap(_) => failwith("type application in view") } and ctr_view = ((ctr, typ)) => switch (typ) { diff --git a/src/haz3lweb/view/dhcode/layout/HTypDoc.re b/src/haz3lweb/view/dhcode/layout/HTypDoc.re index 08186c27b2..28de6b83a0 100644 --- a/src/haz3lweb/view/dhcode/layout/HTypDoc.re +++ b/src/haz3lweb/view/dhcode/layout/HTypDoc.re @@ -41,7 +41,7 @@ let rec mk = (~parenthesize=false, ~enforce_inline: bool, ty: Typ.t): t => { ), ); let (doc, parenthesize) = - switch (ty) { + switch (Typ.term_of(ty)) { | Parens(ty) => (mk(~parenthesize=true, ~enforce_inline, ty), false) | Unknown(_) => ( annot(HTypAnnot.Delim, annot(HTypAnnot.HoleLabel, text("?"))), @@ -138,6 +138,10 @@ let rec mk = (~parenthesize=false, ~enforce_inline: bool, ty: Typ.t): t => { ) |> hcats; (center, true); + | Ap(t1, t2) => ( + hcats([mk'(t1), text("("), mk'(t2), text(")")]), + parenthesize, + ) }; let doc = annot(HTypAnnot.Term, doc); parenthesize ? Doc.hcats([mk_delim("("), doc, mk_delim(")")]) : doc; diff --git a/src/test/Test_Elaboration.re b/src/test/Test_Elaboration.re index 2d4349f2e2..13c64d9e5c 100644 --- a/src/test/Test_Elaboration.re +++ b/src/test/Test_Elaboration.re @@ -173,7 +173,12 @@ let d7: DHExp.t = BinOp( Int(Plus), Int(4) |> fresh, - Cast(Var("x") |> fresh, Unknown(Internal), Int) |> fresh, + Cast( + Var("x") |> fresh, + Unknown(Internal) |> Typ.fresh, + Int |> Typ.fresh, + ) + |> fresh, ) |> fresh, None, From 98cf0e17d9d2bbb96f2d23ab8719bd7a17f4fd13 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 28 Mar 2024 14:37:14 -0400 Subject: [PATCH 060/103] Factor out Ids (adding infrastructure for structure sharing if we need it) --- src/haz3lcore/dynamics/DHExp.re | 9 +-- src/haz3lcore/lang/term/IdTagged.re | 30 ++++++++++ src/haz3lcore/statics/MakeTerm.re | 21 +++---- src/haz3lcore/statics/Statics.re | 11 ++-- src/haz3lcore/statics/Term.re | 29 +++------ src/haz3lcore/statics/TermBase.re | 67 +++++---------------- src/haz3lcore/statics/TypBase.re | 21 ++----- src/haz3lcore/zipper/EditorUtil.re | 92 +++++++++++++++-------------- src/haz3lweb/util/WorkerClient.re | 2 + src/test/Test_Elaboration.re | 21 ++++--- 10 files changed, 144 insertions(+), 159 deletions(-) create mode 100644 src/haz3lcore/lang/term/IdTagged.re diff --git a/src/haz3lcore/dynamics/DHExp.re b/src/haz3lcore/dynamics/DHExp.re index 7f5dadb028..99496240b4 100644 --- a/src/haz3lcore/dynamics/DHExp.re +++ b/src/haz3lcore/dynamics/DHExp.re @@ -7,10 +7,10 @@ include Exp; -let term_of = ({term, _}) => term; -let fast_copy = (id, {term, _}) => {ids: [id], term, copied: true}; +let term_of: t => term = IdTagged.term_of; +let fast_copy: (Id.t, t) => t = IdTagged.fast_copy; -let mk = (ids, term) => { +let mk = (ids, term): t => { {ids, copied: true, term}; }; @@ -92,7 +92,8 @@ let rec strip_casts = _, ); -let rec fast_equal = ({term: d1, _} as d1exp, {term: d2, _} as d2exp): bool => { +let rec fast_equal = + ({term: d1, _} as d1exp: t, {term: d2, _} as d2exp: t): bool => { switch (d1, d2) { /* Primitive forms: regular structural equality */ | (Var(_), _) diff --git a/src/haz3lcore/lang/term/IdTagged.re b/src/haz3lcore/lang/term/IdTagged.re new file mode 100644 index 0000000000..224968319c --- /dev/null +++ b/src/haz3lcore/lang/term/IdTagged.re @@ -0,0 +1,30 @@ +include Sexplib.Std; + +[@deriving (show({with_path: false}), sexp, yojson)] +type t('a) = { + ids: list(Id.t), + /* UExp invariant: copied should always be false, and the id should be unique + DHExp invariant: if copied is true, then this term and its children may not + have unique ids. */ + copied: bool, + term: 'a, +}; + +let fresh = term => { + {ids: [Id.mk()], copied: false, term}; +}; + +let term_of = x => x.term; +let unwrap = x => (x.term, term' => {...x, term: term'}); +let rep_id = ({ids, _}) => List.hd(ids); +let fast_copy = (id, {term, _}) => {ids: [id], term, copied: true}; + +// let serialization = (f1, f2) => +// StructureShareSexp.structure_share_here( +// rep_id, +// sexp_of_t(f1), +// t_of_sexp(f2), +// ); + +// let sexp_of_t = f1 => serialization(f1, Obj.magic()) |> fst; +// let t_of_sexp = f2 => serialization(Obj.magic(), f2) |> snd; diff --git a/src/haz3lcore/statics/MakeTerm.re b/src/haz3lcore/statics/MakeTerm.re index a7b171d595..8f487d819b 100644 --- a/src/haz3lcore/statics/MakeTerm.re +++ b/src/haz3lcore/statics/MakeTerm.re @@ -104,8 +104,8 @@ let return = (wrap, ids, tm) => { let parse_sum_term: UTyp.t => UTyp.variant = fun - | {term: Var(ctr), ids} => Variant(ctr, ids, None) - | {term: Ap({term: Var(ctr), ids: ids_ctr}, u), ids: ids_ap} => + | {term: Var(ctr), ids, _} => Variant(ctr, ids, None) + | {term: Ap({term: Var(ctr), ids: ids_ctr, _}, u), ids: ids_ap, _} => Variant(ctr, ids_ctr @ ids_ap, Some(u)) | t => BadEntry(t); @@ -165,7 +165,7 @@ and exp_term: unsorted => (UExp.term, list(Id.t)) = { | term => ret(ListLit([term])) } | (["test", "end"], [Exp(test)]) => ret(Test(test)) - | (["case", "end"], [Rul({ids, term: Rules(scrut, rules)})]) => ( + | (["case", "end"], [Rul({ids, term: Rules(scrut, rules), _})]) => ( Match(scrut, rules), ids, ) @@ -270,7 +270,7 @@ and exp_term: unsorted => (UExp.term, list(Id.t)) = { and pat = unsorted => { let (term, inner_ids) = pat_term(unsorted); let ids = ids(unsorted) @ inner_ids; - return(p => Pat(p), ids, {ids, term}); + return(p => Pat(p), ids, {ids, term, copied: false}); } and pat_term: unsorted => (UPat.term, list(Id.t)) = { let ret = (term: UPat.term) => (term, []); @@ -337,7 +337,7 @@ and pat_term: unsorted => (UPat.term, list(Id.t)) = { and typ = unsorted => { let (term, inner_ids) = typ_term(unsorted); let ids = ids(unsorted) @ inner_ids; - return(ty => Typ(ty), ids, {ids, term}); + return(ty => Typ(ty), ids, {ids, term, copied: false}); } and typ_term: unsorted => (UTyp.term, list(Id.t)) = { let ret = (term: UTyp.term) => (term, []); @@ -370,7 +370,7 @@ and typ_term: unsorted => (UTyp.term, list(Id.t)) = { } | Pre(([(_id, (["rec", "->"], [TPat(tpat)]))], []), Typ(t)) => ret(Rec(tpat, t)) - | Pre(tiles, Typ({term: Sum(t0), ids})) as tm => + | Pre(tiles, Typ({term: Sum(t0), ids, _})) as tm => /* Case for leading prefix + preceeding a sum */ switch (tiles) { | ([(_, (["+"], []))], []) => (Sum(t0), ids) @@ -401,7 +401,7 @@ and typ_term: unsorted => (UTyp.term, list(Id.t)) = { and tpat = unsorted => { let term = tpat_term(unsorted); let ids = ids(unsorted); - return(ty => TPat(ty), ids, {ids, term}); + return(ty => TPat(ty), ids, {ids, term, copied: false}); } and tpat_term: unsorted => TPat.term = { let ret = (term: TPat.term) => term; @@ -440,12 +440,13 @@ and rul = (unsorted: unsorted): Rul.t => { ids: ids(unsorted), term: Rules(scrut, List.combine(ps, leading_clauses @ [last_clause])), + copied: false, } - | None => {ids: ids(unsorted), term: hole} + | None => {ids: ids(unsorted), term: hole, copied: false} } - | _ => {ids: ids(unsorted), term: hole} + | _ => {ids: ids(unsorted), term: hole, copied: false} } - | e => {ids: [], term: Rules(e, [])} + | e => {ids: [], term: Rules(e, []), copied: false} }; } diff --git a/src/haz3lcore/statics/Statics.re b/src/haz3lcore/statics/Statics.re index 60b42c6e6b..263ff23065 100644 --- a/src/haz3lcore/statics/Statics.re +++ b/src/haz3lcore/statics/Statics.re @@ -34,6 +34,9 @@ module Map = { [@deriving (show({with_path: false}), sexp, yojson)] type t = Id.Map.t(Info.t); + // let (sexp_of_t, t_of_sexp) = + // StructureShareSexp.structure_share_in(sexp_of_t, t_of_sexp); + let error_ids = (term_ranges: TermRanges.t, info_map: t): list(Id.t) => Id.Map.fold( (id, info, acc) => @@ -493,7 +496,7 @@ and upat_to_info_map = ~co_ctx, ~ancestors: Info.ancestors, ~mode: Mode.t=Mode.Syn, - {ids, term} as upat: UPat.t, + {ids, term, _} as upat: UPat.t, m: Map.t, ) : (Info.pat, Map.t) => { @@ -582,7 +585,7 @@ and utyp_to_info_map = ~ctx, ~expects=Info.TypeExpected, ~ancestors, - {ids, term} as utyp: UTyp.t, + {ids, term, _} as utyp: UTyp.t, m: Map.t, ) : (Info.typ, Map.t) => { @@ -666,7 +669,7 @@ and utyp_to_info_map = }; } and utpat_to_info_map = - (~ctx, ~ancestors, {ids, term} as utpat: TPat.t, m: Map.t) + (~ctx, ~ancestors, {ids, term, _} as utpat: TPat.t, m: Map.t) : (Info.tpat, Map.t) => { let add = m => { let info = Info.derived_tpat(~utpat, ~ctx, ~ancestors); @@ -696,7 +699,7 @@ and variant_to_info_map = List.mem(ctr, ctrs) ? Duplicate : Unique, ty_sum, ), - {term: Var(ctr), ids}, + {term: Var(ctr), ids, copied: false}, m, ) |> snd; diff --git a/src/haz3lcore/statics/Term.re b/src/haz3lcore/statics/Term.re index 98339de3a9..9d3ba02baa 100644 --- a/src/haz3lcore/statics/Term.re +++ b/src/haz3lcore/statics/Term.re @@ -8,7 +8,7 @@ module TPat = { include TermBase.TPat; - let rep_id = ({ids, _}) => { + let rep_id = ({ids, _}: t) => { assert(ids != []); List.hd(ids); }; @@ -206,14 +206,11 @@ module Pat = { List.hd(ids); }; - let term_of = ({term, _}) => term; - // All children of term must have expression-unique ids. + let term_of: t => TermBase.Pat.term = IdTagged.term_of; - let unwrap = ({ids, term}) => (term, term => {ids, term}); + let unwrap: t => (term, term => t) = IdTagged.unwrap; - let fresh = term => { - {ids: [Id.mk()], term}; - }; + let fresh: term => t = IdTagged.fresh; let hole = (tms: list(TermBase.Any.t)) => switch (tms) { @@ -455,19 +452,9 @@ module Exp = { | [_, ..._] => MultiHole(tms) }; - let rep_id = ({ids, _}) => { - assert(ids != []); - List.hd(ids); - }; - - let fresh = term => { - {ids: [Id.mk()], copied: false, term}; - }; - - let unwrap = ({ids, term, copied}) => ( - term, - term => {ids, term, copied}, - ); + let rep_id: t => Id.t = IdTagged.rep_id; + let fresh: term => t = IdTagged.fresh; + let unwrap: t => (term, term => t) = IdTagged.unwrap; let cls_of_term: term => cls = fun @@ -634,7 +621,7 @@ module Rul = { // example of awkwardness induced by having forms like rules // that may have a different-sorted child with no delimiters // (eg scrut with no rules) - let ids = (~any_ids, {ids, term}: t) => + let ids = (~any_ids, {ids, term, _}: t) => switch (ids) { | [_, ..._] => ids | [] => diff --git a/src/haz3lcore/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index c52a482210..32ee933e97 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -118,15 +118,7 @@ and Exp: { | BuiltinFun(string) | Match(t, list((Pat.t, t))) | Cast(t, Typ.t, Typ.t) - and t = { - // invariant: ids should be nonempty - ids: list(Id.t), - /* UExp invariant: copied should always be false, and the id should be unique - DHExp invariant: if copied is true, then this term and its children may not - have unique ids. */ - copied: bool, - term, - }; + and t = IdTagged.t(term); let map_term: ( @@ -179,12 +171,7 @@ and Exp: { | BuiltinFun(string) /// Doesn't currently have a distinguishable syntax | Match(t, list((Pat.t, t))) | Cast(t, Typ.t, Typ.t) - and t = { - // invariant: nonempty - ids: list(Id.t), - copied: bool, - term, - }; + and t = IdTagged.t(term); let map_term = ( @@ -215,7 +202,7 @@ and Exp: { ~f_rul, ~f_any, ); - let rec_call = ({term, _} as exp) => { + let rec_call = ({term, _} as exp: t) => { ...exp, term: switch (term) { @@ -288,10 +275,7 @@ and Pat: { | Parens(t) | Ap(t, t) | TypeAnn(t, TypTerm.t) - and t = { - ids: list(Id.t), - term, - }; + and t = IdTagged.t(term); let map_term: ( @@ -323,10 +307,7 @@ and Pat: { | Parens(t) | Ap(t, t) | TypeAnn(t, TypTerm.t) - and t = { - ids: list(Id.t), - term, - }; + and t = IdTagged.t(term); let map_term = ( @@ -344,7 +325,7 @@ and Pat: { TypTerm.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); let any_map_term = Any.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); - let rec_call = ({term, _} as exp) => { + let rec_call = ({term, _} as exp: t) => { ...exp, term: switch (term) { @@ -390,10 +371,7 @@ and TypTerm: { and variant = | Variant(Constructor.t, list(Id.t), option(t)) // What are the ids for? | BadEntry(t) - and t = { - ids: list(Id.t), - term, - }; + and t = IdTagged.t(term); let map_term: ( @@ -427,10 +405,7 @@ and TypTerm: { and variant = | Variant(Constructor.t, list(Id.t), option(t)) | BadEntry(t) - and t = { - ids: list(Id.t), - term, - }; + and t = IdTagged.t(term); let map_term = ( @@ -448,7 +423,7 @@ and TypTerm: { Any.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); let tpat_map_term = TPat.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); - let rec_call = ({term, _} as exp) => { + let rec_call = ({term, _} as exp: t) => { ...exp, term: switch (term) { @@ -488,10 +463,7 @@ and TPat: { | EmptyHole | MultiHole(list(Any.t)) | Var(string) - and t = { - ids: list(Id.t), - term, - }; + and t = IdTagged.t(term); let map_term: ( @@ -511,10 +483,7 @@ and TPat: { | EmptyHole | MultiHole(list(Any.t)) | Var(string) - and t = { - ids: list(Id.t), - term, - }; + and t = IdTagged.t(term); let map_term = ( @@ -528,7 +497,7 @@ and TPat: { ) => { let any_map_term = Any.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); - let rec_call = ({term, _} as exp) => { + let rec_call = ({term, _} as exp: t) => { ...exp, term: switch (term) { @@ -547,10 +516,7 @@ and Rul: { | Invalid(string) | Hole(list(Any.t)) | Rules(Exp.t, list((Pat.t, Exp.t))) - and t = { - ids: list(Id.t), - term, - }; + and t = IdTagged.t(term); let map_term: ( @@ -569,10 +535,7 @@ and Rul: { | Invalid(string) | Hole(list(Any.t)) | Rules(Exp.t, list((Pat.t, Exp.t))) - and t = { - ids: list(Id.t), - term, - }; + and t = IdTagged.t(term); let map_term = ( @@ -590,7 +553,7 @@ and Rul: { Pat.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); let any_map_term = Any.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); - let rec_call = ({term, _} as exp) => { + let rec_call = ({term, _} as exp: t) => { ...exp, term: switch (term) { diff --git a/src/haz3lcore/statics/TypBase.re b/src/haz3lcore/statics/TypBase.re index dca08452a2..844bbfc794 100644 --- a/src/haz3lcore/statics/TypBase.re +++ b/src/haz3lcore/statics/TypBase.re @@ -42,10 +42,7 @@ module rec Typ: { | Ap(t, t) | Rec(string, t) and sum_map = ConstructorMap.t(option(t)) - and t = { - ids: list(Id.t), - term, - }; + and t = IdTagged.t(term); [@deriving (show({with_path: false}), sexp, yojson)] type sum_entry = ConstructorMap.binding(option(t)); @@ -114,19 +111,11 @@ module rec Typ: { | Ap(t, t) | Rec(string, t) and sum_map = ConstructorMap.t(option(t)) - and t = { - ids: list(Id.t), - term, - }; - - let term_of = ({term, _}) => term; - // All children of term must have expression-unique ids. + and t = IdTagged.t(term); - let unwrap = ({ids, term}) => (term, term => {ids, term}); - - let fresh = term => { - {ids: [Id.mk()], term}; - }; + let term_of: t => term = IdTagged.term_of; + let unwrap: t => (term, term => t) = IdTagged.unwrap; + let fresh: term => t = IdTagged.fresh; [@deriving (show({with_path: false}), sexp, yojson)] type sum_entry = ConstructorMap.binding(option(t)); diff --git a/src/haz3lcore/zipper/EditorUtil.re b/src/haz3lcore/zipper/EditorUtil.re index 2ce51611c3..dfcdabd663 100644 --- a/src/haz3lcore/zipper/EditorUtil.re +++ b/src/haz3lcore/zipper/EditorUtil.re @@ -41,47 +41,53 @@ let editors_of_strings = (~read_only=false, xs: list(string)) => { (i, List.map(((_, oe)) => Option.get(oe), aes)); }; -let rec append_exp = (e1: Exp.t, e2: Exp.t) => { - switch (e1.term) { - | EmptyHole - | Invalid(_) - | MultiHole(_) - | StaticErrorHole(_) - | DynamicErrorHole(_) - | FailedCast(_) - | Bool(_) - | Int(_) - | Float(_) - | String(_) - | ListLit(_) - | Constructor(_) - | Closure(_) - | Fun(_) - | FixF(_) - | Tuple(_) - | Var(_) - | Ap(_) - | If(_) - | Test(_) - | Parens(_) - | Cons(_) - | ListConcat(_) - | UnOp(_) - | BinOp(_) - | BuiltinFun(_) - | Cast(_) - | Match(_) => Exp.{ids: [Id.mk()], copied: false, term: Seq(e1, e2)} - | Seq(e11, e12) => - let e12' = append_exp(e12, e2); - Exp.{ids: e1.ids, copied: false, term: Seq(e11, e12')}; - | Filter(kind, ebody) => - let ebody' = append_exp(ebody, e2); - Exp.{ids: e1.ids, copied: false, term: Filter(kind, ebody')}; - | Let(p, edef, ebody) => - let ebody' = append_exp(ebody, e2); - Exp.{ids: e1.ids, copied: false, term: Let(p, edef, ebody')}; - | TyAlias(tp, tdef, ebody) => - let ebody' = append_exp(ebody, e2); - Exp.{ids: e1.ids, copied: false, term: TyAlias(tp, tdef, ebody')}; - }; +let rec append_exp = { + Exp.( + (e1: Exp.t, e2: Exp.t) => ( + { + switch (e1.term) { + | EmptyHole + | Invalid(_) + | MultiHole(_) + | StaticErrorHole(_) + | DynamicErrorHole(_) + | FailedCast(_) + | Bool(_) + | Int(_) + | Float(_) + | String(_) + | ListLit(_) + | Constructor(_) + | Closure(_) + | Fun(_) + | FixF(_) + | Tuple(_) + | Var(_) + | Ap(_) + | If(_) + | Test(_) + | Parens(_) + | Cons(_) + | ListConcat(_) + | UnOp(_) + | BinOp(_) + | BuiltinFun(_) + | Cast(_) + | Match(_) => Exp.{ids: [Id.mk()], copied: false, term: Seq(e1, e2)} + | Seq(e11, e12) => + let e12' = append_exp(e12, e2); + {ids: e1.ids, copied: false, term: Seq(e11, e12')}; + | Filter(kind, ebody) => + let ebody' = append_exp(ebody, e2); + {ids: e1.ids, copied: false, term: Filter(kind, ebody')}; + | Let(p, edef, ebody) => + let ebody' = append_exp(ebody, e2); + {ids: e1.ids, copied: false, term: Let(p, edef, ebody')}; + | TyAlias(tp, tdef, ebody) => + let ebody' = append_exp(ebody, e2); + {ids: e1.ids, copied: false, term: TyAlias(tp, tdef, ebody')}; + }; + }: Exp.t + ) + ); }; diff --git a/src/haz3lweb/util/WorkerClient.re b/src/haz3lweb/util/WorkerClient.re index 92faffe6a9..bb87fc5ada 100644 --- a/src/haz3lweb/util/WorkerClient.re +++ b/src/haz3lweb/util/WorkerClient.re @@ -46,6 +46,8 @@ let request = setupWorkerMessageHandler(workerRef.contents); + // print_endline(Request.serialize(req)); + workerRef.contents##postMessage(Request.serialize(req)); let onTimeout = (): unit => { diff --git a/src/test/Test_Elaboration.re b/src/test/Test_Elaboration.re index 13c64d9e5c..ff961c83ba 100644 --- a/src/test/Test_Elaboration.re +++ b/src/test/Test_Elaboration.re @@ -58,9 +58,10 @@ let u4: UExp.t = { ids: [id_at(1)], term: Tuple([ - {ids: [id_at(2)], term: Var("a")}, - {ids: [id_at(3)], term: Var("b")}, + {ids: [id_at(2)], term: Var("a"), copied: false}, + {ids: [id_at(3)], term: Var("b"), copied: false}, ]), + copied: false, }, { ids: [id_at(4)], @@ -147,7 +148,7 @@ let u7: UExp.t = { copied: false, term: Fun( - {ids: [id_at(2)], term: Var("x")}, + {ids: [id_at(2)], term: Var("x"), copied: false}, { ids: [id_at(3)], copied: false, @@ -212,11 +213,11 @@ let u8: UExp.t = { }, [ ( - {ids: [id_at(6)], term: Bool(true)}, + {ids: [id_at(6)], copied: false, term: Bool(true)}, {ids: [id_at(4)], copied: false, term: Int(24)}, ), ( - {ids: [id_at(7)], term: Bool(false)}, + {ids: [id_at(7)], copied: false, term: Bool(false)}, {ids: [id_at(5)], copied: false, term: Bool(false)}, ), ], @@ -245,16 +246,18 @@ let u9: UExp.t = { Let( { ids: [id_at(1)], + copied: false, term: TypeAnn( - {ids: [id_at(2)], term: Var("f")}, + {ids: [id_at(2)], copied: false, term: Var("f")}, { ids: [id_at(3)], term: Arrow( - {ids: [id_at(4)], term: Int}, - {ids: [id_at(5)], term: Int}, + {ids: [id_at(4)], copied: false, term: Int}, + {ids: [id_at(5)], copied: false, term: Int}, ), + copied: false, }, ), }, @@ -263,7 +266,7 @@ let u9: UExp.t = { copied: false, term: Fun( - {ids: [id_at(7)], term: Var("x")}, + {ids: [id_at(7)], copied: false, term: Var("x")}, { ids: [id_at(8)], copied: false, From ba44262c658695a02b09912a4ec70c2aad096c6b Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Fri, 29 Mar 2024 15:41:34 -0400 Subject: [PATCH 061/103] Fix #1150 for constructors --- src/haz3lcore/dynamics/Builtins.re | 5 +- src/haz3lcore/dynamics/PatternMatch.re | 203 ++++++------ src/haz3lcore/dynamics/Transition.re | 17 +- src/haz3lcore/statics/ConstructorMap.re | 352 ++++++++++++++++----- src/haz3lcore/statics/Mode.re | 2 +- src/haz3lcore/statics/Term.re | 31 +- src/haz3lcore/statics/TypBase.re | 82 ++--- src/haz3lweb/view/Type.re | 14 +- src/haz3lweb/view/dhcode/layout/HTypDoc.re | 24 +- src/util/ListUtil.re | 7 + 10 files changed, 472 insertions(+), 265 deletions(-) diff --git a/src/haz3lcore/dynamics/Builtins.re b/src/haz3lcore/dynamics/Builtins.re index 78ee208b5b..aeed8bd77f 100644 --- a/src/haz3lcore/dynamics/Builtins.re +++ b/src/haz3lcore/dynamics/Builtins.re @@ -350,7 +350,10 @@ module Pervasives = { }; let ctx_init: Ctx.t = { - let meta_cons_map = ConstructorMap.of_list([("$e", None), ("$v", None)]); + let meta_cons_map: ConstructorMap.t(Typ.t) = [ + Variant("$e", [Id.mk()], None), + Variant("$v", [Id.mk()], None), + ]; let meta = Ctx.TVarEntry({ name: "$Meta", diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index 1a2b43dfe7..6308461a77 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -7,26 +7,28 @@ type match_result = let const_unknown: 'a => Typ.t = _ => Unknown(Internal) |> Typ.fresh; -let cast_sum_maps = - (sm1: Typ.sum_map, sm2: Typ.sum_map) - : option(ConstructorMap.t((Typ.t, Typ.t))) => { - let (ctrs1, tys1) = sm1 |> ConstructorMap.bindings |> List.split; - let (ctrs2, tys2) = sm2 |> ConstructorMap.bindings |> List.split; - if (ctrs1 == ctrs2) { - let tys1 = tys1 |> List.filter(Option.is_some) |> List.map(Option.get); - let tys2 = tys2 |> List.filter(Option.is_some) |> List.map(Option.get); - if (List.length(tys1) == List.length(tys2)) { - Some( - List.(combine(tys1, tys2) |> combine(ctrs1)) - |> ConstructorMap.of_list, - ); - } else { - None; - }; - } else { - None; - }; -}; +let cast_sum_maps = (_, _) => None; // TODO[Matt]: Fix + +// let cast_sum_maps = +// (sm1: Typ.sum_map, sm2: Typ.sum_map) +// : option(ConstructorMap.t((Typ.t, Typ.t))) => { +// let (ctrs1, tys1) = sm1 |> ConstructorMap.bindings |> List.split; +// let (ctrs2, tys2) = sm2 |> ConstructorMap.bindings |> List.split; +// if (ctrs1 == ctrs2) { +// let tys1 = tys1 |> List.filter(Option.is_some) |> List.map(Option.get); +// let tys2 = tys2 |> List.filter(Option.is_some) |> List.map(Option.get); +// if (List.length(tys1) == List.length(tys2)) { +// Some( +// List.(combine(tys1, tys2) |> combine(ctrs1)) +// |> ConstructorMap.of_list, +// ); +// } else { +// None; +// }; +// } else { +// None; +// }; +// }; let rec matches = (dp: Pat.t, d: DHExp.t): match_result => switch (DHPat.term_of(dp), DHExp.term_of(d)) { @@ -254,88 +256,89 @@ let rec matches = (dp: Pat.t, d: DHExp.t): match_result => } and matches_cast_Sum = ( - ctr: string, - dp: option(Pat.t), - d: DHExp.t, - castmaps: list(ConstructorMap.t((Typ.t, Typ.t))), + _ctr: string, + _dp: option(Pat.t), + _d: DHExp.t, + _castmaps: list(ConstructorMap.t((Typ.t, Typ.t))), ) : match_result => - switch (DHExp.term_of(d)) { - | Parens(d) => matches_cast_Sum(ctr, dp, d, castmaps) - | Constructor(ctr') => - switch ( - dp, - castmaps |> List.map(ConstructorMap.find_opt(ctr')) |> OptUtil.sequence, - ) { - | (None, Some(_)) => - ctr == ctr' ? Matches(Environment.empty) : DoesNotMatch - | _ => DoesNotMatch - } - | Ap(_, d1, d2) => - switch (DHExp.term_of(d1)) { - | Constructor(ctr') => - switch ( - dp, - castmaps - |> List.map(ConstructorMap.find_opt(ctr')) - |> OptUtil.sequence, - ) { - | (Some(dp), Some(side_casts)) => - matches(dp, DHExp.apply_casts(d2, side_casts)) - | _ => DoesNotMatch - } - | _ => IndetMatch - } - | Cast( - d', - {term: Sum(sm1) | Rec(_, {term: Sum(sm1), _}), _}, - {term: Sum(sm2) | Rec(_, {term: Sum(sm2), _}), _}, - ) => - switch (cast_sum_maps(sm1, sm2)) { - | Some(castmap) => matches_cast_Sum(ctr, dp, d', [castmap, ...castmaps]) - | None => DoesNotMatch - } - | Cast( - d', - {term: Sum(_) | Rec(_, {term: Sum(_), _}), _}, - {term: Unknown(_), _}, - ) - | Cast( - d', - {term: Unknown(_), _}, - {term: Sum(_) | Rec(_, {term: Sum(_), _}), _}, - ) => - matches_cast_Sum(ctr, dp, d', castmaps) - | Invalid(_) - | Let(_) - | UnOp(_) - | BinOp(_) - | EmptyHole - | MultiHole(_) - | StaticErrorHole(_) - | FailedCast(_, _, _) - | Test(_) - | DynamicErrorHole(_) - | Match(_) - | If(_) - | TyAlias(_) - | BuiltinFun(_) => IndetMatch - | Cast(_) - | Var(_) - | FixF(_) - | Fun(_) - | Bool(_) - | Int(_) - | Float(_) - | String(_) - | ListLit(_) - | Tuple(_) - | Seq(_, _) - | Closure(_) - | Filter(_) - | Cons(_) - | ListConcat(_) => DoesNotMatch - } + IndetMatch // TODO[Matt]: fix +// switch (DHExp.term_of(d)) { +// | Parens(d) => matches_cast_Sum(ctr, dp, d, castmaps) +// | Constructor(ctr') => +// switch ( +// dp, +// castmaps |> List.map(ConstructorMap.find_opt(ctr')) |> OptUtil.sequence, +// ) { +// | (None, Some(_)) => +// ctr == ctr' ? Matches(Environment.empty) : DoesNotMatch +// | _ => DoesNotMatch +// } +// | Ap(_, d1, d2) => +// switch (DHExp.term_of(d1)) { +// | Constructor(ctr') => +// switch ( +// dp, +// castmaps +// |> List.map(ConstructorMap.find_opt(ctr')) +// |> OptUtil.sequence, +// ) { +// | (Some(dp), Some(side_casts)) => +// matches(dp, DHExp.apply_casts(d2, side_casts)) +// | _ => DoesNotMatch +// } +// | _ => IndetMatch +// } +// | Cast( +// d', +// {term: Sum(sm1) | Rec(_, {term: Sum(sm1), _}), _}, +// {term: Sum(sm2) | Rec(_, {term: Sum(sm2), _}), _}, +// ) => +// switch (cast_sum_maps(sm1, sm2)) { +// | Some(castmap) => matches_cast_Sum(ctr, dp, d', [castmap, ...castmaps]) +// | None => DoesNotMatch +// } +// | Cast( +// d', +// {term: Sum(_) | Rec(_, {term: Sum(_), _}), _}, +// {term: Unknown(_), _}, +// ) +// | Cast( +// d', +// {term: Unknown(_), _}, +// {term: Sum(_) | Rec(_, {term: Sum(_), _}), _}, +// ) => +// matches_cast_Sum(ctr, dp, d', castmaps) +// | Invalid(_) +// | Let(_) +// | UnOp(_) +// | BinOp(_) +// | EmptyHole +// | MultiHole(_) +// | StaticErrorHole(_) +// | FailedCast(_, _, _) +// | Test(_) +// | DynamicErrorHole(_) +// | Match(_) +// | If(_) +// | TyAlias(_) +// | BuiltinFun(_) => IndetMatch +// | Cast(_) +// | Var(_) +// | FixF(_) +// | Fun(_) +// | Bool(_) +// | Int(_) +// | Float(_) +// | String(_) +// | ListLit(_) +// | Tuple(_) +// | Seq(_, _) +// | Closure(_) +// | Filter(_) +// | Cons(_) +// | ListConcat(_) => DoesNotMatch +// } and matches_cast_Tuple = (dps: list(Pat.t), d: DHExp.t, elt_casts: list(list((Typ.t, Typ.t)))) : match_result => diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index c9dba7aeed..eb713505e3 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -92,19 +92,16 @@ module CastHelpers = { Prod(ListUtil.replicate(length, Typ.Unknown(Internal) |> Typ.fresh)) |> Typ.fresh, ); - let grounded_Sum = (sm: Typ.sum_map): ground_cases => { - let sm' = sm |> ConstructorMap.map(Option.map(const_unknown)); - NotGroundOrHole(Sum(sm') |> Typ.fresh); - }; + let grounded_Sum: unit => Typ.sum_map = + () => [BadEntry(Typ.fresh(Unknown(Internal)))]; let grounded_List = NotGroundOrHole(List(Unknown(Internal) |> Typ.fresh) |> Typ.fresh); let rec ground_cases_of = (ty: Typ.t): ground_cases => { - let is_ground_arg: option(Typ.t) => bool = + let is_hole: Typ.t => bool = fun - | None - | Some({term: Typ.Unknown(_), _}) => true - | Some(ty) => ground_cases_of(ty) == Ground; + | {term: Typ.Unknown(_), _} => true + | _ => false; switch (Typ.term_of(ty)) { | Unknown(_) => Hole | Bool @@ -128,8 +125,8 @@ module CastHelpers = { tys |> List.length |> grounded_Prod; } | Sum(sm) => - sm |> ConstructorMap.is_ground(is_ground_arg) - ? Ground : grounded_Sum(sm) + sm |> ConstructorMap.is_ground(is_hole) + ? Ground : NotGroundOrHole(Sum(grounded_Sum()) |> Typ.fresh) | Arrow(_, _) => grounded_Arrow | List(_) => grounded_List | Ap(_) => failwith("type application in dynamics") diff --git a/src/haz3lcore/statics/ConstructorMap.re b/src/haz3lcore/statics/ConstructorMap.re index c9ff0667dc..7cb3ff7b2a 100644 --- a/src/haz3lcore/statics/ConstructorMap.re +++ b/src/haz3lcore/statics/ConstructorMap.re @@ -2,100 +2,306 @@ open Util.OptUtil.Syntax; open Sexplib.Std; [@deriving (show({with_path: false}), sexp, yojson)] -type binding('a) = (Constructor.t, 'a); +type variant('a) = + | Variant(Constructor.t, list(Id.t), option('a)) + | BadEntry('a); [@deriving (show({with_path: false}), sexp, yojson)] -type t('a) = list(binding('a)); +type t('a) = list(variant('a)); -let compare = compare; +let equal_constructor = + (eq: ('a, 'a) => bool, x: variant('a), y: variant('a)): bool => + switch (x, y) { + | (Variant(ctr1, _, Some(x1)), Variant(ctr2, _, Some(y1))) => + Constructor.equal(ctr1, ctr2) && eq(x1, y1) + | (Variant(ctr1, _, None), Variant(ctr2, _, None)) => + Constructor.equal(ctr1, ctr2) + | (BadEntry(x), BadEntry(y)) => eq(x, y) + | (Variant(_), Variant(_)) + | (BadEntry(_), Variant(_)) + | (Variant(_), BadEntry(_)) => false + }; + +let same_constructor = + (eq: ('a, 'a) => bool, x: variant('a), y: variant('a)): bool => + switch (x, y) { + | (Variant(ctr1, _, _), Variant(ctr2, _, _)) => + Constructor.equal(ctr1, ctr2) + | (BadEntry(x), BadEntry(y)) => eq(x, y) + | (BadEntry(_), Variant(_)) + | (Variant(_), BadEntry(_)) => false + }; -let empty: t('a) = []; +let has_bad_entry = (x: t('a)): bool => + List.exists( + fun + | BadEntry(_) => true + | Variant(_) => false, + x, + ); -let is_empty: t('a) => bool = +let has_good_entry = (x: t('a)): bool => + List.exists( + fun + | BadEntry(_) => false + | Variant(_) => true, + x, + ); + +let free_variables = (f, m) => + m + |> List.map( + fun + | Variant(_, _, Some(value)) => f(value) + | _ => [], + ) + |> List.flatten; + +let is_ground = is_hole => fun - | [] => true + | [BadEntry(x)] when is_hole(x) => true | _ => false; -let rec add = (ctr: Constructor.t, value: 'a, map: t('a)): t('a) => - switch (map) { - | [] => [(ctr, value)] - | [(ctr', value') as head, ...tail] => - if (Constructor.equal(ctr, ctr')) { - if (value === value') { - map; - } else { - [(ctr, value), ...tail]; - }; - } else { - [head, ...add(ctr, value, tail)]; - } +/* computes all three regions of a venn diagram of two sets represented as lists */ +let venn_regions = + (f: ('a, 'a) => bool, xs: list('a), ys: list('a)) + : (list(('a, 'a)), list('a), list('a)) => { + let rec go = (xs, ys, acc, left, right) => + switch (xs) { + | [] => (acc |> List.rev, left |> List.rev, List.rev_append(right, ys)) + | [x, ...xs] => + switch (List.partition(f(x, _), ys)) { + | ([], _) => go(xs, ys, acc, [x, ...left], right) + | ([y], ys') => go(xs, ys', [(x, y), ...acc], left, right) + | _ => failwith("Sum type has non-unique constructors") + } + }; + go(xs, ys, [], [], []); +}; + +let join_entry = + (join: ('a, 'a) => option('a), (x: variant('a), y: variant('a))) + : option(variant('a)) => + switch (x, y) { + | (Variant(ctr1, ids1, Some(value1)), Variant(ctr2, _, Some(value2))) + when Constructor.equal(ctr1, ctr2) => + let+ value = join(value1, value2); + Variant(ctr1, ids1, Some(value)); + | (Variant(ctr1, ids1, None), Variant(ctr2, _, None)) + when Constructor.equal(ctr1, ctr2) => + Some(Variant(ctr1, ids1, None)) + | (BadEntry(x), BadEntry(y)) => + let+ value = join(x, y); + BadEntry(value); + | _ => None }; -let singleton = (ctr: Constructor.t, value: 'a): t('a) => [(ctr, value)]; - -let compare_bindings = - ((ctr1, _): binding('a), (ctr2, _): binding('a)): int => - compare(ctr1, ctr2); - -/* compares ctrs only */ -let equal = (val_equal: ('a, 'a) => bool, map1: t('a), map2: t('a)): bool => { - let equal_bindings = - ( - val_equal: ('a, 'a) => bool, - (ctr1, val1): binding('a), - (ctr2, val2): binding('a), - ) - : bool => - Constructor.equal(ctr1, ctr2) && val_equal(val1, val2); - map1 === map2 - || { - let map1 = List.fast_sort(compare_bindings, map1); - let map2 = List.fast_sort(compare_bindings, map2); - List.equal(equal_bindings(val_equal), map1, map2); +let join = + ( + eq: ('a, 'a) => bool, + join: ('a, 'a) => option('a), + m1: t('a), + m2: t('a), + ) + : option(t('a)) => { + let (inter, left, right) = venn_regions(same_constructor(eq), m1, m2); + let join_entries = List.filter_map(join_entry(join), inter); + if (List.length(join_entries) == List.length(inter)) { + switch ( + has_good_entry(left), + has_bad_entry(m1), + has_good_entry(right), + has_bad_entry(m2), + ) { + | (_, true, _, true) => Some(join_entries @ left @ right) + | (false, true, _, _) => Some(join_entries @ right) + | (_, _, false, true) => Some(join_entries @ left) + | _ when left == [] && right == [] => Some(join_entries) + | _ => None + }; + } else { + None; }; }; -let cardinal: t('a) => int = List.length; +let equal = (eq: ('a, 'a) => bool, m1: t('a), m2: t('a)) => { + switch (venn_regions(same_constructor(eq), m1, m2)) { + | (inter, [], []) => + List.for_all( + ((x, y)) => + switch (x, y) { + | (Variant(_, _, Some(value1)), Variant(_, _, Some(value2))) => + eq(value1, value2) + | (BadEntry(x), BadEntry(y)) => eq(x, y) + | _ => false + }, + inter, + ) + | _ => false + }; +}; -let ctrs_of = (m: list((Constructor.t, 'a))): list(Constructor.t) => - List.map(fst, m); +// let get_valid_variants = +// List.filter_map( +// fun +// | Variant(ctr, ids, value) => Some((ctr, ids, value)) +// | BadEntry(_) => None, +// _, +// ); +// let compare_valid_variants = ((ctr1, _, _), (ctr2, _, _)) => +// String.compare(ctr1, ctr2); -let same_constructors_same_order = (map1: t('a), map2: t('a)): bool => - cardinal(map1) === cardinal(map2) - && List.for_all2(Constructor.equal, ctrs_of(map1), ctrs_of(map2)); +// let join = +// (f: ('a, 'a) => option('a), m1: t('a), m2: t('a)): option(t('a)) => { +// let join_sum_entries = ((ctr1, ids1, ty1), (ctr2, _, ty2)) => +// switch (ty1, ty2) { +// | (None, None) when ctr1 == ctr2 => Some((ctr1, ids1, None)) +// | (Some(ty1), Some(ty2)) when ctr1 == ctr2 => +// let+ ty_join = f(ty1, ty2); +// (ctr1, ids1, Some(ty_join)); +// | _ => None +// }; +// let map1 = m1 |> get_valid_variants; +// let map2 = m2 |> get_valid_variants; +// /* If same order, retain order for UI */ +// let same_constructors_same_order = { +// List.length(map1) === List.length(map2) +// && List.for_all2( +// (x, y) => compare_valid_variants(x, y) == 0, +// map1, +// map2, +// ); +// }; +// let map1 = +// same_constructors_same_order +// ? map1 |> List.fast_sort(compare_valid_variants) : map1; +// let map2 = +// same_constructors_same_order +// ? map2 |> List.fast_sort(compare_valid_variants) : map2; +// if (List.length(map1) == List.length(map2)) { +// List.fold_left2( +// (acc, entry1, entry2) => +// switch (acc) { +// | Some(xs) => +// join_sum_entries(entry1, entry2) +// |> Option.map(x => List.append(xs, [x])) +// | None => None +// }, +// Some([]), +// map1, +// map2, +// ) +// |> Option.map(List.map(((a, b, c)) => Variant(a, b, c))); +// } else { +// None; +// }; +// }; -let ctrs_equal = (map1: t('a), map2: t('a)): bool => { - let ctrs1 = ctrs_of(map1); - let ctrs2 = ctrs_of(map2); - ctrs1 === ctrs2 - || List.fast_sort(compare, ctrs1) == List.fast_sort(compare, ctrs2); -}; +// let compare = compare; -let for_all: (binding('a) => bool, t('a)) => bool = List.for_all; +// let empty: t('a) = []; -let bindings: t('a) => list(binding('a)) = x => x; +// let is_empty: t('a) => bool = +// fun +// | [] => true +// | _ => false; -let find_opt = (ctr: Constructor.t, map: t('a)): option('a) => { - let+ binding = List.find_opt(((k, _)) => Constructor.equal(ctr, k), map); - snd(binding); -}; +// // let rec add = (ctr: Constructor.t, value: option('a), map: t('a)): t('a) => +// // switch (map) { +// // | [] => [(ctr, value)] +// // | [(ctr', value') as head, ...tail] => +// // if (Constructor.equal(ctr, ctr')) { +// // if (value === value') { +// // map; +// // } else { +// // [(ctr, value), ...tail]; +// // }; +// // } else { +// // [head, ...add(ctr, value, tail)]; +// // } +// // }; -let map = (f: 'a => 'b, m: t('a)): t('b) => { - let (ctrs, vals) = List.split(m); - let vals = List.map(f, vals); - List.combine(ctrs, vals); -}; +// // let singleton = (ctr: Constructor.t, value: option('a)): t('a) => [ +// // (ctr, value), +// // ]; -/* sorts on ctrs only */ -let sort = (map: t('a)): t('a) => { - List.fast_sort(compare_bindings, map); +// let compare_bindings = ((ctr1, _), (ctr2, _)): int => compare(ctr1, ctr2); + +// let to_bindings = +// List.filter_map( +// fun +// | Variant(ctr, _, value) => Some((ctr, value)) +// | BadEntry(_) => None, +// _, +// ); + +// /* compares ctrs only */ +// let equal = +// ( +// val_equal: (option('a), option('a)) => bool, +// map1: t('a), +// map2: t('a), +// ) +// : bool => { +// let equal_bindings = (val_equal, (ctr1, _, val1), (ctr2, _, val2)): bool => +// Constructor.equal(ctr1, ctr2) && val_equal(val1, val2); +// map1 === map2 +// || { +// let map1 = +// List.fast_sort(compare_valid_variants, map1 |> get_valid_variants); +// let map2 = +// List.fast_sort(compare_valid_variants, map2 |> get_valid_variants); +// List.equal(equal_bindings(val_equal), map1, map2); +// }; +// }; + +// let cardinal: t('a) => int = List.length; + +// let ctrs_of = (m): list(Constructor.t) => m |> to_bindings |> List.map(fst); + +// let same_constructors_same_order = (map1: t('a), map2: t('a)): bool => +// cardinal(map1) === cardinal(map2) +// && List.for_all2(Constructor.equal, ctrs_of(map1), ctrs_of(map2)); + +// let ctrs_equal = (map1: t('a), map2: t('a)): bool => { +// let ctrs1 = ctrs_of(map1); +// let ctrs2 = ctrs_of(map2); +// ctrs1 === ctrs2 +// || List.fast_sort(compare, ctrs1) == List.fast_sort(compare, ctrs2); +// }; + +// // let for_all: (binding('a) => bool, t('a)) => bool = List.for_all; + +// // let bindings: t('a) => list(binding('a)) = x => x; + +// // let find_opt = (ctr: Constructor.t, map: t('a)): option(option('a)) => { +// // let+ binding = +// // List.find_opt( +// // ((k, _)) => Constructor.equal(ctr, k), +// // map |> to_bindings, +// // ); +// // snd(binding); +// // }; + +let map = (f: option('a) => option('b), m: t('a)): t('b) => { + List.map( + fun + | Variant(ctr, args, value) => Variant(ctr, args, f(value)) + | BadEntry(value) => BadEntry(value), + m, + ); }; -let of_list: list(binding('a)) => t('a) = x => x; +// // /* sorts on ctrs only */ +// // let sort = (map: t('a)): t('a) => { +// // List.fast_sort(compare_bindings, map); +// // }; -let rec is_ground = (is_ground_value: 'a => bool, map: t('a)): bool => - switch (map) { - | [] => true - | [(_, head), ...tail] => - is_ground_value(head) && tail |> is_ground(is_ground_value) - }; +// // let of_list: list(binding('a)) => t('a) = x => x; + +// // let rec is_ground = (is_ground_value: 'a => bool, map: t('a)): bool => +// // switch (map) { +// // | [] => true +// // | [(_, head), ...tail] => +// // is_ground_value(head) && tail |> is_ground(is_ground_value) +// // }; diff --git a/src/haz3lcore/statics/Mode.re b/src/haz3lcore/statics/Mode.re index c9911ec411..48957f607e 100644 --- a/src/haz3lcore/statics/Mode.re +++ b/src/haz3lcore/statics/Mode.re @@ -87,7 +87,7 @@ let ctr_ana_typ = (ctx: Ctx.t, mode: t, ctr: Constructor.t): option(Typ.t) => { | Ana({term: Arrow(_, ty_ana), _}) | Ana(ty_ana) => let* ctrs = Typ.get_sum_constructors(ctx, ty_ana); - let+ (_, ty_entry) = Typ.sum_entry(ctr, ctrs); + let+ (_, _, ty_entry) = Typ.sum_entry(ctr, ctrs); switch (ty_entry) { | None => ty_ana | Some(ty_in) => Arrow(ty_in, ty_ana) |> Typ.fresh diff --git a/src/haz3lcore/statics/Term.re b/src/haz3lcore/statics/Term.re index 9d3ba02baa..67a083198e 100644 --- a/src/haz3lcore/statics/Term.re +++ b/src/haz3lcore/statics/Term.re @@ -1,3 +1,5 @@ +open Util; + module TPat = { [@deriving (show({with_path: false}), sexp, yojson)] type cls = @@ -162,20 +164,27 @@ module TypTerm = { ); Rec(name, to_typ(ctx, tbody)) |> Typ.fresh; } - and to_variant: - (Ctx.t, variant) => option(ConstructorMap.binding(option(Typ.t))) = + and to_variant: (Ctx.t, variant) => ConstructorMap.variant(Typ.t) = ctx => fun - | Variant(ctr, _, u) => Some((ctr, Option.map(to_typ(ctx), u))) - | BadEntry(_) => None + | Variant(ctr, ids, u) => + ConstructorMap.Variant(ctr, ids, Option.map(to_typ(ctx), u)) + | BadEntry(u) => ConstructorMap.BadEntry(to_typ(ctx, u)) and to_ctr_map = (ctx: Ctx.t, uts: list(variant)): Typ.sum_map => { - List.fold_left( - (acc, ut) => - List.find_opt(((ctr, _)) => ctr == fst(ut), acc) == None - ? acc @ [ut] : acc, - [], - List.filter_map(to_variant(ctx), uts), - ); + uts + |> List.map(to_variant(ctx)) + |> ListUtil.dedup_f( + ( + x: ConstructorMap.variant(Typ.t), + y: ConstructorMap.variant(Typ.t), + ) => + switch (x, y) { + | (Variant(c1, _, _), Variant(c2, _, _)) => c1 == c2 + | (Variant(_), BadEntry(_)) + | (BadEntry(_), Variant(_)) + | (BadEntry(_), BadEntry(_)) => false + } + ); }; }; diff --git a/src/haz3lcore/statics/TypBase.re b/src/haz3lcore/statics/TypBase.re index 844bbfc794..dd5fe2bfaf 100644 --- a/src/haz3lcore/statics/TypBase.re +++ b/src/haz3lcore/statics/TypBase.re @@ -41,11 +41,11 @@ module rec Typ: { | Parens(t) | Ap(t, t) | Rec(string, t) - and sum_map = ConstructorMap.t(option(t)) + and sum_map = ConstructorMap.t(t) and t = IdTagged.t(term); [@deriving (show({with_path: false}), sexp, yojson)] - type sum_entry = ConstructorMap.binding(option(t)); + type sum_entry = (Constructor.t, list(Id.t), option(Typ.t)); /* Hazel type annotated with a relevant source location. Currently used to track match branches for inconsistent @@ -110,7 +110,7 @@ module rec Typ: { | Parens(t) | Ap(t, t) | Rec(string, t) - and sum_map = ConstructorMap.t(option(t)) + and sum_map = ConstructorMap.t(t) and t = IdTagged.t(term); let term_of: t => term = IdTagged.term_of; @@ -118,7 +118,7 @@ module rec Typ: { let fresh: term => t = IdTagged.fresh; [@deriving (show({with_path: false}), sexp, yojson)] - type sum_entry = ConstructorMap.binding(option(t)); + type sum_entry = (Constructor.t, list(Id.t), option(Typ.t)); [@deriving (show({with_path: false}), sexp, yojson)] type source = { @@ -216,8 +216,7 @@ module rec Typ: { | (Prod(_), _) => false | (List(t1), List(t2)) => eq(t1, t2) | (List(_), _) => false - | (Sum(sm1), Sum(sm2)) => - ConstructorMap.equal(Option.equal(eq), sm1, sm2) + | (Sum(sm1), Sum(sm2)) => ConstructorMap.equal(eq, sm1, sm2) | (Sum(_), _) => false | (Var(n1), Var(n2)) => n1 == n2 | (Var(_), _) => false @@ -238,13 +237,7 @@ module rec Typ: { | List(ty) => free_vars(~bound, ty) | Ap(t1, t2) | Arrow(t1, t2) => free_vars(~bound, t1) @ free_vars(~bound, t2) - | Sum(sm) => - ListUtil.flat_map( - fun - | None => [] - | Some(typ) => free_vars(~bound, typ), - List.map(snd, sm), - ) + | Sum(sm) => ConstructorMap.free_variables(free_vars(~bound), sm) | Prod(tys) => ListUtil.flat_map(free_vars(~bound), tys) | Rec(x, ty) => free_vars(~bound=[x, ...bound], ty) }; @@ -319,19 +312,9 @@ module rec Typ: { Prod(tys) |> fresh; | (Prod(_), _) => None | (Sum(sm1), Sum(sm2)) => - let (sorted1, sorted2) = - /* If same order, retain order for UI */ - ConstructorMap.same_constructors_same_order(sm1, sm2) - ? (sm1, sm2) - : (ConstructorMap.sort(sm1), ConstructorMap.sort(sm2)); - let* ty = - ListUtil.map2_opt( - join_sum_entries(~resolve, ~fix, ctx), - sorted1, - sorted2, - ); - let+ ty = OptUtil.sequence(ty); - Sum(ty) |> fresh; + let+ sm' = + ConstructorMap.join(eq, join(~resolve, ~fix, ctx), sm1, sm2); + Sum(sm') |> fresh; | (Sum(_), _) => None | (List(ty1), List(ty2)) => let+ ty = join'(ty1, ty2); @@ -339,23 +322,7 @@ module rec Typ: { | (List(_), _) => None | (Ap(_), _) => failwith("Type join of ap") }; - } - and join_sum_entries = - ( - ~resolve, - ~fix, - ctx: Ctx.t, - (ctr1, ty1): sum_entry, - (ctr2, ty2): sum_entry, - ) - : option(sum_entry) => - switch (ty1, ty2) { - | (None, None) when ctr1 == ctr2 => Some((ctr1, None)) - | (Some(ty1), Some(ty2)) when ctr1 == ctr2 => - let+ ty_join = join(~resolve, ~fix, ctx, ty1, ty2); - (ctr1, Some(ty_join)); - | _ => None - }; + }; let join_fix = join(~fix=true); @@ -436,7 +403,8 @@ module rec Typ: { let sum_entry = (ctr: Constructor.t, ctrs: sum_map): option(sum_entry) => List.find_map( fun - | (t, typ) when Constructor.equal(t, ctr) => Some((t, typ)) + | ConstructorMap.Variant(t, ids, v) when Constructor.equal(t, ctr) => + Some((t, ids, v)) | _ => None, ctrs, ); @@ -597,17 +565,21 @@ and Ctx: { }; let add_ctrs = (ctx: t, name: string, id: Id.t, ctrs: Typ.sum_map): t => - List.map( - ((ctr, typ)) => - ConstructorEntry({ - name: ctr, - id, - typ: - switch (typ) { - | None => Var(name) |> Typ.fresh - | Some(typ) => Arrow(typ, Var(name) |> Typ.fresh) |> Typ.fresh - }, - }), + List.filter_map( + fun + | ConstructorMap.Variant(ctr, _, typ) => + Some( + ConstructorEntry({ + name: ctr, + id, + typ: + switch (typ) { + | None => Var(name) |> Typ.fresh + | Some(typ) => Arrow(typ, Var(name) |> Typ.fresh) |> Typ.fresh + }, + }), + ) + | ConstructorMap.BadEntry(_) => None, ctrs, ) @ ctx; diff --git a/src/haz3lweb/view/Type.re b/src/haz3lweb/view/Type.re index b4f5dad06e..4693808ab0 100644 --- a/src/haz3lweb/view/Type.re +++ b/src/haz3lweb/view/Type.re @@ -80,11 +80,15 @@ let rec view_ty = (ty: Haz3lcore.Typ.t): Node.t => ) | Ap(_) => failwith("type application in view") } -and ctr_view = ((ctr, typ)) => - switch (typ) { - | None => [text(ctr)] - | Some(typ) => [text(ctr ++ "("), view_ty(typ), text(")")] - }; +and ctr_view = + fun + | Variant(ctr, _, None) => [text(ctr)] + | Variant(ctr, _, Some(typ)) => [ + text(ctr ++ "("), + view_ty(typ), + text(")"), + ] + | BadEntry(typ) => [view_ty(typ)]; let view = (ty: Haz3lcore.Typ.t): Node.t => div_c("typ-wrapper", [view_ty(ty)]); diff --git a/src/haz3lweb/view/dhcode/layout/HTypDoc.re b/src/haz3lweb/view/dhcode/layout/HTypDoc.re index 28de6b83a0..1bb5662921 100644 --- a/src/haz3lweb/view/dhcode/layout/HTypDoc.re +++ b/src/haz3lweb/view/dhcode/layout/HTypDoc.re @@ -122,15 +122,21 @@ let rec mk = (~parenthesize=false, ~enforce_inline: bool, ty: Typ.t): t => { | Sum(sum_map) => let center = List.mapi( - (i, (ctr, ty)) => - switch (ty) { - | None => annot(HTypAnnot.Step(i + 1), text(ctr)) - | Some(ty) => - annot( - HTypAnnot.Step(i + 1), - hcats([text(ctr ++ "("), mk'(ty), text(")")]), - ) - }, + (i, vr) => { + ConstructorMap.( + switch (vr) { + | Variant(ctr, _, None) => + annot(HTypAnnot.Step(i + 1), text(ctr)) + | Variant(ctr, _, Some(ty)) => + annot( + HTypAnnot.Step(i + 1), + hcats([text(ctr ++ "("), mk'(ty), text(")")]), + ) + | BadEntry(ty) => + annot(HTypAnnot.Step(i + 1), hcats([mk'(ty)])) + } + ) + }, sum_map, ) |> ListUtil.join( diff --git a/src/util/ListUtil.re b/src/util/ListUtil.re index 69cf5d2577..629e83c876 100644 --- a/src/util/ListUtil.re +++ b/src/util/ListUtil.re @@ -7,6 +7,13 @@ let dedup = xs => [], ); +let dedup_f = (f, xs) => + List.fold_right( + (x, deduped) => List.exists(f(x), deduped) ? deduped : [x, ...deduped], + xs, + [], + ); + let are_duplicates = xs => List.length(List.sort_uniq(compare, xs)) == List.length(xs); From 4a4b7c24e80e89f92d4dea38718f3750cd658e68 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Tue, 2 Apr 2024 09:30:01 -0400 Subject: [PATCH 062/103] Update UTyp sums to match Typ --- src/haz3lcore/statics/MakeTerm.re | 2 +- src/haz3lcore/statics/Statics.re | 8 +++++++- src/haz3lcore/statics/Term.re | 6 ++++-- src/haz3lcore/statics/TermBase.re | 17 ++++++----------- src/haz3lcore/statics/TypBase.re | 6 ++++-- 5 files changed, 22 insertions(+), 17 deletions(-) diff --git a/src/haz3lcore/statics/MakeTerm.re b/src/haz3lcore/statics/MakeTerm.re index 8f487d819b..1b3e062814 100644 --- a/src/haz3lcore/statics/MakeTerm.re +++ b/src/haz3lcore/statics/MakeTerm.re @@ -102,7 +102,7 @@ let return = (wrap, ids, tm) => { tm; }; -let parse_sum_term: UTyp.t => UTyp.variant = +let parse_sum_term: UTyp.t => ConstructorMap.variant(UTyp.t) = fun | {term: Var(ctr), ids, _} => Variant(ctr, ids, None) | {term: Ap({term: Var(ctr), ids: ids_ctr, _}, u), ids: ids_ap, _} => diff --git a/src/haz3lcore/statics/Statics.re b/src/haz3lcore/statics/Statics.re index 263ff23065..362a393819 100644 --- a/src/haz3lcore/statics/Statics.re +++ b/src/haz3lcore/statics/Statics.re @@ -686,7 +686,13 @@ and utpat_to_info_map = }; } and variant_to_info_map = - (~ctx, ~ancestors, ~ty_sum, (m, ctrs), uty: UTyp.variant) => { + ( + ~ctx, + ~ancestors, + ~ty_sum, + (m, ctrs), + uty: ConstructorMap.variant(UTyp.t), + ) => { let go = expects => utyp_to_info_map(~ctx, ~ancestors, ~expects); switch (uty) { | BadEntry(uty) => diff --git a/src/haz3lcore/statics/Term.re b/src/haz3lcore/statics/Term.re index 67a083198e..95a8c4d98b 100644 --- a/src/haz3lcore/statics/Term.re +++ b/src/haz3lcore/statics/Term.re @@ -164,13 +164,15 @@ module TypTerm = { ); Rec(name, to_typ(ctx, tbody)) |> Typ.fresh; } - and to_variant: (Ctx.t, variant) => ConstructorMap.variant(Typ.t) = + and to_variant: + (Ctx.t, ConstructorMap.variant(t)) => ConstructorMap.variant(Typ.t) = ctx => fun | Variant(ctr, ids, u) => ConstructorMap.Variant(ctr, ids, Option.map(to_typ(ctx), u)) | BadEntry(u) => ConstructorMap.BadEntry(to_typ(ctx, u)) - and to_ctr_map = (ctx: Ctx.t, uts: list(variant)): Typ.sum_map => { + and to_ctr_map = + (ctx: Ctx.t, uts: list(ConstructorMap.variant(t))): Typ.sum_map => { uts |> List.map(to_variant(ctx)) |> ListUtil.dedup_f( diff --git a/src/haz3lcore/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index 32ee933e97..84480d9788 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -363,14 +363,11 @@ and TypTerm: { | Var(string) | List(t) | Arrow(t, t) - | Sum(list(variant)) + | Sum(ConstructorMap.t(t)) | Prod(list(t)) | Parens(t) | Ap(t, t) | Rec(TPat.t, t) - and variant = - | Variant(Constructor.t, list(Id.t), option(t)) // What are the ids for? - | BadEntry(t) and t = IdTagged.t(term); let map_term: @@ -397,14 +394,11 @@ and TypTerm: { | Var(string) | List(t) | Arrow(t, t) - | Sum(list(variant)) + | Sum(ConstructorMap.t(t)) | Prod(list(t)) | Parens(t) | Ap(t, t) | Rec(TPat.t, t) - and variant = - | Variant(Constructor.t, list(Id.t), option(t)) - | BadEntry(t) and t = IdTagged.t(term); let map_term = @@ -444,9 +438,10 @@ and TypTerm: { Sum( List.map( fun - | Variant(c, ids, t) => - Variant(c, ids, Option.map(typ_map_term, t)) - | BadEntry(t) => BadEntry(typ_map_term(t)), + | ConstructorMap.Variant(c, ids, t) => + ConstructorMap.Variant(c, ids, Option.map(typ_map_term, t)) + | ConstructorMap.BadEntry(t) => + ConstructorMap.BadEntry(typ_map_term(t)), variants, ), ) diff --git a/src/haz3lcore/statics/TypBase.re b/src/haz3lcore/statics/TypBase.re index dd5fe2bfaf..fad0886293 100644 --- a/src/haz3lcore/statics/TypBase.re +++ b/src/haz3lcore/statics/TypBase.re @@ -36,14 +36,16 @@ module rec Typ: { | Var(string) | List(t) | Arrow(t, t) - | Sum(sum_map) + | Sum(ConstructorMap.t(t)) | Prod(list(t)) | Parens(t) | Ap(t, t) | Rec(string, t) - and sum_map = ConstructorMap.t(t) and t = IdTagged.t(term); + [@deriving (show({with_path: false}), sexp, yojson)] + type sum_map = ConstructorMap.t(t); + [@deriving (show({with_path: false}), sexp, yojson)] type sum_entry = (Constructor.t, list(Id.t), option(Typ.t)); From 09cd50c3eba6bc988b6550f916a3e0335e3e8f24 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Tue, 2 Apr 2024 11:53:42 -0400 Subject: [PATCH 063/103] Merge Typ and UTyp --- src/haz3lcore/assistant/AssistantForms.re | 2 +- src/haz3lcore/dynamics/Builtins.re | 2 +- src/haz3lcore/lang/term/Cls.re | 4 +- src/haz3lcore/lang/term/Typ.re | 329 +++++++++++ src/haz3lcore/lang/term/TypTerm.re | 1 - src/haz3lcore/statics/ConstructorMap.re | 163 +----- src/haz3lcore/statics/Ctx.re | 161 ++++- src/haz3lcore/statics/Info.re | 8 +- src/haz3lcore/statics/Kind.re | 1 - src/haz3lcore/statics/MakeTerm.re | 2 +- src/haz3lcore/statics/Mode.re | 4 +- src/haz3lcore/statics/Statics.re | 8 +- src/haz3lcore/statics/Term.re | 91 ++- src/haz3lcore/statics/TermBase.re | 97 +-- src/haz3lcore/statics/Typ.re | 4 - src/haz3lcore/statics/TypBase.re | 649 --------------------- src/haz3lcore/statics/uterm/UTyp.re | 2 +- src/haz3lweb/view/ExplainThis.re | 12 +- src/haz3lweb/view/Kind.re | 2 +- src/haz3lweb/view/Type.re | 15 +- src/haz3lweb/view/dhcode/layout/HTypDoc.re | 18 +- 21 files changed, 644 insertions(+), 931 deletions(-) create mode 100644 src/haz3lcore/lang/term/Typ.re delete mode 100644 src/haz3lcore/lang/term/TypTerm.re delete mode 100644 src/haz3lcore/statics/Kind.re delete mode 100644 src/haz3lcore/statics/Typ.re delete mode 100644 src/haz3lcore/statics/TypBase.re diff --git a/src/haz3lcore/assistant/AssistantForms.re b/src/haz3lcore/assistant/AssistantForms.re index 01229b0807..47c44149a8 100644 --- a/src/haz3lcore/assistant/AssistantForms.re +++ b/src/haz3lcore/assistant/AssistantForms.re @@ -194,7 +194,7 @@ let suggest_form = (ty_map, delims_of_sort, ci: Info.t): list(Suggestion.t) => { let suggest_operator: Info.t => list(Suggestion.t) = suggest_form( - List.map(((a, b)) => (a, TypBase.Typ.fresh(b)), Typ.of_infix_delim), + List.map(((a, b)) => (a, IdTagged.fresh(b)), Typ.of_infix_delim), Delims.infix, ); diff --git a/src/haz3lcore/dynamics/Builtins.re b/src/haz3lcore/dynamics/Builtins.re index aeed8bd77f..6e39a79289 100644 --- a/src/haz3lcore/dynamics/Builtins.re +++ b/src/haz3lcore/dynamics/Builtins.re @@ -358,7 +358,7 @@ let ctx_init: Ctx.t = { Ctx.TVarEntry({ name: "$Meta", id: Id.invalid, - kind: Kind.Singleton(Sum(meta_cons_map) |> Typ.fresh), + kind: Ctx.Singleton(Sum(meta_cons_map) |> Typ.fresh), }); List.map( fun diff --git a/src/haz3lcore/lang/term/Cls.re b/src/haz3lcore/lang/term/Cls.re index dfe8ee6911..e1acb702c8 100644 --- a/src/haz3lcore/lang/term/Cls.re +++ b/src/haz3lcore/lang/term/Cls.re @@ -2,7 +2,7 @@ type t = | Exp(Exp.cls) | Pat(Pat.cls) - | Typ(TypTerm.cls) + | Typ(Typ.cls) | TPat(TPat.cls) | Rul(Rul.cls) | Secondary(Secondary.cls); @@ -11,7 +11,7 @@ let show = (cls: t) => switch (cls) { | Exp(cls) => Exp.show_cls(cls) | Pat(cls) => Pat.show_cls(cls) - | Typ(cls) => TypTerm.show_cls(cls) + | Typ(cls) => Typ.show_cls(cls) | TPat(cls) => TPat.show_cls(cls) | Rul(cls) => Rul.show_cls(cls) | Secondary(cls) => Secondary.show_cls(cls) diff --git a/src/haz3lcore/lang/term/Typ.re b/src/haz3lcore/lang/term/Typ.re new file mode 100644 index 0000000000..b7d72b6051 --- /dev/null +++ b/src/haz3lcore/lang/term/Typ.re @@ -0,0 +1,329 @@ +include Term.Typ; +open Util; +open OptUtil.Syntax; + +let precedence_Prod = 1; +let precedence_Arrow = 2; +let precedence_Sum = 3; +let precedence_Ap = 4; +let precedence_Const = 5; + +let term_of: t => term = IdTagged.term_of; +let unwrap: t => (term, term => t) = IdTagged.unwrap; +let fresh: term => t = IdTagged.fresh; + +[@deriving (show({with_path: false}), sexp, yojson)] +type source = { + id: Id.t, + ty: t, +}; + +/* Strip location information from a list of sources */ +let of_source = List.map((source: source) => source.ty); + +/* How type provenance information should be collated when + joining unknown types. This probably requires more thought, + but right now TypeHole strictly predominates over Internal + which strictly predominates over SynSwitch. */ +let join_type_provenance = + (p1: type_provenance, p2: type_provenance): type_provenance => + switch (p1, p2) { + | (Hole(h1), Hole(h2)) when h1 == h2 => Hole(h1) + | (Hole(EmptyHole), Hole(EmptyHole) | SynSwitch) + | (SynSwitch, Hole(EmptyHole)) => Hole(EmptyHole) + | (SynSwitch, Internal) + | (Internal, SynSwitch) => SynSwitch + | (Internal | Hole(_), _) + | (_, Hole(_)) => Internal + | (SynSwitch, SynSwitch) => SynSwitch + }; + +let precedence = (ty: t): int => + switch (term_of(ty)) { + | Int + | Float + | Bool + | String + | Unknown(_) + | Var(_) + | Rec(_) + | Sum(_) => precedence_Sum + | List(_) => precedence_Const + | Prod(_) => precedence_Prod + | Arrow(_, _) => precedence_Arrow + | Parens(_) => precedence_Const + | Ap(_) => precedence_Ap + }; + +let rec subst = (s: t, x: string, ty: t) => { + let (term, rewrap) = unwrap(ty); + switch (term) { + | Int => Int |> rewrap + | Float => Float |> rewrap + | Bool => Bool |> rewrap + | String => String |> rewrap + | Unknown(prov) => Unknown(prov) |> rewrap + | Arrow(ty1, ty2) => Arrow(subst(s, x, ty1), subst(s, x, ty2)) |> rewrap + | Prod(tys) => Prod(List.map(subst(s, x), tys)) |> rewrap + | Sum(sm) => + Sum(ConstructorMap.map(Option.map(subst(s, x)), sm)) |> rewrap + | Rec({term: Var(y), _} as tp, ty) when x == y => Rec(tp, ty) |> rewrap + | Rec(y, ty) => Rec(y, subst(s, x, ty)) |> rewrap + | List(ty) => List(subst(s, x, ty)) |> rewrap + | Var(y) => x == y ? s : Var(y) |> rewrap + | Parens(ty) => Parens(subst(s, x, ty)) |> rewrap + | Ap(t1, t2) => Ap(subst(s, x, t1), subst(s, x, t2)) |> rewrap + }; +}; + +let unroll = (ty: t): t => + switch (term_of(ty)) { + | Rec({term: Var(x), _}, ty_body) => subst(ty, x, ty_body) + | _ => ty + }; + +/* Type Equality: At the moment, this coincides with alpha equivalence, + but this will change when polymorphic types are implemented */ +let rec eq = (t1: t, t2: t): bool => { + switch (term_of(t1), term_of(t2)) { + | (Parens(t1), _) => eq(t1, t2) + | (_, Parens(t2)) => eq(t1, t2) + | (Rec({term: Var(x1), _}, t1), Rec({term: Var(x2), _}, t2)) => + eq(t1, subst(fresh(Var(x1)), x2, t2)) + | (Rec(_), _) => false + | (Int, Int) => true + | (Int, _) => false + | (Float, Float) => true + | (Float, _) => false + | (Bool, Bool) => true + | (Bool, _) => false + | (String, String) => true + | (String, _) => false + | (Unknown(_), Unknown(_)) => true + | (Unknown(_), _) => false + | (Arrow(t1, t2), Arrow(t1', t2')) => eq(t1, t1') && eq(t2, t2') + | (Arrow(_), _) => false + | (Prod(tys1), Prod(tys2)) => List.equal(eq, tys1, tys2) + | (Prod(_), _) => false + | (List(t1), List(t2)) => eq(t1, t2) + | (List(_), _) => false + | (Sum(sm1), Sum(sm2)) => ConstructorMap.equal(eq, sm1, sm2) + | (Sum(_), _) => false + | (Var(n1), Var(n2)) => n1 == n2 + | (Var(_), _) => false + | (Ap(t1, t2), Ap(t3, t4)) => eq(t1, t3) && eq(t2, t4) + | (Ap(_), _) => false + }; +}; + +let rec free_vars = (~bound=[], ty: t): list(Var.t) => + switch (term_of(ty)) { + | Unknown(_) + | Int + | Float + | Bool + | String => [] + | Var(v) => List.mem(v, bound) ? [] : [v] + | Parens(ty) + | List(ty) => free_vars(~bound, ty) + | Ap(t1, t2) + | Arrow(t1, t2) => free_vars(~bound, t1) @ free_vars(~bound, t2) + | Sum(sm) => ConstructorMap.free_variables(free_vars(~bound), sm) + | Prod(tys) => ListUtil.flat_map(free_vars(~bound), tys) + | Rec({term: Var(x), _}, ty) => free_vars(~bound=[x, ...bound], ty) + | Rec(_, ty) => free_vars(~bound, ty) + }; + +/* Lattice join on types. This is a LUB join in the hazel2 + sense in that any type dominates Unknown. The optional + resolve parameter specifies whether, in the case of a type + variable and a succesful join, to return the resolved join type, + or to return the (first) type variable for readability */ +let rec join = (~resolve=false, ~fix, ctx: Ctx.t, ty1: t, ty2: t): option(t) => { + let join' = join(~resolve, ~fix, ctx); + switch (term_of(ty1), term_of(ty2)) { + | (_, Parens(ty2)) => join'(ty1, ty2) + | (Parens(ty1), _) => join'(ty1, ty2) + | (_, Unknown(Hole(_))) when fix => + /* NOTE(andrew): This is load bearing + for ensuring that function literals get appropriate + casts. Documentation/Dynamics has regression tests */ + Some(ty2) + | (Unknown(p1), Unknown(p2)) => + Some(Unknown(join_type_provenance(p1, p2)) |> fresh) + | (Unknown(_), _) => Some(ty2) + | (_, Unknown(Internal | SynSwitch)) => Some(ty1) + | (Var(n1), Var(n2)) => + if (n1 == n2) { + Some(ty1); + } else { + let* ty1 = Ctx.lookup_alias(ctx, n1); + let* ty2 = Ctx.lookup_alias(ctx, n2); + let+ ty_join = join'(ty1, ty2); + !resolve && eq(ty1, ty_join) ? ty1 : ty_join; + } + | (Var(name), _) => + let* ty_name = Ctx.lookup_alias(ctx, name); + let+ ty_join = join'(ty_name, ty2); + !resolve && eq(ty_name, ty_join) ? ty1 : ty_join; + | (_, Var(name)) => + let* ty_name = Ctx.lookup_alias(ctx, name); + let+ ty_join = join'(ty_name, ty1); + !resolve && eq(ty_name, ty_join) ? ty2 : ty_join; + /* Note: Ordering of Unknown, Var, and Rec above is load-bearing! */ + | (Rec({term: Var(x1), _} as tp1, ty1), Rec({term: Var(x2), _}, ty2)) => + /* TODO: + This code isn't fully correct, as we may be doing + substitution on open terms; if x1 occurs in ty2, + we should be substituting x1 for a fresh variable + in ty2. This is annoying, and should be obviated + by the forthcoming debruijn index implementation + */ + let ctx = Ctx.extend_dummy_tvar(ctx, x1); + let+ ty_body = + join(~resolve, ~fix, ctx, ty1, subst(Var(x1) |> fresh, x2, ty2)); + Rec(tp1, ty_body) |> fresh; + | (Rec(_), _) => None + | (Int, Int) => Some(Int |> fresh) + | (Int, _) => None + | (Float, Float) => Some(Float |> fresh) + | (Float, _) => None + | (Bool, Bool) => Some(Bool |> fresh) + | (Bool, _) => None + | (String, String) => Some(String |> fresh) + | (String, _) => None + | (Arrow(ty1, ty2), Arrow(ty1', ty2')) => + let* ty1 = join'(ty1, ty1'); + let+ ty2 = join'(ty2, ty2'); + Arrow(ty1, ty2) |> fresh; + | (Arrow(_), _) => None + | (Prod(tys1), Prod(tys2)) => + let* tys = ListUtil.map2_opt(join', tys1, tys2); + let+ tys = OptUtil.sequence(tys); + Prod(tys) |> fresh; + | (Prod(_), _) => None + | (Sum(sm1), Sum(sm2)) => + let+ sm' = ConstructorMap.join(eq, join(~resolve, ~fix, ctx), sm1, sm2); + Sum(sm') |> fresh; + | (Sum(_), _) => None + | (List(ty1), List(ty2)) => + let+ ty = join'(ty1, ty2); + List(ty) |> fresh; + | (List(_), _) => None + | (Ap(_), _) => failwith("Type join of ap") + }; +}; + +let join_fix = join(~fix=true); + +let join_all = (~empty: t, ctx: Ctx.t, ts: list(t)): option(t) => + List.fold_left( + (acc, ty) => OptUtil.and_then(join(~fix=false, ctx, ty), acc), + Some(empty), + ts, + ); + +let is_consistent = (ctx: Ctx.t, ty1: t, ty2: t): bool => + join(~fix=false, ctx, ty1, ty2) != None; + +let rec weak_head_normalize = (ctx: Ctx.t, ty: t): t => + switch (term_of(ty)) { + | Var(x) => + switch (Ctx.lookup_alias(ctx, x)) { + | Some(ty) => weak_head_normalize(ctx, ty) + | None => ty + } + | _ => ty + }; + +let rec normalize = (ctx: Ctx.t, ty: t): t => { + let (term, rewrap) = unwrap(ty); + switch (term) { + | Var(x) => + switch (Ctx.lookup_alias(ctx, x)) { + | Some(ty) => normalize(ctx, ty) + | None => ty + } + | Unknown(_) + | Int + | Float + | Bool + | String => ty + | Parens(t) => t + | List(t) => List(normalize(ctx, t)) |> rewrap + | Ap(t1, t2) => Ap(normalize(ctx, t1), normalize(ctx, t2)) |> rewrap + | Arrow(t1, t2) => + Arrow(normalize(ctx, t1), normalize(ctx, t2)) |> rewrap + | Prod(ts) => Prod(List.map(normalize(ctx), ts)) |> rewrap + | Sum(ts) => + Sum(ConstructorMap.map(Option.map(normalize(ctx)), ts)) |> rewrap + | Rec({term: Var(name), _} as tpat, ty) => + /* NOTE: Dummy tvar added has fake id but shouldn't matter + as in current implementation Recs do not occur in the + surface syntax, so we won't try to jump to them. */ + Rec(tpat, normalize(Ctx.extend_dummy_tvar(ctx, name), ty)) |> rewrap + | Rec(tpat, ty) => Rec(tpat, normalize(ctx, ty)) |> rewrap + }; +}; + +let matched_arrow = (ctx, ty) => + switch (term_of(weak_head_normalize(ctx, ty))) { + | Arrow(ty_in, ty_out) => (ty_in, ty_out) + | Unknown(SynSwitch) => ( + Unknown(SynSwitch) |> fresh, + Unknown(SynSwitch) |> fresh, + ) + | _ => (Unknown(Internal) |> fresh, Unknown(Internal) |> fresh) + }; + +let matched_prod = (ctx, length, ty) => + switch (term_of(weak_head_normalize(ctx, ty))) { + | Prod(tys) when List.length(tys) == length => tys + | Unknown(SynSwitch) => List.init(length, _ => Unknown(SynSwitch) |> fresh) + | _ => List.init(length, _ => Unknown(Internal) |> fresh) + }; + +let matched_list = (ctx, ty) => + switch (term_of(weak_head_normalize(ctx, ty))) { + | List(ty) => ty + | Unknown(SynSwitch) => Unknown(SynSwitch) |> fresh + | _ => Unknown(Internal) |> fresh + }; + +let get_sum_constructors = (ctx: Ctx.t, ty: t): option(sum_map) => { + let ty = weak_head_normalize(ctx, ty); + switch (term_of(ty)) { + | Sum(sm) => Some(sm) + | Rec(_) => + /* Note: We must unroll here to get right ctr types; + otherwise the rec parameter will leak. However, seeing + as substitution is too expensive to be used here, we + currently making the optimization that, since all + recursive types are type alises which use the alias name + as the recursive parameter, and type aliases cannot be + shadowed, it is safe to simply remove the Rec constructor, + provided we haven't escaped the context in which the alias + is bound. If either of the above assumptions become invalid, + the below code will be incorrect! */ + let ty = + switch (ty |> term_of) { + | Rec({term: Var(x), _}, ty_body) => + switch (Ctx.lookup_alias(ctx, x)) { + | None => unroll(ty) + | Some(_) => ty_body + } + | _ => ty + }; + switch (ty |> term_of) { + | Sum(sm) => Some(sm) + | _ => None + }; + | _ => None + }; +}; + +let is_unknown = (ty: t): bool => + switch (ty |> term_of) { + | Unknown(_) => true + | _ => false + }; diff --git a/src/haz3lcore/lang/term/TypTerm.re b/src/haz3lcore/lang/term/TypTerm.re deleted file mode 100644 index 457472f4b9..0000000000 --- a/src/haz3lcore/lang/term/TypTerm.re +++ /dev/null @@ -1 +0,0 @@ -include Term.TypTerm; diff --git a/src/haz3lcore/statics/ConstructorMap.re b/src/haz3lcore/statics/ConstructorMap.re index 7cb3ff7b2a..9ad845d6d9 100644 --- a/src/haz3lcore/statics/ConstructorMap.re +++ b/src/haz3lcore/statics/ConstructorMap.re @@ -141,148 +141,6 @@ let equal = (eq: ('a, 'a) => bool, m1: t('a), m2: t('a)) => { }; }; -// let get_valid_variants = -// List.filter_map( -// fun -// | Variant(ctr, ids, value) => Some((ctr, ids, value)) -// | BadEntry(_) => None, -// _, -// ); -// let compare_valid_variants = ((ctr1, _, _), (ctr2, _, _)) => -// String.compare(ctr1, ctr2); - -// let join = -// (f: ('a, 'a) => option('a), m1: t('a), m2: t('a)): option(t('a)) => { -// let join_sum_entries = ((ctr1, ids1, ty1), (ctr2, _, ty2)) => -// switch (ty1, ty2) { -// | (None, None) when ctr1 == ctr2 => Some((ctr1, ids1, None)) -// | (Some(ty1), Some(ty2)) when ctr1 == ctr2 => -// let+ ty_join = f(ty1, ty2); -// (ctr1, ids1, Some(ty_join)); -// | _ => None -// }; -// let map1 = m1 |> get_valid_variants; -// let map2 = m2 |> get_valid_variants; -// /* If same order, retain order for UI */ -// let same_constructors_same_order = { -// List.length(map1) === List.length(map2) -// && List.for_all2( -// (x, y) => compare_valid_variants(x, y) == 0, -// map1, -// map2, -// ); -// }; -// let map1 = -// same_constructors_same_order -// ? map1 |> List.fast_sort(compare_valid_variants) : map1; -// let map2 = -// same_constructors_same_order -// ? map2 |> List.fast_sort(compare_valid_variants) : map2; -// if (List.length(map1) == List.length(map2)) { -// List.fold_left2( -// (acc, entry1, entry2) => -// switch (acc) { -// | Some(xs) => -// join_sum_entries(entry1, entry2) -// |> Option.map(x => List.append(xs, [x])) -// | None => None -// }, -// Some([]), -// map1, -// map2, -// ) -// |> Option.map(List.map(((a, b, c)) => Variant(a, b, c))); -// } else { -// None; -// }; -// }; - -// let compare = compare; - -// let empty: t('a) = []; - -// let is_empty: t('a) => bool = -// fun -// | [] => true -// | _ => false; - -// // let rec add = (ctr: Constructor.t, value: option('a), map: t('a)): t('a) => -// // switch (map) { -// // | [] => [(ctr, value)] -// // | [(ctr', value') as head, ...tail] => -// // if (Constructor.equal(ctr, ctr')) { -// // if (value === value') { -// // map; -// // } else { -// // [(ctr, value), ...tail]; -// // }; -// // } else { -// // [head, ...add(ctr, value, tail)]; -// // } -// // }; - -// // let singleton = (ctr: Constructor.t, value: option('a)): t('a) => [ -// // (ctr, value), -// // ]; - -// let compare_bindings = ((ctr1, _), (ctr2, _)): int => compare(ctr1, ctr2); - -// let to_bindings = -// List.filter_map( -// fun -// | Variant(ctr, _, value) => Some((ctr, value)) -// | BadEntry(_) => None, -// _, -// ); - -// /* compares ctrs only */ -// let equal = -// ( -// val_equal: (option('a), option('a)) => bool, -// map1: t('a), -// map2: t('a), -// ) -// : bool => { -// let equal_bindings = (val_equal, (ctr1, _, val1), (ctr2, _, val2)): bool => -// Constructor.equal(ctr1, ctr2) && val_equal(val1, val2); -// map1 === map2 -// || { -// let map1 = -// List.fast_sort(compare_valid_variants, map1 |> get_valid_variants); -// let map2 = -// List.fast_sort(compare_valid_variants, map2 |> get_valid_variants); -// List.equal(equal_bindings(val_equal), map1, map2); -// }; -// }; - -// let cardinal: t('a) => int = List.length; - -// let ctrs_of = (m): list(Constructor.t) => m |> to_bindings |> List.map(fst); - -// let same_constructors_same_order = (map1: t('a), map2: t('a)): bool => -// cardinal(map1) === cardinal(map2) -// && List.for_all2(Constructor.equal, ctrs_of(map1), ctrs_of(map2)); - -// let ctrs_equal = (map1: t('a), map2: t('a)): bool => { -// let ctrs1 = ctrs_of(map1); -// let ctrs2 = ctrs_of(map2); -// ctrs1 === ctrs2 -// || List.fast_sort(compare, ctrs1) == List.fast_sort(compare, ctrs2); -// }; - -// // let for_all: (binding('a) => bool, t('a)) => bool = List.for_all; - -// // let bindings: t('a) => list(binding('a)) = x => x; - -// // let find_opt = (ctr: Constructor.t, map: t('a)): option(option('a)) => { -// // let+ binding = -// // List.find_opt( -// // ((k, _)) => Constructor.equal(ctr, k), -// // map |> to_bindings, -// // ); -// // snd(binding); -// // }; - let map = (f: option('a) => option('b), m: t('a)): t('b) => { List.map( fun @@ -292,16 +150,11 @@ let map = (f: option('a) => option('b), m: t('a)): t('b) => { ); }; -// // /* sorts on ctrs only */ -// // let sort = (map: t('a)): t('a) => { -// // List.fast_sort(compare_bindings, map); -// // }; - -// // let of_list: list(binding('a)) => t('a) = x => x; - -// // let rec is_ground = (is_ground_value: 'a => bool, map: t('a)): bool => -// // switch (map) { -// // | [] => true -// // | [(_, head), ...tail] => -// // is_ground_value(head) && tail |> is_ground(is_ground_value) -// // }; +let get_entry = (ctr, m) => + List.find_map( + fun + | Variant(ctr', _, value) when Constructor.equal(ctr, ctr') => value + | Variant(_) + | BadEntry(_) => None, + m, + ); diff --git a/src/haz3lcore/statics/Ctx.re b/src/haz3lcore/statics/Ctx.re index a7ddecd669..466d654118 100644 --- a/src/haz3lcore/statics/Ctx.re +++ b/src/haz3lcore/statics/Ctx.re @@ -1,4 +1,159 @@ -include TypBase.Ctx; +open Sexplib.Std; +open Util; -/* Due to otherwise cyclic dependencies, Typ and Ctx - are jointly located in the TypBase module */ +[@deriving (show({with_path: false}), sexp, yojson)] +type kind = + | Singleton(TermBase.Typ.t) + | Abstract; + +[@deriving (show({with_path: false}), sexp, yojson)] +type var_entry = { + name: Var.t, + id: Id.t, + typ: TermBase.Typ.t, +}; + +[@deriving (show({with_path: false}), sexp, yojson)] +type tvar_entry = { + name: string, + id: Id.t, + kind, +}; + +[@deriving (show({with_path: false}), sexp, yojson)] +type entry = + | VarEntry(var_entry) + | ConstructorEntry(var_entry) + | TVarEntry(tvar_entry); + +[@deriving (show({with_path: false}), sexp, yojson)] +type t = list(entry); + +let extend = (ctx, entry) => List.cons(entry, ctx); + +let extend_tvar = (ctx: t, tvar_entry: tvar_entry): t => + extend(ctx, TVarEntry(tvar_entry)); + +let extend_alias = (ctx: t, name: string, id: Id.t, ty: TermBase.Typ.t): t => + extend_tvar(ctx, {name, id, kind: Singleton(ty)}); + +let extend_dummy_tvar = (ctx: t, name: string) => + extend_tvar(ctx, {kind: Abstract, name, id: Id.invalid}); + +let lookup_tvar = (ctx: t, name: string): option(tvar_entry) => + List.find_map( + fun + | TVarEntry(v) when v.name == name => Some(v) + | _ => None, + ctx, + ); + +let lookup_alias = (ctx: t, t: string): option(TermBase.Typ.t) => + switch (lookup_tvar(ctx, t)) { + | Some({kind: Singleton(ty), _}) => Some(ty) + | Some({kind: Abstract, _}) + | None => None + }; + +let get_id: entry => Id.t = + fun + | VarEntry({id, _}) + | ConstructorEntry({id, _}) + | TVarEntry({id, _}) => id; + +let lookup_var = (ctx: t, name: string): option(var_entry) => + List.find_map( + fun + | VarEntry(v) when v.name == name => Some(v) + | _ => None, + ctx, + ); + +let lookup_ctr = (ctx: t, name: string): option(var_entry) => + List.find_map( + fun + | ConstructorEntry(t) when t.name == name => Some(t) + | _ => None, + ctx, + ); + +let is_alias = (ctx: t, name: string): bool => + switch (lookup_alias(ctx, name)) { + | Some(_) => true + | None => false + }; + +let add_ctrs = (ctx: t, name: string, id: Id.t, ctrs: TermBase.Typ.sum_map): t => + List.filter_map( + fun + | ConstructorMap.Variant(ctr, _, typ) => + Some( + ConstructorEntry({ + name: ctr, + id, + typ: + switch (typ) { + | None => TermBase.Typ.Var(name) |> IdTagged.fresh + | Some(typ) => + TermBase.Typ.Arrow( + typ, + TermBase.Typ.Var(name) |> IdTagged.fresh, + ) + |> IdTagged.fresh + }, + }), + ) + | ConstructorMap.BadEntry(_) => None, + ctrs, + ) + @ ctx; + +let subtract_prefix = (ctx: t, prefix_ctx: t): option(t) => { + // NOTE: does not check that the prefix is an actual prefix + let prefix_length = List.length(prefix_ctx); + let ctx_length = List.length(ctx); + if (prefix_length > ctx_length) { + None; + } else { + Some( + List.rev( + ListUtil.sublist((prefix_length, ctx_length), List.rev(ctx)), + ), + ); + }; +}; + +let added_bindings = (ctx_after: t, ctx_before: t): t => { + /* Precondition: new_ctx is old_ctx plus some new bindings */ + let new_count = List.length(ctx_after) - List.length(ctx_before); + switch (ListUtil.split_n_opt(new_count, ctx_after)) { + | Some((ctx, _)) => ctx + | _ => [] + }; +}; + +module VarSet = Set.Make(Var); + +// Note: filter out duplicates when rendering +let filter_duplicates = (ctx: t): t => + ctx + |> List.fold_left( + ((ctx, term_set, typ_set), entry) => { + switch (entry) { + | VarEntry({name, _}) + | ConstructorEntry({name, _}) => + VarSet.mem(name, term_set) + ? (ctx, term_set, typ_set) + : ([entry, ...ctx], VarSet.add(name, term_set), typ_set) + | TVarEntry({name, _}) => + VarSet.mem(name, typ_set) + ? (ctx, term_set, typ_set) + : ([entry, ...ctx], term_set, VarSet.add(name, typ_set)) + } + }, + ([], VarSet.empty, VarSet.empty), + ) + |> (((ctx, _, _)) => List.rev(ctx)); + +let shadows_typ = (ctx: t, name: string): bool => + Form.is_base_typ(name) || lookup_alias(ctx, name) != None; diff --git a/src/haz3lcore/statics/Info.re b/src/haz3lcore/statics/Info.re index ef8be7e488..3ce69a801b 100644 --- a/src/haz3lcore/statics/Info.re +++ b/src/haz3lcore/statics/Info.re @@ -284,7 +284,7 @@ let id_of: t => Id.t = fun | InfoExp(i) => Exp.rep_id(i.term) | InfoPat(i) => Pat.rep_id(i.term) - | InfoTyp(i) => TypTerm.rep_id(i.term) + | InfoTyp(i) => Typ.rep_id(i.term) | InfoTPat(i) => TPat.rep_id(i.term) | Secondary(s) => s.id; @@ -394,10 +394,10 @@ let status_exp = (ctx: Ctx.t, mode: Mode.t, self: Self.exp): status_exp => such as whether or not a type variable reference is free, and whether a ctr name is a dupe. */ let status_typ = - (ctx: Ctx.t, expects: typ_expects, term: TypTerm.t, ty: Typ.t): status_typ => + (ctx: Ctx.t, expects: typ_expects, term: Typ.t, ty: Typ.t): status_typ => switch (term.term) { - | Invalid(token) => InHole(BadToken(token)) - | EmptyHole => NotInHole(Type(ty)) + | Unknown(Hole(Invalid(token))) => InHole(BadToken(token)) + | Unknown(Hole(EmptyHole)) => NotInHole(Type(ty)) | Var(name) => switch (expects) { | VariantExpected(Unique, sum_ty) diff --git a/src/haz3lcore/statics/Kind.re b/src/haz3lcore/statics/Kind.re deleted file mode 100644 index 8db5638e94..0000000000 --- a/src/haz3lcore/statics/Kind.re +++ /dev/null @@ -1 +0,0 @@ -include TypBase.Kind; diff --git a/src/haz3lcore/statics/MakeTerm.re b/src/haz3lcore/statics/MakeTerm.re index 1b3e062814..e296bec732 100644 --- a/src/haz3lcore/statics/MakeTerm.re +++ b/src/haz3lcore/statics/MakeTerm.re @@ -357,7 +357,7 @@ and typ_term: unsorted => (UTyp.term, list(Id.t)) = { | (["(", ")"], [Typ(body)]) => Parens(body) | (["[", "]"], [Typ(body)]) => List(body) | ([t], []) when t != " " && !Form.is_explicit_hole(t) => - Invalid(t) + Unknown(Hole(Invalid(t))) | _ => hole(tm) }, ) diff --git a/src/haz3lcore/statics/Mode.re b/src/haz3lcore/statics/Mode.re index 48957f607e..2883e38d3c 100644 --- a/src/haz3lcore/statics/Mode.re +++ b/src/haz3lcore/statics/Mode.re @@ -86,8 +86,8 @@ let ctr_ana_typ = (ctx: Ctx.t, mode: t, ctr: Constructor.t): option(Typ.t) => { switch (mode) { | Ana({term: Arrow(_, ty_ana), _}) | Ana(ty_ana) => - let* ctrs = Typ.get_sum_constructors(ctx, ty_ana); - let+ (_, _, ty_entry) = Typ.sum_entry(ctr, ctrs); + let+ ctrs = Typ.get_sum_constructors(ctx, ty_ana); + let ty_entry = ConstructorMap.get_entry(ctr, ctrs); switch (ty_entry) { | None => ty_ana | Some(ty_in) => Arrow(ty_in, ty_ana) |> Typ.fresh diff --git a/src/haz3lcore/statics/Statics.re b/src/haz3lcore/statics/Statics.re index 362a393819..8c99882dd5 100644 --- a/src/haz3lcore/statics/Statics.re +++ b/src/haz3lcore/statics/Statics.re @@ -458,7 +458,8 @@ and uexp_to_info_map = /* NOTE: When debugging type system issues it may be beneficial to use a different name than the alias for the recursive parameter */ //let ty_rec = Typ.Rec("α", Typ.subst(Var("α"), name, ty_pre)); - let ty_rec = Typ.Rec(name, ty_pre) |> Typ.fresh; + let ty_rec = + Typ.Rec(TPat.Var(name) |> IdTagged.fresh, ty_pre) |> Typ.fresh; let ctx_def = Ctx.extend_alias(ctx, name, TPat.rep_id(typat), ty_rec); (ty_rec, ctx_def, ctx_def); @@ -598,11 +599,10 @@ and utyp_to_info_map = let go = go'(~expects=TypeExpected); //TODO(andrew): make this return free, replacing Typ.free_vars switch (term) { - | MultiHole(tms) => + | Unknown(Hole(MultiHole(tms))) => let (_, m) = multi(~ctx, ~ancestors, m, tms); add(m); - | Invalid(_) - | EmptyHole + | Unknown(_) | Int | Float | Bool diff --git a/src/haz3lcore/statics/Term.re b/src/haz3lcore/statics/Term.re index 95a8c4d98b..1aebe91ba8 100644 --- a/src/haz3lcore/statics/Term.re +++ b/src/haz3lcore/statics/Term.re @@ -36,14 +36,16 @@ module TPat = { | Var => "Type alias"; }; -module TypTerm = { - include TermBase.TypTerm; +module Typ = { + include TermBase.Typ; [@deriving (show({with_path: false}), sexp, yojson)] type cls = | Invalid | EmptyHole | MultiHole + | SynSwitch + | Internal | Int | Float | Bool @@ -58,7 +60,7 @@ module TypTerm = { | Ap | Rec; - include TermBase.TypTerm; + include TermBase.Typ; let rep_id = ({ids, _}: t) => { assert(ids != []); @@ -67,15 +69,17 @@ module TypTerm = { let hole = (tms: list(TermBase.Any.t)) => switch (tms) { - | [] => EmptyHole - | [_, ..._] => MultiHole(tms) + | [] => Unknown(Hole(EmptyHole)) + | [_, ..._] => Unknown(Hole(MultiHole(tms))) }; let cls_of_term: term => cls = fun - | Invalid(_) => Invalid - | EmptyHole => EmptyHole - | MultiHole(_) => MultiHole + | Unknown(Hole(Invalid(_))) => Invalid + | Unknown(Hole(EmptyHole)) => EmptyHole + | Unknown(Hole(MultiHole(_))) => MultiHole + | Unknown(SynSwitch) => SynSwitch + | Unknown(Internal) => Internal | Int => Int | Float => Float | Bool => Bool @@ -94,6 +98,8 @@ module TypTerm = { | Invalid => "Invalid type" | MultiHole => "Broken type" | EmptyHole => "Empty type hole" + | SynSwitch => "Synthetic type" + | Internal => "Internal type" | Int | Float | String @@ -112,9 +118,7 @@ module TypTerm = { switch (typ.term) { | Parens(typ) => is_arrow(typ) | Arrow(_) => true - | Invalid(_) - | EmptyHole - | MultiHole(_) + | Unknown(_) | Int | Float | Bool @@ -129,57 +133,52 @@ module TypTerm = { }; /* Converts a syntactic type into a semantic type */ - let rec to_typ: (Ctx.t, t) => Typ.t = - (ctx, utyp) => - switch (utyp.term) { - | Invalid(_) - | MultiHole(_) => Unknown(Internal) |> Typ.fresh - | EmptyHole => Unknown(Hole(EmptyHole)) |> Typ.fresh - | Bool => Bool |> Typ.fresh - | Int => Int |> Typ.fresh - | Float => Float |> Typ.fresh - | String => String |> Typ.fresh + let rec to_typ: (Ctx.t, t) => t = + (ctx, utyp) => { + let (term, rewrap) = IdTagged.unwrap(utyp); + switch (term) { + | Unknown(_) + | Bool + | Int + | Float + | String => utyp | Var(name) => switch (Ctx.lookup_tvar(ctx, name)) { - | Some(_) => Var(name) |> Typ.fresh - | None => Unknown(Hole(Invalid(name))) |> Typ.fresh + | Some(_) => Var(name) |> rewrap + | None => Unknown(Hole(Invalid(name))) |> rewrap } - | Arrow(u1, u2) => - Arrow(to_typ(ctx, u1), to_typ(ctx, u2)) |> Typ.fresh - | Prod(us) => Prod(List.map(to_typ(ctx), us)) |> Typ.fresh - | Sum(uts) => Sum(to_ctr_map(ctx, uts)) |> Typ.fresh - | List(u) => List(to_typ(ctx, u)) |> Typ.fresh + | Arrow(u1, u2) => Arrow(to_typ(ctx, u1), to_typ(ctx, u2)) |> rewrap + | Prod(us) => Prod(List.map(to_typ(ctx), us)) |> rewrap + | Sum(uts) => Sum(to_ctr_map(ctx, uts)) |> rewrap + | List(u) => List(to_typ(ctx, u)) |> rewrap | Parens(u) => to_typ(ctx, u) /* The below cases should occur only inside sums */ - | Ap(_) => Unknown(Internal) |> Typ.fresh - | Rec({term: Invalid(_), _}, tbody) - | Rec({term: EmptyHole, _}, tbody) - | Rec({term: MultiHole(_), _}, tbody) => - Rec("?", to_typ(ctx, tbody)) |> Typ.fresh + | Ap(_) => Unknown(Internal) |> rewrap + | Rec({term: Invalid(_), _} as tpat, tbody) + | Rec({term: EmptyHole, _} as tpat, tbody) + | Rec({term: MultiHole(_), _} as tpat, tbody) => + Rec(tpat, to_typ(ctx, tbody)) |> rewrap | Rec({term: Var(name), _} as utpat, tbody) => let ctx = Ctx.extend_tvar( ctx, {name, id: TPat.rep_id(utpat), kind: Abstract}, ); - Rec(name, to_typ(ctx, tbody)) |> Typ.fresh; - } + Rec(utpat, to_typ(ctx, tbody)) |> rewrap; + }; + } and to_variant: - (Ctx.t, ConstructorMap.variant(t)) => ConstructorMap.variant(Typ.t) = + (Ctx.t, ConstructorMap.variant(t)) => ConstructorMap.variant(t) = ctx => fun | Variant(ctr, ids, u) => ConstructorMap.Variant(ctr, ids, Option.map(to_typ(ctx), u)) | BadEntry(u) => ConstructorMap.BadEntry(to_typ(ctx, u)) - and to_ctr_map = - (ctx: Ctx.t, uts: list(ConstructorMap.variant(t))): Typ.sum_map => { + and to_ctr_map = (ctx: Ctx.t, uts: list(ConstructorMap.variant(t))) => { uts |> List.map(to_variant(ctx)) |> ListUtil.dedup_f( - ( - x: ConstructorMap.variant(Typ.t), - y: ConstructorMap.variant(Typ.t), - ) => + (x: ConstructorMap.variant(t), y: ConstructorMap.variant(t)) => switch (x, y) { | (Variant(c1, _, _), Variant(c2, _, _)) => c1 == c2 | (Variant(_), BadEntry(_)) @@ -291,7 +290,7 @@ module Pat = { let rec is_fun_var = (pat: t) => { switch (pat.term) { | Parens(pat) => is_fun_var(pat) - | TypeAnn(pat, typ) => is_var(pat) && TypTerm.is_arrow(typ) + | TypeAnn(pat, typ) => is_var(pat) && Typ.is_arrow(typ) | Invalid(_) | EmptyHole | MultiHole(_) @@ -357,7 +356,7 @@ module Pat = { switch (pat.term) { | Parens(pat) => get_fun_var(pat) | TypeAnn(pat, typ) => - if (TypTerm.is_arrow(typ)) { + if (Typ.is_arrow(typ)) { get_var(pat) |> Option.map(var => var); } else { None; @@ -661,7 +660,7 @@ module Any = { fun | Pat(p) => Some(p) | _ => None; - let is_typ: t => option(TermBase.TypTerm.t) = + let is_typ: t => option(TermBase.Typ.t) = fun | Typ(t) => Some(t) | _ => None; @@ -691,7 +690,7 @@ module Any = { fun | Exp(tm) => Exp.rep_id(tm) | Pat(tm) => Pat.rep_id(tm) - | Typ(tm) => TypTerm.rep_id(tm) + | Typ(tm) => Typ.rep_id(tm) | TPat(tm) => TPat.rep_id(tm) | Rul(tm) => Rul.rep_id(~any_ids=ids, tm) | Nul () diff --git a/src/haz3lcore/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index 84480d9788..8e5964c0c4 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -10,7 +10,7 @@ module rec Any: { type t = | Exp(Exp.t) | Pat(Pat.t) - | Typ(TypTerm.t) + | Typ(Typ.t) | TPat(TPat.t) | Rul(Rul.t) | Nul(unit) @@ -20,7 +20,7 @@ module rec Any: { ( ~f_exp: (Exp.t => Exp.t, Exp.t) => Exp.t=?, ~f_pat: (Pat.t => Pat.t, Pat.t) => Pat.t=?, - ~f_typ: (TypTerm.t => TypTerm.t, TypTerm.t) => TypTerm.t=?, + ~f_typ: (Typ.t => Typ.t, Typ.t) => Typ.t=?, ~f_tpat: (TPat.t => TPat.t, TPat.t) => TPat.t=?, ~f_rul: (Rul.t => Rul.t, Rul.t) => Rul.t=?, ~f_any: (Any.t => Any.t, Any.t) => Any.t=?, @@ -32,7 +32,7 @@ module rec Any: { type t = | Exp(Exp.t) | Pat(Pat.t) - | Typ(TypTerm.t) + | Typ(Typ.t) | TPat(TPat.t) | Rul(Rul.t) | Nul(unit) @@ -55,17 +55,7 @@ module rec Any: { | Pat(x) => Pat(Pat.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any, x)) | Typ(x) => - Typ( - TypTerm.map_term( - ~f_exp, - ~f_pat, - ~f_typ, - ~f_tpat, - ~f_rul, - ~f_any, - x, - ), - ) + Typ(Typ.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any, x)) | TPat(x) => TPat( TPat.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any, x), @@ -103,7 +93,7 @@ and Exp: { | Var(Var.t) | Let(Pat.t, t, t) | FixF(Pat.t, t, [@show.opaque] option(ClosureEnvironment.t)) - | TyAlias(TPat.t, TypTerm.t, t) + | TyAlias(TPat.t, Typ.t, t) | Ap(Operators.ap_direction, t, t) | If(t, t, t) | Seq(t, t) @@ -124,7 +114,7 @@ and Exp: { ( ~f_exp: (Exp.t => Exp.t, Exp.t) => Exp.t=?, ~f_pat: (Pat.t => Pat.t, Pat.t) => Pat.t=?, - ~f_typ: (TypTerm.t => TypTerm.t, TypTerm.t) => TypTerm.t=?, + ~f_typ: (Typ.t => Typ.t, Typ.t) => Typ.t=?, ~f_tpat: (TPat.t => TPat.t, TPat.t) => TPat.t=?, ~f_rul: (Rul.t => Rul.t, Rul.t) => Rul.t=?, ~f_any: (Any.t => Any.t, Any.t) => Any.t=?, @@ -156,7 +146,7 @@ and Exp: { | Var(Var.t) | Let(Pat.t, t, t) | FixF(Pat.t, t, [@show.opaque] option(ClosureEnvironment.t)) - | TyAlias(TPat.t, TypTerm.t, t) + | TyAlias(TPat.t, Typ.t, t) | Ap(Operators.ap_direction, t, t) // note: function is always first then argument; even in pipe mode | If(t, t, t) | Seq(t, t) @@ -188,7 +178,7 @@ and Exp: { let pat_map_term = Pat.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); let typ_map_term = - TypTerm.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); + Typ.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); let tpat_map_term = TPat.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); let any_map_term = @@ -274,14 +264,14 @@ and Pat: { | Tuple(list(t)) | Parens(t) | Ap(t, t) - | TypeAnn(t, TypTerm.t) + | TypeAnn(t, Typ.t) and t = IdTagged.t(term); let map_term: ( ~f_exp: (Exp.t => Exp.t, Exp.t) => Exp.t=?, ~f_pat: (Pat.t => Pat.t, Pat.t) => Pat.t=?, - ~f_typ: (TypTerm.t => TypTerm.t, TypTerm.t) => TypTerm.t=?, + ~f_typ: (Typ.t => Typ.t, Typ.t) => Typ.t=?, ~f_tpat: (TPat.t => TPat.t, TPat.t) => TPat.t=?, ~f_rul: (Rul.t => Rul.t, Rul.t) => Rul.t=?, ~f_any: (Any.t => Any.t, Any.t) => Any.t=?, @@ -306,7 +296,7 @@ and Pat: { | Tuple(list(t)) | Parens(t) | Ap(t, t) - | TypeAnn(t, TypTerm.t) + | TypeAnn(t, Typ.t) and t = IdTagged.t(term); let map_term = @@ -322,7 +312,7 @@ and Pat: { let pat_map_term = Pat.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); let typ_map_term = - TypTerm.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); + Typ.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); let any_map_term = Any.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); let rec_call = ({term, _} as exp: t) => { @@ -350,12 +340,26 @@ and Pat: { x |> f_pat(rec_call); }; } -and TypTerm: { +and Typ: { + [@deriving (show({with_path: false}), sexp, yojson)] + type type_hole = + | Invalid(string) + | EmptyHole + | MultiHole(list(Any.t)); + + /* TYPE_PROVENANCE: From whence does an unknown type originate? + Is it generated from an unannotated pattern variable (SynSwitch), + a pattern variable annotated with a type hole (TypeHole), or + generated by an internal judgement (Internal)? */ + [@deriving (show({with_path: false}), sexp, yojson)] + type type_provenance = + | SynSwitch + | Hole(type_hole) + | Internal; + [@deriving (show({with_path: false}), sexp, yojson)] type term = - | Invalid(string) // TODO[Matt]: Switch to unknown - | EmptyHole // TODO[Matt]: Switch to unknown - | MultiHole(list(Any.t)) // TODO[Matt]: Switch to unknown + | Unknown(Typ.type_provenance) | Int | Float | Bool @@ -370,11 +374,13 @@ and TypTerm: { | Rec(TPat.t, t) and t = IdTagged.t(term); + type sum_map = ConstructorMap.t(t); + let map_term: ( ~f_exp: (Exp.t => Exp.t, Exp.t) => Exp.t=?, ~f_pat: (Pat.t => Pat.t, Pat.t) => Pat.t=?, - ~f_typ: (TypTerm.t => TypTerm.t, TypTerm.t) => TypTerm.t=?, + ~f_typ: (Typ.t => Typ.t, Typ.t) => Typ.t=?, ~f_tpat: (TPat.t => TPat.t, TPat.t) => TPat.t=?, ~f_rul: (Rul.t => Rul.t, Rul.t) => Rul.t=?, ~f_any: (Any.t => Any.t, Any.t) => Any.t=?, @@ -383,10 +389,24 @@ and TypTerm: { t; } = { [@deriving (show({with_path: false}), sexp, yojson)] - type term = + type type_hole = | Invalid(string) | EmptyHole - | MultiHole(list(Any.t)) + | MultiHole(list(Any.t)); + + /* TYPE_PROVENANCE: From whence does an unknown type originate? + Is it generated from an unannotated pattern variable (SynSwitch), + a pattern variable annotated with a type hole (TypeHole), or + generated by an internal judgement (Internal)? */ + [@deriving (show({with_path: false}), sexp, yojson)] + type type_provenance = + | SynSwitch + | Hole(type_hole) + | Internal; + + [@deriving (show({with_path: false}), sexp, yojson)] + type term = + | Unknown(Typ.type_provenance) | Int | Float | Bool @@ -401,6 +421,8 @@ and TypTerm: { | Rec(TPat.t, t) and t = IdTagged.t(term); + type sum_map = ConstructorMap.t(t); + let map_term = ( ~f_exp=continue, @@ -412,7 +434,7 @@ and TypTerm: { x, ) => { let typ_map_term = - TypTerm.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); + Typ.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); let any_map_term = Any.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); let tpat_map_term = @@ -421,15 +443,18 @@ and TypTerm: { ...exp, term: switch (term) { - | EmptyHole - | Invalid(_) + | Unknown(Hole(EmptyHole)) + | Unknown(Hole(Invalid(_))) + | Unknown(SynSwitch) + | Unknown(Internal) | Bool | Int | Float | String | Var(_) => term | List(t) => List(typ_map_term(t)) - | MultiHole(things) => MultiHole(List.map(any_map_term, things)) + | Unknown(Hole(MultiHole(things))) => + Unknown(Hole(MultiHole(List.map(any_map_term, things)))) | Ap(e1, e2) => Ap(typ_map_term(e1), typ_map_term(e2)) | Prod(xs) => Prod(List.map(typ_map_term, xs)) | Parens(e) => Parens(typ_map_term(e)) @@ -464,7 +489,7 @@ and TPat: { ( ~f_exp: (Exp.t => Exp.t, Exp.t) => Exp.t=?, ~f_pat: (Pat.t => Pat.t, Pat.t) => Pat.t=?, - ~f_typ: (TypTerm.t => TypTerm.t, TypTerm.t) => TypTerm.t=?, + ~f_typ: (Typ.t => Typ.t, Typ.t) => Typ.t=?, ~f_tpat: (TPat.t => TPat.t, TPat.t) => TPat.t=?, ~f_rul: (Rul.t => Rul.t, Rul.t) => Rul.t=?, ~f_any: (Any.t => Any.t, Any.t) => Any.t=?, @@ -517,7 +542,7 @@ and Rul: { ( ~f_exp: (Exp.t => Exp.t, Exp.t) => Exp.t=?, ~f_pat: (Pat.t => Pat.t, Pat.t) => Pat.t=?, - ~f_typ: (TypTerm.t => TypTerm.t, TypTerm.t) => TypTerm.t=?, + ~f_typ: (Typ.t => Typ.t, Typ.t) => Typ.t=?, ~f_tpat: (TPat.t => TPat.t, TPat.t) => TPat.t=?, ~f_rul: (Rul.t => Rul.t, Rul.t) => Rul.t=?, ~f_any: (Any.t => Any.t, Any.t) => Any.t=?, @@ -710,7 +735,7 @@ and StepperFilterKind: { ( ~f_exp: (Exp.t => Exp.t, Exp.t) => Exp.t=?, ~f_pat: (Pat.t => Pat.t, Pat.t) => Pat.t=?, - ~f_typ: (TypTerm.t => TypTerm.t, TypTerm.t) => TypTerm.t=?, + ~f_typ: (Typ.t => Typ.t, Typ.t) => Typ.t=?, ~f_tpat: (TPat.t => TPat.t, TPat.t) => TPat.t=?, ~f_rul: (Rul.t => Rul.t, Rul.t) => Rul.t=?, ~f_any: (Any.t => Any.t, Any.t) => Any.t=?, diff --git a/src/haz3lcore/statics/Typ.re b/src/haz3lcore/statics/Typ.re deleted file mode 100644 index 9b6c4033a5..0000000000 --- a/src/haz3lcore/statics/Typ.re +++ /dev/null @@ -1,4 +0,0 @@ -include TypBase.Typ; - -/* Due to otherwise cyclic dependencies, Typ and Ctx - are jointly located in the TypBase module */ diff --git a/src/haz3lcore/statics/TypBase.re b/src/haz3lcore/statics/TypBase.re deleted file mode 100644 index fad0886293..0000000000 --- a/src/haz3lcore/statics/TypBase.re +++ /dev/null @@ -1,649 +0,0 @@ -open Sexplib.Std; -open Util; -open OptUtil.Syntax; - -let precedence_Prod = 1; -let precedence_Arrow = 2; -let precedence_Sum = 3; -let precedence_Ap = 4; -let precedence_Const = 5; - -module rec Typ: { - [@deriving (show({with_path: false}), sexp, yojson)] - type type_hole = - | Invalid(string) - | EmptyHole - | MultiHole(list(string)); - - /* TYPE_PROVENANCE: From whence does an unknown type originate? - Is it generated from an unannotated pattern variable (SynSwitch), - a pattern variable annotated with a type hole (TypeHole), or - generated by an internal judgement (Internal)? */ - [@deriving (show({with_path: false}), sexp, yojson)] - type type_provenance = - | SynSwitch - | Hole(type_hole) - | Internal; - - /* TYP.T: Hazel types */ - [@deriving (show({with_path: false}), sexp, yojson)] - type term = - | Unknown(type_provenance) // Add to TypTerm - | Int - | Float - | Bool - | String - | Var(string) - | List(t) - | Arrow(t, t) - | Sum(ConstructorMap.t(t)) - | Prod(list(t)) - | Parens(t) - | Ap(t, t) - | Rec(string, t) - and t = IdTagged.t(term); - - [@deriving (show({with_path: false}), sexp, yojson)] - type sum_map = ConstructorMap.t(t); - - [@deriving (show({with_path: false}), sexp, yojson)] - type sum_entry = (Constructor.t, list(Id.t), option(Typ.t)); - - /* Hazel type annotated with a relevant source location. - Currently used to track match branches for inconsistent - branches errors, but could perhaps be used more broadly - for type debugging UI. */ - [@deriving (show({with_path: false}), sexp, yojson)] - type source = { - id: Id.t, - ty: t, - }; - - let term_of: t => term; - let unwrap: t => (term, term => t); - let fresh: term => t; - - let of_source: list(source) => list(t); - let join_type_provenance: - (type_provenance, type_provenance) => type_provenance; - let matched_arrow: (Ctx.t, t) => (t, t); - let matched_prod: (Ctx.t, int, t) => list(t); - let matched_list: (Ctx.t, t) => t; - let precedence: t => int; - let subst: (t, string, t) => t; - let unroll: t => t; - let eq: (t, t) => bool; - let free_vars: (~bound: list(Var.t)=?, t) => list(Var.t); - let join: (~resolve: bool=?, ~fix: bool, Ctx.t, t, t) => option(t); - let join_fix: (~resolve: bool=?, Ctx.t, t, t) => option(t); - let join_all: (~empty: t, Ctx.t, list(t)) => option(t); - let is_consistent: (Ctx.t, t, t) => bool; - let weak_head_normalize: (Ctx.t, t) => t; - let normalize: (Ctx.t, t) => t; - let sum_entry: (Constructor.t, sum_map) => option(sum_entry); - let get_sum_constructors: (Ctx.t, t) => option(sum_map); - let is_unknown: t => bool; -} = { - [@deriving (show({with_path: false}), sexp, yojson)] - type type_hole = - | Invalid(string) - | EmptyHole - | MultiHole(list(string)); - - [@deriving (show({with_path: false}), sexp, yojson)] - type type_provenance = - | SynSwitch - | Hole(type_hole) - | Internal; - - /* TYP.T: Hazel types */ - [@deriving (show({with_path: false}), sexp, yojson)] - type term = - | Unknown(type_provenance) - | Int - | Float - | Bool - | String - | Var(string) - | List(t) - | Arrow(t, t) - | Sum(sum_map) - | Prod(list(t)) - | Parens(t) - | Ap(t, t) - | Rec(string, t) - and sum_map = ConstructorMap.t(t) - and t = IdTagged.t(term); - - let term_of: t => term = IdTagged.term_of; - let unwrap: t => (term, term => t) = IdTagged.unwrap; - let fresh: term => t = IdTagged.fresh; - - [@deriving (show({with_path: false}), sexp, yojson)] - type sum_entry = (Constructor.t, list(Id.t), option(Typ.t)); - - [@deriving (show({with_path: false}), sexp, yojson)] - type source = { - id: Id.t, - ty: t, - }; - - /* Strip location information from a list of sources */ - let of_source = List.map((source: source) => source.ty); - - /* How type provenance information should be collated when - joining unknown types. This probably requires more thought, - but right now TypeHole strictly predominates over Internal - which strictly predominates over SynSwitch. */ - let join_type_provenance = - (p1: type_provenance, p2: type_provenance): type_provenance => - switch (p1, p2) { - | (Hole(h1), Hole(h2)) when h1 == h2 => Hole(h1) - | (Hole(EmptyHole), Hole(EmptyHole) | SynSwitch) - | (SynSwitch, Hole(EmptyHole)) => Hole(EmptyHole) - | (SynSwitch, Internal) - | (Internal, SynSwitch) => SynSwitch - | (Internal | Hole(_), _) - | (_, Hole(_)) => Internal - | (SynSwitch, SynSwitch) => SynSwitch - }; - - let precedence = (ty: t): int => - switch (term_of(ty)) { - | Int - | Float - | Bool - | String - | Unknown(_) - | Var(_) - | Rec(_) - | Sum(_) => precedence_Sum - | List(_) => precedence_Const - | Prod(_) => precedence_Prod - | Arrow(_, _) => precedence_Arrow - | Parens(_) => precedence_Const - | Ap(_) => precedence_Ap - }; - - let rec subst = (s: t, x: string, ty: t) => { - let (term, rewrap) = unwrap(ty); - switch (term) { - | Int => Int |> rewrap - | Float => Float |> rewrap - | Bool => Bool |> rewrap - | String => String |> rewrap - | Unknown(prov) => Unknown(prov) |> rewrap - | Arrow(ty1, ty2) => - Arrow(subst(s, x, ty1), subst(s, x, ty2)) |> rewrap - | Prod(tys) => Prod(List.map(subst(s, x), tys)) |> rewrap - | Sum(sm) => - Sum(ConstructorMap.map(Option.map(subst(s, x)), sm)) |> rewrap - | Rec(y, ty) when x == y => Rec(y, ty) |> rewrap - | Rec(y, ty) => Rec(y, subst(s, x, ty)) |> rewrap - | List(ty) => List(subst(s, x, ty)) |> rewrap - | Var(y) => x == y ? s : Var(y) |> rewrap - | Parens(ty) => Parens(subst(s, x, ty)) |> rewrap - | Ap(t1, t2) => Ap(subst(s, x, t1), subst(s, x, t2)) |> rewrap - }; - }; - - let unroll = (ty: t): t => - switch (term_of(ty)) { - | Rec(x, ty_body) => subst(ty, x, ty_body) - | _ => ty - }; - - /* Type Equality: At the moment, this coincides with alpha equivalence, - but this will change when polymorphic types are implemented */ - let rec eq = (t1: t, t2: t): bool => { - switch (term_of(t1), term_of(t2)) { - | (Parens(t1), _) => eq(t1, t2) - | (_, Parens(t2)) => eq(t1, t2) - | (Rec(x1, t1), Rec(x2, t2)) => - eq(t1, subst(fresh(Var(x1)), x2, t2)) - | (Rec(_), _) => false - | (Int, Int) => true - | (Int, _) => false - | (Float, Float) => true - | (Float, _) => false - | (Bool, Bool) => true - | (Bool, _) => false - | (String, String) => true - | (String, _) => false - | (Unknown(_), Unknown(_)) => true - | (Unknown(_), _) => false - | (Arrow(t1, t2), Arrow(t1', t2')) => eq(t1, t1') && eq(t2, t2') - | (Arrow(_), _) => false - | (Prod(tys1), Prod(tys2)) => List.equal(eq, tys1, tys2) - | (Prod(_), _) => false - | (List(t1), List(t2)) => eq(t1, t2) - | (List(_), _) => false - | (Sum(sm1), Sum(sm2)) => ConstructorMap.equal(eq, sm1, sm2) - | (Sum(_), _) => false - | (Var(n1), Var(n2)) => n1 == n2 - | (Var(_), _) => false - | (Ap(t1, t2), Ap(t3, t4)) => eq(t1, t3) && eq(t2, t4) - | (Ap(_), _) => false - }; - }; - - let rec free_vars = (~bound=[], ty: t): list(Var.t) => - switch (term_of(ty)) { - | Unknown(_) - | Int - | Float - | Bool - | String => [] - | Var(v) => List.mem(v, bound) ? [] : [v] - | Parens(ty) - | List(ty) => free_vars(~bound, ty) - | Ap(t1, t2) - | Arrow(t1, t2) => free_vars(~bound, t1) @ free_vars(~bound, t2) - | Sum(sm) => ConstructorMap.free_variables(free_vars(~bound), sm) - | Prod(tys) => ListUtil.flat_map(free_vars(~bound), tys) - | Rec(x, ty) => free_vars(~bound=[x, ...bound], ty) - }; - - /* Lattice join on types. This is a LUB join in the hazel2 - sense in that any type dominates Unknown. The optional - resolve parameter specifies whether, in the case of a type - variable and a succesful join, to return the resolved join type, - or to return the (first) type variable for readability */ - let rec join = - (~resolve=false, ~fix, ctx: Ctx.t, ty1: t, ty2: t): option(t) => { - let join' = join(~resolve, ~fix, ctx); - switch (term_of(ty1), term_of(ty2)) { - | (_, Parens(ty2)) => join'(ty1, ty2) - | (Parens(ty1), _) => join'(ty1, ty2) - | (_, Unknown(Hole(_))) when fix => - /* NOTE(andrew): This is load bearing - for ensuring that function literals get appropriate - casts. Documentation/Dynamics has regression tests */ - Some(ty2) - | (Unknown(p1), Unknown(p2)) => - Some(Unknown(join_type_provenance(p1, p2)) |> fresh) - | (Unknown(_), _) => Some(ty2) - | (_, Unknown(Internal | SynSwitch)) => Some(ty1) - | (Var(n1), Var(n2)) => - if (n1 == n2) { - Some(ty1); - } else { - let* ty1 = Ctx.lookup_alias(ctx, n1); - let* ty2 = Ctx.lookup_alias(ctx, n2); - let+ ty_join = join'(ty1, ty2); - !resolve && eq(ty1, ty_join) ? ty1 : ty_join; - } - | (Var(name), _) => - let* ty_name = Ctx.lookup_alias(ctx, name); - let+ ty_join = join'(ty_name, ty2); - !resolve && eq(ty_name, ty_join) ? ty1 : ty_join; - | (_, Var(name)) => - let* ty_name = Ctx.lookup_alias(ctx, name); - let+ ty_join = join'(ty_name, ty1); - !resolve && eq(ty_name, ty_join) ? ty2 : ty_join; - /* Note: Ordering of Unknown, Var, and Rec above is load-bearing! */ - | (Rec(x1, ty1), Rec(x2, ty2)) => - /* TODO: - This code isn't fully correct, as we may be doing - substitution on open terms; if x1 occurs in ty2, - we should be substituting x1 for a fresh variable - in ty2. This is annoying, and should be obviated - by the forthcoming debruijn index implementation - */ - let ctx = Ctx.extend_dummy_tvar(ctx, x1); - let+ ty_body = - join(~resolve, ~fix, ctx, ty1, subst(Var(x1) |> fresh, x2, ty2)); - Rec(x1, ty_body) |> fresh; - | (Rec(_), _) => None - | (Int, Int) => Some(Int |> fresh) - | (Int, _) => None - | (Float, Float) => Some(Float |> fresh) - | (Float, _) => None - | (Bool, Bool) => Some(Bool |> fresh) - | (Bool, _) => None - | (String, String) => Some(String |> fresh) - | (String, _) => None - | (Arrow(ty1, ty2), Arrow(ty1', ty2')) => - let* ty1 = join'(ty1, ty1'); - let+ ty2 = join'(ty2, ty2'); - Arrow(ty1, ty2) |> fresh; - | (Arrow(_), _) => None - | (Prod(tys1), Prod(tys2)) => - let* tys = ListUtil.map2_opt(join', tys1, tys2); - let+ tys = OptUtil.sequence(tys); - Prod(tys) |> fresh; - | (Prod(_), _) => None - | (Sum(sm1), Sum(sm2)) => - let+ sm' = - ConstructorMap.join(eq, join(~resolve, ~fix, ctx), sm1, sm2); - Sum(sm') |> fresh; - | (Sum(_), _) => None - | (List(ty1), List(ty2)) => - let+ ty = join'(ty1, ty2); - List(ty) |> fresh; - | (List(_), _) => None - | (Ap(_), _) => failwith("Type join of ap") - }; - }; - - let join_fix = join(~fix=true); - - let join_all = (~empty: t, ctx: Ctx.t, ts: list(t)): option(t) => - List.fold_left( - (acc, ty) => OptUtil.and_then(join(~fix=false, ctx, ty), acc), - Some(empty), - ts, - ); - - let is_consistent = (ctx: Ctx.t, ty1: t, ty2: t): bool => - join(~fix=false, ctx, ty1, ty2) != None; - - let rec weak_head_normalize = (ctx: Ctx.t, ty: t): t => - switch (term_of(ty)) { - | Var(x) => - switch (Ctx.lookup_alias(ctx, x)) { - | Some(ty) => weak_head_normalize(ctx, ty) - | None => ty - } - | _ => ty - }; - - let rec normalize = (ctx: Ctx.t, ty: t): t => { - let (term, rewrap) = unwrap(ty); - switch (term) { - | Var(x) => - switch (Ctx.lookup_alias(ctx, x)) { - | Some(ty) => normalize(ctx, ty) - | None => ty - } - | Unknown(_) - | Int - | Float - | Bool - | String => ty - | Parens(t) => t - | List(t) => List(normalize(ctx, t)) |> rewrap - | Ap(t1, t2) => Ap(normalize(ctx, t1), normalize(ctx, t2)) |> rewrap - | Arrow(t1, t2) => - Arrow(normalize(ctx, t1), normalize(ctx, t2)) |> rewrap - | Prod(ts) => Prod(List.map(normalize(ctx), ts)) |> rewrap - | Sum(ts) => - Sum(ConstructorMap.map(Option.map(normalize(ctx)), ts)) |> rewrap - | Rec(name, ty) => - /* NOTE: Dummy tvar added has fake id but shouldn't matter - as in current implementation Recs do not occur in the - surface syntax, so we won't try to jump to them. */ - Rec(name, normalize(Ctx.extend_dummy_tvar(ctx, name), ty)) |> rewrap - }; - }; - - let matched_arrow = (ctx, ty) => - switch (term_of(weak_head_normalize(ctx, ty))) { - | Arrow(ty_in, ty_out) => (ty_in, ty_out) - | Unknown(SynSwitch) => ( - Unknown(SynSwitch) |> fresh, - Unknown(SynSwitch) |> fresh, - ) - | _ => (Unknown(Internal) |> fresh, Unknown(Internal) |> fresh) - }; - - let matched_prod = (ctx, length, ty) => - switch (term_of(weak_head_normalize(ctx, ty))) { - | Prod(tys) when List.length(tys) == length => tys - | Unknown(SynSwitch) => - List.init(length, _ => Unknown(SynSwitch) |> fresh) - | _ => List.init(length, _ => Unknown(Internal) |> fresh) - }; - - let matched_list = (ctx, ty) => - switch (term_of(weak_head_normalize(ctx, ty))) { - | List(ty) => ty - | Unknown(SynSwitch) => Unknown(SynSwitch) |> fresh - | _ => Unknown(Internal) |> fresh - }; - - let sum_entry = (ctr: Constructor.t, ctrs: sum_map): option(sum_entry) => - List.find_map( - fun - | ConstructorMap.Variant(t, ids, v) when Constructor.equal(t, ctr) => - Some((t, ids, v)) - | _ => None, - ctrs, - ); - - let get_sum_constructors = (ctx: Ctx.t, ty: t): option(sum_map) => { - let ty = weak_head_normalize(ctx, ty); - switch (term_of(ty)) { - | Sum(sm) => Some(sm) - | Rec(_) => - /* Note: We must unroll here to get right ctr types; - otherwise the rec parameter will leak. However, seeing - as substitution is too expensive to be used here, we - currently making the optimization that, since all - recursive types are type alises which use the alias name - as the recursive parameter, and type aliases cannot be - shadowed, it is safe to simply remove the Rec constructor, - provided we haven't escaped the context in which the alias - is bound. If either of the above assumptions become invalid, - the below code will be incorrect! */ - let ty = - switch (ty |> term_of) { - | Rec(x, ty_body) => - switch (Ctx.lookup_alias(ctx, x)) { - | None => unroll(ty) - | Some(_) => ty_body - } - | _ => ty - }; - switch (ty |> term_of) { - | Sum(sm) => Some(sm) - | _ => None - }; - | _ => None - }; - }; - - let is_unknown = (ty: t): bool => - switch (ty |> term_of) { - | Unknown(_) => true - | _ => false - }; -} -and Ctx: { - [@deriving (show({with_path: false}), sexp, yojson)] - type var_entry = { - name: Var.t, - id: Id.t, - typ: Typ.t, - }; - - [@deriving (show({with_path: false}), sexp, yojson)] - type tvar_entry = { - name: string, - id: Id.t, - kind: Kind.t, - }; - - [@deriving (show({with_path: false}), sexp, yojson)] - type entry = - | VarEntry(var_entry) - | ConstructorEntry(var_entry) - | TVarEntry(tvar_entry); - - [@deriving (show({with_path: false}), sexp, yojson)] - type t = list(entry); - - let extend: (t, entry) => t; - let extend_tvar: (t, tvar_entry) => t; - let extend_alias: (t, string, Id.t, Typ.t) => t; - let extend_dummy_tvar: (t, string) => t; - let lookup_tvar: (t, string) => option(tvar_entry); - let lookup_alias: (t, string) => option(Typ.t); - let get_id: entry => Id.t; - let lookup_var: (t, string) => option(var_entry); - let lookup_ctr: (t, string) => option(var_entry); - let is_alias: (t, string) => bool; - let add_ctrs: (t, string, Id.t, Typ.sum_map) => t; - let subtract_prefix: (t, t) => option(t); - let added_bindings: (t, t) => t; - let filter_duplicates: t => t; - let shadows_typ: (t, string) => bool; -} = { - [@deriving (show({with_path: false}), sexp, yojson)] - type var_entry = { - name: Var.t, - id: Id.t, - typ: Typ.t, - }; - - [@deriving (show({with_path: false}), sexp, yojson)] - type tvar_entry = { - name: string, - id: Id.t, - kind: Kind.t, - }; - - [@deriving (show({with_path: false}), sexp, yojson)] - type entry = - | VarEntry(var_entry) - | ConstructorEntry(var_entry) - | TVarEntry(tvar_entry); - - [@deriving (show({with_path: false}), sexp, yojson)] - type t = list(entry); - - let extend = (ctx, entry) => List.cons(entry, ctx); - - let extend_tvar = (ctx: t, tvar_entry: tvar_entry): t => - extend(ctx, TVarEntry(tvar_entry)); - - let extend_alias = (ctx: t, name: string, id: Id.t, ty: Typ.t): t => - extend_tvar(ctx, {name, id, kind: Singleton(ty)}); - - let extend_dummy_tvar = (ctx: t, name: string) => - extend_tvar(ctx, {kind: Abstract, name, id: Id.invalid}); - - let lookup_tvar = (ctx: t, name: string): option(tvar_entry) => - List.find_map( - fun - | TVarEntry(v) when v.name == name => Some(v) - | _ => None, - ctx, - ); - - let lookup_alias = (ctx: t, t: string): option(Typ.t) => - switch (lookup_tvar(ctx, t)) { - | Some({kind: Singleton(ty), _}) => Some(ty) - | Some({kind: Abstract, _}) - | None => None - }; - - let get_id: entry => Id.t = - fun - | VarEntry({id, _}) - | ConstructorEntry({id, _}) - | TVarEntry({id, _}) => id; - - let lookup_var = (ctx: t, name: string): option(var_entry) => - List.find_map( - fun - | VarEntry(v) when v.name == name => Some(v) - | _ => None, - ctx, - ); - - let lookup_ctr = (ctx: t, name: string): option(var_entry) => - List.find_map( - fun - | ConstructorEntry(t) when t.name == name => Some(t) - | _ => None, - ctx, - ); - - let is_alias = (ctx: t, name: string): bool => - switch (lookup_alias(ctx, name)) { - | Some(_) => true - | None => false - }; - - let add_ctrs = (ctx: t, name: string, id: Id.t, ctrs: Typ.sum_map): t => - List.filter_map( - fun - | ConstructorMap.Variant(ctr, _, typ) => - Some( - ConstructorEntry({ - name: ctr, - id, - typ: - switch (typ) { - | None => Var(name) |> Typ.fresh - | Some(typ) => Arrow(typ, Var(name) |> Typ.fresh) |> Typ.fresh - }, - }), - ) - | ConstructorMap.BadEntry(_) => None, - ctrs, - ) - @ ctx; - - let subtract_prefix = (ctx: t, prefix_ctx: t): option(t) => { - // NOTE: does not check that the prefix is an actual prefix - let prefix_length = List.length(prefix_ctx); - let ctx_length = List.length(ctx); - if (prefix_length > ctx_length) { - None; - } else { - Some( - List.rev( - ListUtil.sublist((prefix_length, ctx_length), List.rev(ctx)), - ), - ); - }; - }; - - let added_bindings = (ctx_after: t, ctx_before: t): t => { - /* Precondition: new_ctx is old_ctx plus some new bindings */ - let new_count = List.length(ctx_after) - List.length(ctx_before); - switch (ListUtil.split_n_opt(new_count, ctx_after)) { - | Some((ctx, _)) => ctx - | _ => [] - }; - }; - - module VarSet = Set.Make(Var); - - // Note: filter out duplicates when rendering - let filter_duplicates = (ctx: t): t => - ctx - |> List.fold_left( - ((ctx, term_set, typ_set), entry) => { - switch (entry) { - | VarEntry({name, _}) - | ConstructorEntry({name, _}) => - VarSet.mem(name, term_set) - ? (ctx, term_set, typ_set) - : ([entry, ...ctx], VarSet.add(name, term_set), typ_set) - | TVarEntry({name, _}) => - VarSet.mem(name, typ_set) - ? (ctx, term_set, typ_set) - : ([entry, ...ctx], term_set, VarSet.add(name, typ_set)) - } - }, - ([], VarSet.empty, VarSet.empty), - ) - |> (((ctx, _, _)) => List.rev(ctx)); - - let shadows_typ = (ctx: t, name: string): bool => - Form.is_base_typ(name) || lookup_alias(ctx, name) != None; -} -and Kind: { - [@deriving (show({with_path: false}), sexp, yojson)] - type t = - | Singleton(Typ.t) - | Abstract; -} = { - [@deriving (show({with_path: false}), sexp, yojson)] - type t = - | Singleton(Typ.t) - | Abstract; -}; diff --git a/src/haz3lcore/statics/uterm/UTyp.re b/src/haz3lcore/statics/uterm/UTyp.re index 194c5270fd..7dcfba5350 100644 --- a/src/haz3lcore/statics/uterm/UTyp.re +++ b/src/haz3lcore/statics/uterm/UTyp.re @@ -1 +1 @@ -include TypTerm; +include Typ; diff --git a/src/haz3lweb/view/ExplainThis.re b/src/haz3lweb/view/ExplainThis.re index 9318146de9..b5b1a7cba9 100644 --- a/src/haz3lweb/view/ExplainThis.re +++ b/src/haz3lweb/view/ExplainThis.re @@ -402,7 +402,7 @@ let rec bypass_parens_exp = (exp: Exp.t) => { }; }; -let rec bypass_parens_typ = (typ: TypTerm.t) => { +let rec bypass_parens_typ = (typ: Typ.t) => { switch (typ.term) { | Parens(t) => bypass_parens_typ(t) | _ => typ @@ -2030,8 +2030,10 @@ let get_doc = } | Some(InfoTyp({term, _} as typ_info)) => switch (bypass_parens_typ(term).term) { - | EmptyHole => get_message(HoleTyp.empty_hole) - | MultiHole(_) => get_message(HoleTyp.multi_hole) + | Unknown(SynSwitch) + | Unknown(Internal) + | Unknown(Hole(EmptyHole)) => get_message(HoleTyp.empty_hole) + | Unknown(Hole(MultiHole(_))) => get_message(HoleTyp.multi_hole) | Int => get_message(TerminalTyp.int) | Float => get_message(TerminalTyp.float) | Bool => get_message(TerminalTyp.bool) @@ -2084,7 +2086,7 @@ let get_doc = doc, ); switch (result.term) { - | TypTerm.Arrow(arg2, result2) => + | Typ.Arrow(arg2, result2) => if (ArrowTyp.arrow3_typ.id == get_specificity_level(ArrowTyp.arrow3)) { let arg2_id = List.nth(arg2.ids, 0); let result2_id = List.nth(result2.ids, 0); @@ -2198,7 +2200,7 @@ let get_doc = | Sum(_) => get_message(SumTyp.labelled_sum_typs) | Ap({term: Var(c), _}, _) => get_message(SumTyp.sum_typ_unary_constructor_defs(c)) - | Invalid(_) => simple("Not a type or type operator") + | Unknown(Hole(Invalid(_))) => simple("Not a type or type operator") | Ap(_) | Parens(_) => default // Shouldn't be hit? } diff --git a/src/haz3lweb/view/Kind.re b/src/haz3lweb/view/Kind.re index f84672515c..8feb3af0b0 100644 --- a/src/haz3lweb/view/Kind.re +++ b/src/haz3lweb/view/Kind.re @@ -2,7 +2,7 @@ open Virtual_dom.Vdom; open Node; open Util.Web; -let view = (kind: Haz3lcore.Kind.t): Node.t => +let view = (kind: Haz3lcore.Ctx.kind): Node.t => switch (kind) { | Singleton(ty) => div_c("kind-view", [Type.view(ty)]) | Abstract => div_c("kind-view", [text("Type")]) diff --git a/src/haz3lweb/view/Type.re b/src/haz3lweb/view/Type.re index 4693808ab0..c8f677d448 100644 --- a/src/haz3lweb/view/Type.re +++ b/src/haz3lweb/view/Type.re @@ -9,14 +9,6 @@ let ty_view = (cls: string, s: string): Node.t => let alias_view = (s: string): Node.t => div(~attr=clss(["typ-alias-view"]), [text(s)]); -// let prov_view: Typ.type_provenance => Node.t = -// fun -// | Internal => div([]) -// | Free(name) => -// div(~attr=clss(["typ-mod", "free-type-var"]), [text(name)]) -// | TypeHole => div(~attr=clss(["typ-mod", "type-hole"]), [text("𝜏")]) -// | SynSwitch => div(~attr=clss(["typ-mod", "syn-switch"]), [text("⇒")]); - let rec view_ty = (ty: Haz3lcore.Typ.t): Node.t => //TODO: parens on ops when ambiguous switch (Typ.term_of(ty)) { @@ -35,11 +27,16 @@ let rec view_ty = (ty: Haz3lcore.Typ.t): Node.t => | String => ty_view("String", "String") | Bool => ty_view("Bool", "Bool") | Var(name) => ty_view("Var", name) - | Rec(x, t) => + | Rec({term: Var(x), _}, t) => div( ~attr=clss(["typ-view", "Rec"]), [text("Rec " ++ x ++ ". "), view_ty(t)], ) + | Rec(_, t) => + div( + ~attr=clss(["typ-view", "Rec"]), + [text("Rec " ++ "?" ++ ". "), view_ty(t)], + ) | List(t) => div( ~attr=clss(["typ-view", "atom", "List"]), diff --git a/src/haz3lweb/view/dhcode/layout/HTypDoc.re b/src/haz3lweb/view/dhcode/layout/HTypDoc.re index 1bb5662921..a41607b294 100644 --- a/src/haz3lweb/view/dhcode/layout/HTypDoc.re +++ b/src/haz3lweb/view/dhcode/layout/HTypDoc.re @@ -66,7 +66,7 @@ let rec mk = (~parenthesize=false, ~enforce_inline: bool, ty: Typ.t): t => { ) | Arrow(ty1, ty2) => let (d1, d2) = - mk_right_associative_operands(TypBase.precedence_Arrow, ty1, ty2); + mk_right_associative_operands(Typ.precedence_Arrow, ty1, ty2); ( hcats([ d1, @@ -85,7 +85,7 @@ let rec mk = (~parenthesize=false, ~enforce_inline: bool, ty: Typ.t): t => { annot( HTypAnnot.Step(0), mk'( - ~parenthesize=Typ.precedence(head) <= TypBase.precedence_Prod, + ~parenthesize=Typ.precedence(head) <= Typ.precedence_Prod, head, ), ), @@ -94,8 +94,7 @@ let rec mk = (~parenthesize=false, ~enforce_inline: bool, ty: Typ.t): t => { annot( HTypAnnot.Step(i + 1), mk'( - ~parenthesize= - Typ.precedence(ty) <= TypBase.precedence_Prod, + ~parenthesize=Typ.precedence(ty) <= Typ.precedence_Prod, ty, ), ), @@ -109,7 +108,16 @@ let rec mk = (~parenthesize=false, ~enforce_inline: bool, ty: Typ.t): t => { (center, true); | Rec(x, ty) => ( hcats([ - text("Rec " ++ x ++ ".{"), + text( + "Rec " + ++ ( + switch (IdTagged.term_of(x)) { + | Var(name) => name + | _ => "?" + } + ) + ++ ".{", + ), ( (~enforce_inline) => annot(HTypAnnot.Step(0), mk(~enforce_inline, ty)) From f6dcb7a86615ec85fc7ac981803ff26d3d30b85e Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Tue, 2 Apr 2024 12:21:00 -0400 Subject: [PATCH 064/103] Move type functions into one file --- src/haz3lcore/lang/term/Typ.re | 169 ++++++++++++++++++--- src/haz3lcore/statics/Term.re | 155 ------------------- src/haz3lweb/view/dhcode/layout/HTypDoc.re | 39 +++-- 3 files changed, 174 insertions(+), 189 deletions(-) diff --git a/src/haz3lcore/lang/term/Typ.re b/src/haz3lcore/lang/term/Typ.re index b7d72b6051..955e82cedf 100644 --- a/src/haz3lcore/lang/term/Typ.re +++ b/src/haz3lcore/lang/term/Typ.re @@ -1,16 +1,156 @@ -include Term.Typ; open Util; open OptUtil.Syntax; -let precedence_Prod = 1; -let precedence_Arrow = 2; -let precedence_Sum = 3; -let precedence_Ap = 4; -let precedence_Const = 5; +[@deriving (show({with_path: false}), sexp, yojson)] +type cls = + | Invalid + | EmptyHole + | MultiHole + | SynSwitch + | Internal + | Int + | Float + | Bool + | String + | Arrow + | Prod + | Sum + | List + | Var + | Constructor + | Parens + | Ap + | Rec; + +include TermBase.Typ; let term_of: t => term = IdTagged.term_of; let unwrap: t => (term, term => t) = IdTagged.unwrap; let fresh: term => t = IdTagged.fresh; +let rep_id: t => Id.t = IdTagged.rep_id; + +let hole = (tms: list(TermBase.Any.t)) => + switch (tms) { + | [] => Unknown(Hole(EmptyHole)) + | [_, ..._] => Unknown(Hole(MultiHole(tms))) + }; + +let cls_of_term: term => cls = + fun + | Unknown(Hole(Invalid(_))) => Invalid + | Unknown(Hole(EmptyHole)) => EmptyHole + | Unknown(Hole(MultiHole(_))) => MultiHole + | Unknown(SynSwitch) => SynSwitch + | Unknown(Internal) => Internal + | Int => Int + | Float => Float + | Bool => Bool + | String => String + | List(_) => List + | Arrow(_) => Arrow + | Var(_) => Var + | Prod(_) => Prod + | Parens(_) => Parens + | Ap(_) => Ap + | Sum(_) => Sum + | Rec(_) => Rec; + +let show_cls: cls => string = + fun + | Invalid => "Invalid type" + | MultiHole => "Broken type" + | EmptyHole => "Empty type hole" + | SynSwitch => "Synthetic type" + | Internal => "Internal type" + | Int + | Float + | String + | Bool => "Base type" + | Var => "Type variable" + | Constructor => "Sum constructor" + | List => "List type" + | Arrow => "Function type" + | Prod => "Product type" + | Sum => "Sum type" + | Parens => "Parenthesized type" + | Ap => "Constructor application" + | Rec => "Recursive Type"; + +let rec is_arrow = (typ: t) => { + switch (typ.term) { + | Parens(typ) => is_arrow(typ) + | Arrow(_) => true + | Unknown(_) + | Int + | Float + | Bool + | String + | List(_) + | Prod(_) + | Var(_) + | Ap(_) + | Sum(_) + | Rec(_) => false + }; +}; + +/* Converts a syntactic type into a semantic type */ +let rec to_typ: (Ctx.t, t) => t = + (ctx, utyp) => { + let (term, rewrap) = IdTagged.unwrap(utyp); + switch (term) { + | Unknown(_) + | Bool + | Int + | Float + | String => utyp + | Var(name) => + switch (Ctx.lookup_tvar(ctx, name)) { + | Some(_) => Var(name) |> rewrap + | None => Unknown(Hole(Invalid(name))) |> rewrap + } + | Arrow(u1, u2) => Arrow(to_typ(ctx, u1), to_typ(ctx, u2)) |> rewrap + | Prod(us) => Prod(List.map(to_typ(ctx), us)) |> rewrap + | Sum(uts) => Sum(to_ctr_map(ctx, uts)) |> rewrap + | List(u) => List(to_typ(ctx, u)) |> rewrap + | Parens(u) => to_typ(ctx, u) + /* The below cases should occur only inside sums */ + | Ap(_) => Unknown(Internal) |> rewrap + | Rec({term: Invalid(_), _} as tpat, tbody) + | Rec({term: EmptyHole, _} as tpat, tbody) + | Rec({term: MultiHole(_), _} as tpat, tbody) => + Rec(tpat, to_typ(ctx, tbody)) |> rewrap + | Rec({term: Var(name), _} as utpat, tbody) => + let ctx = + Ctx.extend_tvar( + ctx, + {name, id: IdTagged.rep_id(utpat), kind: Abstract}, + ); + Rec(utpat, to_typ(ctx, tbody)) |> rewrap; + }; + } +and to_variant: + (Ctx.t, ConstructorMap.variant(t)) => ConstructorMap.variant(t) = + ctx => + fun + | Variant(ctr, ids, u) => + ConstructorMap.Variant(ctr, ids, Option.map(to_typ(ctx), u)) + | BadEntry(u) => ConstructorMap.BadEntry(to_typ(ctx, u)) +and to_ctr_map = (ctx: Ctx.t, uts: list(ConstructorMap.variant(t))) => { + uts + |> List.map(to_variant(ctx)) + |> ListUtil.dedup_f( + (x: ConstructorMap.variant(t), y: ConstructorMap.variant(t)) => + switch (x, y) { + | (Variant(c1, _, _), Variant(c2, _, _)) => c1 == c2 + | (Variant(_), BadEntry(_)) + | (BadEntry(_), Variant(_)) + | (BadEntry(_), BadEntry(_)) => false + } + ); +}; + +/* Functions below this point assume that types have been through the to_typ function above */ [@deriving (show({with_path: false}), sexp, yojson)] type source = { @@ -38,23 +178,6 @@ let join_type_provenance = | (SynSwitch, SynSwitch) => SynSwitch }; -let precedence = (ty: t): int => - switch (term_of(ty)) { - | Int - | Float - | Bool - | String - | Unknown(_) - | Var(_) - | Rec(_) - | Sum(_) => precedence_Sum - | List(_) => precedence_Const - | Prod(_) => precedence_Prod - | Arrow(_, _) => precedence_Arrow - | Parens(_) => precedence_Const - | Ap(_) => precedence_Ap - }; - let rec subst = (s: t, x: string, ty: t) => { let (term, rewrap) = unwrap(ty); switch (term) { diff --git a/src/haz3lcore/statics/Term.re b/src/haz3lcore/statics/Term.re index 1aebe91ba8..ecca3cb087 100644 --- a/src/haz3lcore/statics/Term.re +++ b/src/haz3lcore/statics/Term.re @@ -1,5 +1,3 @@ -open Util; - module TPat = { [@deriving (show({with_path: false}), sexp, yojson)] type cls = @@ -36,159 +34,6 @@ module TPat = { | Var => "Type alias"; }; -module Typ = { - include TermBase.Typ; - - [@deriving (show({with_path: false}), sexp, yojson)] - type cls = - | Invalid - | EmptyHole - | MultiHole - | SynSwitch - | Internal - | Int - | Float - | Bool - | String - | Arrow - | Prod - | Sum - | List - | Var - | Constructor - | Parens - | Ap - | Rec; - - include TermBase.Typ; - - let rep_id = ({ids, _}: t) => { - assert(ids != []); - List.hd(ids); - }; - - let hole = (tms: list(TermBase.Any.t)) => - switch (tms) { - | [] => Unknown(Hole(EmptyHole)) - | [_, ..._] => Unknown(Hole(MultiHole(tms))) - }; - - let cls_of_term: term => cls = - fun - | Unknown(Hole(Invalid(_))) => Invalid - | Unknown(Hole(EmptyHole)) => EmptyHole - | Unknown(Hole(MultiHole(_))) => MultiHole - | Unknown(SynSwitch) => SynSwitch - | Unknown(Internal) => Internal - | Int => Int - | Float => Float - | Bool => Bool - | String => String - | List(_) => List - | Arrow(_) => Arrow - | Var(_) => Var - | Prod(_) => Prod - | Parens(_) => Parens - | Ap(_) => Ap - | Sum(_) => Sum - | Rec(_) => Rec; - - let show_cls: cls => string = - fun - | Invalid => "Invalid type" - | MultiHole => "Broken type" - | EmptyHole => "Empty type hole" - | SynSwitch => "Synthetic type" - | Internal => "Internal type" - | Int - | Float - | String - | Bool => "Base type" - | Var => "Type variable" - | Constructor => "Sum constructor" - | List => "List type" - | Arrow => "Function type" - | Prod => "Product type" - | Sum => "Sum type" - | Parens => "Parenthesized type" - | Ap => "Constructor application" - | Rec => "Recursive Type"; - - let rec is_arrow = (typ: t) => { - switch (typ.term) { - | Parens(typ) => is_arrow(typ) - | Arrow(_) => true - | Unknown(_) - | Int - | Float - | Bool - | String - | List(_) - | Prod(_) - | Var(_) - | Ap(_) - | Sum(_) - | Rec(_) => false - }; - }; - - /* Converts a syntactic type into a semantic type */ - let rec to_typ: (Ctx.t, t) => t = - (ctx, utyp) => { - let (term, rewrap) = IdTagged.unwrap(utyp); - switch (term) { - | Unknown(_) - | Bool - | Int - | Float - | String => utyp - | Var(name) => - switch (Ctx.lookup_tvar(ctx, name)) { - | Some(_) => Var(name) |> rewrap - | None => Unknown(Hole(Invalid(name))) |> rewrap - } - | Arrow(u1, u2) => Arrow(to_typ(ctx, u1), to_typ(ctx, u2)) |> rewrap - | Prod(us) => Prod(List.map(to_typ(ctx), us)) |> rewrap - | Sum(uts) => Sum(to_ctr_map(ctx, uts)) |> rewrap - | List(u) => List(to_typ(ctx, u)) |> rewrap - | Parens(u) => to_typ(ctx, u) - /* The below cases should occur only inside sums */ - | Ap(_) => Unknown(Internal) |> rewrap - | Rec({term: Invalid(_), _} as tpat, tbody) - | Rec({term: EmptyHole, _} as tpat, tbody) - | Rec({term: MultiHole(_), _} as tpat, tbody) => - Rec(tpat, to_typ(ctx, tbody)) |> rewrap - | Rec({term: Var(name), _} as utpat, tbody) => - let ctx = - Ctx.extend_tvar( - ctx, - {name, id: TPat.rep_id(utpat), kind: Abstract}, - ); - Rec(utpat, to_typ(ctx, tbody)) |> rewrap; - }; - } - and to_variant: - (Ctx.t, ConstructorMap.variant(t)) => ConstructorMap.variant(t) = - ctx => - fun - | Variant(ctr, ids, u) => - ConstructorMap.Variant(ctr, ids, Option.map(to_typ(ctx), u)) - | BadEntry(u) => ConstructorMap.BadEntry(to_typ(ctx, u)) - and to_ctr_map = (ctx: Ctx.t, uts: list(ConstructorMap.variant(t))) => { - uts - |> List.map(to_variant(ctx)) - |> ListUtil.dedup_f( - (x: ConstructorMap.variant(t), y: ConstructorMap.variant(t)) => - switch (x, y) { - | (Variant(c1, _, _), Variant(c2, _, _)) => c1 == c2 - | (Variant(_), BadEntry(_)) - | (BadEntry(_), Variant(_)) - | (BadEntry(_), BadEntry(_)) => false - } - ); - }; -}; - module Pat = { [@deriving (show({with_path: false}), sexp, yojson)] type cls = diff --git a/src/haz3lweb/view/dhcode/layout/HTypDoc.re b/src/haz3lweb/view/dhcode/layout/HTypDoc.re index a41607b294..b122ac7c0a 100644 --- a/src/haz3lweb/view/dhcode/layout/HTypDoc.re +++ b/src/haz3lweb/view/dhcode/layout/HTypDoc.re @@ -6,6 +6,29 @@ type t = Doc.t(HTypAnnot.t); type formattable_child = (~enforce_inline: bool) => t; +let precedence_Prod = 1; +let precedence_Arrow = 2; +let precedence_Sum = 3; +let precedence_Ap = 4; +let precedence_Const = 5; + +let precedence = (ty: Typ.t): int => + switch (Typ.term_of(ty)) { + | Int + | Float + | Bool + | String + | Unknown(_) + | Var(_) + | Rec(_) + | Sum(_) => precedence_Sum + | List(_) => precedence_Const + | Prod(_) => precedence_Prod + | Arrow(_, _) => precedence_Arrow + | Parens(_) => precedence_Const + | Ap(_) => precedence_Ap + }; + let pad_child = ( ~inline_padding as (l, r)=(Doc.empty(), Doc.empty()), @@ -33,11 +56,11 @@ let rec mk = (~parenthesize=false, ~enforce_inline: bool, ty: Typ.t): t => { let mk_right_associative_operands = (precedence_op, ty1, ty2) => ( annot( HTypAnnot.Step(0), - mk'(~parenthesize=Typ.precedence(ty1) <= precedence_op, ty1), + mk'(~parenthesize=precedence(ty1) <= precedence_op, ty1), ), annot( HTypAnnot.Step(1), - mk'(~parenthesize=Typ.precedence(ty2) < precedence_op, ty2), + mk'(~parenthesize=precedence(ty2) < precedence_op, ty2), ), ); let (doc, parenthesize) = @@ -66,7 +89,7 @@ let rec mk = (~parenthesize=false, ~enforce_inline: bool, ty: Typ.t): t => { ) | Arrow(ty1, ty2) => let (d1, d2) = - mk_right_associative_operands(Typ.precedence_Arrow, ty1, ty2); + mk_right_associative_operands(precedence_Arrow, ty1, ty2); ( hcats([ d1, @@ -84,19 +107,13 @@ let rec mk = (~parenthesize=false, ~enforce_inline: bool, ty: Typ.t): t => { [ annot( HTypAnnot.Step(0), - mk'( - ~parenthesize=Typ.precedence(head) <= Typ.precedence_Prod, - head, - ), + mk'(~parenthesize=precedence(head) <= precedence_Prod, head), ), ...List.mapi( (i, ty) => annot( HTypAnnot.Step(i + 1), - mk'( - ~parenthesize=Typ.precedence(ty) <= Typ.precedence_Prod, - ty, - ), + mk'(~parenthesize=precedence(ty) <= precedence_Prod, ty), ), tail, ), From 687a4295582d4c6b857d0e707b18cedd2d6df68c Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Tue, 2 Apr 2024 13:57:01 -0400 Subject: [PATCH 065/103] Delete some small files --- src/haz3lcore/dynamics/Delta.re | 4 +-- src/haz3lcore/dynamics/Delta.rei | 2 +- src/haz3lcore/dynamics/EnvironmentId.re | 1 - src/haz3lcore/dynamics/EnvironmentId.rei | 1 - src/haz3lcore/dynamics/EnvironmentIdMap.re | 1 - src/haz3lcore/dynamics/EnvironmentIdMap.rei | 5 ---- src/haz3lcore/dynamics/ErrStatus.re | 15 ----------- src/haz3lcore/dynamics/Evaluator.re | 22 ++++++++++++++- src/haz3lcore/dynamics/Evaluator.rei | 30 --------------------- src/haz3lcore/dynamics/EvaluatorResult.re | 16 ----------- src/haz3lcore/dynamics/EvaluatorResult.rei | 22 --------------- src/haz3lcore/dynamics/EvaluatorState.rei | 2 +- src/haz3lcore/dynamics/KeywordID.re | 2 -- src/haz3lcore/dynamics/MetaVar.re | 2 -- src/haz3lcore/dynamics/MetaVar.rei | 2 -- src/haz3lcore/dynamics/MetaVarInst.re | 7 ----- src/haz3lcore/dynamics/MetaVarInst.rei | 5 ---- src/haz3lcore/dynamics/MetaVarMap.re | 1 - src/haz3lcore/dynamics/TestMap.re | 2 +- src/haz3lcore/dynamics/Transition.re | 2 +- src/haz3lcore/dynamics/VarErrStatus.re | 2 +- src/haz3lcore/prog/ProgramResult.re | 4 +-- src/haz3lcore/statics/TermBase.re | 12 ++++----- 23 files changed, 36 insertions(+), 126 deletions(-) delete mode 100644 src/haz3lcore/dynamics/EnvironmentId.re delete mode 100644 src/haz3lcore/dynamics/EnvironmentId.rei delete mode 100644 src/haz3lcore/dynamics/EnvironmentIdMap.re delete mode 100644 src/haz3lcore/dynamics/EnvironmentIdMap.rei delete mode 100644 src/haz3lcore/dynamics/ErrStatus.re delete mode 100644 src/haz3lcore/dynamics/Evaluator.rei delete mode 100644 src/haz3lcore/dynamics/EvaluatorResult.re delete mode 100644 src/haz3lcore/dynamics/EvaluatorResult.rei delete mode 100644 src/haz3lcore/dynamics/KeywordID.re delete mode 100644 src/haz3lcore/dynamics/MetaVar.re delete mode 100644 src/haz3lcore/dynamics/MetaVar.rei delete mode 100644 src/haz3lcore/dynamics/MetaVarInst.re delete mode 100644 src/haz3lcore/dynamics/MetaVarInst.rei delete mode 100644 src/haz3lcore/dynamics/MetaVarMap.re diff --git a/src/haz3lcore/dynamics/Delta.re b/src/haz3lcore/dynamics/Delta.re index 8a492c9c20..7f9f4732c4 100644 --- a/src/haz3lcore/dynamics/Delta.re +++ b/src/haz3lcore/dynamics/Delta.re @@ -4,5 +4,5 @@ type hole_sort = | PatternHole; [@deriving sexp] -type t = MetaVarMap.t((hole_sort, Typ.t, VarCtx.t)); -let empty: t = (MetaVarMap.empty: t); +type t = Id.Map.t((hole_sort, Typ.t, VarCtx.t)); +let empty: t = (Id.Map.empty: t); diff --git a/src/haz3lcore/dynamics/Delta.rei b/src/haz3lcore/dynamics/Delta.rei index d37de1926b..3b6d97cfb6 100644 --- a/src/haz3lcore/dynamics/Delta.rei +++ b/src/haz3lcore/dynamics/Delta.rei @@ -4,6 +4,6 @@ type hole_sort = | PatternHole; [@deriving sexp] -type t = MetaVarMap.t((hole_sort, Typ.t, VarCtx.t)); +type t = Id.Map.t((hole_sort, Typ.t, VarCtx.t)); let empty: t; diff --git a/src/haz3lcore/dynamics/EnvironmentId.re b/src/haz3lcore/dynamics/EnvironmentId.re deleted file mode 100644 index 5f6be7cd46..0000000000 --- a/src/haz3lcore/dynamics/EnvironmentId.re +++ /dev/null @@ -1 +0,0 @@ -include Id; diff --git a/src/haz3lcore/dynamics/EnvironmentId.rei b/src/haz3lcore/dynamics/EnvironmentId.rei deleted file mode 100644 index e7d316dd0a..0000000000 --- a/src/haz3lcore/dynamics/EnvironmentId.rei +++ /dev/null @@ -1 +0,0 @@ -include (module type of Id); diff --git a/src/haz3lcore/dynamics/EnvironmentIdMap.re b/src/haz3lcore/dynamics/EnvironmentIdMap.re deleted file mode 100644 index 932d7b1316..0000000000 --- a/src/haz3lcore/dynamics/EnvironmentIdMap.re +++ /dev/null @@ -1 +0,0 @@ -include Id.Map; diff --git a/src/haz3lcore/dynamics/EnvironmentIdMap.rei b/src/haz3lcore/dynamics/EnvironmentIdMap.rei deleted file mode 100644 index d5194bbcf2..0000000000 --- a/src/haz3lcore/dynamics/EnvironmentIdMap.rei +++ /dev/null @@ -1,5 +0,0 @@ -/* Mapping from EnvironmentId.t (to some other type) - - Used in HoleInstanceInfo_.re - */ -include (module type of Id.Map); diff --git a/src/haz3lcore/dynamics/ErrStatus.re b/src/haz3lcore/dynamics/ErrStatus.re deleted file mode 100644 index 94fd844ffe..0000000000 --- a/src/haz3lcore/dynamics/ErrStatus.re +++ /dev/null @@ -1,15 +0,0 @@ -module HoleReason = { - /* Variable: `reason` */ - [@deriving (show({with_path: false}), sexp, yojson)] - type t = - | TypeInconsistent - | WrongLength; - - let eq = (x, y) => x == y; -}; - -/* Variable: `err` */ -[@deriving (show({with_path: false}), sexp, yojson)] -type t = - | NotInHole - | InHole(HoleReason.t, MetaVar.t); diff --git a/src/haz3lcore/dynamics/Evaluator.re b/src/haz3lcore/dynamics/Evaluator.re index eb9d885628..2c1cf96606 100644 --- a/src/haz3lcore/dynamics/Evaluator.re +++ b/src/haz3lcore/dynamics/Evaluator.re @@ -1,6 +1,26 @@ -open EvaluatorResult; open Transition; +module Result = { + [@deriving (show({with_path: false}), sexp, yojson)] + type t = + | BoxedValue(DHExp.t) + | Indet(DHExp.t); + + let unbox = + fun + | BoxedValue(d) + | Indet(d) => d; + + let fast_equal = (r1, r2) => + switch (r1, r2) { + | (BoxedValue(d1), BoxedValue(d2)) + | (Indet(d1), Indet(d2)) => DHExp.fast_equal(d1, d2) + | _ => false + }; +}; + +open Result; + module EvaluatorEVMode: { type result_unfinished = | BoxedValue(DHExp.t) diff --git a/src/haz3lcore/dynamics/Evaluator.rei b/src/haz3lcore/dynamics/Evaluator.rei deleted file mode 100644 index 5e720a0205..0000000000 --- a/src/haz3lcore/dynamics/Evaluator.rei +++ /dev/null @@ -1,30 +0,0 @@ -open Transition; - -let evaluate: - (Environment.t, Elaborator.Elaboration.t) => - (EvaluatorState.t, EvaluatorResult.t); - -module EvaluatorEVMode: { - type result_unfinished = - | BoxedValue(DHExp.t) - | Indet(DHExp.t) - | Uneval(DHExp.t); - - let unbox: result_unfinished => DHExp.t; - - include - EV_MODE with - type state = ref(EvaluatorState.t) and type result = result_unfinished; -}; - -module Eval: { - let transition: - ( - (EvaluatorEVMode.state, ClosureEnvironment.t, DHExp.t) => - EvaluatorEVMode.result_unfinished, - EvaluatorEVMode.state, - ClosureEnvironment.t, - DHExp.t - ) => - EvaluatorEVMode.result_unfinished; -}; diff --git a/src/haz3lcore/dynamics/EvaluatorResult.re b/src/haz3lcore/dynamics/EvaluatorResult.re deleted file mode 100644 index 73628a7c89..0000000000 --- a/src/haz3lcore/dynamics/EvaluatorResult.re +++ /dev/null @@ -1,16 +0,0 @@ -[@deriving (show({with_path: false}), sexp, yojson)] -type t = - | BoxedValue(DHExp.t) - | Indet(DHExp.t); - -let unbox = - fun - | BoxedValue(d) - | Indet(d) => d; - -let fast_equal = (r1, r2) => - switch (r1, r2) { - | (BoxedValue(d1), BoxedValue(d2)) - | (Indet(d1), Indet(d2)) => DHExp.fast_equal(d1, d2) - | _ => false - }; diff --git a/src/haz3lcore/dynamics/EvaluatorResult.rei b/src/haz3lcore/dynamics/EvaluatorResult.rei deleted file mode 100644 index 350c3cec62..0000000000 --- a/src/haz3lcore/dynamics/EvaluatorResult.rei +++ /dev/null @@ -1,22 +0,0 @@ -/** - The output from {!val:Evaluator.evaluate}. - */ - -/** - The type for the evaluation result, a {!type:DHExp.t} wrapped in its {v final - v} judgment (boxed value or indeterminate). - */ -[@deriving (show({with_path: false}), sexp, yojson)] -type t = - | BoxedValue(DHExp.t) - | Indet(DHExp.t); - -/** - [unbox r] is the inner expression. - */ -let unbox: t => DHExp.t; - -/** - See {!val:DHExp.fast_equal}. - */ -let fast_equal: (t, t) => bool; diff --git a/src/haz3lcore/dynamics/EvaluatorState.rei b/src/haz3lcore/dynamics/EvaluatorState.rei index fc17591573..b33f989ea7 100644 --- a/src/haz3lcore/dynamics/EvaluatorState.rei +++ b/src/haz3lcore/dynamics/EvaluatorState.rei @@ -28,7 +28,7 @@ let get_step: t => int; let put_step: (int, t) => t; -let add_test: (t, KeywordID.t, TestMap.instance_report) => t; +let add_test: (t, Id.t, TestMap.instance_report) => t; let get_tests: t => TestMap.t; diff --git a/src/haz3lcore/dynamics/KeywordID.re b/src/haz3lcore/dynamics/KeywordID.re deleted file mode 100644 index d176549da7..0000000000 --- a/src/haz3lcore/dynamics/KeywordID.re +++ /dev/null @@ -1,2 +0,0 @@ -[@deriving (show({with_path: false}), sexp, yojson)] -type t = Id.t; diff --git a/src/haz3lcore/dynamics/MetaVar.re b/src/haz3lcore/dynamics/MetaVar.re deleted file mode 100644 index d176549da7..0000000000 --- a/src/haz3lcore/dynamics/MetaVar.re +++ /dev/null @@ -1,2 +0,0 @@ -[@deriving (show({with_path: false}), sexp, yojson)] -type t = Id.t; diff --git a/src/haz3lcore/dynamics/MetaVar.rei b/src/haz3lcore/dynamics/MetaVar.rei deleted file mode 100644 index d176549da7..0000000000 --- a/src/haz3lcore/dynamics/MetaVar.rei +++ /dev/null @@ -1,2 +0,0 @@ -[@deriving (show({with_path: false}), sexp, yojson)] -type t = Id.t; diff --git a/src/haz3lcore/dynamics/MetaVarInst.re b/src/haz3lcore/dynamics/MetaVarInst.re deleted file mode 100644 index 9b410f2e61..0000000000 --- a/src/haz3lcore/dynamics/MetaVarInst.re +++ /dev/null @@ -1,7 +0,0 @@ -open Sexplib.Std; - -/** - * Hole instance index in DHPat and DHExp - */ -[@deriving (show({with_path: false}), sexp, yojson)] -type t = int; diff --git a/src/haz3lcore/dynamics/MetaVarInst.rei b/src/haz3lcore/dynamics/MetaVarInst.rei deleted file mode 100644 index 89692b7bed..0000000000 --- a/src/haz3lcore/dynamics/MetaVarInst.rei +++ /dev/null @@ -1,5 +0,0 @@ -/** - * Hole instance index in DHPat and DHExp - */ -[@deriving (show({with_path: false}), sexp, yojson)] -type t = int; diff --git a/src/haz3lcore/dynamics/MetaVarMap.re b/src/haz3lcore/dynamics/MetaVarMap.re deleted file mode 100644 index 932d7b1316..0000000000 --- a/src/haz3lcore/dynamics/MetaVarMap.re +++ /dev/null @@ -1 +0,0 @@ -include Id.Map; diff --git a/src/haz3lcore/dynamics/TestMap.re b/src/haz3lcore/dynamics/TestMap.re index 8592e0e546..91f9ff4430 100644 --- a/src/haz3lcore/dynamics/TestMap.re +++ b/src/haz3lcore/dynamics/TestMap.re @@ -8,7 +8,7 @@ let joint_status: list(instance_report) => TestStatus.t = reports => TestStatus.join_all(List.map(((_, _, x)) => x, reports)); [@deriving (show({with_path: false}), sexp, yojson)] -type report = (KeywordID.t, list(instance_report)); +type report = (Id.t, list(instance_report)); [@deriving (show({with_path: false}), sexp, yojson)] type t = list(report); diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index eb713505e3..99aa08295c 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -188,7 +188,7 @@ module type EV_MODE = { requirements(('a, 'c), 'b); let otherwise: (ClosureEnvironment.t, 'a) => requirements(unit, 'a); - let update_test: (state, KeywordID.t, TestMap.instance_report) => unit; + let update_test: (state, Id.t, TestMap.instance_report) => unit; let get_info_map: state => Statics.Map.t; }; diff --git a/src/haz3lcore/dynamics/VarErrStatus.re b/src/haz3lcore/dynamics/VarErrStatus.re index 167db32cad..d52f5809a5 100644 --- a/src/haz3lcore/dynamics/VarErrStatus.re +++ b/src/haz3lcore/dynamics/VarErrStatus.re @@ -9,4 +9,4 @@ module HoleReason = { [@deriving (show({with_path: false}), sexp, yojson)] type t = | NotInVarHole - | InVarHole(HoleReason.t, MetaVar.t); + | InVarHole(HoleReason.t, Id.t); diff --git a/src/haz3lcore/prog/ProgramResult.re b/src/haz3lcore/prog/ProgramResult.re index 0b57d2558f..fb746fe06f 100644 --- a/src/haz3lcore/prog/ProgramResult.re +++ b/src/haz3lcore/prog/ProgramResult.re @@ -7,7 +7,7 @@ open Sexplib.Std; */ [@deriving (show({with_path: false}), sexp, yojson)] type inner = { - result: EvaluatorResult.t, + result: Evaluator.Result.t, state: EvaluatorState.t, }; @@ -24,5 +24,5 @@ type t = | ResultFail(error) | ResultPending; -let get_dhexp = (r: inner) => EvaluatorResult.unbox(r.result); +let get_dhexp = (r: inner) => Evaluator.Result.unbox(r.result); let get_state = (r: inner) => r.state; diff --git a/src/haz3lcore/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index 8e5964c0c4..c9d0635d4f 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -611,9 +611,9 @@ and ClosureEnvironment: { [@deriving (show({with_path: false}), sexp, yojson)] type t; - let wrap: (EnvironmentId.t, Environment.t) => t; + let wrap: (Id.t, Environment.t) => t; - let id_of: t => EnvironmentId.t; + let id_of: t => Id.t; let map_of: t => Environment.t; let to_list: t => list((Var.t, Exp.t)); @@ -648,13 +648,13 @@ and ClosureEnvironment: { [@deriving (show({with_path: false}), sexp, yojson)] type t; - let wrap: (EnvironmentId.t, Environment.t) => t; + let wrap: (Id.t, Environment.t) => t; - let id_of: t => EnvironmentId.t; + let id_of: t => Id.t; let map_of: t => Environment.t; } = { [@deriving (show({with_path: false}), sexp, yojson)] - type t = (EnvironmentId.t, Environment.t); + type t = (Id.t, Environment.t); let wrap = (ei, map): t => (ei, map); @@ -715,7 +715,7 @@ and ClosureEnvironment: { let fold = (f, init, env) => env |> map_of |> Environment.foldo(f, init); - let placeholder = wrap(EnvironmentId.invalid, Environment.empty); + let placeholder = wrap(Id.invalid, Environment.empty); let without_keys = keys => update(Environment.without_keys(keys)); } From 7be9f32d8653e42979d083e0776f00f1f2e31228 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Wed, 3 Apr 2024 13:37:49 -0400 Subject: [PATCH 066/103] Rewrite pattern matching --- src/haz3lcore/dynamics/Casts.re | 155 ++++++ src/haz3lcore/dynamics/EvaluatorError.re | 1 + src/haz3lcore/dynamics/EvaluatorError.rei | 1 + src/haz3lcore/dynamics/EvaluatorStep.re | 6 +- src/haz3lcore/dynamics/PatternMatch.re | 630 +++------------------- src/haz3lcore/dynamics/PatternMatch.rei | 6 - src/haz3lcore/dynamics/Transition.re | 272 +++------- src/haz3lcore/dynamics/Unboxing.re | 177 ++++++ src/haz3lcore/lang/term/IdTagged.re | 2 + src/haz3lcore/statics/ConstructorMap.re | 8 + src/util/ListUtil.re | 10 + 11 files changed, 508 insertions(+), 760 deletions(-) create mode 100644 src/haz3lcore/dynamics/Casts.re delete mode 100644 src/haz3lcore/dynamics/PatternMatch.rei create mode 100644 src/haz3lcore/dynamics/Unboxing.re diff --git a/src/haz3lcore/dynamics/Casts.re b/src/haz3lcore/dynamics/Casts.re new file mode 100644 index 0000000000..aa8f15a585 --- /dev/null +++ b/src/haz3lcore/dynamics/Casts.re @@ -0,0 +1,155 @@ +open Util; + +/* The cast calculus is based off the POPL 2019 paper: + https://arxiv.org/pdf/1805.00155.pdf */ + +/* GROUND TYPES */ + +/* You can think of a ground type as a typet that tells you what the root of the + type expression is, but nothing more. For example: Int, [?], ? -> ?, ... are + ground types and [Int], ? -> Float are not. + + The most important property of ground types is: + If two types are ground types, + and the two types are consistent, + then they are equal. + + Make sure this holds for your new feature!! + + e.g. [?] and [?] are equal, but [?] and [Int] are not (because [Int] is not + ground, even though [Int] and [?] are consistent). + + */ + +[@deriving sexp] +type ground_cases = + | Hole + | Ground + | NotGroundOrHole(Typ.t) /* the argument is the corresponding ground type */; + +let rec ground_cases_of = (ty: Typ.t): ground_cases => { + let grounded_Arrow = + NotGroundOrHole( + Arrow(Unknown(Internal) |> Typ.fresh, Unknown(Internal) |> Typ.fresh) + |> Typ.fresh, + ); + let grounded_Prod = length => + NotGroundOrHole( + Prod(ListUtil.replicate(length, Typ.Unknown(Internal) |> Typ.fresh)) + |> Typ.fresh, + ); + let grounded_Sum: unit => Typ.sum_map = + () => [BadEntry(Typ.fresh(Unknown(Internal)))]; + let grounded_List = + NotGroundOrHole(List(Unknown(Internal) |> Typ.fresh) |> Typ.fresh); + let is_hole: Typ.t => bool = + fun + | {term: Typ.Unknown(_), _} => true + | _ => false; + switch (Typ.term_of(ty)) { + | Unknown(_) => Hole + | Bool + | Int + | Float + | String + | Var(_) + | Rec(_) + | Arrow({term: Unknown(_), _}, {term: Unknown(_), _}) + | List({term: Unknown(_), _}) => Ground + | Parens(ty) => ground_cases_of(ty) + | Prod(tys) => + if (List.for_all( + fun + | ({term: Typ.Unknown(_), _}: Typ.t) => true + | _ => false, + tys, + )) { + Ground; + } else { + tys |> List.length |> grounded_Prod; + } + | Sum(sm) => + sm |> ConstructorMap.is_ground(is_hole) + ? Ground : NotGroundOrHole(Sum(grounded_Sum()) |> Typ.fresh) + | Arrow(_, _) => grounded_Arrow + | List(_) => grounded_List + | Ap(_) => failwith("type application in dynamics") + }; +}; + +/* CAST CALCULUS */ + +/* Rules are taken from figure 12 of https://arxiv.org/pdf/1805.00155.pdf */ + +/* gives a transition step that can be taken by the cast calculus here if applicable. */ +let rec transition = (~recursive=false, d: DHExp.t): option(DHExp.t) => { + switch (DHExp.term_of(d)) { + | Cast(d1, t1, t2) => + let d1 = + if (recursive) { + d1 |> transition(~recursive) |> Option.value(~default=d1); + } else { + d1; + }; + switch (ground_cases_of(t1), ground_cases_of(t2)) { + | (Hole, Hole) + | (Ground, Ground) => + /* if two types are ground and consistent, then they are eq */ + Some(d1) // Rule ITCastId + + | (Ground, Hole) => + /* can't remove the cast or do anything else here, so we're done */ + None // TODO[Matt]: CONSTRUCTOR + + | (Hole, Ground) => + switch (DHExp.term_of(d1)) { + | Cast(d2, t3, {term: Unknown(_), _}) => + /* by canonical forms, d1' must be of the form d ?> */ + if (Typ.eq(t3, t2)) { + Some + (d2); // Rule ITCastSucceed + } else { + Some + (FailedCast(d2, t1, t2) |> DHExp.fresh); // Rule ITCastFail + } + | _ => None // TODO[Matt]: INDET + } + + | (Hole, NotGroundOrHole(t2_grounded)) => + /* ITExpand rule */ + Some( + DHExp.Cast(Cast(d1, t1, t2_grounded) |> DHExp.fresh, t2_grounded, t2) + |> DHExp.fresh, + ) + + | (NotGroundOrHole(t1_grounded), Hole) => + /* ITGround rule */ + Some( + DHExp.Cast(Cast(d1, t1, t1_grounded) |> DHExp.fresh, t1_grounded, t2) + |> DHExp.fresh, + ) + + | (Ground, NotGroundOrHole(_)) + | (NotGroundOrHole(_), Ground) => + /* can't do anything when casting between diseq, non-hole types */ + None // TODO[Matt]: CONSTRUCTOR + + | (NotGroundOrHole(_), NotGroundOrHole(_)) => + /* they might be eq in this case, so remove cast if so */ + if (Typ.eq(t1, t2)) { + Some + (d1); // Rule ITCastId + } else { + None; // TODO[Matt]: CONSTRUCTOR + } + }; + | _ => None + }; +}; + +let rec transition_multiple = (d: DHExp.t): DHExp.t => { + switch (transition(~recursive=true, d)) { + | Some(d'') => transition_multiple(d'') + | None => d + }; +}; diff --git a/src/haz3lcore/dynamics/EvaluatorError.re b/src/haz3lcore/dynamics/EvaluatorError.re index 7cd750d1bc..c0f8dd5449 100644 --- a/src/haz3lcore/dynamics/EvaluatorError.re +++ b/src/haz3lcore/dynamics/EvaluatorError.re @@ -13,6 +13,7 @@ type t = | InvalidBoxedFloatLit(DHExp.t) | InvalidBoxedListLit(DHExp.t) | InvalidBoxedStringLit(DHExp.t) + | InvalidBoxedSumConstructor(DHExp.t) | InvalidBoxedTuple(DHExp.t) | InvalidBuiltin(string) | BadBuiltinAp(string, list(DHExp.t)) diff --git a/src/haz3lcore/dynamics/EvaluatorError.rei b/src/haz3lcore/dynamics/EvaluatorError.rei index e5a07fe847..cc576c5d23 100644 --- a/src/haz3lcore/dynamics/EvaluatorError.rei +++ b/src/haz3lcore/dynamics/EvaluatorError.rei @@ -11,6 +11,7 @@ type t = | InvalidBoxedFloatLit(DHExp.t) | InvalidBoxedListLit(DHExp.t) | InvalidBoxedStringLit(DHExp.t) + | InvalidBoxedSumConstructor(DHExp.t) | InvalidBoxedTuple(DHExp.t) | InvalidBuiltin(string) | BadBuiltinAp(string, list(DHExp.t)) diff --git a/src/haz3lcore/dynamics/EvaluatorStep.re b/src/haz3lcore/dynamics/EvaluatorStep.re index 2ad3738cca..fdf1beef51 100644 --- a/src/haz3lcore/dynamics/EvaluatorStep.re +++ b/src/haz3lcore/dynamics/EvaluatorStep.re @@ -172,7 +172,11 @@ module Decompose = { Step({apply: () => d1, kind: CompleteFilter, value: true}); } ) - | _ => Decomp.transition(decompose, state, env, exp) + | _ => + switch (Decomp.transition(decompose, state, env, exp)) { + | r => r + | exception (EvaluatorError.Exception(_)) => Result.Indet + } }; }; }; diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index 6308461a77..9b0dd0b829 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -1,566 +1,74 @@ -open Util; +type match_result = Unboxing.unboxed(Environment.t); +let ( let* ) = Unboxing.( let* ); -type match_result = - | Matches(Environment.t) - | DoesNotMatch - | IndetMatch; - -let const_unknown: 'a => Typ.t = _ => Unknown(Internal) |> Typ.fresh; - -let cast_sum_maps = (_, _) => None; // TODO[Matt]: Fix - -// let cast_sum_maps = -// (sm1: Typ.sum_map, sm2: Typ.sum_map) -// : option(ConstructorMap.t((Typ.t, Typ.t))) => { -// let (ctrs1, tys1) = sm1 |> ConstructorMap.bindings |> List.split; -// let (ctrs2, tys2) = sm2 |> ConstructorMap.bindings |> List.split; -// if (ctrs1 == ctrs2) { -// let tys1 = tys1 |> List.filter(Option.is_some) |> List.map(Option.get); -// let tys2 = tys2 |> List.filter(Option.is_some) |> List.map(Option.get); -// if (List.length(tys1) == List.length(tys2)) { -// Some( -// List.(combine(tys1, tys2) |> combine(ctrs1)) -// |> ConstructorMap.of_list, -// ); -// } else { -// None; -// }; -// } else { -// None; -// }; -// }; - -let rec matches = (dp: Pat.t, d: DHExp.t): match_result => - switch (DHPat.term_of(dp), DHExp.term_of(d)) { - | (Parens(x), _) => matches(x, d) - | (TypeAnn(x, _), _) => matches(x, d) - | (_, Var(_)) => DoesNotMatch - | (EmptyHole, _) - | (MultiHole(_), _) - | (Wild, _) => Matches(Environment.empty) - | (Invalid(_), _) => IndetMatch - | (Var(x), _) => - let env = Environment.extend(Environment.empty, (x, d)); - Matches(env); - | (_, EmptyHole) => IndetMatch - | (_, StaticErrorHole(_)) => IndetMatch - | (_, FailedCast(_)) => IndetMatch - | (_, DynamicErrorHole(_)) => IndetMatch - | (_, Invalid(_)) => IndetMatch - | (_, Let(_)) => IndetMatch - | (_, FixF(_)) => DoesNotMatch - | (_, Fun(_)) => DoesNotMatch - | (_, BinOp(_)) => IndetMatch - | (_, UnOp(_)) => IndetMatch - | (_, Match(_, _)) => IndetMatch - - /* Closure should match like underlying expression. */ - | (_, Closure(_, d')) - | (_, Filter(_, d')) => matches(dp, d') - - | (Bool(b1), Bool(b2)) => - if (b1 == b2) { - Matches(Environment.empty); - } else { - DoesNotMatch; - } - | (Bool(_), Cast(d, {term: Bool, _}, {term: Unknown(_), _})) => - matches(dp, d) - | (Bool(_), Cast(d, {term: Unknown(_), _}, {term: Bool, _})) => - matches(dp, d) - | (Bool(_), _) => DoesNotMatch - | (Int(n1), Int(n2)) => - if (n1 == n2) { - Matches(Environment.empty); - } else { - DoesNotMatch; - } - | (Int(_), Cast(d, {term: Int, _}, {term: Unknown(_), _})) => - matches(dp, d) - | (Int(_), Cast(d, {term: Unknown(_), _}, {term: Int, _})) => - matches(dp, d) - | (Int(_), _) => DoesNotMatch - | (Float(n1), Float(n2)) => - if (n1 == n2) { - Matches(Environment.empty); - } else { - DoesNotMatch; - } - | (Float(_), Cast(d, {term: Float, _}, {term: Unknown(_), _})) => - matches(dp, d) - | (Float(_), Cast(d, {term: Unknown(_), _}, {term: Float, _})) => - matches(dp, d) - | (Float(_), _) => DoesNotMatch - | (String(s1), String(s2)) => - if (s1 == s2) { - Matches(Environment.empty); - } else { - DoesNotMatch; - } - | (String(_), Cast(d, {term: String, _}, {term: Unknown(_), _})) => - matches(dp, d) - | (String(_), Cast(d, {term: Unknown(_), _}, {term: String, _})) => - matches(dp, d) - | (String(_), _) => DoesNotMatch - - | (Ap(dp1, dp2), Ap(_, d1, d2)) => - switch (matches(dp1, d1)) { - | DoesNotMatch => DoesNotMatch - | IndetMatch => - switch (matches(dp2, d2)) { - | DoesNotMatch => DoesNotMatch - | IndetMatch - | Matches(_) => IndetMatch - } - | Matches(env1) => - switch (matches(dp2, d2)) { - | DoesNotMatch => DoesNotMatch - | IndetMatch => IndetMatch - | Matches(env2) => Matches(Environment.union(env1, env2)) - } - } - | ( - Ap({term: Constructor(ctr), _}, dp_opt), - Cast( - d, - {term: Sum(sm1) | Rec(_, {term: Sum(sm1), _}), _}, - {term: Sum(sm2) | Rec(_, {term: Sum(sm2), _}), _}, - ), - ) => - switch (cast_sum_maps(sm1, sm2)) { - | Some(castmap) => matches_cast_Sum(ctr, Some(dp_opt), d, [castmap]) - | None => DoesNotMatch - } - - | ( - Ap(_, _), - Cast( - d, - {term: Sum(_) | Rec(_, {term: Sum(_), _}), _}, - {term: Unknown(_), _}, - ), - ) - | ( - Ap(_, _), - Cast( - d, - {term: Unknown(_), _}, - {term: Sum(_) | Rec(_, {term: Sum(_), _}), _}, - ), - ) => - matches(dp, d) - | (Ap(_, _), _) => DoesNotMatch - - | (Constructor(ctr), Constructor(ctr')) => - ctr == ctr' ? Matches(Environment.empty) : DoesNotMatch - | ( - Constructor(ctr), - Cast( - d, - {term: Sum(sm1) | Rec(_, {term: Sum(sm1), _}), _}, - {term: Sum(sm2) | Rec(_, {term: Sum(sm2), _}), _}, - ), - ) => - switch (cast_sum_maps(sm1, sm2)) { - | Some(castmap) => matches_cast_Sum(ctr, None, d, [castmap]) - | None => DoesNotMatch - } - | ( - Constructor(_), - Cast( - d, - {term: Sum(_) | Rec(_, {term: Sum(_), _}), _}, - {term: Unknown(_), _}, - ), - ) => - matches(dp, d) - | ( - Constructor(_), - Cast( - d, - {term: Unknown(_), _}, - {term: Sum(_) | Rec(_, {term: Sum(_), _}), _}, - ), - ) => - matches(dp, d) - | (Constructor(_), _) => DoesNotMatch +let combine_result = (r1: match_result, r2: match_result): match_result => + switch (r1, r2) { + | (DoesNotMatch, _) + | (_, DoesNotMatch) => DoesNotMatch + | (IndetMatch, _) + | (_, IndetMatch) => IndetMatch + | (Matches(env1), Matches(env2)) => + Matches(Environment.union(env1, env2)) + }; - | (Tuple(dps), Tuple(ds)) => - if (List.length(dps) != List.length(ds)) { - DoesNotMatch; +let rec matches = (m: Statics.Map.t, dp: Pat.t, d: DHExp.t): match_result => + switch (DHPat.term_of(dp)) { + | Invalid(_) + | EmptyHole + | MultiHole(_) + | Wild => Matches(Environment.empty) + | Int(n) => + let* n' = Unboxing.unbox(Int, d); + n == n' ? Matches(Environment.empty) : DoesNotMatch; + | Float(n) => + let* n' = Unboxing.unbox(Float, d); + n == n' ? Matches(Environment.empty) : DoesNotMatch; + | Bool(b) => + let* b' = Unboxing.unbox(Bool, d); + b == b' ? Matches(Environment.empty) : DoesNotMatch; + | String(s) => + let* s' = Unboxing.unbox(String, d); + s == s' ? Matches(Environment.empty) : DoesNotMatch; + | ListLit(xs) => + let* s' = Unboxing.unbox(List, d); + if (List.length(xs) == List.length(s')) { + List.map2(matches(m), xs, s') + |> List.fold_left(combine_result, Matches(Environment.empty)); } else { - List.fold_left2( - (result, dp, d) => - switch (result) { - | DoesNotMatch => DoesNotMatch - | IndetMatch => IndetMatch - | Matches(env) => - switch (matches(dp, d)) { - | DoesNotMatch => DoesNotMatch - | IndetMatch => IndetMatch - | Matches(env') => Matches(Environment.union(env, env')) - } - }, - Matches(Environment.empty), - dps, - ds, - ); - } - | (Tuple(dps), Cast(d, {term: Prod(tys), _}, {term: Prod(tys'), _})) => - assert(List.length(tys) == List.length(tys')); - matches_cast_Tuple( - dps, - d, - List.map(p => [p], List.combine(tys, tys')), - ); - | (Tuple(dps), Cast(d, {term: Prod(tys), _}, {term: Unknown(_), _})) => - matches_cast_Tuple( - dps, - d, - List.map( - p => [p], - List.combine(tys, List.init(List.length(tys), const_unknown)), - ), - ) - | (Tuple(dps), Cast(d, {term: Unknown(_), _}, {term: Prod(tys'), _})) => - matches_cast_Tuple( - dps, - d, - List.map( - p => [p], - List.combine(List.init(List.length(tys'), const_unknown), tys'), - ), - ) - | (Tuple(_), Cast(_)) => DoesNotMatch - | (Tuple(_), _) => DoesNotMatch - | ( - Cons(_) | ListLit(_), - Cast(d, {term: List(ty1), _}, {term: List(ty2), _}), - ) => - matches_cast_Cons(dp, d, [(ty1, ty2)]) - | ( - Cons(_) | ListLit(_), - Cast(d, {term: Unknown(_), _}, {term: List(ty2), _}), - ) => - matches_cast_Cons(dp, d, [(Unknown(Internal) |> Typ.fresh, ty2)]) - | ( - Cons(_) | ListLit(_), - Cast(d, {term: List(ty1), _}, {term: Unknown(_), _}), - ) => - matches_cast_Cons(dp, d, [(ty1, Unknown(Internal) |> Typ.fresh)]) - | (Cons(_, _), Cons(_, _)) - | (ListLit(_), Cons(_, _)) - | (Cons(_, _), ListLit(_)) - | (ListLit(_), ListLit(_)) => matches_cast_Cons(dp, d, []) - | (Cons(_) | ListLit(_), _) => DoesNotMatch - } -and matches_cast_Sum = - ( - _ctr: string, - _dp: option(Pat.t), - _d: DHExp.t, - _castmaps: list(ConstructorMap.t((Typ.t, Typ.t))), - ) - : match_result => - IndetMatch // TODO[Matt]: fix -// switch (DHExp.term_of(d)) { -// | Parens(d) => matches_cast_Sum(ctr, dp, d, castmaps) -// | Constructor(ctr') => -// switch ( -// dp, -// castmaps |> List.map(ConstructorMap.find_opt(ctr')) |> OptUtil.sequence, -// ) { -// | (None, Some(_)) => -// ctr == ctr' ? Matches(Environment.empty) : DoesNotMatch -// | _ => DoesNotMatch -// } -// | Ap(_, d1, d2) => -// switch (DHExp.term_of(d1)) { -// | Constructor(ctr') => -// switch ( -// dp, -// castmaps -// |> List.map(ConstructorMap.find_opt(ctr')) -// |> OptUtil.sequence, -// ) { -// | (Some(dp), Some(side_casts)) => -// matches(dp, DHExp.apply_casts(d2, side_casts)) -// | _ => DoesNotMatch -// } -// | _ => IndetMatch -// } -// | Cast( -// d', -// {term: Sum(sm1) | Rec(_, {term: Sum(sm1), _}), _}, -// {term: Sum(sm2) | Rec(_, {term: Sum(sm2), _}), _}, -// ) => -// switch (cast_sum_maps(sm1, sm2)) { -// | Some(castmap) => matches_cast_Sum(ctr, dp, d', [castmap, ...castmaps]) -// | None => DoesNotMatch -// } -// | Cast( -// d', -// {term: Sum(_) | Rec(_, {term: Sum(_), _}), _}, -// {term: Unknown(_), _}, -// ) -// | Cast( -// d', -// {term: Unknown(_), _}, -// {term: Sum(_) | Rec(_, {term: Sum(_), _}), _}, -// ) => -// matches_cast_Sum(ctr, dp, d', castmaps) -// | Invalid(_) -// | Let(_) -// | UnOp(_) -// | BinOp(_) -// | EmptyHole -// | MultiHole(_) -// | StaticErrorHole(_) -// | FailedCast(_, _, _) -// | Test(_) -// | DynamicErrorHole(_) -// | Match(_) -// | If(_) -// | TyAlias(_) -// | BuiltinFun(_) => IndetMatch -// | Cast(_) -// | Var(_) -// | FixF(_) -// | Fun(_) -// | Bool(_) -// | Int(_) -// | Float(_) -// | String(_) -// | ListLit(_) -// | Tuple(_) -// | Seq(_, _) -// | Closure(_) -// | Filter(_) -// | Cons(_) -// | ListConcat(_) => DoesNotMatch -// } -and matches_cast_Tuple = - (dps: list(Pat.t), d: DHExp.t, elt_casts: list(list((Typ.t, Typ.t)))) - : match_result => - switch (DHExp.term_of(d)) { - | Parens(d) => matches_cast_Tuple(dps, d, elt_casts) - | Tuple(ds) => - if (List.length(dps) != List.length(ds)) { DoesNotMatch; - } else { - assert(List.length(List.combine(dps, ds)) == List.length(elt_casts)); - List.fold_right( - (((dp, d), casts), result) => { - switch (result) { - | DoesNotMatch - | IndetMatch => result - | Matches(env) => - switch (matches(dp, DHExp.apply_casts(d, casts))) { - | DoesNotMatch => DoesNotMatch - | IndetMatch => IndetMatch - | Matches(env') => Matches(Environment.union(env, env')) - } - } - }, - List.combine(List.combine(dps, ds), elt_casts), - Matches(Environment.empty), - ); - } - | Cast(d', {term: Prod(tys), _}, {term: Prod(tys'), _}) => - if (List.length(dps) != List.length(tys)) { - DoesNotMatch; - } else { - assert(List.length(tys) == List.length(tys')); - matches_cast_Tuple( - dps, - d', - List.map2(List.cons, List.combine(tys, tys'), elt_casts), - ); - } - | Cast(d', {term: Prod(tys), _}, {term: Unknown(_), _}) => - let tys' = List.init(List.length(tys), const_unknown); - matches_cast_Tuple( - dps, - d', - List.map2(List.cons, List.combine(tys, tys'), elt_casts), - ); - | Cast(d', {term: Unknown(_), _}, {term: Prod(tys'), _}) => - let tys = List.init(List.length(tys'), const_unknown); - matches_cast_Tuple( - dps, - d', - List.map2(List.cons, List.combine(tys, tys'), elt_casts), - ); - | Cast(_, _, _) => DoesNotMatch - | Var(_) => DoesNotMatch - | Invalid(_) => IndetMatch - | Let(_, _, _) => IndetMatch - | FixF(_, _, _) => DoesNotMatch - | Fun(_, _, _, _) => DoesNotMatch - | Closure(_, _) => IndetMatch - | Filter(_, _) => IndetMatch - | Ap(_, _, _) => IndetMatch - | TyAlias(_) => IndetMatch - | UnOp(_, _) - | BinOp(_, _, _) => DoesNotMatch - | Bool(_) => DoesNotMatch - | Int(_) => DoesNotMatch - | Seq(_) - | BuiltinFun(_) - | Test(_) => DoesNotMatch - | Float(_) => DoesNotMatch - | String(_) => DoesNotMatch - | ListLit(_) => DoesNotMatch - | Cons(_, _) => DoesNotMatch - | ListConcat(_) => DoesNotMatch - | Constructor(_) => DoesNotMatch - | Match(_) => IndetMatch - | EmptyHole => IndetMatch - | MultiHole(_) => IndetMatch - | StaticErrorHole(_) => IndetMatch - | FailedCast(_, _, _) => IndetMatch - | DynamicErrorHole(_) => IndetMatch - | If(_) => IndetMatch - } -and matches_cast_Cons = - (dp: Pat.t, d: DHExp.t, elt_casts: list((Typ.t, Typ.t))): match_result => - switch (DHExp.term_of(d)) { - | Parens(d) => matches_cast_Cons(dp, d, elt_casts) - | ListLit([]) => - switch (DHPat.term_of(dp)) { - | ListLit([]) => Matches(Environment.empty) - | _ => DoesNotMatch - } - | ListLit([dhd, ...dtl] as ds) => - switch (DHPat.term_of(dp)) { - | Cons(dp1, dp2) => - switch (matches(dp1, DHExp.apply_casts(dhd, elt_casts))) { - | DoesNotMatch => DoesNotMatch - | IndetMatch => IndetMatch - | Matches(env1) => - let list_casts = - List.map( - (c: (Typ.t, Typ.t)) => { - let (ty1, ty2) = c; - (Typ.List(ty1) |> Typ.fresh, Typ.List(ty2) |> Typ.fresh); - }, - elt_casts, - ); - let d2 = DHExp.ListLit(dtl) |> DHExp.fresh; - switch (matches(dp2, DHExp.apply_casts(d2, list_casts))) { - | DoesNotMatch => DoesNotMatch - | IndetMatch => IndetMatch - | Matches(env2) => Matches(Environment.union(env1, env2)) - }; - } - | ListLit(dps) => - switch (ListUtil.opt_zip(dps, ds)) { - | None => DoesNotMatch - | Some(lst) => - lst - |> List.map(((dp, d)) => - matches(dp, DHExp.apply_casts(d, elt_casts)) - ) - |> List.fold_left( - (match1, match2) => - switch (match1, match2) { - | (DoesNotMatch, _) - | (_, DoesNotMatch) => DoesNotMatch - | (IndetMatch, _) - | (_, IndetMatch) => IndetMatch - | (Matches(env1), Matches(env2)) => - Matches(Environment.union(env1, env2)) - }, - Matches(Environment.empty), - ) - } - | _ => failwith("called matches_cast_Cons with non-list pattern") - } - | Cons(d1, d2) => - switch (DHPat.term_of(dp)) { - | Cons(dp1, dp2) => - switch (matches(dp1, DHExp.apply_casts(d1, elt_casts))) { - | DoesNotMatch => DoesNotMatch - | IndetMatch => IndetMatch - | Matches(env1) => - let list_casts = - List.map( - (c: (Typ.t, Typ.t)) => { - let (ty1, ty2) = c; - (Typ.List(ty1) |> Typ.fresh, Typ.List(ty2) |> Typ.fresh); - }, - elt_casts, - ); - switch (matches(dp2, DHExp.apply_casts(d2, list_casts))) { - | DoesNotMatch => DoesNotMatch - | IndetMatch => IndetMatch - | Matches(env2) => Matches(Environment.union(env1, env2)) - }; - } - | ListLit([]) => DoesNotMatch - | ListLit([dphd, ...dptl]) => - switch (matches(dphd, DHExp.apply_casts(d1, elt_casts))) { - | DoesNotMatch => DoesNotMatch - | IndetMatch => IndetMatch - | Matches(env1) => - let list_casts = - List.map( - (c: (Typ.t, Typ.t)) => { - let (ty1, ty2) = c; - (Typ.List(ty1) |> Typ.fresh, Typ.List(ty2) |> Typ.fresh); - }, - elt_casts, - ); - let dp2 = Pat.ListLit(dptl) |> DHPat.fresh; - switch (matches(dp2, DHExp.apply_casts(d2, list_casts))) { - | DoesNotMatch => DoesNotMatch - | IndetMatch => IndetMatch - | Matches(env2) => Matches(Environment.union(env1, env2)) - }; - } - | _ => failwith("called matches_cast_Cons with non-list pattern") - } - | Cast(d', {term: List(ty1), _}, {term: List(ty2), _}) => - matches_cast_Cons(dp, d', [(ty1, ty2), ...elt_casts]) - | Cast(d', {term: List(ty1), _}, {term: Unknown(_), _}) => - matches_cast_Cons( - dp, - d', - [(ty1, Unknown(Internal) |> Typ.fresh), ...elt_casts], - ) - | Cast(d', {term: Unknown(_), _}, {term: List(ty2), _}) => - matches_cast_Cons( - dp, - d', - [(Unknown(Internal) |> Typ.fresh, ty2), ...elt_casts], - ) - | Cast(_, _, _) => DoesNotMatch - | Var(_) => DoesNotMatch - | Invalid(_) => IndetMatch - | Let(_, _, _) => IndetMatch - | FixF(_, _, _) => DoesNotMatch - | Fun(_, _, _, _) => DoesNotMatch - | Closure(_, d') => matches_cast_Cons(dp, d', elt_casts) - | Filter(_, d') => matches_cast_Cons(dp, d', elt_casts) - | Ap(_, _, _) => IndetMatch - | TyAlias(_) => IndetMatch - | UnOp(_, _) - | BinOp(_, _, _) - | ListConcat(_) - | BuiltinFun(_) => DoesNotMatch - | Bool(_) => DoesNotMatch - | Int(_) => DoesNotMatch - | Seq(_) - | Test(_) => DoesNotMatch - | Float(_) => DoesNotMatch - | String(_) => DoesNotMatch - | Tuple(_) => DoesNotMatch - | Constructor(_) => DoesNotMatch - | Match(_) => IndetMatch - | EmptyHole => IndetMatch - | MultiHole(_) => IndetMatch - | StaticErrorHole(_) => IndetMatch - | FailedCast(_, _, _) => IndetMatch - | DynamicErrorHole(_) => IndetMatch - | If(_) => IndetMatch + }; + | Cons(x, xs) => + let* (x', xs') = Unboxing.unbox(Cons, d); + let* m_x = matches(m, x, x'); + let* m_xs = matches(m, xs, xs'); + Matches(Environment.union(m_x, m_xs)); + | Constructor(ctr) => + let* () = Unboxing.unbox(SumNoArg(ctr), d); + Matches(Environment.empty); + | Ap({term: Constructor(ctr), _}, p2) => + let* d2 = Unboxing.unbox(SumWithArg(ctr), d); + matches(m, p2, d2); + | Ap(_, _) => IndetMatch // TODO: should this fail? + | Var(x) => Matches(Environment.singleton((x, d))) + | Tuple(ps) => + let* ds = Unboxing.unbox(Tuple(List.length(ps)), d); + List.map2(matches(m), ps, ds) + |> List.fold_left(combine_result, Matches(Environment.empty)); + | Parens(p) => matches(m, p, d) + | TypeAnn(p, t) => + let _ = print_endline("TypeAnn"); + let mode = + switch (Id.Map.find_opt(Pat.rep_id(p), m)) { + | Some(Info.InfoPat({mode, _})) => mode + | _ => raise(Elaborator.MissingTypeInfo) + }; + switch (mode) { + | Ana(ana_ty) when !Typ.eq(ana_ty, t) => + let _ = Typ.show(ana_ty) |> print_endline; + let _ = Typ.show(t) |> print_endline; + matches(m, p, Cast(d, ana_ty, t) |> DHExp.fresh); + | Ana(_) + | Syn + | SynFun => matches(m, p, d) + }; }; diff --git a/src/haz3lcore/dynamics/PatternMatch.rei b/src/haz3lcore/dynamics/PatternMatch.rei deleted file mode 100644 index 2cba4e6681..0000000000 --- a/src/haz3lcore/dynamics/PatternMatch.rei +++ /dev/null @@ -1,6 +0,0 @@ -type match_result = - | Matches(Environment.t) - | DoesNotMatch - | IndetMatch; - -let matches: (Pat.t, DHExp.t) => match_result; diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index 99aa08295c..04944e128a 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -1,5 +1,5 @@ -open Sexplib.Std; open Util; +open Sexplib.Std; open PatternMatch; /* Transition.re @@ -72,37 +72,6 @@ type step_kind = | Cast | RemoveTypeAlias | RemoveParens; - -module CastHelpers = { - [@deriving sexp] - type ground_cases = - | Hole - | Ground - | NotGroundOrHole(Typ.t) /* the argument is the corresponding ground type */; - - let const_unknown: 'a => Typ.t = _ => Unknown(Internal) |> Typ.fresh; - - let grounded_Arrow = - NotGroundOrHole( - Arrow(Unknown(Internal) |> Typ.fresh, Unknown(Internal) |> Typ.fresh) - |> Typ.fresh, - ); - let grounded_Prod = length => - NotGroundOrHole( - Prod(ListUtil.replicate(length, Typ.Unknown(Internal) |> Typ.fresh)) - |> Typ.fresh, - ); - let grounded_Sum: unit => Typ.sum_map = - () => [BadEntry(Typ.fresh(Unknown(Internal)))]; - let grounded_List = - NotGroundOrHole(List(Unknown(Internal) |> Typ.fresh) |> Typ.fresh); - - let rec ground_cases_of = (ty: Typ.t): ground_cases => { - let is_hole: Typ.t => bool = - fun - | {term: Typ.Unknown(_), _} => true - | _ => false; - switch (Typ.term_of(ty)) { | Unknown(_) => Hole | Bool | Int @@ -132,8 +101,6 @@ module CastHelpers = { | Ap(_) => failwith("type application in dynamics") }; }; -}; - let evaluate_extend_env = (new_bindings: Environment.t, to_extend: ClosureEnvironment.t) : ClosureEnvironment.t => { @@ -152,6 +119,13 @@ type rule = | Constructor | Indet; +let (let-unbox) = ((request, v), f) => + switch (Unboxing.unbox(request, v)) { + | IndetMatch + | DoesNotMatch => Indet + | Matches(n) => f(n) + }; + module type EV_MODE = { type state; type result; @@ -196,7 +170,7 @@ module type EV_MODE = { module Transition = (EV: EV_MODE) => { open EV; open DHExp; - let (let.match) = ((env, match_result), r) => + let (let.match) = ((env, match_result: PatternMatch.match_result), r) => switch (match_result) { | IndetMatch | DoesNotMatch => Indet @@ -255,7 +229,7 @@ module Transition = (EV: EV_MODE) => { let. _ = otherwise(env, d1 => Let(dp, d1, d2) |> rewrap) and. d1' = req_final(req(state, env), d1 => Let1(dp, d1, d2) |> wrap_ctx, d1); - let.match env' = (env, matches(dp, d1')); + let.match env' = (env, matches(info_map, dp, d1')); Step({ apply: () => Closure(env', d2) |> fresh, kind: LetBind, @@ -352,7 +326,7 @@ module Transition = (EV: EV_MODE) => { switch (DHExp.term_of(d1')) { | Constructor(_) => Constructor | Fun(dp, d3, Some(env'), _) => - let.match env'' = (env', matches(dp, d2')); + let.match env'' = (env', matches(info_map, dp, d2')); Step({ apply: () => Closure(env'', d3) |> fresh, kind: FunAp, @@ -443,12 +417,9 @@ module Transition = (EV: EV_MODE) => { c => UnOp(Int(Minus), c) |> wrap_ctx, d1, ); + let-unbox n = (Int, d1'); Step({ - apply: () => - switch (DHExp.term_of(d1')) { - | Int(n) => Int(- n) |> fresh - | _ => raise(EvaluatorError.Exception(InvalidBoxedIntLit(d1'))) - }, + apply: () => Int(- n) |> fresh, kind: UnOp(Int(Minus)), value: true, }); @@ -460,12 +431,9 @@ module Transition = (EV: EV_MODE) => { c => UnOp(Bool(Not), c) |> wrap_ctx, d1, ); + let-unbox b = (Bool, d1'); Step({ - apply: () => - switch (DHExp.term_of(d1')) { - | Bool(b) => Bool(!b) |> fresh - | _ => raise(EvaluatorError.Exception(InvalidBoxedIntLit(d1'))) - }, + apply: () => Bool(!b) |> fresh, kind: UnOp(Bool(Not)), value: true, }); @@ -477,13 +445,9 @@ module Transition = (EV: EV_MODE) => { d1 => BinOp1(Bool(And), d1, d2) |> wrap_ctx, d1, ); + let-unbox b1 = (Bool, d1'); Step({ - apply: () => - switch (DHExp.term_of(d1')) { - | Bool(true) => d2 - | Bool(false) => Bool(false) |> fresh - | _ => raise(EvaluatorError.Exception(InvalidBoxedBoolLit(d1'))) - }, + apply: () => b1 ? d2 : Bool(false) |> fresh, kind: BinBoolOp(And), value: false, }); @@ -495,13 +459,9 @@ module Transition = (EV: EV_MODE) => { d1 => BinOp1(Bool(Or), d1, d2) |> wrap_ctx, d1, ); + let-unbox b1 = (Bool, d1'); Step({ - apply: () => - switch (DHExp.term_of(d1')) { - | Bool(true) => Bool(true) |> fresh - | Bool(false) => d2 - | _ => raise(EvaluatorError.Exception(InvalidBoxedBoolLit(d2))) - }, + apply: () => b1 ? Bool(true) |> fresh : d2, kind: BinBoolOp(Or), value: false, }); @@ -519,40 +479,36 @@ module Transition = (EV: EV_MODE) => { d2 => BinOp2(Int(op), d1, d2) |> wrap_ctx, d2, ); + let-unbox n1 = (Int, d1'); + let-unbox n2 = (Int, d2'); Step({ apply: () => - switch (DHExp.term_of(d1'), DHExp.term_of(d2')) { - | (Int(n1), Int(n2)) => - ( - switch (op) { - | Plus => Int(n1 + n2) - | Minus => Int(n1 - n2) - | Power when n2 < 0 => - DynamicErrorHole( - BinOp(Int(op), d1', d2') |> rewrap, - NegativeExponent, - ) - | Power => Int(IntUtil.ipow(n1, n2)) - | Times => Int(n1 * n2) - | Divide when n2 == 0 => - DynamicErrorHole( - BinOp(Int(op), d1', d1') |> rewrap, - DivideByZero, - ) - | Divide => Int(n1 / n2) - | LessThan => Bool(n1 < n2) - | LessThanOrEqual => Bool(n1 <= n2) - | GreaterThan => Bool(n1 > n2) - | GreaterThanOrEqual => Bool(n1 >= n2) - | Equals => Bool(n1 == n2) - | NotEquals => Bool(n1 != n2) - } - ) - |> fresh - | (Int(_), _) => - raise(EvaluatorError.Exception(InvalidBoxedIntLit(d2'))) - | _ => raise(EvaluatorError.Exception(InvalidBoxedIntLit(d1'))) - }, + ( + switch (op) { + | Plus => Int(n1 + n2) + | Minus => Int(n1 - n2) + | Power when n2 < 0 => + DynamicErrorHole( + BinOp(Int(op), d1', d2') |> rewrap, + NegativeExponent, + ) + | Power => Int(IntUtil.ipow(n1, n2)) + | Times => Int(n1 * n2) + | Divide when n2 == 0 => + DynamicErrorHole( + BinOp(Int(op), d1', d1') |> rewrap, + DivideByZero, + ) + | Divide => Int(n1 / n2) + | LessThan => Bool(n1 < n2) + | LessThanOrEqual => Bool(n1 <= n2) + | GreaterThan => Bool(n1 > n2) + | GreaterThanOrEqual => Bool(n1 >= n2) + | Equals => Bool(n1 == n2) + | NotEquals => Bool(n1 != n2) + } + ) + |> fresh, kind: BinIntOp(op), // False so that InvalidOperations are caught and made indet by the next step value: false, @@ -572,30 +528,27 @@ module Transition = (EV: EV_MODE) => { d2 => BinOp2(Float(op), d1, d2) |> wrap_ctx, d2, ); + let-unbox n1 = (Float, d1'); + let-unbox n2 = (Float, d2'); Step({ apply: () => - switch (DHExp.term_of(d1'), DHExp.term_of(d2')) { - | (Float(n1), Float(n2)) => - ( - switch (op) { - | Plus => Float(n1 +. n2) - | Minus => Float(n1 -. n2) - | Power => Float(n1 ** n2) - | Times => Float(n1 *. n2) - | Divide => Float(n1 /. n2) - | LessThan => Bool(n1 < n2) - | LessThanOrEqual => Bool(n1 <= n2) - | GreaterThan => Bool(n1 > n2) - | GreaterThanOrEqual => Bool(n1 >= n2) - | Equals => Bool(n1 == n2) - | NotEquals => Bool(n1 != n2) - } - ) - |> fresh - | (Float(_), _) => - raise(EvaluatorError.Exception(InvalidBoxedFloatLit(d2'))) - | _ => raise(EvaluatorError.Exception(InvalidBoxedFloatLit(d1'))) - }, + ( + switch (op) { + | Plus => Float(n1 +. n2) + | Minus => Float(n1 -. n2) + | Power => Float(n1 ** n2) + | Times => Float(n1 *. n2) + | Divide => Float(n1 /. n2) + | LessThan => Bool(n1 < n2) + | LessThanOrEqual => Bool(n1 <= n2) + | GreaterThan => Bool(n1 > n2) + | GreaterThanOrEqual => Bool(n1 >= n2) + | Equals => Bool(n1 == n2) + | NotEquals => Bool(n1 != n2) + } + ) + |> fresh, + kind: BinFloatOp(op), value: true, }); @@ -614,17 +567,13 @@ module Transition = (EV: EV_MODE) => { d2 => BinOp2(String(op), d1, d2) |> wrap_ctx, d2, ); + let-unbox s1 = (String, d1'); + let-unbox s2 = (String, d2'); Step({ apply: () => - switch (DHExp.term_of(d1'), DHExp.term_of(d2')) { - | (String(s1), String(s2)) => - switch (op) { - | Concat => String(s1 ++ s2) |> fresh - | Equals => Bool(s1 == s2) |> fresh - } - | (String(_), _) => - raise(EvaluatorError.Exception(InvalidBoxedStringLit(d2'))) - | _ => raise(EvaluatorError.Exception(InvalidBoxedStringLit(d1'))) + switch (op) { + | Concat => String(s1 ++ s2) |> fresh + | Equals => Bool(s1 == s2) |> fresh }, kind: BinStringOp(op), value: true, @@ -638,24 +587,19 @@ module Transition = (EV: EV_MODE) => { ds, ); Constructor; - // TODO(Matt): Can we do something cleverer when the list structure is complete but the contents aren't? | Cons(d1, d2) => let. _ = otherwise(env, (d1, d2) => Cons(d1, d2) |> rewrap) and. d1' = req_final(req(state, env), d1 => Cons1(d1, d2) |> wrap_ctx, d1) and. d2' = req_value(req(state, env), d2 => Cons2(d1, d2) |> wrap_ctx, d2); + let-unbox ds = (List, d2'); Step({ - apply: () => - switch (term_of(d2')) { - | ListLit(ds) => ListLit([d1', ...ds]) |> fresh - | _ => raise(EvaluatorError.Exception(InvalidBoxedListLit(d2'))) - }, + apply: () => ListLit([d1', ...ds]) |> fresh, kind: ListCons, value: true, }); | ListConcat(d1, d2) => - // TODO(Matt): Can we do something cleverer when the list structure is complete but the contents aren't? let. _ = otherwise(env, (d1, d2) => ListConcat(d1, d2) |> rewrap) and. d1' = req_value( @@ -669,15 +613,10 @@ module Transition = (EV: EV_MODE) => { d2 => ListConcat2(d1, d2) |> wrap_ctx, d2, ); + let-unbox ds1 = (List, d1'); + let-unbox ds2 = (List, d2'); Step({ - apply: () => - switch (term_of(d1'), term_of(d2')) { - | (ListLit(ds1), ListLit(ds2)) => ListLit(ds1 @ ds2) |> fresh - | (ListLit(_), _) => - raise(EvaluatorError.Exception(InvalidBoxedListLit(d2'))) - | (_, _) => - raise(EvaluatorError.Exception(InvalidBoxedListLit(d1'))) - }, + apply: () => ListLit(ds1 @ ds2) |> fresh, kind: ListConcat, value: true, }); @@ -702,7 +641,7 @@ module Transition = (EV: EV_MODE) => { fun | [] => None | [(dp, d2), ...rules] => - switch (matches(dp, d1)) { + switch (matches(info_map, dp, d1)) { | Matches(env') => Some((env', d2)) | DoesNotMatch => next_rule(rules) | IndetMatch => None @@ -746,63 +685,12 @@ module Transition = (EV: EV_MODE) => { let. _ = otherwise(env, d); Indet; | Cast(d, t1, t2) => - open CastHelpers; /* Cast calculus */ - let. _ = otherwise(env, d => Cast(d, t1, t2) |> rewrap) and. d' = req_final(req(state, env), d => Cast(d, t1, t2) |> wrap_ctx, d); - switch (ground_cases_of(t1), ground_cases_of(t2)) { - | (Hole, Hole) - | (Ground, Ground) => - /* if two types are ground and consistent, then they are eq */ - Step({apply: () => d', kind: Cast, value: true}) - | (Ground, Hole) => - /* can't remove the cast or do anything else here, so we're done */ - Constructor - | (Hole, Ground) => - switch (term_of(d')) { - | Cast(d2, t3, {term: Unknown(_), _}) => - /* by canonical forms, d1' must be of the form d ?> */ - if (Typ.eq(t3, t2)) { - Step({apply: () => d2, kind: Cast, value: true}); - } else { - Step({ - apply: () => FailedCast(d', t1, t2) |> fresh, - kind: Cast, - value: false, - }); - } - | _ => Indet - } - | (Hole, NotGroundOrHole(t2_grounded)) => - /* ITExpand rule */ - Step({ - apply: () => - DHExp.Cast(Cast(d', t1, t2_grounded) |> fresh, t2_grounded, t2) - |> fresh, - kind: Cast, - value: false, - }) - | (NotGroundOrHole(t1_grounded), Hole) => - /* ITGround rule */ - Step({ - apply: () => - DHExp.Cast(Cast(d', t1, t1_grounded) |> fresh, t1_grounded, t2) - |> fresh, - kind: Cast, - value: false, - }) - | (Ground, NotGroundOrHole(_)) - | (NotGroundOrHole(_), Ground) => - /* can't do anything when casting between diseq, non-hole types */ - Constructor - | (NotGroundOrHole(_), NotGroundOrHole(_)) => - /* they might be eq in this case, so remove cast if so */ - if (Typ.eq(t1, t2)) { - Step({apply: () => d', kind: Cast, value: true}); - } else { - Constructor; - } + switch (Casts.transition(Cast(d', t1, t2) |> rewrap)) { + | Some(d) => Step({apply: () => d, kind: Cast, value: false}) + | None => Constructor }; | FailedCast(d1, t1, t2) => let. _ = otherwise(env, d1 => FailedCast(d1, t1, t2) |> rewrap) diff --git a/src/haz3lcore/dynamics/Unboxing.re b/src/haz3lcore/dynamics/Unboxing.re new file mode 100644 index 0000000000..2aeba3bd93 --- /dev/null +++ b/src/haz3lcore/dynamics/Unboxing.re @@ -0,0 +1,177 @@ +open Util; + +/* What is unboxing? + + When you have an expression of type list, and it's finished evaluating, + is it a list? Sadly not necessarily, it might be: + + - indeterminate, e.g. it has a hole in it + - a list with some casts wrapped around it + + Unboxing is the process of turning a list into a list if it is a list, + by pushing casts inside data structures, or giving up if it is not a list. + + Note unboxing only works one layer deep, if we have a list of lists then + the inner lists may still have casts around them after unboxing. + */ + +type unbox_request('a) = + | Int: unbox_request(int) + | Float: unbox_request(float) + | Bool: unbox_request(bool) + | String: unbox_request(string) + | Tuple(int): unbox_request(list(DHExp.t)) + | List: unbox_request(list(DHExp.t)) + | Cons: unbox_request((DHExp.t, DHExp.t)) + | SumNoArg(string): unbox_request(unit) + | SumWithArg(string): unbox_request(DHExp.t); + +type unboxed('a) = + | DoesNotMatch + | IndetMatch + | Matches('a); + +let ( let* ) = (x: unboxed('a), f: 'a => unboxed('b)): unboxed('b) => + switch (x) { + | IndetMatch => IndetMatch + | DoesNotMatch => DoesNotMatch + | Matches(x) => f(x) + }; + +let fixup_cast = Casts.transition_multiple; + +/* This function has a different return type depending on what kind of request + it is given. This unfortunately uses a crazy OCaml feature called GADTS, but + it avoids having to write a separate unbox function for each kind of request. + */ + +let rec unbox: type a. (unbox_request(a), DHExp.t) => unboxed(a) = + (request, expr) => { + let _ = print_endline(DHExp.show(expr)); + switch (request, DHExp.term_of(expr)) { + /* Base types are always already unboxed because of the ITCastID rule*/ + | (Bool, Bool(b)) => Matches(b) + | (Int, Int(i)) => Matches(i) + | (Float, Float(f)) => Matches(f) + | (String, String(s)) => Matches(s) + + /* Lists can be either lists or list casts */ + | (List, ListLit(l)) => Matches(l) + | (Cons, ListLit([x, ...xs])) => + Matches((x, ListLit(xs) |> DHExp.fresh)) + | (Cons, ListLit([])) => DoesNotMatch + | (List, Cast(l, {term: List(t1), _}, {term: List(t2), _})) => + let* l = unbox(List, l); + let l = List.map(d => Cast(d, t1, t2) |> DHExp.fresh, l); + let l = List.map(fixup_cast, l); + Matches(l); + | ( + Cons, + Cast(l, {term: List(t1), _} as ct1, {term: List(t2), _} as ct2), + ) => + let* l = unbox(List, l); + switch (l) { + | [] => DoesNotMatch + | [x, ...xs] => + Matches(( + Cast(x, t1, t2) |> DHExp.fresh |> fixup_cast, + Cast(ListLit(xs) |> DHExp.fresh, ct1, ct2) |> DHExp.fresh, + )) + }; + + /* Tuples can be either tuples or tuple casts */ + | (Tuple(n), Tuple(t)) when List.length(t) == n => Matches(t) + | (Tuple(_), Tuple(_)) => DoesNotMatch + | (Tuple(n), Cast(t, {term: Prod(t1s), _}, {term: Prod(t2s), _})) + when n == List.length(t1s) && n == List.length(t2s) => + let* t = unbox(Tuple(n), t); + let t = + ListUtil.map3( + (d, t1, t2) => Cast(d, t1, t2) |> DHExp.fresh, + t, + t1s, + t2s, + ); + let t = List.map(fixup_cast, t); + Matches(t); + + /* Sum constructors can be either sum constructors, sum constructors + applied to some value or sum casts */ + | (SumNoArg(name1), Constructor(name2)) when name1 == name2 => Matches() + | (SumNoArg(_), Constructor(_)) => DoesNotMatch + | (SumNoArg(_), Ap(_, {term: Constructor(_), _}, _)) => DoesNotMatch + | (SumNoArg(name), Cast(d1, {term: Sum(_), _}, {term: Sum(s2), _})) + when ConstructorMap.has_constructor_no_args(name, s2) => + let* d1 = unbox(SumNoArg(name), d1); + Matches(d1); + | (SumNoArg(_), Cast(_, {term: Sum(_), _}, {term: Sum(_), _})) => + IndetMatch + + | (SumWithArg(_), Constructor(_)) => DoesNotMatch + | (SumWithArg(name1), Ap(_, {term: Constructor(name2), _}, d3)) + when name1 == name2 => + Matches(d3) + | (SumWithArg(_), Ap(_, {term: Constructor(_), _}, _)) => DoesNotMatch + | (SumWithArg(name), Cast(d1, {term: Sum(_), _}, {term: Sum(s2), _})) + when ConstructorMap.get_entry(name, s2) != None => + let* d1 = unbox(SumWithArg(name), d1); + Matches(d1 |> fixup_cast); + | (SumWithArg(_), Cast(_, {term: Sum(_), _}, {term: Sum(_), _})) => + IndetMatch + + /* Any cast from unknown is indet */ + | (_, Cast(_, {term: Unknown(_), _}, _)) => IndetMatch + + /* Forms that are the wrong type of value - these cases indicate an error + in elaboration or in the cast calculus. */ + | ( + _, + Bool(_) | Int(_) | Float(_) | String(_) | Constructor(_) | + BuiltinFun(_) | + Fun(_, _, _, Some(_)) | + ListLit(_) | + Tuple(_) | + Cast(_) | + Ap(_, {term: Constructor(_), _}, _), + ) => + switch (request) { + | Bool => raise(EvaluatorError.Exception(InvalidBoxedBoolLit(expr))) + | Int => raise(EvaluatorError.Exception(InvalidBoxedIntLit(expr))) + | Float => raise(EvaluatorError.Exception(InvalidBoxedFloatLit(expr))) + | String => + raise(EvaluatorError.Exception(InvalidBoxedStringLit(expr))) + | Tuple(_) => raise(EvaluatorError.Exception(InvalidBoxedTuple(expr))) + | List + | Cons => raise(EvaluatorError.Exception(InvalidBoxedListLit(expr))) + | SumNoArg(_) + | SumWithArg(_) => + raise(EvaluatorError.Exception(InvalidBoxedSumConstructor(expr))) + } + + /* Forms that are not yet or will never be a value */ + | ( + _, + Invalid(_) | EmptyHole | MultiHole(_) | StaticErrorHole(_) | + DynamicErrorHole(_) | + FailedCast(_) | + Var(_) | + Let(_) | + Fun(_, _, _, None) | + FixF(_) | + TyAlias(_) | + Ap(_) | + If(_) | + Seq(_) | + Test(_) | + Filter(_) | + Closure(_) | + Parens(_) | + Cons(_) | + ListConcat(_) | + UnOp(_) | + BinOp(_) | + Match(_), + ) => + IndetMatch + }; + }; diff --git a/src/haz3lcore/lang/term/IdTagged.re b/src/haz3lcore/lang/term/IdTagged.re index 224968319c..6e0306f805 100644 --- a/src/haz3lcore/lang/term/IdTagged.re +++ b/src/haz3lcore/lang/term/IdTagged.re @@ -2,10 +2,12 @@ include Sexplib.Std; [@deriving (show({with_path: false}), sexp, yojson)] type t('a) = { + [@show.opaque] ids: list(Id.t), /* UExp invariant: copied should always be false, and the id should be unique DHExp invariant: if copied is true, then this term and its children may not have unique ids. */ + [@show.opaque] copied: bool, term: 'a, }; diff --git a/src/haz3lcore/statics/ConstructorMap.re b/src/haz3lcore/statics/ConstructorMap.re index 9ad845d6d9..848c740ed9 100644 --- a/src/haz3lcore/statics/ConstructorMap.re +++ b/src/haz3lcore/statics/ConstructorMap.re @@ -158,3 +158,11 @@ let get_entry = (ctr, m) => | BadEntry(_) => None, m, ); + +let has_constructor_no_args = ctr => + List.exists( + fun + | Variant(ctr', _, None) when Constructor.equal(ctr, ctr') => true + | Variant(_) + | BadEntry(_) => false, + ); diff --git a/src/util/ListUtil.re b/src/util/ListUtil.re index 629e83c876..fe6627c4d5 100644 --- a/src/util/ListUtil.re +++ b/src/util/ListUtil.re @@ -495,3 +495,13 @@ let rec rev_concat: (list('a), list('a)) => list('a) = | [hd, ...tl] => rev_concat(tl, [hd, ...rs]) }; }; + +let rec map3 = (f, xs, ys, zs) => + switch (xs, ys, zs) { + | ([], [], []) => [] + | ([x, ...xs], [y, ...ys], [z, ...zs]) => [ + f(x, y, z), + ...map3(f, xs, ys, zs), + ] + | _ => failwith("Lists are of unequal length") + }; From d87a27aa9d136de71fa44c626e74ca95ca8bab8b Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Wed, 3 Apr 2024 13:37:49 -0400 Subject: [PATCH 067/103] Rewrite pattern matching --- src/haz3lcore/dynamics/Casts.re | 155 ++++++ src/haz3lcore/dynamics/EvaluatorError.re | 1 + src/haz3lcore/dynamics/EvaluatorError.rei | 1 + src/haz3lcore/dynamics/EvaluatorStep.re | 6 +- src/haz3lcore/dynamics/PatternMatch.re | 630 +++------------------- src/haz3lcore/dynamics/PatternMatch.rei | 6 - src/haz3lcore/dynamics/Transition.re | 301 +++-------- src/haz3lcore/dynamics/Unboxing.re | 177 ++++++ src/haz3lcore/lang/term/IdTagged.re | 2 + src/haz3lcore/statics/ConstructorMap.re | 8 + src/util/ListUtil.re | 10 + 11 files changed, 508 insertions(+), 789 deletions(-) create mode 100644 src/haz3lcore/dynamics/Casts.re delete mode 100644 src/haz3lcore/dynamics/PatternMatch.rei create mode 100644 src/haz3lcore/dynamics/Unboxing.re diff --git a/src/haz3lcore/dynamics/Casts.re b/src/haz3lcore/dynamics/Casts.re new file mode 100644 index 0000000000..aa8f15a585 --- /dev/null +++ b/src/haz3lcore/dynamics/Casts.re @@ -0,0 +1,155 @@ +open Util; + +/* The cast calculus is based off the POPL 2019 paper: + https://arxiv.org/pdf/1805.00155.pdf */ + +/* GROUND TYPES */ + +/* You can think of a ground type as a typet that tells you what the root of the + type expression is, but nothing more. For example: Int, [?], ? -> ?, ... are + ground types and [Int], ? -> Float are not. + + The most important property of ground types is: + If two types are ground types, + and the two types are consistent, + then they are equal. + + Make sure this holds for your new feature!! + + e.g. [?] and [?] are equal, but [?] and [Int] are not (because [Int] is not + ground, even though [Int] and [?] are consistent). + + */ + +[@deriving sexp] +type ground_cases = + | Hole + | Ground + | NotGroundOrHole(Typ.t) /* the argument is the corresponding ground type */; + +let rec ground_cases_of = (ty: Typ.t): ground_cases => { + let grounded_Arrow = + NotGroundOrHole( + Arrow(Unknown(Internal) |> Typ.fresh, Unknown(Internal) |> Typ.fresh) + |> Typ.fresh, + ); + let grounded_Prod = length => + NotGroundOrHole( + Prod(ListUtil.replicate(length, Typ.Unknown(Internal) |> Typ.fresh)) + |> Typ.fresh, + ); + let grounded_Sum: unit => Typ.sum_map = + () => [BadEntry(Typ.fresh(Unknown(Internal)))]; + let grounded_List = + NotGroundOrHole(List(Unknown(Internal) |> Typ.fresh) |> Typ.fresh); + let is_hole: Typ.t => bool = + fun + | {term: Typ.Unknown(_), _} => true + | _ => false; + switch (Typ.term_of(ty)) { + | Unknown(_) => Hole + | Bool + | Int + | Float + | String + | Var(_) + | Rec(_) + | Arrow({term: Unknown(_), _}, {term: Unknown(_), _}) + | List({term: Unknown(_), _}) => Ground + | Parens(ty) => ground_cases_of(ty) + | Prod(tys) => + if (List.for_all( + fun + | ({term: Typ.Unknown(_), _}: Typ.t) => true + | _ => false, + tys, + )) { + Ground; + } else { + tys |> List.length |> grounded_Prod; + } + | Sum(sm) => + sm |> ConstructorMap.is_ground(is_hole) + ? Ground : NotGroundOrHole(Sum(grounded_Sum()) |> Typ.fresh) + | Arrow(_, _) => grounded_Arrow + | List(_) => grounded_List + | Ap(_) => failwith("type application in dynamics") + }; +}; + +/* CAST CALCULUS */ + +/* Rules are taken from figure 12 of https://arxiv.org/pdf/1805.00155.pdf */ + +/* gives a transition step that can be taken by the cast calculus here if applicable. */ +let rec transition = (~recursive=false, d: DHExp.t): option(DHExp.t) => { + switch (DHExp.term_of(d)) { + | Cast(d1, t1, t2) => + let d1 = + if (recursive) { + d1 |> transition(~recursive) |> Option.value(~default=d1); + } else { + d1; + }; + switch (ground_cases_of(t1), ground_cases_of(t2)) { + | (Hole, Hole) + | (Ground, Ground) => + /* if two types are ground and consistent, then they are eq */ + Some(d1) // Rule ITCastId + + | (Ground, Hole) => + /* can't remove the cast or do anything else here, so we're done */ + None // TODO[Matt]: CONSTRUCTOR + + | (Hole, Ground) => + switch (DHExp.term_of(d1)) { + | Cast(d2, t3, {term: Unknown(_), _}) => + /* by canonical forms, d1' must be of the form d ?> */ + if (Typ.eq(t3, t2)) { + Some + (d2); // Rule ITCastSucceed + } else { + Some + (FailedCast(d2, t1, t2) |> DHExp.fresh); // Rule ITCastFail + } + | _ => None // TODO[Matt]: INDET + } + + | (Hole, NotGroundOrHole(t2_grounded)) => + /* ITExpand rule */ + Some( + DHExp.Cast(Cast(d1, t1, t2_grounded) |> DHExp.fresh, t2_grounded, t2) + |> DHExp.fresh, + ) + + | (NotGroundOrHole(t1_grounded), Hole) => + /* ITGround rule */ + Some( + DHExp.Cast(Cast(d1, t1, t1_grounded) |> DHExp.fresh, t1_grounded, t2) + |> DHExp.fresh, + ) + + | (Ground, NotGroundOrHole(_)) + | (NotGroundOrHole(_), Ground) => + /* can't do anything when casting between diseq, non-hole types */ + None // TODO[Matt]: CONSTRUCTOR + + | (NotGroundOrHole(_), NotGroundOrHole(_)) => + /* they might be eq in this case, so remove cast if so */ + if (Typ.eq(t1, t2)) { + Some + (d1); // Rule ITCastId + } else { + None; // TODO[Matt]: CONSTRUCTOR + } + }; + | _ => None + }; +}; + +let rec transition_multiple = (d: DHExp.t): DHExp.t => { + switch (transition(~recursive=true, d)) { + | Some(d'') => transition_multiple(d'') + | None => d + }; +}; diff --git a/src/haz3lcore/dynamics/EvaluatorError.re b/src/haz3lcore/dynamics/EvaluatorError.re index 7cd750d1bc..c0f8dd5449 100644 --- a/src/haz3lcore/dynamics/EvaluatorError.re +++ b/src/haz3lcore/dynamics/EvaluatorError.re @@ -13,6 +13,7 @@ type t = | InvalidBoxedFloatLit(DHExp.t) | InvalidBoxedListLit(DHExp.t) | InvalidBoxedStringLit(DHExp.t) + | InvalidBoxedSumConstructor(DHExp.t) | InvalidBoxedTuple(DHExp.t) | InvalidBuiltin(string) | BadBuiltinAp(string, list(DHExp.t)) diff --git a/src/haz3lcore/dynamics/EvaluatorError.rei b/src/haz3lcore/dynamics/EvaluatorError.rei index e5a07fe847..cc576c5d23 100644 --- a/src/haz3lcore/dynamics/EvaluatorError.rei +++ b/src/haz3lcore/dynamics/EvaluatorError.rei @@ -11,6 +11,7 @@ type t = | InvalidBoxedFloatLit(DHExp.t) | InvalidBoxedListLit(DHExp.t) | InvalidBoxedStringLit(DHExp.t) + | InvalidBoxedSumConstructor(DHExp.t) | InvalidBoxedTuple(DHExp.t) | InvalidBuiltin(string) | BadBuiltinAp(string, list(DHExp.t)) diff --git a/src/haz3lcore/dynamics/EvaluatorStep.re b/src/haz3lcore/dynamics/EvaluatorStep.re index 2ad3738cca..fdf1beef51 100644 --- a/src/haz3lcore/dynamics/EvaluatorStep.re +++ b/src/haz3lcore/dynamics/EvaluatorStep.re @@ -172,7 +172,11 @@ module Decompose = { Step({apply: () => d1, kind: CompleteFilter, value: true}); } ) - | _ => Decomp.transition(decompose, state, env, exp) + | _ => + switch (Decomp.transition(decompose, state, env, exp)) { + | r => r + | exception (EvaluatorError.Exception(_)) => Result.Indet + } }; }; }; diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index 6308461a77..9b0dd0b829 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -1,566 +1,74 @@ -open Util; +type match_result = Unboxing.unboxed(Environment.t); +let ( let* ) = Unboxing.( let* ); -type match_result = - | Matches(Environment.t) - | DoesNotMatch - | IndetMatch; - -let const_unknown: 'a => Typ.t = _ => Unknown(Internal) |> Typ.fresh; - -let cast_sum_maps = (_, _) => None; // TODO[Matt]: Fix - -// let cast_sum_maps = -// (sm1: Typ.sum_map, sm2: Typ.sum_map) -// : option(ConstructorMap.t((Typ.t, Typ.t))) => { -// let (ctrs1, tys1) = sm1 |> ConstructorMap.bindings |> List.split; -// let (ctrs2, tys2) = sm2 |> ConstructorMap.bindings |> List.split; -// if (ctrs1 == ctrs2) { -// let tys1 = tys1 |> List.filter(Option.is_some) |> List.map(Option.get); -// let tys2 = tys2 |> List.filter(Option.is_some) |> List.map(Option.get); -// if (List.length(tys1) == List.length(tys2)) { -// Some( -// List.(combine(tys1, tys2) |> combine(ctrs1)) -// |> ConstructorMap.of_list, -// ); -// } else { -// None; -// }; -// } else { -// None; -// }; -// }; - -let rec matches = (dp: Pat.t, d: DHExp.t): match_result => - switch (DHPat.term_of(dp), DHExp.term_of(d)) { - | (Parens(x), _) => matches(x, d) - | (TypeAnn(x, _), _) => matches(x, d) - | (_, Var(_)) => DoesNotMatch - | (EmptyHole, _) - | (MultiHole(_), _) - | (Wild, _) => Matches(Environment.empty) - | (Invalid(_), _) => IndetMatch - | (Var(x), _) => - let env = Environment.extend(Environment.empty, (x, d)); - Matches(env); - | (_, EmptyHole) => IndetMatch - | (_, StaticErrorHole(_)) => IndetMatch - | (_, FailedCast(_)) => IndetMatch - | (_, DynamicErrorHole(_)) => IndetMatch - | (_, Invalid(_)) => IndetMatch - | (_, Let(_)) => IndetMatch - | (_, FixF(_)) => DoesNotMatch - | (_, Fun(_)) => DoesNotMatch - | (_, BinOp(_)) => IndetMatch - | (_, UnOp(_)) => IndetMatch - | (_, Match(_, _)) => IndetMatch - - /* Closure should match like underlying expression. */ - | (_, Closure(_, d')) - | (_, Filter(_, d')) => matches(dp, d') - - | (Bool(b1), Bool(b2)) => - if (b1 == b2) { - Matches(Environment.empty); - } else { - DoesNotMatch; - } - | (Bool(_), Cast(d, {term: Bool, _}, {term: Unknown(_), _})) => - matches(dp, d) - | (Bool(_), Cast(d, {term: Unknown(_), _}, {term: Bool, _})) => - matches(dp, d) - | (Bool(_), _) => DoesNotMatch - | (Int(n1), Int(n2)) => - if (n1 == n2) { - Matches(Environment.empty); - } else { - DoesNotMatch; - } - | (Int(_), Cast(d, {term: Int, _}, {term: Unknown(_), _})) => - matches(dp, d) - | (Int(_), Cast(d, {term: Unknown(_), _}, {term: Int, _})) => - matches(dp, d) - | (Int(_), _) => DoesNotMatch - | (Float(n1), Float(n2)) => - if (n1 == n2) { - Matches(Environment.empty); - } else { - DoesNotMatch; - } - | (Float(_), Cast(d, {term: Float, _}, {term: Unknown(_), _})) => - matches(dp, d) - | (Float(_), Cast(d, {term: Unknown(_), _}, {term: Float, _})) => - matches(dp, d) - | (Float(_), _) => DoesNotMatch - | (String(s1), String(s2)) => - if (s1 == s2) { - Matches(Environment.empty); - } else { - DoesNotMatch; - } - | (String(_), Cast(d, {term: String, _}, {term: Unknown(_), _})) => - matches(dp, d) - | (String(_), Cast(d, {term: Unknown(_), _}, {term: String, _})) => - matches(dp, d) - | (String(_), _) => DoesNotMatch - - | (Ap(dp1, dp2), Ap(_, d1, d2)) => - switch (matches(dp1, d1)) { - | DoesNotMatch => DoesNotMatch - | IndetMatch => - switch (matches(dp2, d2)) { - | DoesNotMatch => DoesNotMatch - | IndetMatch - | Matches(_) => IndetMatch - } - | Matches(env1) => - switch (matches(dp2, d2)) { - | DoesNotMatch => DoesNotMatch - | IndetMatch => IndetMatch - | Matches(env2) => Matches(Environment.union(env1, env2)) - } - } - | ( - Ap({term: Constructor(ctr), _}, dp_opt), - Cast( - d, - {term: Sum(sm1) | Rec(_, {term: Sum(sm1), _}), _}, - {term: Sum(sm2) | Rec(_, {term: Sum(sm2), _}), _}, - ), - ) => - switch (cast_sum_maps(sm1, sm2)) { - | Some(castmap) => matches_cast_Sum(ctr, Some(dp_opt), d, [castmap]) - | None => DoesNotMatch - } - - | ( - Ap(_, _), - Cast( - d, - {term: Sum(_) | Rec(_, {term: Sum(_), _}), _}, - {term: Unknown(_), _}, - ), - ) - | ( - Ap(_, _), - Cast( - d, - {term: Unknown(_), _}, - {term: Sum(_) | Rec(_, {term: Sum(_), _}), _}, - ), - ) => - matches(dp, d) - | (Ap(_, _), _) => DoesNotMatch - - | (Constructor(ctr), Constructor(ctr')) => - ctr == ctr' ? Matches(Environment.empty) : DoesNotMatch - | ( - Constructor(ctr), - Cast( - d, - {term: Sum(sm1) | Rec(_, {term: Sum(sm1), _}), _}, - {term: Sum(sm2) | Rec(_, {term: Sum(sm2), _}), _}, - ), - ) => - switch (cast_sum_maps(sm1, sm2)) { - | Some(castmap) => matches_cast_Sum(ctr, None, d, [castmap]) - | None => DoesNotMatch - } - | ( - Constructor(_), - Cast( - d, - {term: Sum(_) | Rec(_, {term: Sum(_), _}), _}, - {term: Unknown(_), _}, - ), - ) => - matches(dp, d) - | ( - Constructor(_), - Cast( - d, - {term: Unknown(_), _}, - {term: Sum(_) | Rec(_, {term: Sum(_), _}), _}, - ), - ) => - matches(dp, d) - | (Constructor(_), _) => DoesNotMatch +let combine_result = (r1: match_result, r2: match_result): match_result => + switch (r1, r2) { + | (DoesNotMatch, _) + | (_, DoesNotMatch) => DoesNotMatch + | (IndetMatch, _) + | (_, IndetMatch) => IndetMatch + | (Matches(env1), Matches(env2)) => + Matches(Environment.union(env1, env2)) + }; - | (Tuple(dps), Tuple(ds)) => - if (List.length(dps) != List.length(ds)) { - DoesNotMatch; +let rec matches = (m: Statics.Map.t, dp: Pat.t, d: DHExp.t): match_result => + switch (DHPat.term_of(dp)) { + | Invalid(_) + | EmptyHole + | MultiHole(_) + | Wild => Matches(Environment.empty) + | Int(n) => + let* n' = Unboxing.unbox(Int, d); + n == n' ? Matches(Environment.empty) : DoesNotMatch; + | Float(n) => + let* n' = Unboxing.unbox(Float, d); + n == n' ? Matches(Environment.empty) : DoesNotMatch; + | Bool(b) => + let* b' = Unboxing.unbox(Bool, d); + b == b' ? Matches(Environment.empty) : DoesNotMatch; + | String(s) => + let* s' = Unboxing.unbox(String, d); + s == s' ? Matches(Environment.empty) : DoesNotMatch; + | ListLit(xs) => + let* s' = Unboxing.unbox(List, d); + if (List.length(xs) == List.length(s')) { + List.map2(matches(m), xs, s') + |> List.fold_left(combine_result, Matches(Environment.empty)); } else { - List.fold_left2( - (result, dp, d) => - switch (result) { - | DoesNotMatch => DoesNotMatch - | IndetMatch => IndetMatch - | Matches(env) => - switch (matches(dp, d)) { - | DoesNotMatch => DoesNotMatch - | IndetMatch => IndetMatch - | Matches(env') => Matches(Environment.union(env, env')) - } - }, - Matches(Environment.empty), - dps, - ds, - ); - } - | (Tuple(dps), Cast(d, {term: Prod(tys), _}, {term: Prod(tys'), _})) => - assert(List.length(tys) == List.length(tys')); - matches_cast_Tuple( - dps, - d, - List.map(p => [p], List.combine(tys, tys')), - ); - | (Tuple(dps), Cast(d, {term: Prod(tys), _}, {term: Unknown(_), _})) => - matches_cast_Tuple( - dps, - d, - List.map( - p => [p], - List.combine(tys, List.init(List.length(tys), const_unknown)), - ), - ) - | (Tuple(dps), Cast(d, {term: Unknown(_), _}, {term: Prod(tys'), _})) => - matches_cast_Tuple( - dps, - d, - List.map( - p => [p], - List.combine(List.init(List.length(tys'), const_unknown), tys'), - ), - ) - | (Tuple(_), Cast(_)) => DoesNotMatch - | (Tuple(_), _) => DoesNotMatch - | ( - Cons(_) | ListLit(_), - Cast(d, {term: List(ty1), _}, {term: List(ty2), _}), - ) => - matches_cast_Cons(dp, d, [(ty1, ty2)]) - | ( - Cons(_) | ListLit(_), - Cast(d, {term: Unknown(_), _}, {term: List(ty2), _}), - ) => - matches_cast_Cons(dp, d, [(Unknown(Internal) |> Typ.fresh, ty2)]) - | ( - Cons(_) | ListLit(_), - Cast(d, {term: List(ty1), _}, {term: Unknown(_), _}), - ) => - matches_cast_Cons(dp, d, [(ty1, Unknown(Internal) |> Typ.fresh)]) - | (Cons(_, _), Cons(_, _)) - | (ListLit(_), Cons(_, _)) - | (Cons(_, _), ListLit(_)) - | (ListLit(_), ListLit(_)) => matches_cast_Cons(dp, d, []) - | (Cons(_) | ListLit(_), _) => DoesNotMatch - } -and matches_cast_Sum = - ( - _ctr: string, - _dp: option(Pat.t), - _d: DHExp.t, - _castmaps: list(ConstructorMap.t((Typ.t, Typ.t))), - ) - : match_result => - IndetMatch // TODO[Matt]: fix -// switch (DHExp.term_of(d)) { -// | Parens(d) => matches_cast_Sum(ctr, dp, d, castmaps) -// | Constructor(ctr') => -// switch ( -// dp, -// castmaps |> List.map(ConstructorMap.find_opt(ctr')) |> OptUtil.sequence, -// ) { -// | (None, Some(_)) => -// ctr == ctr' ? Matches(Environment.empty) : DoesNotMatch -// | _ => DoesNotMatch -// } -// | Ap(_, d1, d2) => -// switch (DHExp.term_of(d1)) { -// | Constructor(ctr') => -// switch ( -// dp, -// castmaps -// |> List.map(ConstructorMap.find_opt(ctr')) -// |> OptUtil.sequence, -// ) { -// | (Some(dp), Some(side_casts)) => -// matches(dp, DHExp.apply_casts(d2, side_casts)) -// | _ => DoesNotMatch -// } -// | _ => IndetMatch -// } -// | Cast( -// d', -// {term: Sum(sm1) | Rec(_, {term: Sum(sm1), _}), _}, -// {term: Sum(sm2) | Rec(_, {term: Sum(sm2), _}), _}, -// ) => -// switch (cast_sum_maps(sm1, sm2)) { -// | Some(castmap) => matches_cast_Sum(ctr, dp, d', [castmap, ...castmaps]) -// | None => DoesNotMatch -// } -// | Cast( -// d', -// {term: Sum(_) | Rec(_, {term: Sum(_), _}), _}, -// {term: Unknown(_), _}, -// ) -// | Cast( -// d', -// {term: Unknown(_), _}, -// {term: Sum(_) | Rec(_, {term: Sum(_), _}), _}, -// ) => -// matches_cast_Sum(ctr, dp, d', castmaps) -// | Invalid(_) -// | Let(_) -// | UnOp(_) -// | BinOp(_) -// | EmptyHole -// | MultiHole(_) -// | StaticErrorHole(_) -// | FailedCast(_, _, _) -// | Test(_) -// | DynamicErrorHole(_) -// | Match(_) -// | If(_) -// | TyAlias(_) -// | BuiltinFun(_) => IndetMatch -// | Cast(_) -// | Var(_) -// | FixF(_) -// | Fun(_) -// | Bool(_) -// | Int(_) -// | Float(_) -// | String(_) -// | ListLit(_) -// | Tuple(_) -// | Seq(_, _) -// | Closure(_) -// | Filter(_) -// | Cons(_) -// | ListConcat(_) => DoesNotMatch -// } -and matches_cast_Tuple = - (dps: list(Pat.t), d: DHExp.t, elt_casts: list(list((Typ.t, Typ.t)))) - : match_result => - switch (DHExp.term_of(d)) { - | Parens(d) => matches_cast_Tuple(dps, d, elt_casts) - | Tuple(ds) => - if (List.length(dps) != List.length(ds)) { DoesNotMatch; - } else { - assert(List.length(List.combine(dps, ds)) == List.length(elt_casts)); - List.fold_right( - (((dp, d), casts), result) => { - switch (result) { - | DoesNotMatch - | IndetMatch => result - | Matches(env) => - switch (matches(dp, DHExp.apply_casts(d, casts))) { - | DoesNotMatch => DoesNotMatch - | IndetMatch => IndetMatch - | Matches(env') => Matches(Environment.union(env, env')) - } - } - }, - List.combine(List.combine(dps, ds), elt_casts), - Matches(Environment.empty), - ); - } - | Cast(d', {term: Prod(tys), _}, {term: Prod(tys'), _}) => - if (List.length(dps) != List.length(tys)) { - DoesNotMatch; - } else { - assert(List.length(tys) == List.length(tys')); - matches_cast_Tuple( - dps, - d', - List.map2(List.cons, List.combine(tys, tys'), elt_casts), - ); - } - | Cast(d', {term: Prod(tys), _}, {term: Unknown(_), _}) => - let tys' = List.init(List.length(tys), const_unknown); - matches_cast_Tuple( - dps, - d', - List.map2(List.cons, List.combine(tys, tys'), elt_casts), - ); - | Cast(d', {term: Unknown(_), _}, {term: Prod(tys'), _}) => - let tys = List.init(List.length(tys'), const_unknown); - matches_cast_Tuple( - dps, - d', - List.map2(List.cons, List.combine(tys, tys'), elt_casts), - ); - | Cast(_, _, _) => DoesNotMatch - | Var(_) => DoesNotMatch - | Invalid(_) => IndetMatch - | Let(_, _, _) => IndetMatch - | FixF(_, _, _) => DoesNotMatch - | Fun(_, _, _, _) => DoesNotMatch - | Closure(_, _) => IndetMatch - | Filter(_, _) => IndetMatch - | Ap(_, _, _) => IndetMatch - | TyAlias(_) => IndetMatch - | UnOp(_, _) - | BinOp(_, _, _) => DoesNotMatch - | Bool(_) => DoesNotMatch - | Int(_) => DoesNotMatch - | Seq(_) - | BuiltinFun(_) - | Test(_) => DoesNotMatch - | Float(_) => DoesNotMatch - | String(_) => DoesNotMatch - | ListLit(_) => DoesNotMatch - | Cons(_, _) => DoesNotMatch - | ListConcat(_) => DoesNotMatch - | Constructor(_) => DoesNotMatch - | Match(_) => IndetMatch - | EmptyHole => IndetMatch - | MultiHole(_) => IndetMatch - | StaticErrorHole(_) => IndetMatch - | FailedCast(_, _, _) => IndetMatch - | DynamicErrorHole(_) => IndetMatch - | If(_) => IndetMatch - } -and matches_cast_Cons = - (dp: Pat.t, d: DHExp.t, elt_casts: list((Typ.t, Typ.t))): match_result => - switch (DHExp.term_of(d)) { - | Parens(d) => matches_cast_Cons(dp, d, elt_casts) - | ListLit([]) => - switch (DHPat.term_of(dp)) { - | ListLit([]) => Matches(Environment.empty) - | _ => DoesNotMatch - } - | ListLit([dhd, ...dtl] as ds) => - switch (DHPat.term_of(dp)) { - | Cons(dp1, dp2) => - switch (matches(dp1, DHExp.apply_casts(dhd, elt_casts))) { - | DoesNotMatch => DoesNotMatch - | IndetMatch => IndetMatch - | Matches(env1) => - let list_casts = - List.map( - (c: (Typ.t, Typ.t)) => { - let (ty1, ty2) = c; - (Typ.List(ty1) |> Typ.fresh, Typ.List(ty2) |> Typ.fresh); - }, - elt_casts, - ); - let d2 = DHExp.ListLit(dtl) |> DHExp.fresh; - switch (matches(dp2, DHExp.apply_casts(d2, list_casts))) { - | DoesNotMatch => DoesNotMatch - | IndetMatch => IndetMatch - | Matches(env2) => Matches(Environment.union(env1, env2)) - }; - } - | ListLit(dps) => - switch (ListUtil.opt_zip(dps, ds)) { - | None => DoesNotMatch - | Some(lst) => - lst - |> List.map(((dp, d)) => - matches(dp, DHExp.apply_casts(d, elt_casts)) - ) - |> List.fold_left( - (match1, match2) => - switch (match1, match2) { - | (DoesNotMatch, _) - | (_, DoesNotMatch) => DoesNotMatch - | (IndetMatch, _) - | (_, IndetMatch) => IndetMatch - | (Matches(env1), Matches(env2)) => - Matches(Environment.union(env1, env2)) - }, - Matches(Environment.empty), - ) - } - | _ => failwith("called matches_cast_Cons with non-list pattern") - } - | Cons(d1, d2) => - switch (DHPat.term_of(dp)) { - | Cons(dp1, dp2) => - switch (matches(dp1, DHExp.apply_casts(d1, elt_casts))) { - | DoesNotMatch => DoesNotMatch - | IndetMatch => IndetMatch - | Matches(env1) => - let list_casts = - List.map( - (c: (Typ.t, Typ.t)) => { - let (ty1, ty2) = c; - (Typ.List(ty1) |> Typ.fresh, Typ.List(ty2) |> Typ.fresh); - }, - elt_casts, - ); - switch (matches(dp2, DHExp.apply_casts(d2, list_casts))) { - | DoesNotMatch => DoesNotMatch - | IndetMatch => IndetMatch - | Matches(env2) => Matches(Environment.union(env1, env2)) - }; - } - | ListLit([]) => DoesNotMatch - | ListLit([dphd, ...dptl]) => - switch (matches(dphd, DHExp.apply_casts(d1, elt_casts))) { - | DoesNotMatch => DoesNotMatch - | IndetMatch => IndetMatch - | Matches(env1) => - let list_casts = - List.map( - (c: (Typ.t, Typ.t)) => { - let (ty1, ty2) = c; - (Typ.List(ty1) |> Typ.fresh, Typ.List(ty2) |> Typ.fresh); - }, - elt_casts, - ); - let dp2 = Pat.ListLit(dptl) |> DHPat.fresh; - switch (matches(dp2, DHExp.apply_casts(d2, list_casts))) { - | DoesNotMatch => DoesNotMatch - | IndetMatch => IndetMatch - | Matches(env2) => Matches(Environment.union(env1, env2)) - }; - } - | _ => failwith("called matches_cast_Cons with non-list pattern") - } - | Cast(d', {term: List(ty1), _}, {term: List(ty2), _}) => - matches_cast_Cons(dp, d', [(ty1, ty2), ...elt_casts]) - | Cast(d', {term: List(ty1), _}, {term: Unknown(_), _}) => - matches_cast_Cons( - dp, - d', - [(ty1, Unknown(Internal) |> Typ.fresh), ...elt_casts], - ) - | Cast(d', {term: Unknown(_), _}, {term: List(ty2), _}) => - matches_cast_Cons( - dp, - d', - [(Unknown(Internal) |> Typ.fresh, ty2), ...elt_casts], - ) - | Cast(_, _, _) => DoesNotMatch - | Var(_) => DoesNotMatch - | Invalid(_) => IndetMatch - | Let(_, _, _) => IndetMatch - | FixF(_, _, _) => DoesNotMatch - | Fun(_, _, _, _) => DoesNotMatch - | Closure(_, d') => matches_cast_Cons(dp, d', elt_casts) - | Filter(_, d') => matches_cast_Cons(dp, d', elt_casts) - | Ap(_, _, _) => IndetMatch - | TyAlias(_) => IndetMatch - | UnOp(_, _) - | BinOp(_, _, _) - | ListConcat(_) - | BuiltinFun(_) => DoesNotMatch - | Bool(_) => DoesNotMatch - | Int(_) => DoesNotMatch - | Seq(_) - | Test(_) => DoesNotMatch - | Float(_) => DoesNotMatch - | String(_) => DoesNotMatch - | Tuple(_) => DoesNotMatch - | Constructor(_) => DoesNotMatch - | Match(_) => IndetMatch - | EmptyHole => IndetMatch - | MultiHole(_) => IndetMatch - | StaticErrorHole(_) => IndetMatch - | FailedCast(_, _, _) => IndetMatch - | DynamicErrorHole(_) => IndetMatch - | If(_) => IndetMatch + }; + | Cons(x, xs) => + let* (x', xs') = Unboxing.unbox(Cons, d); + let* m_x = matches(m, x, x'); + let* m_xs = matches(m, xs, xs'); + Matches(Environment.union(m_x, m_xs)); + | Constructor(ctr) => + let* () = Unboxing.unbox(SumNoArg(ctr), d); + Matches(Environment.empty); + | Ap({term: Constructor(ctr), _}, p2) => + let* d2 = Unboxing.unbox(SumWithArg(ctr), d); + matches(m, p2, d2); + | Ap(_, _) => IndetMatch // TODO: should this fail? + | Var(x) => Matches(Environment.singleton((x, d))) + | Tuple(ps) => + let* ds = Unboxing.unbox(Tuple(List.length(ps)), d); + List.map2(matches(m), ps, ds) + |> List.fold_left(combine_result, Matches(Environment.empty)); + | Parens(p) => matches(m, p, d) + | TypeAnn(p, t) => + let _ = print_endline("TypeAnn"); + let mode = + switch (Id.Map.find_opt(Pat.rep_id(p), m)) { + | Some(Info.InfoPat({mode, _})) => mode + | _ => raise(Elaborator.MissingTypeInfo) + }; + switch (mode) { + | Ana(ana_ty) when !Typ.eq(ana_ty, t) => + let _ = Typ.show(ana_ty) |> print_endline; + let _ = Typ.show(t) |> print_endline; + matches(m, p, Cast(d, ana_ty, t) |> DHExp.fresh); + | Ana(_) + | Syn + | SynFun => matches(m, p, d) + }; }; diff --git a/src/haz3lcore/dynamics/PatternMatch.rei b/src/haz3lcore/dynamics/PatternMatch.rei deleted file mode 100644 index 2cba4e6681..0000000000 --- a/src/haz3lcore/dynamics/PatternMatch.rei +++ /dev/null @@ -1,6 +0,0 @@ -type match_result = - | Matches(Environment.t) - | DoesNotMatch - | IndetMatch; - -let matches: (Pat.t, DHExp.t) => match_result; diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index 99aa08295c..f7b757975a 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -1,5 +1,5 @@ -open Sexplib.Std; open Util; +open Sexplib.Std; open PatternMatch; /* Transition.re @@ -72,68 +72,6 @@ type step_kind = | Cast | RemoveTypeAlias | RemoveParens; - -module CastHelpers = { - [@deriving sexp] - type ground_cases = - | Hole - | Ground - | NotGroundOrHole(Typ.t) /* the argument is the corresponding ground type */; - - let const_unknown: 'a => Typ.t = _ => Unknown(Internal) |> Typ.fresh; - - let grounded_Arrow = - NotGroundOrHole( - Arrow(Unknown(Internal) |> Typ.fresh, Unknown(Internal) |> Typ.fresh) - |> Typ.fresh, - ); - let grounded_Prod = length => - NotGroundOrHole( - Prod(ListUtil.replicate(length, Typ.Unknown(Internal) |> Typ.fresh)) - |> Typ.fresh, - ); - let grounded_Sum: unit => Typ.sum_map = - () => [BadEntry(Typ.fresh(Unknown(Internal)))]; - let grounded_List = - NotGroundOrHole(List(Unknown(Internal) |> Typ.fresh) |> Typ.fresh); - - let rec ground_cases_of = (ty: Typ.t): ground_cases => { - let is_hole: Typ.t => bool = - fun - | {term: Typ.Unknown(_), _} => true - | _ => false; - switch (Typ.term_of(ty)) { - | Unknown(_) => Hole - | Bool - | Int - | Float - | String - | Var(_) - | Rec(_) - | Arrow({term: Unknown(_), _}, {term: Unknown(_), _}) - | List({term: Unknown(_), _}) => Ground - | Parens(ty) => ground_cases_of(ty) - | Prod(tys) => - if (List.for_all( - fun - | ({term: Typ.Unknown(_), _}: Typ.t) => true - | _ => false, - tys, - )) { - Ground; - } else { - tys |> List.length |> grounded_Prod; - } - | Sum(sm) => - sm |> ConstructorMap.is_ground(is_hole) - ? Ground : NotGroundOrHole(Sum(grounded_Sum()) |> Typ.fresh) - | Arrow(_, _) => grounded_Arrow - | List(_) => grounded_List - | Ap(_) => failwith("type application in dynamics") - }; - }; -}; - let evaluate_extend_env = (new_bindings: Environment.t, to_extend: ClosureEnvironment.t) : ClosureEnvironment.t => { @@ -152,6 +90,13 @@ type rule = | Constructor | Indet; +let (let-unbox) = ((request, v), f) => + switch (Unboxing.unbox(request, v)) { + | IndetMatch + | DoesNotMatch => Indet + | Matches(n) => f(n) + }; + module type EV_MODE = { type state; type result; @@ -196,7 +141,7 @@ module type EV_MODE = { module Transition = (EV: EV_MODE) => { open EV; open DHExp; - let (let.match) = ((env, match_result), r) => + let (let.match) = ((env, match_result: PatternMatch.match_result), r) => switch (match_result) { | IndetMatch | DoesNotMatch => Indet @@ -255,7 +200,7 @@ module Transition = (EV: EV_MODE) => { let. _ = otherwise(env, d1 => Let(dp, d1, d2) |> rewrap) and. d1' = req_final(req(state, env), d1 => Let1(dp, d1, d2) |> wrap_ctx, d1); - let.match env' = (env, matches(dp, d1')); + let.match env' = (env, matches(info_map, dp, d1')); Step({ apply: () => Closure(env', d2) |> fresh, kind: LetBind, @@ -352,7 +297,7 @@ module Transition = (EV: EV_MODE) => { switch (DHExp.term_of(d1')) { | Constructor(_) => Constructor | Fun(dp, d3, Some(env'), _) => - let.match env'' = (env', matches(dp, d2')); + let.match env'' = (env', matches(info_map, dp, d2')); Step({ apply: () => Closure(env'', d3) |> fresh, kind: FunAp, @@ -443,12 +388,9 @@ module Transition = (EV: EV_MODE) => { c => UnOp(Int(Minus), c) |> wrap_ctx, d1, ); + let-unbox n = (Int, d1'); Step({ - apply: () => - switch (DHExp.term_of(d1')) { - | Int(n) => Int(- n) |> fresh - | _ => raise(EvaluatorError.Exception(InvalidBoxedIntLit(d1'))) - }, + apply: () => Int(- n) |> fresh, kind: UnOp(Int(Minus)), value: true, }); @@ -460,12 +402,9 @@ module Transition = (EV: EV_MODE) => { c => UnOp(Bool(Not), c) |> wrap_ctx, d1, ); + let-unbox b = (Bool, d1'); Step({ - apply: () => - switch (DHExp.term_of(d1')) { - | Bool(b) => Bool(!b) |> fresh - | _ => raise(EvaluatorError.Exception(InvalidBoxedIntLit(d1'))) - }, + apply: () => Bool(!b) |> fresh, kind: UnOp(Bool(Not)), value: true, }); @@ -477,13 +416,9 @@ module Transition = (EV: EV_MODE) => { d1 => BinOp1(Bool(And), d1, d2) |> wrap_ctx, d1, ); + let-unbox b1 = (Bool, d1'); Step({ - apply: () => - switch (DHExp.term_of(d1')) { - | Bool(true) => d2 - | Bool(false) => Bool(false) |> fresh - | _ => raise(EvaluatorError.Exception(InvalidBoxedBoolLit(d1'))) - }, + apply: () => b1 ? d2 : Bool(false) |> fresh, kind: BinBoolOp(And), value: false, }); @@ -495,13 +430,9 @@ module Transition = (EV: EV_MODE) => { d1 => BinOp1(Bool(Or), d1, d2) |> wrap_ctx, d1, ); + let-unbox b1 = (Bool, d1'); Step({ - apply: () => - switch (DHExp.term_of(d1')) { - | Bool(true) => Bool(true) |> fresh - | Bool(false) => d2 - | _ => raise(EvaluatorError.Exception(InvalidBoxedBoolLit(d2))) - }, + apply: () => b1 ? Bool(true) |> fresh : d2, kind: BinBoolOp(Or), value: false, }); @@ -519,40 +450,36 @@ module Transition = (EV: EV_MODE) => { d2 => BinOp2(Int(op), d1, d2) |> wrap_ctx, d2, ); + let-unbox n1 = (Int, d1'); + let-unbox n2 = (Int, d2'); Step({ apply: () => - switch (DHExp.term_of(d1'), DHExp.term_of(d2')) { - | (Int(n1), Int(n2)) => - ( - switch (op) { - | Plus => Int(n1 + n2) - | Minus => Int(n1 - n2) - | Power when n2 < 0 => - DynamicErrorHole( - BinOp(Int(op), d1', d2') |> rewrap, - NegativeExponent, - ) - | Power => Int(IntUtil.ipow(n1, n2)) - | Times => Int(n1 * n2) - | Divide when n2 == 0 => - DynamicErrorHole( - BinOp(Int(op), d1', d1') |> rewrap, - DivideByZero, - ) - | Divide => Int(n1 / n2) - | LessThan => Bool(n1 < n2) - | LessThanOrEqual => Bool(n1 <= n2) - | GreaterThan => Bool(n1 > n2) - | GreaterThanOrEqual => Bool(n1 >= n2) - | Equals => Bool(n1 == n2) - | NotEquals => Bool(n1 != n2) - } - ) - |> fresh - | (Int(_), _) => - raise(EvaluatorError.Exception(InvalidBoxedIntLit(d2'))) - | _ => raise(EvaluatorError.Exception(InvalidBoxedIntLit(d1'))) - }, + ( + switch (op) { + | Plus => Int(n1 + n2) + | Minus => Int(n1 - n2) + | Power when n2 < 0 => + DynamicErrorHole( + BinOp(Int(op), d1', d2') |> rewrap, + NegativeExponent, + ) + | Power => Int(IntUtil.ipow(n1, n2)) + | Times => Int(n1 * n2) + | Divide when n2 == 0 => + DynamicErrorHole( + BinOp(Int(op), d1', d1') |> rewrap, + DivideByZero, + ) + | Divide => Int(n1 / n2) + | LessThan => Bool(n1 < n2) + | LessThanOrEqual => Bool(n1 <= n2) + | GreaterThan => Bool(n1 > n2) + | GreaterThanOrEqual => Bool(n1 >= n2) + | Equals => Bool(n1 == n2) + | NotEquals => Bool(n1 != n2) + } + ) + |> fresh, kind: BinIntOp(op), // False so that InvalidOperations are caught and made indet by the next step value: false, @@ -572,30 +499,27 @@ module Transition = (EV: EV_MODE) => { d2 => BinOp2(Float(op), d1, d2) |> wrap_ctx, d2, ); + let-unbox n1 = (Float, d1'); + let-unbox n2 = (Float, d2'); Step({ apply: () => - switch (DHExp.term_of(d1'), DHExp.term_of(d2')) { - | (Float(n1), Float(n2)) => - ( - switch (op) { - | Plus => Float(n1 +. n2) - | Minus => Float(n1 -. n2) - | Power => Float(n1 ** n2) - | Times => Float(n1 *. n2) - | Divide => Float(n1 /. n2) - | LessThan => Bool(n1 < n2) - | LessThanOrEqual => Bool(n1 <= n2) - | GreaterThan => Bool(n1 > n2) - | GreaterThanOrEqual => Bool(n1 >= n2) - | Equals => Bool(n1 == n2) - | NotEquals => Bool(n1 != n2) - } - ) - |> fresh - | (Float(_), _) => - raise(EvaluatorError.Exception(InvalidBoxedFloatLit(d2'))) - | _ => raise(EvaluatorError.Exception(InvalidBoxedFloatLit(d1'))) - }, + ( + switch (op) { + | Plus => Float(n1 +. n2) + | Minus => Float(n1 -. n2) + | Power => Float(n1 ** n2) + | Times => Float(n1 *. n2) + | Divide => Float(n1 /. n2) + | LessThan => Bool(n1 < n2) + | LessThanOrEqual => Bool(n1 <= n2) + | GreaterThan => Bool(n1 > n2) + | GreaterThanOrEqual => Bool(n1 >= n2) + | Equals => Bool(n1 == n2) + | NotEquals => Bool(n1 != n2) + } + ) + |> fresh, + kind: BinFloatOp(op), value: true, }); @@ -614,17 +538,13 @@ module Transition = (EV: EV_MODE) => { d2 => BinOp2(String(op), d1, d2) |> wrap_ctx, d2, ); + let-unbox s1 = (String, d1'); + let-unbox s2 = (String, d2'); Step({ apply: () => - switch (DHExp.term_of(d1'), DHExp.term_of(d2')) { - | (String(s1), String(s2)) => - switch (op) { - | Concat => String(s1 ++ s2) |> fresh - | Equals => Bool(s1 == s2) |> fresh - } - | (String(_), _) => - raise(EvaluatorError.Exception(InvalidBoxedStringLit(d2'))) - | _ => raise(EvaluatorError.Exception(InvalidBoxedStringLit(d1'))) + switch (op) { + | Concat => String(s1 ++ s2) |> fresh + | Equals => Bool(s1 == s2) |> fresh }, kind: BinStringOp(op), value: true, @@ -638,24 +558,19 @@ module Transition = (EV: EV_MODE) => { ds, ); Constructor; - // TODO(Matt): Can we do something cleverer when the list structure is complete but the contents aren't? | Cons(d1, d2) => let. _ = otherwise(env, (d1, d2) => Cons(d1, d2) |> rewrap) and. d1' = req_final(req(state, env), d1 => Cons1(d1, d2) |> wrap_ctx, d1) and. d2' = req_value(req(state, env), d2 => Cons2(d1, d2) |> wrap_ctx, d2); + let-unbox ds = (List, d2'); Step({ - apply: () => - switch (term_of(d2')) { - | ListLit(ds) => ListLit([d1', ...ds]) |> fresh - | _ => raise(EvaluatorError.Exception(InvalidBoxedListLit(d2'))) - }, + apply: () => ListLit([d1', ...ds]) |> fresh, kind: ListCons, value: true, }); | ListConcat(d1, d2) => - // TODO(Matt): Can we do something cleverer when the list structure is complete but the contents aren't? let. _ = otherwise(env, (d1, d2) => ListConcat(d1, d2) |> rewrap) and. d1' = req_value( @@ -669,15 +584,10 @@ module Transition = (EV: EV_MODE) => { d2 => ListConcat2(d1, d2) |> wrap_ctx, d2, ); + let-unbox ds1 = (List, d1'); + let-unbox ds2 = (List, d2'); Step({ - apply: () => - switch (term_of(d1'), term_of(d2')) { - | (ListLit(ds1), ListLit(ds2)) => ListLit(ds1 @ ds2) |> fresh - | (ListLit(_), _) => - raise(EvaluatorError.Exception(InvalidBoxedListLit(d2'))) - | (_, _) => - raise(EvaluatorError.Exception(InvalidBoxedListLit(d1'))) - }, + apply: () => ListLit(ds1 @ ds2) |> fresh, kind: ListConcat, value: true, }); @@ -702,7 +612,7 @@ module Transition = (EV: EV_MODE) => { fun | [] => None | [(dp, d2), ...rules] => - switch (matches(dp, d1)) { + switch (matches(info_map, dp, d1)) { | Matches(env') => Some((env', d2)) | DoesNotMatch => next_rule(rules) | IndetMatch => None @@ -746,63 +656,12 @@ module Transition = (EV: EV_MODE) => { let. _ = otherwise(env, d); Indet; | Cast(d, t1, t2) => - open CastHelpers; /* Cast calculus */ - let. _ = otherwise(env, d => Cast(d, t1, t2) |> rewrap) and. d' = req_final(req(state, env), d => Cast(d, t1, t2) |> wrap_ctx, d); - switch (ground_cases_of(t1), ground_cases_of(t2)) { - | (Hole, Hole) - | (Ground, Ground) => - /* if two types are ground and consistent, then they are eq */ - Step({apply: () => d', kind: Cast, value: true}) - | (Ground, Hole) => - /* can't remove the cast or do anything else here, so we're done */ - Constructor - | (Hole, Ground) => - switch (term_of(d')) { - | Cast(d2, t3, {term: Unknown(_), _}) => - /* by canonical forms, d1' must be of the form d ?> */ - if (Typ.eq(t3, t2)) { - Step({apply: () => d2, kind: Cast, value: true}); - } else { - Step({ - apply: () => FailedCast(d', t1, t2) |> fresh, - kind: Cast, - value: false, - }); - } - | _ => Indet - } - | (Hole, NotGroundOrHole(t2_grounded)) => - /* ITExpand rule */ - Step({ - apply: () => - DHExp.Cast(Cast(d', t1, t2_grounded) |> fresh, t2_grounded, t2) - |> fresh, - kind: Cast, - value: false, - }) - | (NotGroundOrHole(t1_grounded), Hole) => - /* ITGround rule */ - Step({ - apply: () => - DHExp.Cast(Cast(d', t1, t1_grounded) |> fresh, t1_grounded, t2) - |> fresh, - kind: Cast, - value: false, - }) - | (Ground, NotGroundOrHole(_)) - | (NotGroundOrHole(_), Ground) => - /* can't do anything when casting between diseq, non-hole types */ - Constructor - | (NotGroundOrHole(_), NotGroundOrHole(_)) => - /* they might be eq in this case, so remove cast if so */ - if (Typ.eq(t1, t2)) { - Step({apply: () => d', kind: Cast, value: true}); - } else { - Constructor; - } + switch (Casts.transition(Cast(d', t1, t2) |> rewrap)) { + | Some(d) => Step({apply: () => d, kind: Cast, value: false}) + | None => Constructor }; | FailedCast(d1, t1, t2) => let. _ = otherwise(env, d1 => FailedCast(d1, t1, t2) |> rewrap) diff --git a/src/haz3lcore/dynamics/Unboxing.re b/src/haz3lcore/dynamics/Unboxing.re new file mode 100644 index 0000000000..2aeba3bd93 --- /dev/null +++ b/src/haz3lcore/dynamics/Unboxing.re @@ -0,0 +1,177 @@ +open Util; + +/* What is unboxing? + + When you have an expression of type list, and it's finished evaluating, + is it a list? Sadly not necessarily, it might be: + + - indeterminate, e.g. it has a hole in it + - a list with some casts wrapped around it + + Unboxing is the process of turning a list into a list if it is a list, + by pushing casts inside data structures, or giving up if it is not a list. + + Note unboxing only works one layer deep, if we have a list of lists then + the inner lists may still have casts around them after unboxing. + */ + +type unbox_request('a) = + | Int: unbox_request(int) + | Float: unbox_request(float) + | Bool: unbox_request(bool) + | String: unbox_request(string) + | Tuple(int): unbox_request(list(DHExp.t)) + | List: unbox_request(list(DHExp.t)) + | Cons: unbox_request((DHExp.t, DHExp.t)) + | SumNoArg(string): unbox_request(unit) + | SumWithArg(string): unbox_request(DHExp.t); + +type unboxed('a) = + | DoesNotMatch + | IndetMatch + | Matches('a); + +let ( let* ) = (x: unboxed('a), f: 'a => unboxed('b)): unboxed('b) => + switch (x) { + | IndetMatch => IndetMatch + | DoesNotMatch => DoesNotMatch + | Matches(x) => f(x) + }; + +let fixup_cast = Casts.transition_multiple; + +/* This function has a different return type depending on what kind of request + it is given. This unfortunately uses a crazy OCaml feature called GADTS, but + it avoids having to write a separate unbox function for each kind of request. + */ + +let rec unbox: type a. (unbox_request(a), DHExp.t) => unboxed(a) = + (request, expr) => { + let _ = print_endline(DHExp.show(expr)); + switch (request, DHExp.term_of(expr)) { + /* Base types are always already unboxed because of the ITCastID rule*/ + | (Bool, Bool(b)) => Matches(b) + | (Int, Int(i)) => Matches(i) + | (Float, Float(f)) => Matches(f) + | (String, String(s)) => Matches(s) + + /* Lists can be either lists or list casts */ + | (List, ListLit(l)) => Matches(l) + | (Cons, ListLit([x, ...xs])) => + Matches((x, ListLit(xs) |> DHExp.fresh)) + | (Cons, ListLit([])) => DoesNotMatch + | (List, Cast(l, {term: List(t1), _}, {term: List(t2), _})) => + let* l = unbox(List, l); + let l = List.map(d => Cast(d, t1, t2) |> DHExp.fresh, l); + let l = List.map(fixup_cast, l); + Matches(l); + | ( + Cons, + Cast(l, {term: List(t1), _} as ct1, {term: List(t2), _} as ct2), + ) => + let* l = unbox(List, l); + switch (l) { + | [] => DoesNotMatch + | [x, ...xs] => + Matches(( + Cast(x, t1, t2) |> DHExp.fresh |> fixup_cast, + Cast(ListLit(xs) |> DHExp.fresh, ct1, ct2) |> DHExp.fresh, + )) + }; + + /* Tuples can be either tuples or tuple casts */ + | (Tuple(n), Tuple(t)) when List.length(t) == n => Matches(t) + | (Tuple(_), Tuple(_)) => DoesNotMatch + | (Tuple(n), Cast(t, {term: Prod(t1s), _}, {term: Prod(t2s), _})) + when n == List.length(t1s) && n == List.length(t2s) => + let* t = unbox(Tuple(n), t); + let t = + ListUtil.map3( + (d, t1, t2) => Cast(d, t1, t2) |> DHExp.fresh, + t, + t1s, + t2s, + ); + let t = List.map(fixup_cast, t); + Matches(t); + + /* Sum constructors can be either sum constructors, sum constructors + applied to some value or sum casts */ + | (SumNoArg(name1), Constructor(name2)) when name1 == name2 => Matches() + | (SumNoArg(_), Constructor(_)) => DoesNotMatch + | (SumNoArg(_), Ap(_, {term: Constructor(_), _}, _)) => DoesNotMatch + | (SumNoArg(name), Cast(d1, {term: Sum(_), _}, {term: Sum(s2), _})) + when ConstructorMap.has_constructor_no_args(name, s2) => + let* d1 = unbox(SumNoArg(name), d1); + Matches(d1); + | (SumNoArg(_), Cast(_, {term: Sum(_), _}, {term: Sum(_), _})) => + IndetMatch + + | (SumWithArg(_), Constructor(_)) => DoesNotMatch + | (SumWithArg(name1), Ap(_, {term: Constructor(name2), _}, d3)) + when name1 == name2 => + Matches(d3) + | (SumWithArg(_), Ap(_, {term: Constructor(_), _}, _)) => DoesNotMatch + | (SumWithArg(name), Cast(d1, {term: Sum(_), _}, {term: Sum(s2), _})) + when ConstructorMap.get_entry(name, s2) != None => + let* d1 = unbox(SumWithArg(name), d1); + Matches(d1 |> fixup_cast); + | (SumWithArg(_), Cast(_, {term: Sum(_), _}, {term: Sum(_), _})) => + IndetMatch + + /* Any cast from unknown is indet */ + | (_, Cast(_, {term: Unknown(_), _}, _)) => IndetMatch + + /* Forms that are the wrong type of value - these cases indicate an error + in elaboration or in the cast calculus. */ + | ( + _, + Bool(_) | Int(_) | Float(_) | String(_) | Constructor(_) | + BuiltinFun(_) | + Fun(_, _, _, Some(_)) | + ListLit(_) | + Tuple(_) | + Cast(_) | + Ap(_, {term: Constructor(_), _}, _), + ) => + switch (request) { + | Bool => raise(EvaluatorError.Exception(InvalidBoxedBoolLit(expr))) + | Int => raise(EvaluatorError.Exception(InvalidBoxedIntLit(expr))) + | Float => raise(EvaluatorError.Exception(InvalidBoxedFloatLit(expr))) + | String => + raise(EvaluatorError.Exception(InvalidBoxedStringLit(expr))) + | Tuple(_) => raise(EvaluatorError.Exception(InvalidBoxedTuple(expr))) + | List + | Cons => raise(EvaluatorError.Exception(InvalidBoxedListLit(expr))) + | SumNoArg(_) + | SumWithArg(_) => + raise(EvaluatorError.Exception(InvalidBoxedSumConstructor(expr))) + } + + /* Forms that are not yet or will never be a value */ + | ( + _, + Invalid(_) | EmptyHole | MultiHole(_) | StaticErrorHole(_) | + DynamicErrorHole(_) | + FailedCast(_) | + Var(_) | + Let(_) | + Fun(_, _, _, None) | + FixF(_) | + TyAlias(_) | + Ap(_) | + If(_) | + Seq(_) | + Test(_) | + Filter(_) | + Closure(_) | + Parens(_) | + Cons(_) | + ListConcat(_) | + UnOp(_) | + BinOp(_) | + Match(_), + ) => + IndetMatch + }; + }; diff --git a/src/haz3lcore/lang/term/IdTagged.re b/src/haz3lcore/lang/term/IdTagged.re index 224968319c..6e0306f805 100644 --- a/src/haz3lcore/lang/term/IdTagged.re +++ b/src/haz3lcore/lang/term/IdTagged.re @@ -2,10 +2,12 @@ include Sexplib.Std; [@deriving (show({with_path: false}), sexp, yojson)] type t('a) = { + [@show.opaque] ids: list(Id.t), /* UExp invariant: copied should always be false, and the id should be unique DHExp invariant: if copied is true, then this term and its children may not have unique ids. */ + [@show.opaque] copied: bool, term: 'a, }; diff --git a/src/haz3lcore/statics/ConstructorMap.re b/src/haz3lcore/statics/ConstructorMap.re index 9ad845d6d9..848c740ed9 100644 --- a/src/haz3lcore/statics/ConstructorMap.re +++ b/src/haz3lcore/statics/ConstructorMap.re @@ -158,3 +158,11 @@ let get_entry = (ctr, m) => | BadEntry(_) => None, m, ); + +let has_constructor_no_args = ctr => + List.exists( + fun + | Variant(ctr', _, None) when Constructor.equal(ctr, ctr') => true + | Variant(_) + | BadEntry(_) => false, + ); diff --git a/src/util/ListUtil.re b/src/util/ListUtil.re index 629e83c876..fe6627c4d5 100644 --- a/src/util/ListUtil.re +++ b/src/util/ListUtil.re @@ -495,3 +495,13 @@ let rec rev_concat: (list('a), list('a)) => list('a) = | [hd, ...tl] => rev_concat(tl, [hd, ...rs]) }; }; + +let rec map3 = (f, xs, ys, zs) => + switch (xs, ys, zs) { + | ([], [], []) => [] + | ([x, ...xs], [y, ...ys], [z, ...zs]) => [ + f(x, y, z), + ...map3(f, xs, ys, zs), + ] + | _ => failwith("Lists are of unequal length") + }; From e09c74c225b33765c9c53ba6b6ed92a42da1a89f Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Tue, 9 Apr 2024 16:35:41 -0400 Subject: [PATCH 068/103] Merge fixup --- src/haz3lcore/dynamics/DHExp.re | 8 ++ src/haz3lcore/dynamics/Elaborator.re | 87 +++++++++++++++++++- src/haz3lcore/dynamics/EvalCtx.re | 8 ++ src/haz3lcore/dynamics/FilterMatcher.re | 13 +++ src/haz3lcore/dynamics/Stepper.re | 7 ++ src/haz3lcore/dynamics/Substitution.re | 5 ++ src/haz3lcore/dynamics/Transition.re | 54 +++++++++++- src/haz3lcore/dynamics/Unboxing.re | 2 + src/haz3lcore/lang/term/Typ.re | 9 ++ src/haz3lcore/statics/MakeTerm.re | 5 +- src/haz3lcore/statics/Mode.re | 2 +- src/haz3lcore/statics/Self.re | 12 +-- src/haz3lcore/statics/TermBase.re | 3 + src/haz3lschool/SyntaxTest.re | 53 ++++++------ src/haz3lweb/view/Deco.re | 2 +- src/haz3lweb/view/ExplainThis.re | 6 +- src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 78 ++++++++---------- 17 files changed, 270 insertions(+), 84 deletions(-) diff --git a/src/haz3lcore/dynamics/DHExp.re b/src/haz3lcore/dynamics/DHExp.re index 99496240b4..ba8fcdcb6a 100644 --- a/src/haz3lcore/dynamics/DHExp.re +++ b/src/haz3lcore/dynamics/DHExp.re @@ -66,6 +66,8 @@ let rec strip_casts = | TyAlias(_) | Fun(_) | Ap(_) + | Deferral(_) + | DeferredAp(_) | Test(_) | BuiltinFun(_) | UnOp(_) @@ -101,6 +103,7 @@ let rec fast_equal = | (Bool(_), _) | (Int(_), _) | (Float(_), _) + | (Deferral(_), _) | (Constructor(_), _) => d1 == d2 | (String(s1), String(s2)) => String.equal(s1, s2) | (String(_), _) => false @@ -129,6 +132,10 @@ let rec fast_equal = && s1 == s2 | (Ap(dir1, d11, d21), Ap(dir2, d12, d22)) => dir1 == dir2 && fast_equal(d11, d12) && fast_equal(d21, d22) + | (DeferredAp(d1, ds1), DeferredAp(d2, ds2)) => + fast_equal(d1, d2) + && List.length(ds1) == List.length(ds2) + && List.for_all2(fast_equal, ds1, ds2) | (Cons(d11, d21), Cons(d12, d22)) => fast_equal(d11, d12) && fast_equal(d21, d22) | (ListConcat(d11, d21), ListConcat(d12, d22)) => @@ -180,6 +187,7 @@ let rec fast_equal = | (FailedCast(_), _) | (TyAlias(_), _) | (DynamicErrorHole(_), _) + | (DeferredAp(_), _) | (If(_), _) | (Match(_), _) => false diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 4edaf46024..0eece9c8a2 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -113,6 +113,9 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => | Filter(_) | FailedCast(_) | DynamicErrorHole(_) => d + /* Forms that are currently desugared in elaboration */ + | Deferral(_) + | DeferredAp(_) => d /* Normal cases: wrap */ | Var(_) | BuiltinFun(_) @@ -145,7 +148,7 @@ let wrap = (m, exp: Exp.t): DHExp.t => { }; cast(ctx, mode, self_ty, exp); | InHole( - FreeVariable(_) | Common(NoType(_)) | + FreeVariable(_) | Common(NoType(_)) | UnusedDeferral | BadPartialAp(_) | Common(Inconsistent(Internal(_))), ) => exp | InHole(Common(Inconsistent(Expectation(_) | WithArrow(_)))) => @@ -204,7 +207,87 @@ let rec dexp_of_uexp = (m, uexp, ~in_filter) => { | If(_) | Fun(_) | FixF(_) - | Match(_) => continue(exp) |> wrap(m) + | Match(_) + | Deferral(_) => continue(exp) |> wrap(m) + + /* DeferredAp - TODO: this is currently desugared, but it should ideally persist + through to evaluation. Changing `dexp_of_uexp` will be easy (add it to default cases), + but someone will need to work out what `cast` should do. */ + | DeferredAp(fn, args) => + let (mode, self, ctx, ancestors) = + switch (Id.Map.find_opt(Exp.rep_id(uexp), m)) { + | Some(Info.InfoExp({mode, self, ctx, ancestors, _})) => ( + mode, + self, + ctx, + ancestors, + ) + | _ => failwith("DeferredAp missing info") + }; + let err_status = Info.status_exp(ctx, mode, self); + switch (err_status) { + | InHole(BadPartialAp(NoDeferredArgs)) => + dexp_of_uexp(~in_filter, m, fn) + | InHole(BadPartialAp(ArityMismatch(_))) => + DHExp.Invalid("") |> DHExp.fresh + | _ => + let mk_tuple = (ctor, xs) => + List.length(xs) == 1 ? List.hd(xs) : ctor(xs); + let ty_fn = fixed_exp_typ(m, fn) |> Option.get; + let (ty_arg, ty_ret) = Typ.matched_arrow(ctx, ty_fn); + let ty_ins = Typ.matched_args(ctx, List.length(args), ty_arg); + /* Substitute all deferrals for new variables */ + let (pats, ty_args, ap_args, ap_ctx) = + List.combine(args, ty_ins) + |> List.fold_left( + ((pats, ty_args, ap_args, ap_ctx), (e: Exp.t, ty)) => + if (Exp.is_deferral(e)) { + // Internal variable name for deferrals + let name = + "__deferred__" ++ string_of_int(List.length(pats)); + let var: Exp.t = { + ids: e.ids, + copied: false, + term: Var(name), + }; + let var_entry = + Ctx.VarEntry({name, id: Exp.rep_id(e), typ: ty}); + ( + pats @ [Var(name) |> DHPat.fresh], + ty_args @ [ty], + ap_args @ [var], + Ctx.extend(ap_ctx, var_entry), + ); + } else { + (pats, ty_args, ap_args @ [e], ap_ctx); + }, + ([], [], [], ctx), + ); + let (pat, _) = ( + mk_tuple(x => DHPat.Tuple(x) |> DHPat.fresh, pats), + mk_tuple(x => Typ.Prod(x) |> Typ.fresh, ty_args), + ); + let arg: Exp.t = { + ids: [Id.mk()], + copied: false, + term: Tuple(ap_args), + }; + let body: Exp.t = { + ids: [Id.mk()], + copied: false, + term: Ap(Forward, fn, arg), + }; + let (_info, m) = + Statics.uexp_to_info_map( + ~ctx=ap_ctx, + ~mode=Ana(ty_ret), + ~ancestors, + body, + m, + ); + let dbody = dexp_of_uexp(~in_filter, m, body); + Fun(pat, dbody, None, None) |> DHExp.fresh; + }; // Unquote operator: should be turned into constructor if inside filter body. | UnOp(Meta(Unquote), e) => diff --git a/src/haz3lcore/dynamics/EvalCtx.re b/src/haz3lcore/dynamics/EvalCtx.re index 5365cc4b2e..930581aa84 100644 --- a/src/haz3lcore/dynamics/EvalCtx.re +++ b/src/haz3lcore/dynamics/EvalCtx.re @@ -13,6 +13,8 @@ type term = | FixF(Pat.t, t, option(ClosureEnvironment.t)) | Ap1(Operators.ap_direction, t, DHExp.t) | Ap2(Operators.ap_direction, DHExp.t, t) + | DeferredAp1(t, list(DHExp.t)) + | DeferredAp2(DHExp.t, t, (list(DHExp.t), list(DHExp.t))) | If1(t, DHExp.t, DHExp.t) | If2(DHExp.t, t, DHExp.t) | If3(DHExp.t, DHExp.t, t) @@ -70,6 +72,12 @@ let rec compose = (ctx: t, d: DHExp.t): DHExp.t => { | Ap2(dir, d1, ctx) => let d2 = compose(ctx, d); Ap(dir, d1, d2) |> wrap; + | DeferredAp1(ctx, d2s) => + let d1 = compose(ctx, d); + DeferredAp(d1, d2s) |> wrap; + | DeferredAp2(d1, ctx, (ld, rd)) => + let d2 = compose(ctx, d); + DeferredAp(d1, ListUtil.rev_concat(ld, [d2, ...rd])) |> wrap; | If1(ctx, d2, d3) => let d' = compose(ctx, d); If(d', d2, d3) |> wrap; diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index 5197d34498..3e76d346c4 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -47,6 +47,9 @@ let rec matches_exp = | (EmptyHole, _) => false + | (Deferral(x), Deferral(y)) => x == y + | (Deferral(_), _) => false + | (Filter(df, dd), Filter(ff, fd)) => DHExp.filter_fast_equal(df, ff) && matches_exp(env, dd, fd) | (Filter(_), _) => false @@ -94,6 +97,16 @@ let rec matches_exp = matches_exp(env, d1, f1) && matches_exp(env, d2, f2) | (Ap(_), _) => false + | (DeferredAp(d1, d2), DeferredAp(f1, f2)) => + matches_exp(env, d1, f1) + && List.fold_left2( + (acc, d, f) => acc && matches_exp(env, d, f), + true, + d2, + f2, + ) + | (DeferredAp(_), _) => false + | (If(d1, d2, d3), If(f1, f2, f3)) => matches_exp(env, d1, f1) && matches_exp(env, d2, f2) diff --git a/src/haz3lcore/dynamics/Stepper.re b/src/haz3lcore/dynamics/Stepper.re index 9be6e0a4aa..8d3120aec7 100644 --- a/src/haz3lcore/dynamics/Stepper.re +++ b/src/haz3lcore/dynamics/Stepper.re @@ -109,6 +109,12 @@ let rec matches = | Ap2(dir, d1, ctx) => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); Ap2(dir, d1, ctx) |> rewrap; + | DeferredAp1(ctx, d2) => + let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); + DeferredAp1(ctx, d2) |> rewrap; + | DeferredAp2(d1, ctx, ds) => + let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); + DeferredAp2(d1, ctx, ds) |> rewrap; | If1(ctx, d2, d3) => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); If1(ctx, d2, d3) |> rewrap; @@ -352,6 +358,7 @@ let get_justification: step_kind => string = | FixUnwrap => "unroll fixpoint" | UpdateTest => "update test" | FunAp => "apply function" + | DeferredAp => "deferred application" | BuiltinWrap => "wrap builtin" | BuiltinAp(s) => "evaluate " ++ s | UnOp(Int(Minus)) diff --git a/src/haz3lcore/dynamics/Substitution.re b/src/haz3lcore/dynamics/Substitution.re index e829c22c3c..11582890a5 100644 --- a/src/haz3lcore/dynamics/Substitution.re +++ b/src/haz3lcore/dynamics/Substitution.re @@ -118,6 +118,11 @@ let rec subst_var = (m, d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => { | Parens(d4) => let d4' = subst_var(m, d1, x, d4); Parens(d4') |> rewrap; + | Deferral(_) => d2 + | DeferredAp(d3, d4s) => + let d3 = subst_var(m, d1, x, d3); + let d4s = List.map(subst_var(m, d1, x), d4s); + DeferredAp(d3, d4s) |> rewrap; }; } diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index 9586499b98..e279d9a4e7 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -52,9 +52,9 @@ type step_kind = | FunClosure | FixUnwrap | FixClosure - | FixClosure | UpdateTest | FunAp + | DeferredAp | CastAp | BuiltinWrap | BuiltinAp(string) @@ -160,7 +160,9 @@ module Transition = (EV: EV_MODE) => { let (let.) = switch (err_info) { | Some( - FreeVariable(_) | Common(NoType(_) | Inconsistent(Internal(_))), + FreeVariable(_) | Common(NoType(_) | Inconsistent(Internal(_))) | + UnusedDeferral | + BadPartialAp(_), ) => ( (x, _) => { let. _ = x; @@ -285,6 +287,21 @@ module Transition = (EV: EV_MODE) => { kind: UpdateTest, value: true, }); + | DeferredAp(d1, ds) => + let. _ = otherwise(env, (d1, ds) => DeferredAp(d1, ds) |> rewrap) + and. _ = + req_final( + req(state, env), + d1 => DeferredAp1(d1, ds) |> wrap_ctx, + d1, + ) + and. _ = + req_all_final( + req(state, env), + (d2, ds) => DeferredAp2(d1, d2, ds) |> wrap_ctx, + ds, + ); + Constructor; | Ap(dir, d1, d2) => let. _ = otherwise(env, (d1, (d2, _)) => Ap(dir, d1, d2) |> rewrap) and. d1' = @@ -337,6 +354,35 @@ module Transition = (EV: EV_MODE) => { } else { Indet; } + /* This case isn't currently used because deferrals are elaborated away */ + | DeferredAp(d3, d4s) => + let n_args = + List.length( + List.map( + fun + | {term: Deferral(_), _} => true + | _ => false: Exp.t => bool, + d4s, + ), + ); + let-unbox args = (Tuple(n_args), d2); + let new_args = { + let rec go = (deferred, args) => + switch ((deferred: list(Exp.t))) { + | [] => [] + | [{term: Deferral(_), _}, ...deferred] => + /* I can use List.hd and List.tl here because let-unbox ensure that + there are the correct number of args */ + [List.hd(args), ...go(deferred, List.tl(args))] + | [x, ...deferred] => [x, ...go(deferred, args)] + }; + go(d4s, args); + }; + Step({ + apply: () => Ap(Forward, d3, Tuple(new_args) |> fresh) |> fresh, + kind: DeferredAp, + value: false, + }); | _ => Step({ apply: () => { @@ -346,6 +392,9 @@ module Transition = (EV: EV_MODE) => { value: true, }) }; + | Deferral(_) => + let. _ = otherwise(env, d); + Indet; | Bool(_) | Int(_) | Float(_) @@ -694,6 +743,7 @@ let should_hide_step = (~settings: CoreSettings.Evaluation.t) => | Seq | UpdateTest | FunAp + | DeferredAp | BuiltinAp(_) | BinBoolOp(_) | BinIntOp(_) diff --git a/src/haz3lcore/dynamics/Unboxing.re b/src/haz3lcore/dynamics/Unboxing.re index 2aeba3bd93..d11f937f2c 100644 --- a/src/haz3lcore/dynamics/Unboxing.re +++ b/src/haz3lcore/dynamics/Unboxing.re @@ -128,6 +128,8 @@ let rec unbox: type a. (unbox_request(a), DHExp.t) => unboxed(a) = _, Bool(_) | Int(_) | Float(_) | String(_) | Constructor(_) | BuiltinFun(_) | + Deferral(_) | + DeferredAp(_) | Fun(_, _, _, Some(_)) | ListLit(_) | Tuple(_) | diff --git a/src/haz3lcore/lang/term/Typ.re b/src/haz3lcore/lang/term/Typ.re index 955e82cedf..5ec0ea9908 100644 --- a/src/haz3lcore/lang/term/Typ.re +++ b/src/haz3lcore/lang/term/Typ.re @@ -413,6 +413,15 @@ let matched_list = (ctx, ty) => | _ => Unknown(Internal) |> fresh }; +let matched_args = (ctx, default_arity, ty) => { + let ty' = weak_head_normalize(ctx, ty); + switch (term_of(ty')) { + | Prod([_, ..._] as tys) => tys + | Unknown(_) => List.init(default_arity, _ => ty') + | _ => [ty'] + }; +}; + let get_sum_constructors = (ctx: Ctx.t, ty: t): option(sum_map) => { let ty = weak_head_normalize(ctx, ty); switch (term_of(ty)) { diff --git a/src/haz3lcore/statics/MakeTerm.re b/src/haz3lcore/statics/MakeTerm.re index f5d5c21939..4d5ffc3fd6 100644 --- a/src/haz3lcore/statics/MakeTerm.re +++ b/src/haz3lcore/statics/MakeTerm.re @@ -219,11 +219,12 @@ and exp_term: unsorted => (UExp.term, list(Id.t)) = { | (["(", ")"], [Exp(arg)]) => let use_deferral = (arg: UExp.t): UExp.t => { ids: arg.ids, + copied: false, term: Deferral(InAp), }; switch (arg.term) { | _ when UExp.is_deferral(arg) => - ret(DeferredAp(Forward, l, [use_deferral(arg)])) + ret(DeferredAp(l, [use_deferral(arg)])) | Tuple(es) when List.exists(UExp.is_deferral, es) => ( DeferredAp( l, @@ -234,7 +235,7 @@ and exp_term: unsorted => (UExp.term, list(Id.t)) = { ), arg.ids, ) - | _ => ret(Ap(l, arg)) + | _ => ret(Ap(Forward, l, arg)) }; | _ => ret(hole(tm)) } diff --git a/src/haz3lcore/statics/Mode.re b/src/haz3lcore/statics/Mode.re index a6e32e4efa..eb3ee03fd6 100644 --- a/src/haz3lcore/statics/Mode.re +++ b/src/haz3lcore/statics/Mode.re @@ -126,6 +126,6 @@ let of_ap = (ctx, mode, ctr: option(Constructor.t)): t => let of_deferred_ap_args = (length: int, ty_ins: list(Typ.t)): list(t) => ( List.length(ty_ins) == length - ? ty_ins : List.init(length, _ => Typ.Unknown(Internal)) + ? ty_ins : List.init(length, _ => Typ.Unknown(Internal) |> Typ.fresh) ) |> List.map(ty => Ana(ty)); diff --git a/src/haz3lcore/statics/Self.re b/src/haz3lcore/statics/Self.re index 81add66b3e..2d094fd501 100644 --- a/src/haz3lcore/statics/Self.re +++ b/src/haz3lcore/statics/Self.re @@ -49,7 +49,7 @@ type error_partial_ap = [@deriving (show({with_path: false}), sexp, yojson)] type exp = | Free(Var.t) - | IsDeferral(Term.UExp.deferral_position) + | IsDeferral(Exp.deferral_position) | IsBadPartialAp(error_partial_ap) | Common(t); @@ -115,15 +115,17 @@ let of_deferred_ap = (args, ty_ins: list(Typ.t), ty_out: Typ.t): exp => { let actual = List.length(args); if (expected != actual) { IsBadPartialAp(ArityMismatch({expected, actual})); - } else if (List.for_all(Term.UExp.is_deferral, args)) { + } else if (List.for_all(Exp.is_deferral, args)) { IsBadPartialAp(NoDeferredArgs); } else { let ty_ins = List.combine(args, ty_ins) - |> List.filter(((arg, _ty)) => Term.UExp.is_deferral(arg)) + |> List.filter(((arg, _ty)) => Exp.is_deferral(arg)) |> List.map(snd); - let ty_in = List.length(ty_ins) == 1 ? List.hd(ty_ins) : Prod(ty_ins); - Common(Just(Arrow(ty_in, ty_out))); + let ty_in = + List.length(ty_ins) == 1 + ? List.hd(ty_ins) : Prod(ty_ins) |> Typ.fresh; + Common(Just(Arrow(ty_in, ty_out) |> Typ.fresh)); }; }; diff --git a/src/haz3lcore/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index 4782a244dc..c770e8c3ad 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -217,6 +217,7 @@ and Exp: { | Float(_) | Constructor(_) | String(_) + | Deferral(_) | Var(_) => term | MultiHole(things) => MultiHole(List.map(any_map_term, things)) | StaticErrorHole(id, e) => StaticErrorHole(id, exp_map_term(e)) @@ -232,6 +233,8 @@ and Exp: { | TyAlias(tp, t, e) => TyAlias(tpat_map_term(tp), typ_map_term(t), exp_map_term(e)) | Ap(op, e1, e2) => Ap(op, exp_map_term(e1), exp_map_term(e2)) + | DeferredAp(e, es) => + DeferredAp(exp_map_term(e), List.map(exp_map_term, es)) | If(e1, e2, e3) => If(exp_map_term(e1), exp_map_term(e2), exp_map_term(e3)) | Seq(e1, e2) => Seq(exp_map_term(e1), exp_map_term(e2)) diff --git a/src/haz3lschool/SyntaxTest.re b/src/haz3lschool/SyntaxTest.re index cd8db58ad4..a2a488274c 100644 --- a/src/haz3lschool/SyntaxTest.re +++ b/src/haz3lschool/SyntaxTest.re @@ -112,12 +112,11 @@ let rec find_fn = /* Finds whether variable name is ever mentioned in upat. */ -let rec var_mention_upat = (name: string, upat: Term.UPat.t): bool => { +let rec var_mention_upat = (name: string, upat: Pat.t): bool => { switch (upat.term) { | Var(x) => x == name | EmptyHole | Wild - | Triv | Invalid(_) | MultiHole(_) | Int(_) @@ -144,11 +143,10 @@ let rec var_mention_upat = (name: string, upat: Term.UPat.t): bool => { /* Finds whether variable name is ever mentioned in uexp. */ -let rec var_mention = (name: string, uexp: Term.UExp.t): bool => { +let rec var_mention = (name: string, uexp: Exp.t): bool => { switch (uexp.term) { | Var(x) => x == name | EmptyHole - | Triv | Invalid(_) | MultiHole(_) | Bool(_) @@ -157,7 +155,7 @@ let rec var_mention = (name: string, uexp: Term.UExp.t): bool => { | String(_) | Constructor(_) | Deferral(_) => false - | Fun(args, body) => + | Fun(args, body, _, _) => var_mention_upat(name, args) ? false : var_mention(name, body) | ListLit(l) | Tuple(l) => @@ -169,9 +167,16 @@ let rec var_mention = (name: string, uexp: Term.UExp.t): bool => { | Parens(u) | UnOp(_, u) | TyAlias(_, _, u) - | Filter(_, _, u) => var_mention(name, u) - | Ap(u1, u2) - | Pipeline(u1, u2) + | Filter(_, u) => var_mention(name, u) + | StaticErrorHole(_, u) => var_mention(name, u) + | DynamicErrorHole(u, _) => var_mention(name, u) + | FailedCast(u, _, _) => var_mention(name, u) + | FixF(args, body, _) => + var_mention_upat(name, args) ? false : var_mention(name, body) + | Closure(_, u) => var_mention(name, u) + | BuiltinFun(_) => false + | Cast(d, _, _) => var_mention(name, d) + | Ap(_, u1, u2) | Seq(u1, u2) | Cons(u1, u2) | ListConcat(u1, u2) @@ -197,11 +202,10 @@ let rec var_mention = (name: string, uexp: Term.UExp.t): bool => { Finds whether variable name is applied on another expresssion. i.e. Ap(Var(name), u) occurs anywhere in the uexp. */ -let rec var_applied = (name: string, uexp: Term.UExp.t): bool => { +let rec var_applied = (name: string, uexp: Exp.t): bool => { switch (uexp.term) { | Var(_) | EmptyHole - | Triv | Invalid(_) | MultiHole(_) | Bool(_) @@ -210,7 +214,8 @@ let rec var_applied = (name: string, uexp: Term.UExp.t): bool => { | String(_) | Constructor(_) | Deferral(_) => false - | Fun(args, body) => + | Fun(args, body, _, _) + | FixF(args, body, _) => var_mention_upat(name, args) ? false : var_applied(name, body) | ListLit(l) | Tuple(l) => @@ -222,8 +227,15 @@ let rec var_applied = (name: string, uexp: Term.UExp.t): bool => { | Parens(u) | UnOp(_, u) | TyAlias(_, _, u) - | Filter(_, _, u) => var_applied(name, u) - | Ap(u1, u2) => + | Filter(_, u) => var_applied(name, u) + | StaticErrorHole(_) => false + | DynamicErrorHole(_) => false + | FailedCast(_) => false + // This case shouldn't come up! + | Closure(_) => false + | BuiltinFun(_) => false + | Cast(d, _, _) => var_applied(name, d) + | Ap(_, u1, u2) => switch (u1.term) { | Var(x) => x == name ? true : var_applied(name, u2) | _ => var_applied(name, u1) || var_applied(name, u2) @@ -233,11 +245,6 @@ let rec var_applied = (name: string, uexp: Term.UExp.t): bool => { | Var(x) => x == name ? true : List.exists(var_applied(name), us) | _ => List.exists(var_applied(name), us) } - | Pipeline(u1, u2) => - switch (u2.term) { - | Var(x) => x == name ? true : var_applied(name, u1) - | _ => var_applied(name, u1) || var_applied(name, u2) - } | Cons(u1, u2) | Seq(u1, u2) | ListConcat(u1, u2) @@ -260,7 +267,7 @@ let rec var_applied = (name: string, uexp: Term.UExp.t): bool => { /* Check whether all functions bound to variable name are recursive. */ -let is_recursive = (name: string, uexp: Term.UExp.t): bool => { +let is_recursive = (name: string, uexp: Exp.t): bool => { let fn_bodies = [] |> find_fn(name, uexp); if (List.length(fn_bodies) == 0) { false; @@ -278,7 +285,7 @@ let is_recursive = (name: string, uexp: Term.UExp.t): bool => { a tail position in uexp. Note that if the variable is not mentioned anywhere in the expression, the function returns true. */ -let rec tail_check = (name: string, uexp: Term.UExp.t): bool => { +let rec tail_check = (name: string, uexp: Exp.t): bool => { switch (uexp.term) { | EmptyHole | Deferral(_) @@ -313,11 +320,7 @@ let rec tail_check = (name: string, uexp: Term.UExp.t): bool => { | UnOp(_, u) => !var_mention(name, u) | Ap(_, u1, u2) => var_mention(name, u2) ? false : tail_check(name, u1) | DeferredAp(fn, args) => - tail_check( - name, - {ids: [], term: Ap(fn, {ids: [], term: Tuple(args)})}, - ) - | Pipeline(u1, u2) => var_mention(name, u1) ? false : tail_check(name, u2) + tail_check(name, Ap(Forward, fn, Tuple(args) |> Exp.fresh) |> Exp.fresh) | Seq(u1, u2) => var_mention(name, u1) ? false : tail_check(name, u2) | Cons(u1, u2) | ListConcat(u1, u2) diff --git a/src/haz3lweb/view/Deco.re b/src/haz3lweb/view/Deco.re index 346a6023fe..c82dfd53d4 100644 --- a/src/haz3lweb/view/Deco.re +++ b/src/haz3lweb/view/Deco.re @@ -119,7 +119,7 @@ module Deco = }; let range: option((Measured.Point.t, Measured.Point.t)) = { // if (Piece.has_ends(p)) { - let id = Id.Map.find(Piece.id(p), M.terms) |> Term.rep_id; + let id = Id.Map.find(Piece.id(p), M.terms) |> Any.rep_id; switch (TermRanges.find_opt(id, M.term_ranges)) { | None => None | Some((p_l, p_r)) => diff --git a/src/haz3lweb/view/ExplainThis.re b/src/haz3lweb/view/ExplainThis.re index 78c079ce2d..e18e95d729 100644 --- a/src/haz3lweb/view/ExplainThis.re +++ b/src/haz3lweb/view/ExplainThis.re @@ -1582,7 +1582,7 @@ let get_doc = let x_id = List.nth(x.ids, 0); let supplied_id = Id.mk(); let deferred_id = { - let deferral = List.find(Term.UExp.is_deferral, args); + let deferral = List.find(Exp.is_deferral, args); List.nth(deferral.ids, 0); }; switch (mode) { @@ -1606,11 +1606,11 @@ let get_doc = let color_fn = List.nth(ColorSteps.child_colors, 0); let color_supplied = List.nth(ColorSteps.child_colors, 1); let color_deferred = List.nth(ColorSteps.child_colors, 2); - let add = (mapping, arg: Term.UExp.t) => { + let add = (mapping, arg: Exp.t) => { let arg_id = List.nth(arg.ids, 0); Haz3lcore.Id.Map.add( arg_id, - Term.UExp.is_deferral(arg) ? color_deferred : color_supplied, + Exp.is_deferral(arg) ? color_deferred : color_supplied, mapping, ); }; diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index dfaacf8626..daa5dd9ce8 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -61,9 +61,11 @@ let rec precedence = (~show_casts: bool, d: DHExp.t) => { | If(_) | Closure(_) | BuiltinFun(_) + | Deferral(_) | Filter(_) => DHDoc_common.precedence_const | Cast(d1, _, _) => show_casts ? DHDoc_common.precedence_const : precedence'(d1) + | DeferredAp(_) | Ap(_) => DHDoc_common.precedence_Ap | Cons(_) => DHDoc_common.precedence_Cons | ListConcat(_) => DHDoc_common.precedence_Plus @@ -152,7 +154,7 @@ let mk = | (Seq, _) | (FunClosure, _) | (FixClosure, _) - | (FixClosure, _) + | (DeferredAp, _) | (UpdateTest, _) | (CastAp, _) | (BuiltinWrap, _) @@ -175,27 +177,14 @@ let mk = } | _ => recent_subst }; - let substitution = - hidden_steps - |> List.find_opt(step => - step.knd == VarLookup - // HACK[Matt]: to prevent substitutions hiding inside casts - && EvalCtx.fuzzy_mark(step.ctx) - ); - let next_recent_subst = - switch (substitution) { - | Some({d_loc: BoundVar(v), _}) => - List.filter(u => u != v, recent_subst) - | _ => recent_subst - }; let go' = ( ~env=env, ~enforce_inline=enforce_inline, - ~recent_subst=next_recent_subst, + ~recent_subst=recent_subst, d, ) => { - go(d, env, enforce_inline, recent_subst, recursive_calls); + go(d, env, enforce_inline, recent_subst); }; let parenthesize = (b, doc) => if (b) { @@ -307,7 +296,6 @@ let mk = ) | StaticErrorHole(_, d') => go'(d') |> annot(DHAnnot.NonEmptyHole) | Invalid(t) => DHDoc_common.mk_InvalidText(t) - | Var(x) when List.mem(x, recursive_calls) => text(x) | Var(x) when settings.show_lookup_steps => text(x) | Var(x) => switch (ClosureEnvironment.lookup(env, x)) { @@ -319,9 +307,8 @@ let mk = |> annot(DHAnnot.Substituted), go'( ~env=ClosureEnvironment.empty, - ~recent_subst=List.filter(u => u != x, next_recent_subst), + ~recent_subst=List.filter(u => u != x, recent_subst), d', - BoundVar, ), ]); } else { @@ -335,6 +322,7 @@ let mk = | Float(f) => DHDoc_common.mk_FloatLit(f) | String(s) => DHDoc_common.mk_StringLit(s) | Test(d) => DHDoc_common.mk_Test(go'(d)) + | Deferral(_) => text("_") | Seq(d1, d2) => let (doc1, doc2) = (go'(d1), go'(d2)); DHDoc_common.mk_Sequence(doc1, doc2); @@ -348,6 +336,13 @@ let mk = go'(d2), ); DHDoc_common.mk_Ap(doc1, doc2); + | DeferredAp(d1, d2) => + let (doc1, doc2) = ( + go_formattable(d1) + |> parenthesize(precedence(d1) > DHDoc_common.precedence_Ap), + go'(Tuple(d2) |> DHExp.fresh), + ); + DHDoc_common.mk_Ap(doc1, doc2); | Ap(Reverse, d1, d2) => let (doc1, doc2) = ( go_formattable(d1) @@ -445,36 +440,31 @@ let mk = ~enforce_inline=false, ~env=ClosureEnvironment.without_keys(bindings, env), ~recent_subst= - List.filter(x => !List.mem(x, bindings), next_recent_subst), + List.filter(x => !List.mem(x, bindings), recent_subst), dbody, ), ]); } - | FailedCast(d1, ty2', ty3) => - switch (DHExp.term_of(d1)) { - | Cast(d, ty1, ty2) when Typ.eq(ty2, ty2') => - let d_doc = go'(d); - let cast_decoration = - hcats([ - DHDoc_common.Delim.open_FailedCast, - hseps([ - DHDoc_Typ.mk(~enforce_inline=true, ty1), - DHDoc_common.Delim.arrow_FailedCast, - DHDoc_Typ.mk(~enforce_inline=true, ty3), - ]), - DHDoc_common.Delim.close_FailedCast, - ]) - |> annot(DHAnnot.FailedCastDecoration); - hcats([d_doc, cast_decoration]); - | _ => failwith("unexpected FailedCast without inner cast") - } + | FailedCast(d1, ty1, ty3) => + let d_doc = go'(d1); + let cast_decoration = + hcats([ + DHDoc_common.Delim.open_FailedCast, + hseps([ + DHDoc_Typ.mk(~enforce_inline=true, ty1), + DHDoc_common.Delim.arrow_FailedCast, + DHDoc_Typ.mk(~enforce_inline=true, ty3), + ]), + DHDoc_common.Delim.close_FailedCast, + ]) + |> annot(DHAnnot.FailedCastDecoration); + hcats([d_doc, cast_decoration]); | DynamicErrorHole(d, err) => let d_doc = go'(d); let decoration = Doc.text(InvalidOperationError.err_msg(err)) |> annot(DHAnnot.OperationError(err)); hcats([d_doc, decoration]); - | If(c, d1, d2) => let c_doc = go_formattable(c); let d1_doc = go_formattable(d1); @@ -549,7 +539,6 @@ let mk = ~env=ClosureEnvironment.without_keys(bindings, env), ~recent_subst= List.filter(x => !List.mem(x, bindings), recent_subst), - ~recursive_calls=Option.to_list(s) @ recursive_calls, ); hcats( [ @@ -572,7 +561,8 @@ let mk = | Some(name) => annot(DHAnnot.Collapsed, text("<" ++ name ++ ">")) }; } - | FixF(dp, dbody, _) when settings.show_fn_bodies && settings.show_fixpoints => + | FixF(dp, dbody, _) + when settings.show_fn_bodies && settings.show_fixpoints => let doc_body = go_formattable( dbody, @@ -595,7 +585,9 @@ let mk = doc_body |> DHDoc_common.pad_child(~enforce_inline), ], ); - | FixF(x, _, _) => annot(DHAnnot.Collapsed, text("<" ++ x ++ ">")) + | FixF(_, {term: Fun(_, _, _, Some(x)), _}, _) => + annot(DHAnnot.Collapsed, text("<" ++ x ++ ">")) + | FixF(_, _, _) => annot(DHAnnot.Collapsed, text("")) }; }; let steppable = @@ -632,5 +624,5 @@ let mk = }; doc; }; - go(d, env, enforce_inline, [], []); + go(d, env, enforce_inline, []); }; From 8478fca910329e7e04bf3738209df7d45aa4a32a Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Wed, 10 Apr 2024 11:26:36 -0400 Subject: [PATCH 069/103] Take SynSwitches out of Elaboration --- src/haz3lcore/dynamics/DHExp.re | 10 --- src/haz3lcore/dynamics/Elaborator.re | 100 +++++++++++++++++++++--- src/haz3lcore/statics/ConstructorMap.re | 38 +++++++++ 3 files changed, 127 insertions(+), 21 deletions(-) diff --git a/src/haz3lcore/dynamics/DHExp.re b/src/haz3lcore/dynamics/DHExp.re index ba8fcdcb6a..f32a3bfa93 100644 --- a/src/haz3lcore/dynamics/DHExp.re +++ b/src/haz3lcore/dynamics/DHExp.re @@ -14,16 +14,6 @@ let mk = (ids, term): t => { {ids, copied: true, term}; }; -let fresh_cast = (d: t, t1: Typ.t, t2: Typ.t): t => - if (Typ.eq(t1, t2) || Typ.term_of(t2) == Unknown(SynSwitch)) { - d; - } else { - fresh(Cast(d, t1, t2)); - }; - -let apply_casts = (d: t, casts: list((Typ.t, Typ.t))): t => - List.fold_left((d, (ty1, ty2)) => fresh_cast(d, ty1, ty2), d, casts); - // TODO: make this function emit a map of changes let replace_all_ids = map_term( diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 0eece9c8a2..c885616252 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -4,6 +4,9 @@ A nice property would be that elaboration is idempotent... */ +open Util; +open OptUtil.Syntax; + exception MissingTypeInfo; module Elaboration = { @@ -33,8 +36,83 @@ let fixed_pat_typ = (m: Statics.Map.t, p: UPat.t): option(Typ.t) => | _ => None }; -/* Adds casts if required. +/* This function gets rid of casts that do nothing, and casts to a + type with a SynSwitch. */ +let rec get_cast = (t1: Typ.t, t2: Typ.t): option((Typ.t, Typ.t)) => { + switch (Typ.term_of(t1), Typ.term_of(t2)) { + // SynSwitch should only appear on right. + | (_, Unknown(SynSwitch)) + | (Unknown(SynSwitch), _) => None + | (Parens(t1), _) => get_cast(t1, t2) + | (_, Parens(t2)) => get_cast(t1, t2) + | (Int, Int) + | (Bool, Bool) + | (Float, Float) + | (String, String) + | (Unknown(_) | Ap(_), Unknown(_) | Ap(_)) => None + | (Var(x), Var(y)) when x == y => None + + | (List(t1), List(t2)) => + let+ (t1', t2') = get_cast(t1, t2); + (List(t1') |> Typ.fresh, List(t2') |> Typ.fresh); + | (Arrow(t1, t2), Arrow(t3, t4)) => + let cast1 = get_cast(t1, t3); + let cast2 = get_cast(t2, t4); + switch (cast1, cast2) { + | (None, None) => None + | _ => + let (t1', t2') = cast1 |> Option.value(~default=(t1, t1)); + let (t3', t4') = cast2 |> Option.value(~default=(t2, t2)); + Some((Arrow(t1', t2') |> Typ.fresh, Arrow(t3', t4') |> Typ.fresh)); + }; + | (Prod(ts1), Prod(ts2)) => + let casts = List.map2(get_cast, ts1, ts2); + if (List.for_all(Option.is_none, casts)) { + None; + } else { + let casts = + List.map2( + (cst, dft) => Option.value(~default=(dft, dft), cst), + casts, + ts1, + ); + Some(( + Prod(casts |> List.map(fst)) |> Typ.fresh, + Prod(casts |> List.map(snd)) |> Typ.fresh, + )); + }; + | (Sum(m1), Sum(m2)) => + let+ (m1', m2') = ConstructorMap.get_cast(Typ.eq, get_cast, m1, m2); + (Sum(m1') |> Typ.fresh, Sum(m2') |> Typ.fresh); + | (Rec({term: Var(x1), _}, t1), Rec({term: Var(x2), _}, t2)) + when x1 == x2 => + get_cast(t1, t2) + | (Rec({term: Var(x1), _}, t1), Rec({term: Var(x2), _}, t2)) => + get_cast(t1, Typ.subst(Typ.fresh(Var(x1)), x2, t2)) + + | (Int, _) + | (Bool, _) + | (Float, _) + | (String, _) + | (Unknown(_) | Ap(_), _) + | (List(_), _) + | (Arrow(_), _) + | (Prod(_), _) + | (Sum(_), _) + | (Var(_), _) + | (Rec(_), _) => Some((t1, t2)) + }; +}; + +let fresh_cast = (d: DHExp.t, t1: Typ.t, t2: Typ.t): DHExp.t => { + switch (get_cast(t1, t2)) { + | Some((t1', t2')) => DHExp.Cast(d, t1', t2') |> DHExp.fresh + | None => d + }; +}; + +/* Adds casts if required. When adding a new construct, [TODO: write something helpful here] */ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => switch (mode) { @@ -42,7 +120,7 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => | SynFun => switch (Typ.term_of(self_ty)) { | Unknown(_) => - DHExp.fresh_cast(d, self_ty, Arrow(self_ty, self_ty) |> Typ.fresh) + fresh_cast(d, self_ty, Arrow(self_ty, self_ty) |> Typ.fresh) | Arrow(_) => d | _ => failwith("Elaborator.wrap: SynFun non-arrow-type") } @@ -54,26 +132,26 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => | ListConcat(_) | Cons(_) => switch (Typ.term_of(ana_ty)) { - | Unknown(_) => DHExp.fresh_cast(d, List(ana_ty) |> Typ.fresh, ana_ty) + | Unknown(_) => fresh_cast(d, List(ana_ty) |> Typ.fresh, ana_ty) | _ => d } | Fun(_) => /* See regression tests in Documentation/Dynamics */ let (_, ana_out) = Typ.matched_arrow(ctx, ana_ty); let (self_in, _) = Typ.matched_arrow(ctx, self_ty); - DHExp.fresh_cast(d, Arrow(self_in, ana_out) |> Typ.fresh, ana_ty); + fresh_cast(d, Arrow(self_in, ana_out) |> Typ.fresh, ana_ty); | Tuple(ds) => switch (Typ.term_of(ana_ty)) { | Unknown(prov) => let us = List.init(List.length(ds), _ => Typ.Unknown(prov) |> Typ.fresh); - DHExp.fresh_cast(d, Prod(us) |> Typ.fresh, ana_ty); + fresh_cast(d, Prod(us) |> Typ.fresh, ana_ty); | _ => d } | Constructor(_) => switch (ana_ty |> Typ.term_of, self_ty |> Typ.term_of) { | (Unknown(_), Rec(_, {term: Sum(_), _})) - | (Unknown(_), Sum(_)) => DHExp.fresh_cast(d, self_ty, ana_ty) + | (Unknown(_), Sum(_)) => fresh_cast(d, self_ty, ana_ty) | _ => d } | Ap(_, f, _) => @@ -81,7 +159,7 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => | Constructor(_) => switch (ana_ty |> Typ.term_of, self_ty |> Typ.term_of) { | (Unknown(_), Rec(_, {term: Sum(_), _})) - | (Unknown(_), Sum(_)) => DHExp.fresh_cast(d, self_ty, ana_ty) + | (Unknown(_), Sum(_)) => fresh_cast(d, self_ty, ana_ty) | _ => d } | StaticErrorHole(_, g) => @@ -89,12 +167,12 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => | Constructor(_) => switch (ana_ty |> Typ.term_of, self_ty |> Typ.term_of) { | (Unknown(_), Rec(_, {term: Sum(_), _})) - | (Unknown(_), Sum(_)) => DHExp.fresh_cast(d, self_ty, ana_ty) + | (Unknown(_), Sum(_)) => fresh_cast(d, self_ty, ana_ty) | _ => d } - | _ => DHExp.fresh_cast(d, self_ty, ana_ty) + | _ => fresh_cast(d, self_ty, ana_ty) } - | _ => DHExp.fresh_cast(d, self_ty, ana_ty) + | _ => fresh_cast(d, self_ty, ana_ty) } /* Forms with special ana rules but no particular typing requirements */ | Match(_) @@ -127,7 +205,7 @@ let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => | UnOp(_) | BinOp(_) | TyAlias(_) - | Test(_) => DHExp.fresh_cast(d, self_ty, ana_ty) + | Test(_) => fresh_cast(d, self_ty, ana_ty) }; }; diff --git a/src/haz3lcore/statics/ConstructorMap.re b/src/haz3lcore/statics/ConstructorMap.re index 848c740ed9..867c0a91f8 100644 --- a/src/haz3lcore/statics/ConstructorMap.re +++ b/src/haz3lcore/statics/ConstructorMap.re @@ -124,6 +124,44 @@ let join = }; }; +// See Elaborator.get_cast - this function removes synswitches from casts. +let get_cast = + ( + eq: ('a, 'a) => bool, + get_cast: ('a, 'a) => option(('a, 'a)), + m1: t('a), + m2: t('a), + ) + : option((t('a), t('a))) => { + let (inter, left, right) = venn_regions(same_constructor(eq), m1, m2); + let inter' = + List.map( + fun + | (Variant(ctr, ids, Some(value1)), Variant(_, _, Some(value2))) => + switch (get_cast(value1, value2)) { + | Some((v1, v2)) => + Some((Variant(ctr, ids, Some(v1)), Variant(ctr, ids, Some(v2)))) + | None => None + } + // In this case they must be eq + | _ => None, + inter, + ); + switch (left, right) { + | ([], []) when List.for_all(Option.is_none, inter') => None + | _ => + Some(( + m1, + List.map2( + (v, (x, _)) => Option.value(~default=(x, x), v) |> snd, + inter', + inter, + ) + @ right, + )) + }; +}; + let equal = (eq: ('a, 'a) => bool, m1: t('a), m2: t('a)) => { switch (venn_regions(same_constructor(eq), m1, m2)) { | (inter, [], []) => From 4c8dd5abd8e172cf342a979c10ff92d365051051 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Wed, 10 Apr 2024 14:26:21 -0400 Subject: [PATCH 070/103] Fix type parentheses problem --- src/haz3lcore/dynamics/PatternMatch.re | 16 ++++++---------- src/haz3lcore/dynamics/Unboxing.re | 5 +++++ 2 files changed, 11 insertions(+), 10 deletions(-) diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index 9b0dd0b829..9238f0fe85 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -57,18 +57,14 @@ let rec matches = (m: Statics.Map.t, dp: Pat.t, d: DHExp.t): match_result => | Parens(p) => matches(m, p, d) | TypeAnn(p, t) => let _ = print_endline("TypeAnn"); - let mode = + let ty = switch (Id.Map.find_opt(Pat.rep_id(p), m)) { - | Some(Info.InfoPat({mode, _})) => mode + | Some(Info.InfoPat({ty, _})) => ty | _ => raise(Elaborator.MissingTypeInfo) }; - switch (mode) { - | Ana(ana_ty) when !Typ.eq(ana_ty, t) => - let _ = Typ.show(ana_ty) |> print_endline; - let _ = Typ.show(t) |> print_endline; - matches(m, p, Cast(d, ana_ty, t) |> DHExp.fresh); - | Ana(_) - | Syn - | SynFun => matches(m, p, d) + if (Typ.eq(ty, t)) { + matches(m, p, d); + } else { + matches(m, p, Cast(d, t, ty) |> DHExp.fresh |> Unboxing.fixup_cast); }; }; diff --git a/src/haz3lcore/dynamics/Unboxing.re b/src/haz3lcore/dynamics/Unboxing.re index d11f937f2c..6aee5da64c 100644 --- a/src/haz3lcore/dynamics/Unboxing.re +++ b/src/haz3lcore/dynamics/Unboxing.re @@ -49,6 +49,11 @@ let rec unbox: type a. (unbox_request(a), DHExp.t) => unboxed(a) = (request, expr) => { let _ = print_endline(DHExp.show(expr)); switch (request, DHExp.term_of(expr)) { + /* Remove parentheses from casts */ + | (_, Cast(d, {term: Parens(x), _}, y)) + | (_, Cast(d, x, {term: Parens(y), _})) => + unbox(request, Cast(d, x, y) |> DHExp.fresh) + /* Base types are always already unboxed because of the ITCastID rule*/ | (Bool, Bool(b)) => Matches(b) | (Int, Int(i)) => Matches(i) From c8c69b5962eef3f24ed8a2436583aa323ce818e7 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Wed, 17 Apr 2024 14:30:21 -0400 Subject: [PATCH 071/103] Make elaborator more explicit --- src/haz3lcore/dynamics/Casts.re | 49 +- src/haz3lcore/dynamics/DHPat.re | 4 +- src/haz3lcore/dynamics/Elaborator.re | 859 ++++++++++--------- src/haz3lcore/dynamics/FilterMatcher.re | 4 +- src/haz3lcore/dynamics/PatternMatch.re | 14 +- src/haz3lcore/lang/Form.re | 1 + src/haz3lcore/lang/term/Typ.re | 33 + src/haz3lcore/statics/ConstructorMap.re | 45 +- src/haz3lcore/statics/Info.re | 44 +- src/haz3lcore/statics/MakeTerm.re | 9 +- src/haz3lcore/statics/Statics.re | 10 +- src/haz3lcore/statics/Term.re | 20 +- src/haz3lcore/statics/TermBase.re | 7 +- src/haz3lschool/SyntaxTest.re | 4 +- src/haz3lweb/view/ExplainThis.re | 8 +- src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 10 +- src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re | 11 +- src/haz3lweb/view/dhcode/layout/HTypDoc.re | 2 +- src/util/ListUtil.re | 9 + 19 files changed, 651 insertions(+), 492 deletions(-) diff --git a/src/haz3lcore/dynamics/Casts.re b/src/haz3lcore/dynamics/Casts.re index aa8f15a585..66a67d5a10 100644 --- a/src/haz3lcore/dynamics/Casts.re +++ b/src/haz3lcore/dynamics/Casts.re @@ -99,7 +99,7 @@ let rec transition = (~recursive=false, d: DHExp.t): option(DHExp.t) => { | (Ground, Hole) => /* can't remove the cast or do anything else here, so we're done */ - None // TODO[Matt]: CONSTRUCTOR + None | (Hole, Ground) => switch (DHExp.term_of(d1)) { @@ -110,17 +110,21 @@ let rec transition = (~recursive=false, d: DHExp.t): option(DHExp.t) => { (d2); // Rule ITCastSucceed } else { Some - (FailedCast(d2, t1, t2) |> DHExp.fresh); // Rule ITCastFail + (FailedCast(d2, t3, t2) |> DHExp.fresh); // Rule ITCastFail } - | _ => None // TODO[Matt]: INDET + | _ => None } | (Hole, NotGroundOrHole(t2_grounded)) => /* ITExpand rule */ - Some( - DHExp.Cast(Cast(d1, t1, t2_grounded) |> DHExp.fresh, t2_grounded, t2) - |> DHExp.fresh, - ) + let inner_cast = Cast(d1, t1, t2_grounded) |> DHExp.fresh; + // HACK: we need to check the inner cast here + let inner_cast = + switch (transition(~recursive, inner_cast)) { + | Some(d1) => d1 + | None => inner_cast + }; + Some(DHExp.Cast(inner_cast, t2_grounded, t2) |> DHExp.fresh); | (NotGroundOrHole(t1_grounded), Hole) => /* ITGround rule */ @@ -132,7 +136,7 @@ let rec transition = (~recursive=false, d: DHExp.t): option(DHExp.t) => { | (Ground, NotGroundOrHole(_)) | (NotGroundOrHole(_), Ground) => /* can't do anything when casting between diseq, non-hole types */ - None // TODO[Matt]: CONSTRUCTOR + None | (NotGroundOrHole(_), NotGroundOrHole(_)) => /* they might be eq in this case, so remove cast if so */ @@ -140,7 +144,7 @@ let rec transition = (~recursive=false, d: DHExp.t): option(DHExp.t) => { Some (d1); // Rule ITCastId } else { - None; // TODO[Matt]: CONSTRUCTOR + None; } }; | _ => None @@ -153,3 +157,30 @@ let rec transition_multiple = (d: DHExp.t): DHExp.t => { | None => d }; }; + +// Hacky way to do transition_multiple on patterns by transferring +// the cast to the expression and then back to the pattern. +let pattern_fixup = (p: DHPat.t): DHPat.t => { + let rec unwrap_casts = (p: DHPat.t): (DHPat.t, DHExp.t) => { + switch (DHPat.term_of(p)) { + | Cast(p1, t1, t2) => + let (p1, d1) = unwrap_casts(p1); + ( + p1, + {term: DHExp.Cast(d1, t1, t2), copied: p.copied, ids: p.ids} + |> transition_multiple, + ); + | _ => (p, EmptyHole |> DHExp.fresh) + }; + }; + let rec rewrap_casts = ((p: DHPat.t, d: DHExp.t)): DHPat.t => { + switch (DHExp.term_of(d)) { + | EmptyHole => p + | Cast(d1, t1, t2) => + let p1 = rewrap_casts((p, d1)); + {term: DHPat.Cast(p1, t1, t2), copied: d.copied, ids: d.ids}; + | _ => failwith("unexpected term in rewrap_casts") + }; + }; + p |> unwrap_casts |> rewrap_casts; +}; diff --git a/src/haz3lcore/dynamics/DHPat.re b/src/haz3lcore/dynamics/DHPat.re index 45829b6a1a..d41aacb637 100644 --- a/src/haz3lcore/dynamics/DHPat.re +++ b/src/haz3lcore/dynamics/DHPat.re @@ -21,7 +21,7 @@ let rec binds_var = (m: Statics.Map.t, x: Var.t, dp: t): bool => | Bool(_) | String(_) | Constructor(_) => false - | TypeAnn(y, _) + | Cast(y, _, _) | Parens(y) => binds_var(m, x, y) | Var(y) => Var.eq(x, y) | Tuple(dps) => dps |> List.exists(binds_var(m, x)) @@ -47,7 +47,7 @@ let rec bound_vars = (m, dp: t): list(Var.t) => | Bool(_) | String(_) | Constructor(_) => [] - | TypeAnn(y, _) + | Cast(y, _, _) | Parens(y) => bound_vars(m, y) | Var(y) => [y] | Tuple(dps) => List.flatten(List.map(bound_vars(m), dps)) diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index c885616252..d18347e6d7 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -1,11 +1,8 @@ /* - - A nice property would be that elaboration is idempotent... */ open Util; -open OptUtil.Syntax; exception MissingTypeInfo; @@ -24,427 +21,489 @@ module ElaborationResult = { | DoesNotElaborate; }; -let fixed_exp_typ = (m: Statics.Map.t, e: UExp.t): option(Typ.t) => - switch (Id.Map.find_opt(UExp.rep_id(e), m)) { - | Some(InfoExp({ty, _})) => Some(ty) - | _ => None - }; - -let fixed_pat_typ = (m: Statics.Map.t, p: UPat.t): option(Typ.t) => - switch (Id.Map.find_opt(UPat.rep_id(p), m)) { - | Some(InfoPat({ty, _})) => Some(ty) - | _ => None - }; - -/* This function gets rid of casts that do nothing, and casts to a - type with a SynSwitch. */ -let rec get_cast = (t1: Typ.t, t2: Typ.t): option((Typ.t, Typ.t)) => { - switch (Typ.term_of(t1), Typ.term_of(t2)) { - // SynSwitch should only appear on right. - | (_, Unknown(SynSwitch)) - | (Unknown(SynSwitch), _) => None - | (Parens(t1), _) => get_cast(t1, t2) - | (_, Parens(t2)) => get_cast(t1, t2) - - | (Int, Int) - | (Bool, Bool) - | (Float, Float) - | (String, String) - | (Unknown(_) | Ap(_), Unknown(_) | Ap(_)) => None - | (Var(x), Var(y)) when x == y => None - - | (List(t1), List(t2)) => - let+ (t1', t2') = get_cast(t1, t2); - (List(t1') |> Typ.fresh, List(t2') |> Typ.fresh); - | (Arrow(t1, t2), Arrow(t3, t4)) => - let cast1 = get_cast(t1, t3); - let cast2 = get_cast(t2, t4); - switch (cast1, cast2) { - | (None, None) => None - | _ => - let (t1', t2') = cast1 |> Option.value(~default=(t1, t1)); - let (t3', t4') = cast2 |> Option.value(~default=(t2, t2)); - Some((Arrow(t1', t2') |> Typ.fresh, Arrow(t3', t4') |> Typ.fresh)); +let fresh_cast = (d: DHExp.t, t1: Typ.t, t2: Typ.t): DHExp.t => { + Typ.eq(t1, t2) + ? d + : { + let d' = + DHExp.Cast(d, t1, Typ.fresh(Unknown(Internal))) + |> DHExp.fresh + |> Casts.transition_multiple; + DHExp.Cast(d', Typ.fresh(Unknown(Internal)), t2) + |> DHExp.fresh + |> Casts.transition_multiple; }; - | (Prod(ts1), Prod(ts2)) => - let casts = List.map2(get_cast, ts1, ts2); - if (List.for_all(Option.is_none, casts)) { - None; - } else { - let casts = - List.map2( - (cst, dft) => Option.value(~default=(dft, dft), cst), - casts, - ts1, - ); - Some(( - Prod(casts |> List.map(fst)) |> Typ.fresh, - Prod(casts |> List.map(snd)) |> Typ.fresh, - )); +}; + +let fresh_pat_cast = (p: DHPat.t, t1: Typ.t, t2: Typ.t): DHPat.t => + Typ.eq(t1, t2) + ? p + : { + Cast( + DHPat.fresh(Cast(p, t1, Typ.fresh(Unknown(Internal)))) + |> Casts.pattern_fixup, + Typ.fresh(Unknown(Internal)), + t2, + ) + |> DHPat.fresh + |> Casts.pattern_fixup; }; - | (Sum(m1), Sum(m2)) => - let+ (m1', m2') = ConstructorMap.get_cast(Typ.eq, get_cast, m1, m2); - (Sum(m1') |> Typ.fresh, Sum(m2') |> Typ.fresh); - | (Rec({term: Var(x1), _}, t1), Rec({term: Var(x2), _}, t2)) - when x1 == x2 => - get_cast(t1, t2) - | (Rec({term: Var(x1), _}, t1), Rec({term: Var(x2), _}, t2)) => - get_cast(t1, Typ.subst(Typ.fresh(Var(x1)), x2, t2)) - | (Int, _) - | (Bool, _) - | (Float, _) - | (String, _) - | (Unknown(_) | Ap(_), _) - | (List(_), _) - | (Arrow(_), _) - | (Prod(_), _) - | (Sum(_), _) - | (Var(_), _) - | (Rec(_), _) => Some((t1, t2)) +let elaborated_type = (m: Statics.Map.t, uexp: UExp.t): (Typ.t, Ctx.t) => { + let (mode, self_ty, ctx) = + switch (Id.Map.find_opt(Exp.rep_id(uexp), m)) { + | Some(Info.InfoExp({mode, ty, ctx, _})) => (mode, ty, ctx) + | _ => raise(MissingTypeInfo) + }; + switch (mode) { + | SynFun + | Syn => (self_ty, ctx) + // We need to remove the synswitches from this type. + | Ana(ana_ty) => (Typ.match_synswitch(ana_ty, self_ty), ctx) }; }; -let fresh_cast = (d: DHExp.t, t1: Typ.t, t2: Typ.t): DHExp.t => { - switch (get_cast(t1, t2)) { - | Some((t1', t2')) => DHExp.Cast(d, t1', t2') |> DHExp.fresh - | None => d +let elaborated_pat_type = (m: Statics.Map.t, upat: UPat.t): (Typ.t, Ctx.t) => { + let (mode, self_ty, ctx, prev_synswitch) = + switch (Id.Map.find_opt(UPat.rep_id(upat), m)) { + | Some(Info.InfoPat({mode, ty, ctx, prev_synswitch, _})) => ( + mode, + ty, + ctx, + prev_synswitch, + ) + | _ => raise(MissingTypeInfo) + }; + switch (mode) { + | SynFun + | Syn => (self_ty, ctx) + | Ana(ana_ty) => + switch (prev_synswitch) { + | None => (ana_ty, ctx) + | Some(syn_ty) => (Typ.match_synswitch(syn_ty, ana_ty), ctx) + } }; }; -/* Adds casts if required. - When adding a new construct, [TODO: write something helpful here] */ -let cast = (ctx: Ctx.t, mode: Mode.t, self_ty: Typ.t, d: DHExp.t) => - switch (mode) { - | Syn => d - | SynFun => - switch (Typ.term_of(self_ty)) { - | Unknown(_) => - fresh_cast(d, self_ty, Arrow(self_ty, self_ty) |> Typ.fresh) - | Arrow(_) => d - | _ => failwith("Elaborator.wrap: SynFun non-arrow-type") - } - | Ana(ana_ty) => - let ana_ty = Typ.normalize(ctx, ana_ty); - /* Forms with special ana rules get cast from their appropriate Matched types */ - switch (DHExp.term_of(d)) { - | ListLit(_) - | ListConcat(_) - | Cons(_) => - switch (Typ.term_of(ana_ty)) { - | Unknown(_) => fresh_cast(d, List(ana_ty) |> Typ.fresh, ana_ty) - | _ => d - } - | Fun(_) => - /* See regression tests in Documentation/Dynamics */ - let (_, ana_out) = Typ.matched_arrow(ctx, ana_ty); - let (self_in, _) = Typ.matched_arrow(ctx, self_ty); - fresh_cast(d, Arrow(self_in, ana_out) |> Typ.fresh, ana_ty); - | Tuple(ds) => - switch (Typ.term_of(ana_ty)) { - | Unknown(prov) => - let us = - List.init(List.length(ds), _ => Typ.Unknown(prov) |> Typ.fresh); - fresh_cast(d, Prod(us) |> Typ.fresh, ana_ty); - | _ => d - } - | Constructor(_) => - switch (ana_ty |> Typ.term_of, self_ty |> Typ.term_of) { - | (Unknown(_), Rec(_, {term: Sum(_), _})) - | (Unknown(_), Sum(_)) => fresh_cast(d, self_ty, ana_ty) - | _ => d - } - | Ap(_, f, _) => - switch (DHExp.term_of(f)) { - | Constructor(_) => - switch (ana_ty |> Typ.term_of, self_ty |> Typ.term_of) { - | (Unknown(_), Rec(_, {term: Sum(_), _})) - | (Unknown(_), Sum(_)) => fresh_cast(d, self_ty, ana_ty) - | _ => d - } - | StaticErrorHole(_, g) => - switch (DHExp.term_of(g)) { - | Constructor(_) => - switch (ana_ty |> Typ.term_of, self_ty |> Typ.term_of) { - | (Unknown(_), Rec(_, {term: Sum(_), _})) - | (Unknown(_), Sum(_)) => fresh_cast(d, self_ty, ana_ty) - | _ => d - } - | _ => fresh_cast(d, self_ty, ana_ty) - } - | _ => fresh_cast(d, self_ty, ana_ty) - } - /* Forms with special ana rules but no particular typing requirements */ - | Match(_) - | If(_) - | Seq(_) - | Let(_) - | FixF(_) => d - /* Hole-like forms: Don't cast */ +let rec elaborate_pattern = + (m: Statics.Map.t, upat: UPat.t): (DHPat.t, Typ.t) => { + let (elaborated_type, ctx) = elaborated_pat_type(m, upat); + let cast_from = (ty, exp) => fresh_pat_cast(exp, ty, elaborated_type); + let (term, rewrap) = UPat.unwrap(upat); + let dpat = + switch (term) { + | Int(_) => upat |> cast_from(Int |> Typ.fresh) + | Bool(_) => upat |> cast_from(Bool |> Typ.fresh) + | Float(_) => upat |> cast_from(Float |> Typ.fresh) + | String(_) => upat |> cast_from(String |> Typ.fresh) + | ListLit(ps) => + let (ps, tys) = List.map(elaborate_pattern(m), ps) |> ListUtil.unzip; + let inner_type = + tys + |> Typ.join_all(~empty=Unknown(Internal) |> Typ.fresh, ctx) + |> Option.value(~default=Typ.fresh(Unknown(Internal))); + ps + |> List.map2((p, t) => fresh_pat_cast(p, t, inner_type), _, tys) + |> ( + ps' => + DHPat.ListLit(ps') + |> rewrap + |> cast_from(List(inner_type) |> Typ.fresh) + ); + | Cons(p1, p2) => + let (p1', ty1) = elaborate_pattern(m, p1); + let (p2', ty2) = elaborate_pattern(m, p2); + let ty2_inner = Typ.matched_list(ctx, ty2); + let ty_inner = + Typ.join(~fix=false, ctx, ty1, ty2_inner) + |> Option.value(~default=Typ.fresh(Unknown(Internal))); + let p1'' = fresh_pat_cast(p1', ty1, ty_inner); + let p2'' = fresh_pat_cast(p2', ty2, List(ty_inner) |> Typ.fresh); + DHPat.Cons(p1'', p2'') + |> rewrap + |> cast_from(List(ty_inner) |> Typ.fresh); + | Tuple(ps) => + let (ps', tys) = List.map(elaborate_pattern(m), ps) |> ListUtil.unzip; + DHPat.Tuple(ps') |> rewrap |> cast_from(Typ.Prod(tys) |> Typ.fresh); + | Ap(p1, p2) => + let (p1', ty1) = elaborate_pattern(m, p1); + let (p2', ty2) = elaborate_pattern(m, p2); + let (ty1l, ty1r) = Typ.matched_arrow(ctx, ty1); + let p1'' = fresh_pat_cast(p1', ty1, Arrow(ty1l, ty1r) |> Typ.fresh); + let p2'' = fresh_pat_cast(p2', ty2, ty1l); + DHPat.Ap(p1'', p2'') |> rewrap |> cast_from(ty1r); + | Constructor(_) | Invalid(_) | EmptyHole | MultiHole(_) - | StaticErrorHole(_) => d - /* DHExp-specific forms: Don't cast */ - | Cast(_) - | Closure(_) - | Filter(_) - | FailedCast(_) - | DynamicErrorHole(_) => d - /* Forms that are currently desugared in elaboration */ - | Deferral(_) - | DeferredAp(_) => d - /* Normal cases: wrap */ - | Var(_) - | BuiltinFun(_) - | Parens(_) - | Bool(_) - | Int(_) - | Float(_) - | String(_) - | UnOp(_) - | BinOp(_) - | TyAlias(_) - | Test(_) => fresh_cast(d, self_ty, ana_ty) + | Wild => upat |> cast_from(Typ.fresh(Unknown(Internal))) + | Var(v) => + upat + |> cast_from( + Ctx.lookup_var(ctx, v) + |> Option.map((x: Ctx.var_entry) => x.typ) + |> Option.value(~default=Typ.fresh(Unknown(Internal))), + ) + // Type annotations should already appear + | Parens(p) + | Cast(p, _, _) => + let (p', ty) = elaborate_pattern(m, p); + p' |> cast_from(ty); }; - }; - -/* Handles cast insertion and non-empty-hole wrapping - for elaborated expressions */ -let wrap = (m, exp: Exp.t): DHExp.t => { - let (mode, self, ctx) = - switch (Id.Map.find_opt(Exp.rep_id(exp), m)) { - | Some(Info.InfoExp({mode, self, ctx, _})) => (mode, self, ctx) - | _ => raise(MissingTypeInfo) - }; - switch (Info.status_exp(ctx, mode, self)) { - | NotInHole(_) => - let self_ty = - switch (Self.typ_of_exp(ctx, self)) { - | Some(self_ty) => Typ.normalize(ctx, self_ty) - | None => Unknown(Internal) |> Typ.fresh - }; - cast(ctx, mode, self_ty, exp); - | InHole( - FreeVariable(_) | Common(NoType(_)) | UnusedDeferral | BadPartialAp(_) | - Common(Inconsistent(Internal(_))), - ) => exp - | InHole(Common(Inconsistent(Expectation(_) | WithArrow(_)))) => - DHExp.fresh(StaticErrorHole(Exp.rep_id(exp), exp)) - }; + (dpat, elaborated_type); }; -/* - This function converts user-expressions (UExp.t) to dynamic expressions (DHExp.t). They - have the same datatype but there are some small differences so that UExp.t can be edited - and DHExp.t can be evaluated. - - Currently, Elaboration does the following things: +/* The primary goal of elaboration is to convert from a type system + where we have consistency, to a type system where types are either + equal or they're not. Anything that was just consistent needs to + become a cast. [The one other thing elaboration does is make + recursive let bindings explicit.] - - Insert casts - - Insert non-empty hole wrappers - - Annotate functions with names - - Insert implicit fixpoints - - Remove parentheses [not strictly necessary] - - Remove TyAlias [not strictly necessary] + At the top of this function we work out the "elaborated type" of + of the expression. We also return this elaborated type so we can + use it in the recursive call. When elaborate returns, you can trust + that the returned expression will have the returned type. There is + however, no guarantee that the returned type is even consistent with + the "elaborated type" at the top, so you should fresh_cast EVERYWHERE + just in case. - When adding a new construct you can probably just add it to the default cases. - */ -let rec dexp_of_uexp = (m, uexp, ~in_filter) => { - Exp.map_term( - ~f_exp= - (continue, exp) => { - let (term, rewrap) = Exp.unwrap(exp); - switch (term) { - // Default cases: do not need to change at elaboration - | Closure(_) - | Cast(_) - | Invalid(_) - | EmptyHole - | MultiHole(_) - | StaticErrorHole(_) - | DynamicErrorHole(_) - | FailedCast(_) - | Bool(_) - | Int(_) - | Float(_) - | String(_) - | ListLit(_) - | Tuple(_) - | Cons(_) - | ListConcat(_) - | UnOp(Int(_) | Bool(_), _) - | BinOp(_) - | BuiltinFun(_) - | Seq(_) - | Test(_) - | Filter(Residue(_), _) - | Var(_) - | Constructor(_) - | Ap(_) - | If(_) - | Fun(_) - | FixF(_) - | Match(_) - | Deferral(_) => continue(exp) |> wrap(m) - - /* DeferredAp - TODO: this is currently desugared, but it should ideally persist - through to evaluation. Changing `dexp_of_uexp` will be easy (add it to default cases), - but someone will need to work out what `cast` should do. */ - | DeferredAp(fn, args) => - let (mode, self, ctx, ancestors) = - switch (Id.Map.find_opt(Exp.rep_id(uexp), m)) { - | Some(Info.InfoExp({mode, self, ctx, ancestors, _})) => ( - mode, - self, - ctx, - ancestors, - ) - | _ => failwith("DeferredAp missing info") - }; - let err_status = Info.status_exp(ctx, mode, self); - switch (err_status) { - | InHole(BadPartialAp(NoDeferredArgs)) => - dexp_of_uexp(~in_filter, m, fn) - | InHole(BadPartialAp(ArityMismatch(_))) => - DHExp.Invalid("") |> DHExp.fresh - | _ => - let mk_tuple = (ctor, xs) => - List.length(xs) == 1 ? List.hd(xs) : ctor(xs); - let ty_fn = fixed_exp_typ(m, fn) |> Option.get; - let (ty_arg, ty_ret) = Typ.matched_arrow(ctx, ty_fn); - let ty_ins = Typ.matched_args(ctx, List.length(args), ty_arg); - /* Substitute all deferrals for new variables */ - let (pats, ty_args, ap_args, ap_ctx) = - List.combine(args, ty_ins) - |> List.fold_left( - ((pats, ty_args, ap_args, ap_ctx), (e: Exp.t, ty)) => - if (Exp.is_deferral(e)) { - // Internal variable name for deferrals - let name = - "__deferred__" ++ string_of_int(List.length(pats)); - let var: Exp.t = { - ids: e.ids, - copied: false, - term: Var(name), - }; - let var_entry = - Ctx.VarEntry({name, id: Exp.rep_id(e), typ: ty}); - ( - pats @ [Var(name) |> DHPat.fresh], - ty_args @ [ty], - ap_args @ [var], - Ctx.extend(ap_ctx, var_entry), - ); - } else { - (pats, ty_args, ap_args @ [e], ap_ctx); - }, - ([], [], [], ctx), - ); - let (pat, _) = ( - mk_tuple(x => DHPat.Tuple(x) |> DHPat.fresh, pats), - mk_tuple(x => Typ.Prod(x) |> Typ.fresh, ty_args), - ); - let arg: Exp.t = { - ids: [Id.mk()], - copied: false, - term: Tuple(ap_args), - }; - let body: Exp.t = { - ids: [Id.mk()], - copied: false, - term: Ap(Forward, fn, arg), - }; - let (_info, m) = - Statics.uexp_to_info_map( - ~ctx=ap_ctx, - ~mode=Ana(ty_ret), - ~ancestors, - body, - m, - ); - let dbody = dexp_of_uexp(~in_filter, m, body); - Fun(pat, dbody, None, None) |> DHExp.fresh; - }; - - // Unquote operator: should be turned into constructor if inside filter body. - | UnOp(Meta(Unquote), e) => - switch (e.term) { - | Var("e") when in_filter => - Constructor("$e") |> DHExp.fresh |> wrap(m) - | Var("v") when in_filter => - Constructor("$v") |> DHExp.fresh |> wrap(m) - | _ => DHExp.EmptyHole |> DHExp.fresh |> wrap(m) - } - | Filter(Filter({act, pat}), body) => - Filter( - Filter({act, pat: dexp_of_uexp(m, pat, ~in_filter=true)}), - dexp_of_uexp(m, body, ~in_filter), - ) + [Matt] A lot of these fresh_cast calls are redundant, however if you + want to remove one, I'd ask you instead comment it out and leave + a comment explaining why it's redundant. */ +let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { + let (elaborated_type, ctx) = elaborated_type(m, uexp); + let cast_from = (ty, exp) => fresh_cast(exp, ty, elaborated_type); + let (term, rewrap) = UExp.unwrap(uexp); + let dhexp = + switch (term) { + | Invalid(_) + | EmptyHole => uexp |> cast_from(Typ.fresh(Typ.Unknown(Internal))) + | MultiHole(stuff) => + Any.map_term( + ~f_exp=(_, exp) => {elaborate(m, exp) |> fst}, + ~f_pat=(_, pat) => {elaborate_pattern(m, pat) |> fst}, + _, + ) + |> List.map(_, stuff) + |> ( + stuff => + DHExp.MultiHole(stuff) |> rewrap - |> wrap(m) - - // Let bindings: insert implicit fixpoints and label functions with their names. - | Let(p, def, body) => - let add_name: (option(string), DHExp.t) => DHExp.t = ( - (name, d) => { - let (term, rewrap) = DHExp.unwrap(d); - switch (term) { - | Fun(p, e, ctx, _) => DHExp.Fun(p, e, ctx, name) |> rewrap - | _ => d - }; - } - ); - let ddef = dexp_of_uexp(m, def, ~in_filter); - let dbody = dexp_of_uexp(m, body, ~in_filter); - switch (UPat.get_recursive_bindings(p)) { - | None => - /* not recursive */ - DHExp.Let( - p, - add_name(Option.map(x => x ++ "", UPat.get_var(p)), ddef), - dbody, - ) - |> rewrap - |> wrap(m) - | Some(b) => - DHExp.Let( - p, - FixF( - p, - add_name( - Some(String.concat(",", List.map(x => x ++ "+", b))), - ddef, - ), - None, - ) - |> DHExp.fresh, - dbody, - ) - |> rewrap - |> wrap(m) + |> cast_from(Typ.fresh(Typ.Unknown(Internal))) + ) + | StaticErrorHole(id, e) => + let (e', _) = elaborate(m, e); + StaticErrorHole(id, e') + |> rewrap + |> cast_from(Typ.fresh(Unknown(Internal))); + | DynamicErrorHole(e, err) => + let (e', _) = elaborate(m, e); + DynamicErrorHole(e', err) + |> rewrap + |> cast_from(Typ.fresh(Unknown(Internal))); + | Cast(e, _, _) // We remove these casts because they should be re-inserted in the recursive call + | FailedCast(e, _, _) + | Parens(e) => + let (e', ty) = elaborate(m, e); + e' |> cast_from(ty); + | Deferral(_) => uexp + | Int(_) => uexp |> cast_from(Int |> Typ.fresh) + | Bool(_) => uexp |> cast_from(Bool |> Typ.fresh) + | Float(_) => uexp |> cast_from(Float |> Typ.fresh) + | String(_) => uexp |> cast_from(String |> Typ.fresh) + | ListLit(es) => + let (ds, tys) = List.map(elaborate(m), es) |> ListUtil.unzip; + let inner_type = + Typ.join_all(~empty=Typ.Unknown(Internal) |> Typ.fresh, ctx, tys) + |> Option.value(~default=Typ.fresh(Typ.Unknown(Internal))); + let ds' = List.map2((d, t) => fresh_cast(d, t, inner_type), ds, tys); + Exp.ListLit(ds') |> rewrap |> cast_from(List(inner_type) |> Typ.fresh); + | Constructor(c) => + uexp + |> cast_from( + Ctx.lookup_ctr(ctx, c) + |> Option.map((x: Ctx.var_entry) => x.typ) + |> Option.value(~default=Typ.fresh(Typ.Unknown(Internal))), + ) + | Fun(p, e, env, n) => + let (p', typ) = elaborate_pattern(m, p); + let (e', tye) = elaborate(m, e); + Exp.Fun(p', e', env, n) + |> rewrap + |> cast_from(Arrow(typ, tye) |> Typ.fresh); + | Tuple(es) => + let (ds, tys) = List.map(elaborate(m), es) |> ListUtil.unzip; + Exp.Tuple(ds) |> rewrap |> cast_from(Prod(tys) |> Typ.fresh); + | Var(v) => + uexp + |> cast_from( + Ctx.lookup_var(ctx, v) + |> Option.map((x: Ctx.var_entry) => x.typ) + |> Option.value(~default=Typ.fresh(Typ.Unknown(Internal))), + ) + | Let(p, def, body) => + let add_name: (option(string), DHExp.t) => DHExp.t = ( + (name, exp) => { + let (term, rewrap) = DHExp.unwrap(exp); + switch (term) { + | Fun(p, e, ctx, _) => Fun(p, e, ctx, name) |> rewrap + | _ => exp }; - - // type alias and parentheses: remove during elaboration - | TyAlias(_, _, e) - | Parens(e) => dexp_of_uexp(m, e, ~in_filter) + } + ); + switch (Pat.get_recursive_bindings(p)) { + | None => + let def = add_name(Pat.get_var(p), def); + let (p, ty1) = elaborate_pattern(m, p); + let (def, ty2) = elaborate(m, def); + let (body, ty) = elaborate(m, body); + Exp.Let(p, fresh_cast(def, ty2, ty1), body) + |> rewrap + |> cast_from(ty); + | Some(_) => + // TODO: Add names to mutually recursive functions + // TODO: Don't add fixpoint if there already is one + let (p, ty1) = elaborate_pattern(m, p); + let (def, ty2) = elaborate(m, def); + let (body, ty) = elaborate(m, body); + let fixf = + FixF(p, fresh_cast(def, ty2, ty1), None) + |> DHExp.fresh + |> fresh_cast(_, ty1, ty); + Exp.Let(p, fixf, body) |> rewrap |> cast_from(ty); + }; + | FixF(p, e, env) => + let (p', typ) = elaborate_pattern(m, p); + let (e', tye) = elaborate(m, e); + Exp.FixF(p', fresh_cast(e', tye, typ), env) + |> rewrap + |> cast_from(Arrow(typ, typ) |> Typ.fresh); + | TyAlias(_, _, e) => + let (e', tye) = elaborate(m, e); + e' |> cast_from(tye); + | Ap(dir, f, a) => + let (f', tyf) = elaborate(m, f); + let (a', tya) = elaborate(m, a); + let (tyf1, tyf2) = Typ.matched_arrow(ctx, tyf); + let a'' = fresh_cast(a', tya, tyf1); + Exp.Ap(dir, f', a'') |> rewrap |> cast_from(tyf2); + | DeferredAp(f, args) => + let (f', tyf) = elaborate(m, f); + let (args', tys) = List.map(elaborate(m), args) |> ListUtil.unzip; + let (tyf1, tyf2) = Typ.matched_arrow(ctx, tyf); + let ty_fargs = Typ.matched_prod(ctx, List.length(args), tyf1); + let f'' = + fresh_cast( + f', + tyf, + Arrow(Prod(ty_fargs) |> Typ.fresh, tyf2) |> Typ.fresh, + ); + let args'' = ListUtil.map3(fresh_cast, args', tys, ty_fargs); + let remaining_args = + List.filter( + ((arg, _)) => Exp.is_deferral(arg), + List.combine(args, ty_fargs), + ); + let remaining_arg_ty = + Prod(List.map(snd, remaining_args)) |> Typ.fresh; + DeferredAp(f'', args'') + |> rewrap + |> cast_from(Arrow(remaining_arg_ty, tyf2) |> Typ.fresh); + | If(c, t, f) => + let (c', tyc) = elaborate(m, c); + let (t', tyt) = elaborate(m, t); + let (f', tyf) = elaborate(m, f); + let ty = + Typ.join(~fix=false, ctx, tyt, tyf) + |> Option.value(~default=Typ.fresh(Typ.Unknown(Internal))); + let c'' = fresh_cast(c', tyc, Bool |> Typ.fresh); + let t'' = fresh_cast(t', tyt, ty); + let f'' = fresh_cast(f', tyf, ty); + Exp.If(c'', t'', f'') |> rewrap |> cast_from(ty); + | Seq(e1, e2) => + let (e1', _) = elaborate(m, e1); + let (e2', ty2) = elaborate(m, e2); + Seq(e1', e2') |> rewrap |> cast_from(ty2); + | Test(e) => + let (e', t) = elaborate(m, e); + Test(fresh_cast(e', t, Bool |> Typ.fresh)) + |> rewrap + |> cast_from(Prod([]) |> Typ.fresh); + | Filter(kind, e) => + let (e', t) = elaborate(m, e); + let kind' = + switch (kind) { + | Residue(_) => kind + | Filter({act, pat}) => Filter({act, pat: elaborate(m, pat) |> fst}) }; - }, - uexp, - ); + Filter(kind', e') |> rewrap |> cast_from(t); + | Closure(env, e) => + // Should we be elaborating the contents of the environment? + let (e', t) = elaborate(m, e); + Closure(env, e') |> rewrap |> cast_from(t); + | Cons(e1, e2) => + let (e1', ty1) = elaborate(m, e1); + let (e2', ty2) = elaborate(m, e2); + let ty2_inner = Typ.matched_list(ctx, ty2); + let ty_inner = + Typ.join(~fix=false, ctx, ty1, ty2_inner) + |> Option.value(~default=Typ.fresh(Unknown(Internal))); + let e1'' = fresh_cast(e1', ty1, ty_inner); + let e2'' = fresh_cast(e2', ty2, List(ty_inner) |> Typ.fresh); + Cons(e1'', e2'') |> rewrap |> cast_from(List(ty_inner) |> Typ.fresh); + | ListConcat(e1, e2) => + let (e1', ty1) = elaborate(m, e1); + let (e2', ty2) = elaborate(m, e2); + let ty_inner1 = Typ.matched_list(ctx, ty1); + let ty_inner2 = Typ.matched_list(ctx, ty2); + let ty_inner = + Typ.join(~fix=false, ctx, ty_inner1, ty_inner2) + |> Option.value(~default=Typ.fresh(Unknown(Internal))); + let e1'' = fresh_cast(e1', ty1, List(ty_inner) |> Typ.fresh); + let e2'' = fresh_cast(e2', ty2, List(ty_inner) |> Typ.fresh); + ListConcat(e1'', e2'') + |> rewrap + |> cast_from(List(ty_inner) |> Typ.fresh); + | UnOp(Meta(Unquote), e) => + switch (e.term) { + | Var("e") => Constructor("$e") |> rewrap + | Var("v") => Constructor("$v") |> rewrap + | _ => + DHExp.EmptyHole + |> rewrap + |> cast_from(Typ.fresh(Typ.Unknown(Internal))) + } + | UnOp(Int(Minus), e) => + let (e', t) = elaborate(m, e); + UnOp(Int(Minus), fresh_cast(e', t, Int |> Typ.fresh)) + |> rewrap + |> cast_from(Int |> Typ.fresh); + | UnOp(Bool(Not), e) => + let (e', t) = elaborate(m, e); + UnOp(Bool(Not), fresh_cast(e', t, Bool |> Typ.fresh)) + |> rewrap + |> cast_from(Bool |> Typ.fresh); + | BinOp(Int(Plus | Minus | Times | Power | Divide) as op, e1, e2) => + let (e1', t1) = elaborate(m, e1); + let (e2', t2) = elaborate(m, e2); + BinOp( + op, + fresh_cast(e1', t1, Int |> Typ.fresh), + fresh_cast(e2', t2, Int |> Typ.fresh), + ) + |> rewrap + |> cast_from(Int |> Typ.fresh); + | BinOp( + Int( + LessThan | LessThanOrEqual | GreaterThan | GreaterThanOrEqual | + Equals | + NotEquals, + ) as op, + e1, + e2, + ) => + let (e1', t1) = elaborate(m, e1); + let (e2', t2) = elaborate(m, e2); + BinOp( + op, + fresh_cast(e1', t1, Int |> Typ.fresh), + fresh_cast(e2', t2, Int |> Typ.fresh), + ) + |> rewrap + |> cast_from(Bool |> Typ.fresh); + | BinOp(Bool(And | Or) as op, e1, e2) => + let (e1', t1) = elaborate(m, e1); + let (e2', t2) = elaborate(m, e2); + BinOp( + op, + fresh_cast(e1', t1, Bool |> Typ.fresh), + fresh_cast(e2', t2, Bool |> Typ.fresh), + ) + |> rewrap + |> cast_from(Bool |> Typ.fresh); + | BinOp(Float(Plus | Minus | Times | Divide | Power) as op, e1, e2) => + let (e1', t1) = elaborate(m, e1); + let (e2', t2) = elaborate(m, e2); + BinOp( + op, + fresh_cast(e1', t1, Float |> Typ.fresh), + fresh_cast(e2', t2, Float |> Typ.fresh), + ) + |> rewrap + |> cast_from(Float |> Typ.fresh); + | BinOp( + Float( + LessThan | LessThanOrEqual | GreaterThan | GreaterThanOrEqual | + Equals | + NotEquals, + ) as op, + e1, + e2, + ) => + let (e1', t1) = elaborate(m, e1); + let (e2', t2) = elaborate(m, e2); + BinOp( + op, + fresh_cast(e1', t1, Float |> Typ.fresh), + fresh_cast(e2', t2, Float |> Typ.fresh), + ) + |> rewrap + |> cast_from(Bool |> Typ.fresh); + | BinOp(String(Concat) as op, e1, e2) => + let (e1', t1) = elaborate(m, e1); + let (e2', t2) = elaborate(m, e2); + BinOp( + op, + fresh_cast(e1', t1, String |> Typ.fresh), + fresh_cast(e2', t2, String |> Typ.fresh), + ) + |> rewrap + |> cast_from(String |> Typ.fresh); + | BinOp(String(Equals) as op, e1, e2) => + let (e1', t1) = elaborate(m, e1); + let (e2', t2) = elaborate(m, e2); + BinOp( + op, + fresh_cast(e1', t1, String |> Typ.fresh), + fresh_cast(e2', t2, String |> Typ.fresh), + ) + |> rewrap + |> cast_from(Bool |> Typ.fresh); + | BuiltinFun(fn) => + uexp + |> cast_from( + Ctx.lookup_var(Builtins.ctx_init, fn) + |> Option.map((x: Ctx.var_entry) => x.typ) + |> Option.value(~default=Typ.fresh(Typ.Unknown(Internal))), + ) + | Match(e, cases) => + let (e', t) = elaborate(m, e); + let (ps, es) = ListUtil.unzip(cases); + let (ps', ptys) = + List.map(elaborate_pattern(m), ps) |> ListUtil.unzip; + let joined_pty = + Typ.join_all(~empty=Typ.Unknown(Internal) |> Typ.fresh, ctx, ptys) + |> Option.value(~default=Typ.fresh(Typ.Unknown(Internal))); + let ps'' = + List.map2((p, t) => fresh_pat_cast(p, t, joined_pty), ps', ptys); + let e'' = fresh_cast(e', t, joined_pty); + let (es', etys) = List.map(elaborate(m), es) |> ListUtil.unzip; + let joined_ety = + Typ.join_all(~empty=Typ.Unknown(Internal) |> Typ.fresh, ctx, etys) + |> Option.value(~default=Typ.fresh(Typ.Unknown(Internal))); + let es'' = + List.map2((e, t) => fresh_cast(e, t, joined_ety), es', etys); + Match(e'', List.combine(ps'', es'')) + |> rewrap + |> cast_from(joined_ety); + }; + (dhexp, elaborated_type); }; //let dhexp_of_uexp = Core.Memo.general(~cache_size_bound=1000, dhexp_of_uexp); let uexp_elab = (m: Statics.Map.t, uexp: UExp.t): ElaborationResult.t => - switch (dexp_of_uexp(m, uexp, ~in_filter=false)) { + switch (elaborate(m, uexp)) { | exception MissingTypeInfo => DoesNotElaborate - | d => - //let d = uexp_elab_wrap_builtins(d); - let ty = - switch (fixed_exp_typ(m, uexp)) { - | Some(ty) => ty - | None => Typ.Unknown(Internal) |> Typ.fresh - }; - Elaborates(d, ty, Delta.empty); + | (d, ty) => Elaborates(d, ty, Delta.empty) }; diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index 3e76d346c4..c3847edca4 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -186,8 +186,8 @@ and matches_pat = (d: Pat.t, f: Pat.t): bool => { // Matt: I'm not sure what the exact semantics of matching should be here. | (Parens(x), _) => matches_pat(x, f) | (_, Parens(x)) => matches_pat(d, x) - | (TypeAnn(x, _), _) => matches_pat(x, f) - | (_, TypeAnn(x, _)) => matches_pat(d, x) + | (Cast(x, _, _), _) => matches_pat(x, f) + | (_, Cast(x, _, _)) => matches_pat(d, x) | (_, EmptyHole) => true | (MultiHole(_), MultiHole(_)) => true | (MultiHole(_), _) => false diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index 9238f0fe85..b5e2359575 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -55,16 +55,6 @@ let rec matches = (m: Statics.Map.t, dp: Pat.t, d: DHExp.t): match_result => List.map2(matches(m), ps, ds) |> List.fold_left(combine_result, Matches(Environment.empty)); | Parens(p) => matches(m, p, d) - | TypeAnn(p, t) => - let _ = print_endline("TypeAnn"); - let ty = - switch (Id.Map.find_opt(Pat.rep_id(p), m)) { - | Some(Info.InfoPat({ty, _})) => ty - | _ => raise(Elaborator.MissingTypeInfo) - }; - if (Typ.eq(ty, t)) { - matches(m, p, d); - } else { - matches(m, p, Cast(d, t, ty) |> DHExp.fresh |> Unboxing.fixup_cast); - }; + | Cast(p, t1, t2) => + matches(m, p, Cast(d, t2, t1) |> DHExp.fresh |> Unboxing.fixup_cast) }; diff --git a/src/haz3lcore/lang/Form.re b/src/haz3lcore/lang/Form.re index 1e80a2cf7b..0ae2f51d63 100644 --- a/src/haz3lcore/lang/Form.re +++ b/src/haz3lcore/lang/Form.re @@ -278,6 +278,7 @@ let forms: list((string, t)) = [ ("cons_exp", mk_infix("::", Exp, P.cons)), ("cons_pat", mk_infix("::", Pat, P.cons)), ("typeann", mk(ss, [":"], mk_bin'(P.ann, Pat, Pat, [], Typ))), + ("exptypeann", mk(ss, [":"], mk_bin'(P.ann, Exp, Exp, [], Typ))), // UNARY PREFIX OPERATORS ("not", mk(ii, ["!"], mk_pre(P.not_, Exp, []))), //TODO: precedence ("typ_sum_single", mk(ss, ["+"], mk_pre(P.or_, Typ, []))), diff --git a/src/haz3lcore/lang/term/Typ.re b/src/haz3lcore/lang/term/Typ.re index 5ec0ea9908..6bebfe4770 100644 --- a/src/haz3lcore/lang/term/Typ.re +++ b/src/haz3lcore/lang/term/Typ.re @@ -337,6 +337,39 @@ let rec join = (~resolve=false, ~fix, ctx: Ctx.t, ty1: t, ty2: t): option(t) => }; }; +/* REQUIRES NORMALIZED TYPES + Remove synswitches from t1 by maching against t2 */ +let rec match_synswitch = (t1: t, t2: t) => { + let (term1, rewrap1) = unwrap(t1); + switch (term1, term_of(t2)) { + | (Parens(t1), _) => Parens(match_synswitch(t1, t2)) |> rewrap1 + | (Unknown(SynSwitch), _) => t2 + // These cases can't have a synswitch inside + | (Unknown(_), _) + | (Int, _) + | (Float, _) + | (Bool, _) + | (String, _) + | (Var(_), _) + | (Ap(_), _) + | (Rec(_), _) => t1 + // These might + | (List(ty1), List(ty2)) => List(match_synswitch(ty1, ty2)) |> rewrap1 + | (List(_), _) => t1 + | (Arrow(ty1, ty2), Arrow(ty1', ty2')) => + Arrow(match_synswitch(ty1, ty1'), match_synswitch(ty2, ty2')) |> rewrap1 + | (Arrow(_), _) => t1 + | (Prod(tys1), Prod(tys2)) when List.length(tys1) == List.length(tys2) => + let tys = List.map2(match_synswitch, tys1, tys2); + Prod(tys) |> rewrap1; + | (Prod(_), _) => t1 + | (Sum(sm1), Sum(sm2)) => + let sm' = ConstructorMap.match_synswitch(match_synswitch, sm1, sm2); + Sum(sm') |> rewrap1; + | (Sum(_), _) => t1 + }; +}; + let join_fix = join(~fix=true); let join_all = (~empty: t, ctx: Ctx.t, ts: list(t)): option(t) => diff --git a/src/haz3lcore/statics/ConstructorMap.re b/src/haz3lcore/statics/ConstructorMap.re index 867c0a91f8..7284e35b2d 100644 --- a/src/haz3lcore/statics/ConstructorMap.re +++ b/src/haz3lcore/statics/ConstructorMap.re @@ -124,42 +124,15 @@ let join = }; }; -// See Elaborator.get_cast - this function removes synswitches from casts. -let get_cast = - ( - eq: ('a, 'a) => bool, - get_cast: ('a, 'a) => option(('a, 'a)), - m1: t('a), - m2: t('a), - ) - : option((t('a), t('a))) => { - let (inter, left, right) = venn_regions(same_constructor(eq), m1, m2); - let inter' = - List.map( - fun - | (Variant(ctr, ids, Some(value1)), Variant(_, _, Some(value2))) => - switch (get_cast(value1, value2)) { - | Some((v1, v2)) => - Some((Variant(ctr, ids, Some(v1)), Variant(ctr, ids, Some(v2)))) - | None => None - } - // In this case they must be eq - | _ => None, - inter, - ); - switch (left, right) { - | ([], []) when List.for_all(Option.is_none, inter') => None - | _ => - Some(( - m1, - List.map2( - (v, (x, _)) => Option.value(~default=(x, x), v) |> snd, - inter', - inter, - ) - @ right, - )) - }; +let match_synswitch = + (match_synswitch: ('a, 'a) => 'a, m1: t('a), m2: t('a)): t('a) => { + List.map( + fun + | (Variant(ctr, ids, Some(value1)), Variant(_, _, Some(value2))) => + Variant(ctr, ids, Some(match_synswitch(value1, value2))) + | (v, _) => v, + List.combine(m1, m2), + ); }; let equal = (eq: ('a, 'a) => bool, m1: t('a), m2: t('a)) => { diff --git a/src/haz3lcore/statics/Info.re b/src/haz3lcore/statics/Info.re index 99020d7b81..377684ab3c 100644 --- a/src/haz3lcore/statics/Info.re +++ b/src/haz3lcore/statics/Info.re @@ -201,6 +201,7 @@ type pat = { ancestors, ctx: Ctx.t, co_ctx: CoCtx.t, + prev_synswitch: option(Typ.t), // If a pattern is first synthesized, then analysed, the initial syn is stored here. mode: Mode.t, self: Self.pat, cls: Cls.t, @@ -479,7 +480,7 @@ let is_error = (ci: t): bool => { }; /* Determined the type of an expression or pattern 'after hole fixing'; - that is, all ill-typed terms are considered to be 'wrapped in + that is, some ill-typed terms are considered to be 'wrapped in non-empty holes', i.e. assigned Unknown type. */ let fixed_typ_ok: ok_pat => Typ.t = fun @@ -487,15 +488,36 @@ let fixed_typ_ok: ok_pat => Typ.t = | Ana(Consistent({join, _})) => join | Ana(InternallyInconsistent({ana, _})) => ana; +let fixed_typ_err_common: error_common => Typ.t = + fun + | NoType(_) => Unknown(Internal) |> Typ.fresh + | Inconsistent(Expectation({ana, _})) => ana + | Inconsistent(Internal(_)) => Unknown(Internal) |> Typ.fresh // Should this be some sort of meet? + | Inconsistent(WithArrow(_)) => + Arrow(Unknown(Internal) |> Typ.fresh, Unknown(Internal) |> Typ.fresh) + |> Typ.fresh; + +let fixed_typ_err: error_exp => Typ.t = + fun + | FreeVariable(_) => Unknown(Internal) |> Typ.fresh + | UnusedDeferral => Unknown(Internal) |> Typ.fresh + | BadPartialAp(_) => Unknown(Internal) |> Typ.fresh + | Common(err) => fixed_typ_err_common(err); + +let fixed_typ_err_pat: error_pat => Typ.t = + fun + | ExpectedConstructor => Unknown(Internal) |> Typ.fresh + | Common(err) => fixed_typ_err_common(err); + let fixed_typ_pat = (ctx, mode: Mode.t, self: Self.pat): Typ.t => switch (status_pat(ctx, mode, self)) { - | InHole(_) => Unknown(Internal) |> Typ.fresh + | InHole(err) => fixed_typ_err_pat(err) | NotInHole(ok) => fixed_typ_ok(ok) }; let fixed_typ_exp = (ctx, mode: Mode.t, self: Self.exp): Typ.t => switch (status_exp(ctx, mode, self)) { - | InHole(_) => Unknown(Internal) |> Typ.fresh + | InHole(err) => fixed_typ_err(err) | NotInHole(AnaDeferralConsistent(ana)) => ana | NotInHole(Common(ok)) => fixed_typ_ok(ok) }; @@ -511,11 +533,23 @@ let derived_exp = /* Add derivable attributes for pattern terms */ let derived_pat = - (~upat: UPat.t, ~ctx, ~co_ctx, ~mode, ~ancestors, ~self): pat => { + (~upat: UPat.t, ~ctx, ~co_ctx, ~prev_synswitch, ~mode, ~ancestors, ~self) + : pat => { let cls = Cls.Pat(UPat.cls_of_term(upat.term)); let status = status_pat(ctx, mode, self); let ty = fixed_typ_pat(ctx, mode, self); - {cls, self, mode, ty, status, ctx, co_ctx, ancestors, term: upat}; + { + cls, + self, + prev_synswitch, + mode, + ty, + status, + ctx, + co_ctx, + ancestors, + term: upat, + }; }; /* Add derivable attributes for types */ diff --git a/src/haz3lcore/statics/MakeTerm.re b/src/haz3lcore/statics/MakeTerm.re index 4d5ffc3fd6..ad21c0b272 100644 --- a/src/haz3lcore/statics/MakeTerm.re +++ b/src/haz3lcore/statics/MakeTerm.re @@ -285,6 +285,12 @@ and exp_term: unsorted => (UExp.term, list(Id.t)) = { | _ => ret(hole(tm)) } } + | Bin(Exp(e), tiles, Typ(ty)) as tm => + switch (tiles) { + | ([(_id, ([":", "=>"], []))], []) => + ret(Cast(e, Unknown(Internal) |> Typ.fresh, ty)) + | _ => ret(hole(tm)) + } | tm => ret(hole(tm)); } @@ -341,7 +347,8 @@ and pat_term: unsorted => (UPat.term, list(Id.t)) = { | Pre(_) as tm => ret(hole(tm)) | Bin(Pat(p), tiles, Typ(ty)) as tm => switch (tiles) { - | ([(_id, ([":"], []))], []) => ret(TypeAnn(p, ty)) + | ([(_id, ([":"], []))], []) => + ret(Cast(p, ty, Unknown(Internal) |> Typ.fresh)) | _ => ret(hole(tm)) } | Bin(Pat(l), tiles, Pat(r)) as tm => diff --git a/src/haz3lcore/statics/Statics.re b/src/haz3lcore/statics/Statics.re index 0711152353..daf9cc3c81 100644 --- a/src/haz3lcore/statics/Statics.re +++ b/src/haz3lcore/statics/Statics.re @@ -514,8 +514,16 @@ and upat_to_info_map = ) : (Info.pat, Map.t) => { let add = (~self, ~ctx, m) => { + let prev_synswitch = + switch (Id.Map.find_opt(Pat.rep_id(upat), m)) { + | Some(Info.InfoPat({mode: Syn | SynFun, ty, _})) => Some(ty) + | Some(Info.InfoPat({mode: Ana(_), prev_synswitch, _})) => prev_synswitch + | Some(_) + | None => None + }; let info = Info.derived_pat( + ~prev_synswitch, ~upat, ~ctx, ~co_ctx, @@ -587,7 +595,7 @@ and upat_to_info_map = let (ty_in, ty_out) = Typ.matched_arrow(ctx, fn.ty); let (arg, m) = go(~ctx, ~mode=Ana(ty_in), arg, m); add(~self=Just(ty_out), ~ctx=arg.ctx, m); - | TypeAnn(p, ann) => + | Cast(p, ann, _) => let (ann, m) = utyp_to_info_map(~ctx, ~ancestors, ann, m); let (p, m) = go(~ctx, ~mode=Ana(ann.ty), p, m); add(~self=Just(ann.ty), ~ctx=p.ctx, m); diff --git a/src/haz3lcore/statics/Term.re b/src/haz3lcore/statics/Term.re index c490bf068c..b640952e1b 100644 --- a/src/haz3lcore/statics/Term.re +++ b/src/haz3lcore/statics/Term.re @@ -52,7 +52,7 @@ module Pat = { | Tuple | Parens | Ap - | TypeAnn; + | Cast; include TermBase.Pat; @@ -90,7 +90,7 @@ module Pat = { | Tuple(_) => Tuple | Parens(_) => Parens | Ap(_) => Ap - | TypeAnn(_) => TypeAnn; + | Cast(_) => Cast; let show_cls: cls => string = fun @@ -109,13 +109,13 @@ module Pat = { | Tuple => "Tuple" | Parens => "Parenthesized pattern" | Ap => "Constructor application" - | TypeAnn => "Annotation"; + | Cast => "Annotation"; let rec is_var = (pat: t) => { switch (pat.term) { | Parens(pat) => is_var(pat) | Var(_) => true - | TypeAnn(_) + | Cast(_) | Invalid(_) | EmptyHole | MultiHole(_) @@ -135,7 +135,7 @@ module Pat = { let rec is_fun_var = (pat: t) => { switch (pat.term) { | Parens(pat) => is_fun_var(pat) - | TypeAnn(pat, typ) => is_var(pat) && Typ.is_arrow(typ) + | Cast(pat, t1, _) => is_var(pat) && Typ.is_arrow(t1) | Invalid(_) | EmptyHole | MultiHole(_) @@ -170,7 +170,7 @@ module Pat = { | ListLit(_) | Cons(_, _) | Var(_) - | TypeAnn(_) + | Cast(_) | Constructor(_) | Ap(_) => false } @@ -180,7 +180,7 @@ module Pat = { switch (pat.term) { | Parens(pat) => get_var(pat) | Var(x) => Some(x) - | TypeAnn(x, _) => get_var(x) + | Cast(x, _, _) => get_var(x) | Invalid(_) | EmptyHole | MultiHole(_) @@ -200,8 +200,8 @@ module Pat = { let rec get_fun_var = (pat: t) => { switch (pat.term) { | Parens(pat) => get_fun_var(pat) - | TypeAnn(pat, typ) => - if (Typ.is_arrow(typ)) { + | Cast(pat, t1, _) => + if (Typ.is_arrow(t1)) { get_var(pat) |> Option.map(var => var); } else { None; @@ -247,7 +247,7 @@ module Pat = { | ListLit(_) | Cons(_, _) | Var(_) - | TypeAnn(_) + | Cast(_) | Constructor(_) | Ap(_) => None } diff --git a/src/haz3lcore/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index c770e8c3ad..7cefc89268 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -281,7 +281,7 @@ and Pat: { | Tuple(list(t)) | Parens(t) | Ap(t, t) - | TypeAnn(t, Typ.t) + | Cast(t, Typ.t, Typ.t) // The second one is hidden from the user and t = IdTagged.t(term); let map_term: @@ -313,7 +313,7 @@ and Pat: { | Tuple(list(t)) | Parens(t) | Ap(t, t) - | TypeAnn(t, Typ.t) + | Cast(t, Typ.t, Typ.t) // The second one is hidden from the user and t = IdTagged.t(term); let map_term = @@ -351,7 +351,8 @@ and Pat: { | Cons(e1, e2) => Cons(pat_map_term(e1), pat_map_term(e2)) | Tuple(xs) => Tuple(List.map(pat_map_term, xs)) | Parens(e) => Parens(pat_map_term(e)) - | TypeAnn(e, t) => TypeAnn(pat_map_term(e), typ_map_term(t)) + | Cast(e, t1, t2) => + Cast(pat_map_term(e), typ_map_term(t1), typ_map_term(t2)) }, }; x |> f_pat(rec_call); diff --git a/src/haz3lschool/SyntaxTest.re b/src/haz3lschool/SyntaxTest.re index a2a488274c..cc281ef0c9 100644 --- a/src/haz3lschool/SyntaxTest.re +++ b/src/haz3lschool/SyntaxTest.re @@ -28,7 +28,7 @@ let rec find_in_let = | (Parens(up), Parens(ue)) => find_in_let(name, up, ue, l) | (Parens(up), _) => find_in_let(name, up, def, l) | (_, Parens(ue)) => find_in_let(name, upat, ue, l) - | (TypeAnn(up, _), _) => find_in_let(name, up, def, l) + | (Cast(up, _, _), _) => find_in_let(name, up, def, l) | (Var(x), Fun(_)) => x == name ? [def, ...l] : l | (Tuple(pl), Tuple(ul)) => if (List.length(pl) != List.length(ul)) { @@ -136,7 +136,7 @@ let rec var_mention_upat = (name: string, upat: Pat.t): bool => { | Parens(up) => var_mention_upat(name, up) | Ap(up1, up2) => var_mention_upat(name, up1) || var_mention_upat(name, up2) - | TypeAnn(up, _) => var_mention_upat(name, up) + | Cast(up, _, _) => var_mention_upat(name, up) }; }; diff --git a/src/haz3lweb/view/ExplainThis.re b/src/haz3lweb/view/ExplainThis.re index e18e95d729..6e4d77ef51 100644 --- a/src/haz3lweb/view/ExplainThis.re +++ b/src/haz3lweb/view/ExplainThis.re @@ -383,7 +383,7 @@ let example_view = let rec bypass_parens_and_annot_pat = (pat: Pat.t) => { switch (pat.term) { | Parens(p) - | TypeAnn(p, _) => bypass_parens_and_annot_pat(p) + | Cast(p, _, _) => bypass_parens_and_annot_pat(p) | _ => pat }; }; @@ -1021,7 +1021,7 @@ let get_doc = } | Invalid(_) => default // Shouldn't get hit | Parens(_) => default // Shouldn't get hit? - | TypeAnn(_) => default // Shouldn't get hit? + | Cast(_) => default // Shouldn't get hit? }; | Tuple(terms) => let basic = group_id => @@ -1527,7 +1527,7 @@ let get_doc = } | Invalid(_) => default // Shouldn't get hit | Parens(_) => default // Shouldn't get hit? - | TypeAnn(_) => default // Shouldn't get hit? + | Cast(_) => default // Shouldn't get hit? }; | FixF(pat, body, _) => message_single( @@ -2049,7 +2049,7 @@ let get_doc = ), TerminalPat.ctr(con), ) - | TypeAnn(pat, typ) => + | Cast(pat, typ, _) => let pat_id = List.nth(pat.ids, 0); let typ_id = List.nth(typ.ids, 0); get_message( diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index daa5dd9ce8..2d01ae4e28 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -399,7 +399,7 @@ let mk = | Tuple(ds) => DHDoc_common.mk_Tuple(ds |> List.map(d => go'(d))) | Match(dscrut, drs) => go_case(dscrut, drs) | TyAlias(_, _, d) => go'(d) - | Cast(d, _, ty) when settings.show_casts => + | Cast(d, t1, t2) when settings.show_casts => // TODO[Matt]: Roll multiple casts into one cast let doc = go'(d); Doc.( @@ -407,7 +407,13 @@ let mk = doc, annot( DHAnnot.CastDecoration, - DHDoc_Typ.mk(~enforce_inline=true, ty), + hcats([ + DHDoc_common.Delim.open_Cast, + DHDoc_Typ.mk(~enforce_inline=true, t1), + DHDoc_common.Delim.arrow_Cast, + DHDoc_Typ.mk(~enforce_inline=true, t2), + DHDoc_common.Delim.close_Cast, + ]), ), ) ); diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re index 57b7fc5622..e3bb88e74b 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re @@ -18,7 +18,7 @@ let precedence = (dp: Pat.t) => | Cons(_) => DHDoc_common.precedence_Cons | Ap(_) => DHDoc_common.precedence_Ap | Parens(_) => DHDoc_common.precedence_const - | TypeAnn(_) => DHDoc_common.precedence_Times + | Cast(_) => DHDoc_common.precedence_Times }; let rec mk = @@ -60,7 +60,14 @@ let rec mk = | Tuple([]) => DHDoc_common.Delim.triv | Tuple(ds) => DHDoc_common.mk_Tuple(List.map(mk', ds)) // TODO: Print type annotations - | TypeAnn(dp, _) + | Cast(dp, t1, t2) => + Doc.hcats([ + mk'(dp), + Doc.text(":"), + DHDoc_Typ.mk(~enforce_inline, t1), + Doc.text("<-"), + DHDoc_Typ.mk(~enforce_inline, t2), + ]) | Parens(dp) => mk(~enforce_inline, ~parenthesize=true, ~infomap, dp) | Ap(dp1, dp2) => let (doc1, doc2) = diff --git a/src/haz3lweb/view/dhcode/layout/HTypDoc.re b/src/haz3lweb/view/dhcode/layout/HTypDoc.re index b122ac7c0a..53459ad4e3 100644 --- a/src/haz3lweb/view/dhcode/layout/HTypDoc.re +++ b/src/haz3lweb/view/dhcode/layout/HTypDoc.re @@ -41,7 +41,7 @@ let pad_child = Doc.( hcats([ linebreak(), - indent_and_align(child(~enforce_inline=false)), + indent_and_align(child(~enforce_inline)), linebreak(), ]) ); diff --git a/src/util/ListUtil.re b/src/util/ListUtil.re index fe6627c4d5..52ffd1ac73 100644 --- a/src/util/ListUtil.re +++ b/src/util/ListUtil.re @@ -505,3 +505,12 @@ let rec map3 = (f, xs, ys, zs) => ] | _ => failwith("Lists are of unequal length") }; + +let rec unzip = (lst: list(('a, 'b))): (list('a), list('b)) => { + switch (lst) { + | [] => ([], []) + | [(a, b), ...tail] => + let (_as, bs) = unzip(tail); + ([a, ..._as], [b, ...bs]); + }; +}; From ee802a4504dd2aff28bcdf93246bd1e102ccf9d7 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Wed, 17 Apr 2024 17:16:20 -0400 Subject: [PATCH 072/103] Remove infomap from transition --- src/haz3lcore/dynamics/DHExp.re | 4 -- src/haz3lcore/dynamics/DHPat.re | 40 ++++++++---------- src/haz3lcore/dynamics/Elaborator.re | 5 --- src/haz3lcore/dynamics/EvalCtx.re | 4 -- src/haz3lcore/dynamics/Evaluator.re | 2 - src/haz3lcore/dynamics/EvaluatorStep.re | 2 - src/haz3lcore/dynamics/FilterMatcher.re | 1 - src/haz3lcore/dynamics/PatternMatch.re | 16 +++---- src/haz3lcore/dynamics/Stepper.re | 3 -- src/haz3lcore/dynamics/Substitution.re | 3 -- src/haz3lcore/dynamics/TestMap.re | 4 +- src/haz3lcore/dynamics/Transition.re | 44 ++++---------------- src/haz3lcore/dynamics/Unboxing.re | 3 +- src/haz3lcore/dynamics/ValueChecker.re | 1 - src/haz3lcore/statics/Statics.re | 1 - src/haz3lcore/statics/Term.re | 3 -- src/haz3lcore/statics/TermBase.re | 3 -- src/haz3lcore/zipper/EditorUtil.re | 1 - src/haz3lschool/SyntaxTest.re | 4 -- src/haz3lweb/view/ExplainThis.re | 1 - src/haz3lweb/view/TestView.re | 18 ++++++-- src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 24 ++++------- 22 files changed, 59 insertions(+), 128 deletions(-) diff --git a/src/haz3lcore/dynamics/DHExp.re b/src/haz3lcore/dynamics/DHExp.re index f32a3bfa93..8013bda96d 100644 --- a/src/haz3lcore/dynamics/DHExp.re +++ b/src/haz3lcore/dynamics/DHExp.re @@ -76,7 +76,6 @@ let rec strip_casts = | Closure(_) | If(_) => continue(exp) /* Remove casts*/ - | StaticErrorHole(_, d) | FailedCast(d, _, _) | Cast(d, _, _) => strip_casts(d) } @@ -187,14 +186,11 @@ let rec fast_equal = (This resolves a performance issue with many nested holes.) */ | (EmptyHole, EmptyHole) => true | (MultiHole(_), MultiHole(_)) => rep_id(d1exp) == rep_id(d2exp) - | (StaticErrorHole(sid1, d1), StaticErrorHole(sid2, d2)) => - sid1 == sid2 && d1 == d2 | (Invalid(text1), Invalid(text2)) => text1 == text2 | (Closure(sigma1, d1), Closure(sigma2, d2)) => ClosureEnvironment.id_equal(sigma1, sigma2) && fast_equal(d1, d2) | (EmptyHole, _) | (MultiHole(_), _) - | (StaticErrorHole(_), _) | (Invalid(_), _) | (Closure(_), _) => false }; diff --git a/src/haz3lcore/dynamics/DHPat.re b/src/haz3lcore/dynamics/DHPat.re index d41aacb637..f9e4adbddb 100644 --- a/src/haz3lcore/dynamics/DHPat.re +++ b/src/haz3lcore/dynamics/DHPat.re @@ -33,26 +33,22 @@ let rec binds_var = (m: Statics.Map.t, x: Var.t, dp: t): bool => } }; -let rec bound_vars = (m, dp: t): list(Var.t) => - switch (Statics.get_pat_error_at(m, rep_id(dp))) { - | Some(_) => [] - | None => - switch (dp |> term_of) { - | EmptyHole - | MultiHole(_) - | Wild - | Invalid(_) - | Int(_) - | Float(_) - | Bool(_) - | String(_) - | Constructor(_) => [] - | Cast(y, _, _) - | Parens(y) => bound_vars(m, y) - | Var(y) => [y] - | Tuple(dps) => List.flatten(List.map(bound_vars(m), dps)) - | Cons(dp1, dp2) => bound_vars(m, dp1) @ bound_vars(m, dp2) - | ListLit(dps) => List.flatten(List.map(bound_vars(m), dps)) - | Ap(_, dp1) => bound_vars(m, dp1) - } +let rec bound_vars = (dp: t): list(Var.t) => + switch (dp |> term_of) { + | EmptyHole + | MultiHole(_) + | Wild + | Invalid(_) + | Int(_) + | Float(_) + | Bool(_) + | String(_) + | Constructor(_) => [] + | Cast(y, _, _) + | Parens(y) => bound_vars(y) + | Var(y) => [y] + | Tuple(dps) => List.flatten(List.map(bound_vars, dps)) + | Cons(dp1, dp2) => bound_vars(dp1) @ bound_vars(dp2) + | ListLit(dps) => List.flatten(List.map(bound_vars, dps)) + | Ap(_, dp1) => bound_vars(dp1) }; diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index d18347e6d7..4edd74dc93 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -191,11 +191,6 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { |> rewrap |> cast_from(Typ.fresh(Typ.Unknown(Internal))) ) - | StaticErrorHole(id, e) => - let (e', _) = elaborate(m, e); - StaticErrorHole(id, e') - |> rewrap - |> cast_from(Typ.fresh(Unknown(Internal))); | DynamicErrorHole(e, err) => let (e', _) = elaborate(m, e); DynamicErrorHole(e', err) diff --git a/src/haz3lcore/dynamics/EvalCtx.re b/src/haz3lcore/dynamics/EvalCtx.re index 930581aa84..a8b6375997 100644 --- a/src/haz3lcore/dynamics/EvalCtx.re +++ b/src/haz3lcore/dynamics/EvalCtx.re @@ -29,7 +29,6 @@ type term = | Cons2(DHExp.t, t) | ListConcat1(t, DHExp.t) | ListConcat2(DHExp.t, t) - | StaticErrorHole(Id.t, t) | Cast(t, Typ.t, Typ.t) | FailedCast(t, Typ.t, Typ.t) | DynamicErrorHole(t, InvalidOperationError.t) @@ -142,9 +141,6 @@ let rec compose = (ctx: t, d: DHExp.t): DHExp.t => { | DynamicErrorHole(ctx, err) => let d = compose(ctx, d); DynamicErrorHole(d, err) |> wrap; - | StaticErrorHole(i, ctx) => - let d = compose(ctx, d); - StaticErrorHole(i, d) |> wrap; | MatchScrut(ctx, rules) => let d = compose(ctx, d); Match(d, rules) |> wrap; diff --git a/src/haz3lcore/dynamics/Evaluator.re b/src/haz3lcore/dynamics/Evaluator.re index 2c1cf96606..7652f28573 100644 --- a/src/haz3lcore/dynamics/Evaluator.re +++ b/src/haz3lcore/dynamics/Evaluator.re @@ -54,8 +54,6 @@ module EvaluatorEVMode: { let update_test = (state, id, v) => state := EvaluatorState.add_test(state^, id, v); - let get_info_map = (state: state) => EvaluatorState.get_info_map(state^); - type result_unfinished = | BoxedValue(DHExp.t) | Indet(DHExp.t) diff --git a/src/haz3lcore/dynamics/EvaluatorStep.re b/src/haz3lcore/dynamics/EvaluatorStep.re index fdf1beef51..fcb1277007 100644 --- a/src/haz3lcore/dynamics/EvaluatorStep.re +++ b/src/haz3lcore/dynamics/EvaluatorStep.re @@ -150,7 +150,6 @@ module Decompose = { let otherwise = (env, o) => (o, Result.BoxedValue, env, ()); let update_test = (state, id, v) => state := EvaluatorState.add_test(state^, id, v); - let get_info_map = (state: state) => EvaluatorState.get_info_map(state^); }; module Decomp = Transition(DecomposeEVMode); @@ -213,7 +212,6 @@ module TakeStep = { let update_test = (state, id, v) => state := EvaluatorState.add_test(state^, id, v); - let get_info_map = (state: state) => EvaluatorState.get_info_map(state^); }; module TakeStepEV = Transition(TakeStepEVMode); diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index c3847edca4..5094659553 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -172,7 +172,6 @@ let rec matches_exp = | (Match(_), _) => false // TODO: should these not default to false? | (MultiHole(_), _) => false - | (StaticErrorHole(_), _) => false | (Invalid(_), _) => false | (DynamicErrorHole(_), _) => false diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index b5e2359575..46b3ed9373 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -11,7 +11,7 @@ let combine_result = (r1: match_result, r2: match_result): match_result => Matches(Environment.union(env1, env2)) }; -let rec matches = (m: Statics.Map.t, dp: Pat.t, d: DHExp.t): match_result => +let rec matches = (dp: Pat.t, d: DHExp.t): match_result => switch (DHPat.term_of(dp)) { | Invalid(_) | EmptyHole @@ -32,29 +32,29 @@ let rec matches = (m: Statics.Map.t, dp: Pat.t, d: DHExp.t): match_result => | ListLit(xs) => let* s' = Unboxing.unbox(List, d); if (List.length(xs) == List.length(s')) { - List.map2(matches(m), xs, s') + List.map2(matches, xs, s') |> List.fold_left(combine_result, Matches(Environment.empty)); } else { DoesNotMatch; }; | Cons(x, xs) => let* (x', xs') = Unboxing.unbox(Cons, d); - let* m_x = matches(m, x, x'); - let* m_xs = matches(m, xs, xs'); + let* m_x = matches(x, x'); + let* m_xs = matches(xs, xs'); Matches(Environment.union(m_x, m_xs)); | Constructor(ctr) => let* () = Unboxing.unbox(SumNoArg(ctr), d); Matches(Environment.empty); | Ap({term: Constructor(ctr), _}, p2) => let* d2 = Unboxing.unbox(SumWithArg(ctr), d); - matches(m, p2, d2); + matches(p2, d2); | Ap(_, _) => IndetMatch // TODO: should this fail? | Var(x) => Matches(Environment.singleton((x, d))) | Tuple(ps) => let* ds = Unboxing.unbox(Tuple(List.length(ps)), d); - List.map2(matches(m), ps, ds) + List.map2(matches, ps, ds) |> List.fold_left(combine_result, Matches(Environment.empty)); - | Parens(p) => matches(m, p, d) + | Parens(p) => matches(p, d) | Cast(p, t1, t2) => - matches(m, p, Cast(d, t2, t1) |> DHExp.fresh |> Unboxing.fixup_cast) + matches(p, Cast(d, t2, t1) |> DHExp.fresh |> Unboxing.fixup_cast) }; diff --git a/src/haz3lcore/dynamics/Stepper.re b/src/haz3lcore/dynamics/Stepper.re index 8d3120aec7..0fdc6fee7c 100644 --- a/src/haz3lcore/dynamics/Stepper.re +++ b/src/haz3lcore/dynamics/Stepper.re @@ -157,9 +157,6 @@ let rec matches = | MultiHole(ctx, (dl, dr)) => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); MultiHole(ctx, (dl, dr)) |> rewrap; - | StaticErrorHole(i, ctx) => - let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); - StaticErrorHole(i, ctx) |> rewrap; | Cast(ctx, ty, ty') => let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); Cast(ctx, ty, ty') |> rewrap; diff --git a/src/haz3lcore/dynamics/Substitution.re b/src/haz3lcore/dynamics/Substitution.re index 11582890a5..b102f4d462 100644 --- a/src/haz3lcore/dynamics/Substitution.re +++ b/src/haz3lcore/dynamics/Substitution.re @@ -95,9 +95,6 @@ let rec subst_var = (m, d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => { | EmptyHole => EmptyHole |> rewrap // TODO: handle multihole | MultiHole(_d2) => d2 //MultiHole(List.map(subst_var(m, d1, x), ds)) |> rewrap - | StaticErrorHole(u, d3) => - let d3' = subst_var(m, d1, x, d3); - StaticErrorHole(u, d3') |> rewrap; | Cast(d, ty1, ty2) => let d' = subst_var(m, d1, x, d); Cast(d', ty1, ty2) |> rewrap; diff --git a/src/haz3lcore/dynamics/TestMap.re b/src/haz3lcore/dynamics/TestMap.re index 91f9ff4430..5d1a2f6454 100644 --- a/src/haz3lcore/dynamics/TestMap.re +++ b/src/haz3lcore/dynamics/TestMap.re @@ -2,10 +2,10 @@ open Sexplib.Std; /* FIXME: Make more obvious names. */ [@deriving (show({with_path: false}), sexp, yojson)] -type instance_report = (DHExp.t, Statics.Map.t, TestStatus.t); +type instance_report = (DHExp.t, TestStatus.t); let joint_status: list(instance_report) => TestStatus.t = - reports => TestStatus.join_all(List.map(((_, _, x)) => x, reports)); + reports => TestStatus.join_all(List.map(((_, x)) => x, reports)); [@deriving (show({with_path: false}), sexp, yojson)] type report = (Id.t, list(instance_report)); diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index e279d9a4e7..7c6085d356 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -135,8 +135,6 @@ module type EV_MODE = { let otherwise: (ClosureEnvironment.t, 'a) => requirements(unit, 'a); let update_test: (state, Id.t, TestMap.instance_report) => unit; - - let get_info_map: state => Statics.Map.t; }; module Transition = (EV: EV_MODE) => { @@ -154,25 +152,6 @@ module Transition = (EV: EV_MODE) => { children change, we use rewrap */ let transition = (req, state, env, d): 'a => { - // If there is an error at this location, swap out the rule for indet. - let info_map = get_info_map(state); - let err_info = Statics.get_error_at(info_map, DHExp.rep_id(d)); - let (let.) = - switch (err_info) { - | Some( - FreeVariable(_) | Common(NoType(_) | Inconsistent(Internal(_))) | - UnusedDeferral | - BadPartialAp(_), - ) => ( - (x, _) => { - let. _ = x; - Indet; - } - ) - | Some(Common(Inconsistent(Expectation(_) | WithArrow(_)))) - | None => (let.) - }; - // Split DHExp into term and id information let (term, rewrap) = DHExp.unwrap(d); let wrap_ctx = (term): EvalCtx.t => Term({term, ids: [rep_id(d)]}); @@ -203,7 +182,7 @@ module Transition = (EV: EV_MODE) => { let. _ = otherwise(env, d1 => Let(dp, d1, d2) |> rewrap) and. d1' = req_final(req(state, env), d1 => Let1(dp, d1, d2) |> wrap_ctx, d1); - let.match env' = (env, matches(info_map, dp, d1')); + let.match env' = (env, matches(dp, d1')); Step({ apply: () => Closure(env', d2) |> fresh, kind: LetBind, @@ -244,7 +223,7 @@ module Transition = (EV: EV_MODE) => { // Mutual Recursion case | None => let. _ = otherwise(env, d); - let bindings = DHPat.bound_vars(info_map, dp); + let bindings = DHPat.bound_vars(dp); let substitutions = List.map( binding => @@ -274,14 +253,14 @@ module Transition = (EV: EV_MODE) => { apply: () => switch (DHExp.term_of(d')) { | Bool(true) => - update_test(state, DHExp.rep_id(d), (d', info_map, Pass)); + update_test(state, DHExp.rep_id(d), (d', Pass)); Tuple([]) |> fresh; | Bool(false) => - update_test(state, DHExp.rep_id(d), (d', info_map, Fail)); + update_test(state, DHExp.rep_id(d), (d', Fail)); Tuple([]) |> fresh; /* Hack: assume if final and not Bool, then Indet; this won't catch errors in statics */ | _ => - update_test(state, DHExp.rep_id(d), (d', info_map, Indet)); + update_test(state, DHExp.rep_id(d), (d', Indet)); Tuple([]) |> fresh; }, kind: UpdateTest, @@ -315,7 +294,7 @@ module Transition = (EV: EV_MODE) => { switch (DHExp.term_of(d1')) { | Constructor(_) => Constructor | Fun(dp, d3, Some(env'), _) => - let.match env'' = (env', matches(info_map, dp, d2')); + let.match env'' = (env', matches(dp, d2')); Step({ apply: () => Closure(env'', d3) |> fresh, kind: FunAp, @@ -662,7 +641,7 @@ module Transition = (EV: EV_MODE) => { fun | [] => None | [(dp, d2), ...rules] => - switch (matches(info_map, dp, d1)) { + switch (matches(dp, d1)) { | Matches(env') => Some((env', d2)) | DoesNotMatch => next_rule(rules) | IndetMatch => None @@ -682,15 +661,6 @@ module Transition = (EV: EV_MODE) => { and. d' = req_final(req(state, env'), d1 => Closure(env', d1) |> wrap_ctx, d); Step({apply: () => d', kind: CompleteClosure, value: true}); - | StaticErrorHole(sid, d1) => - let. _ = otherwise(env, d1 => StaticErrorHole(sid, d1) |> rewrap) - and. _ = - req_final( - req(state, env), - d1 => StaticErrorHole(sid, d1) |> wrap_ctx, - d1, - ); - Indet; | MultiHole(_) => let. _ = otherwise(env, d); // and. _ = diff --git a/src/haz3lcore/dynamics/Unboxing.re b/src/haz3lcore/dynamics/Unboxing.re index 6aee5da64c..fbfb7af364 100644 --- a/src/haz3lcore/dynamics/Unboxing.re +++ b/src/haz3lcore/dynamics/Unboxing.re @@ -158,8 +158,7 @@ let rec unbox: type a. (unbox_request(a), DHExp.t) => unboxed(a) = /* Forms that are not yet or will never be a value */ | ( _, - Invalid(_) | EmptyHole | MultiHole(_) | StaticErrorHole(_) | - DynamicErrorHole(_) | + Invalid(_) | EmptyHole | MultiHole(_) | DynamicErrorHole(_) | FailedCast(_) | Var(_) | Let(_) | diff --git a/src/haz3lcore/dynamics/ValueChecker.re b/src/haz3lcore/dynamics/ValueChecker.re index f8f73c7536..b2db830cb8 100644 --- a/src/haz3lcore/dynamics/ValueChecker.re +++ b/src/haz3lcore/dynamics/ValueChecker.re @@ -79,7 +79,6 @@ module ValueCheckerEVMode: { }; let update_test = (_, _, _) => (); - let get_info_map = (info_map: state) => info_map; }; module CV = Transition(ValueCheckerEVMode); diff --git a/src/haz3lcore/statics/Statics.re b/src/haz3lcore/statics/Statics.re index daf9cc3c81..93632ba7a6 100644 --- a/src/haz3lcore/statics/Statics.re +++ b/src/haz3lcore/statics/Statics.re @@ -266,7 +266,6 @@ and uexp_to_info_map = ~co_ctx=CoCtx.singleton(name, UExp.rep_id(uexp), Mode.ty_of(mode)), m, ) - | StaticErrorHole(_, e) | DynamicErrorHole(e, _) | Parens(e) => let (e, m) = go(~mode, e, m); diff --git a/src/haz3lcore/statics/Term.re b/src/haz3lcore/statics/Term.re index b640952e1b..ffb0c397c9 100644 --- a/src/haz3lcore/statics/Term.re +++ b/src/haz3lcore/statics/Term.re @@ -318,7 +318,6 @@ module Exp = { | Invalid(_) => Invalid | EmptyHole => EmptyHole | MultiHole(_) => MultiHole - | StaticErrorHole(_) => StaticErrorHole | DynamicErrorHole(_) => DynamicErrorHole | FailedCast(_) => FailedCast | Deferral(_) => Deferral @@ -398,7 +397,6 @@ module Exp = { | Invalid(_) | EmptyHole | MultiHole(_) - | StaticErrorHole(_) | DynamicErrorHole(_) | FailedCast(_) | Deferral(_) @@ -438,7 +436,6 @@ module Exp = { | Invalid(_) | EmptyHole | MultiHole(_) - | StaticErrorHole(_) | DynamicErrorHole(_) | FailedCast(_) | Deferral(_) diff --git a/src/haz3lcore/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index 7cefc89268..5a21ff3104 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -79,7 +79,6 @@ and Exp: { | Invalid(string) | EmptyHole | MultiHole(list(Any.t)) - | StaticErrorHole(Id.t, t) | DynamicErrorHole(t, InvalidOperationError.t) | FailedCast(t, Typ.t, Typ.t) | Deferral(deferral_position) @@ -139,7 +138,6 @@ and Exp: { | Invalid(string) | EmptyHole // Combine the problems into one construct | MultiHole(list(Any.t)) - | StaticErrorHole(Id.t, t) | DynamicErrorHole(t, InvalidOperationError.t) | FailedCast(t, Typ.t, Typ.t) // TODO: get rid of failedcast | Deferral(deferral_position) @@ -220,7 +218,6 @@ and Exp: { | Deferral(_) | Var(_) => term | MultiHole(things) => MultiHole(List.map(any_map_term, things)) - | StaticErrorHole(id, e) => StaticErrorHole(id, exp_map_term(e)) | DynamicErrorHole(e, err) => DynamicErrorHole(exp_map_term(e), err) | FailedCast(e, t1, t2) => FailedCast(exp_map_term(e), t1, t2) | ListLit(ts) => ListLit(List.map(exp_map_term, ts)) diff --git a/src/haz3lcore/zipper/EditorUtil.re b/src/haz3lcore/zipper/EditorUtil.re index c5f8768409..309e0771d0 100644 --- a/src/haz3lcore/zipper/EditorUtil.re +++ b/src/haz3lcore/zipper/EditorUtil.re @@ -49,7 +49,6 @@ let rec append_exp = { | EmptyHole | Invalid(_) | MultiHole(_) - | StaticErrorHole(_) | DynamicErrorHole(_) | FailedCast(_) | Deferral(_) diff --git a/src/haz3lschool/SyntaxTest.re b/src/haz3lschool/SyntaxTest.re index cc281ef0c9..663fe7af82 100644 --- a/src/haz3lschool/SyntaxTest.re +++ b/src/haz3lschool/SyntaxTest.re @@ -96,7 +96,6 @@ let rec find_fn = | Deferral(_) | Invalid(_) | MultiHole(_) - | StaticErrorHole(_) | DynamicErrorHole(_) | FailedCast(_) | Bool(_) @@ -168,7 +167,6 @@ let rec var_mention = (name: string, uexp: Exp.t): bool => { | UnOp(_, u) | TyAlias(_, _, u) | Filter(_, u) => var_mention(name, u) - | StaticErrorHole(_, u) => var_mention(name, u) | DynamicErrorHole(u, _) => var_mention(name, u) | FailedCast(u, _, _) => var_mention(name, u) | FixF(args, body, _) => @@ -228,7 +226,6 @@ let rec var_applied = (name: string, uexp: Exp.t): bool => { | UnOp(_, u) | TyAlias(_, _, u) | Filter(_, u) => var_applied(name, u) - | StaticErrorHole(_) => false | DynamicErrorHole(_) => false | FailedCast(_) => false // This case shouldn't come up! @@ -291,7 +288,6 @@ let rec tail_check = (name: string, uexp: Exp.t): bool => { | Deferral(_) | Invalid(_) | MultiHole(_) - | StaticErrorHole(_) | DynamicErrorHole(_) | FailedCast(_) | Bool(_) diff --git a/src/haz3lweb/view/ExplainThis.re b/src/haz3lweb/view/ExplainThis.re index 6e4d77ef51..705437e7be 100644 --- a/src/haz3lweb/view/ExplainThis.re +++ b/src/haz3lweb/view/ExplainThis.re @@ -523,7 +523,6 @@ let get_doc = switch ((term: Exp.term)) { | Exp.Invalid(_) => simple("Not a valid expression") | DynamicErrorHole(_) - | StaticErrorHole(_) | FailedCast(_) | Closure(_) | Cast(_) diff --git a/src/haz3lweb/view/TestView.re b/src/haz3lweb/view/TestView.re index fb36e28b6e..4488751d3a 100644 --- a/src/haz3lweb/view/TestView.re +++ b/src/haz3lweb/view/TestView.re @@ -12,7 +12,8 @@ let test_instance_view = ~settings, ~inject, ~font_metrics, - (d, infomap, status): TestMap.instance_report, + ~infomap, + (d, status): TestMap.instance_report, ) => div( ~attr= @@ -43,6 +44,7 @@ let test_report_view = ~inject, ~font_metrics, ~description: option(string)=None, + ~infomap, i: int, (id, instance_reports): TestMap.report, ) => { @@ -63,7 +65,7 @@ let test_report_view = div( ~attr=Attr.class_("test-instances"), List.map( - test_instance_view(~settings, ~inject, ~font_metrics), + test_instance_view(~infomap, ~settings, ~inject, ~font_metrics), instance_reports, ), ), @@ -78,7 +80,13 @@ let test_report_view = }; let test_reports_view = - (~settings, ~inject, ~font_metrics, ~test_results: option(TestResults.t)) => + ( + ~settings, + ~inject, + ~font_metrics, + ~infomap, + ~test_results: option(TestResults.t), + ) => div( ~attr=clss(["panel-body", "test-reports"]), switch (test_results) { @@ -90,6 +98,7 @@ let test_reports_view = ~settings, ~inject, ~font_metrics, + ~infomap, ~description=List.nth_opt(test_results.descriptions, i), i, r, @@ -168,6 +177,7 @@ let inspector_view = ~inject, ~font_metrics, ~test_map: TestMap.t, + ~infomap, id: Haz3lcore.Id.t, ) : option(t) => { @@ -180,7 +190,7 @@ let inspector_view = div( ~attr=Attr.class_("test-instances"), List.map( - test_instance_view(~settings, ~inject, ~font_metrics), + test_instance_view(~settings, ~inject, ~font_metrics, ~infomap), instances, ), ), diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index 2d01ae4e28..32ff07d319 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -83,8 +83,7 @@ let rec precedence = (~show_casts: bool, d: DHExp.t) => { | BinOp(Float(op), _, _) => precedence_bin_float_op(op) | BinOp(String(op), _, _) => precedence_bin_string_op(op) | MultiHole(_) => DHDoc_common.precedence_max - | Parens(d) - | StaticErrorHole(_, d) => precedence'(d) + | Parens(d) => precedence'(d) }; }; @@ -141,13 +140,13 @@ let mk = switch (ps.knd, DHExp.term_of(ps.d_loc)) { | (FunAp, Ap(_, d2, _)) => switch (DHExp.term_of(d2)) { - | Fun(p, _, _, _) => DHPat.bound_vars(infomap, p) + | Fun(p, _, _, _) => DHPat.bound_vars(p) | _ => [] } | (FunAp, _) => [] - | (LetBind, Let(p, _, _)) => DHPat.bound_vars(infomap, p) + | (LetBind, Let(p, _, _)) => DHPat.bound_vars(p) | (LetBind, _) => [] - | (FixUnwrap, FixF(p, _, _)) => DHPat.bound_vars(infomap, p) + | (FixUnwrap, FixF(p, _, _)) => DHPat.bound_vars(p) | (FixUnwrap, _) => [] | (InvalidStep, _) | (VarLookup, _) @@ -294,7 +293,6 @@ let mk = ~selected=Some(DHExp.rep_id(d)) == selected_hole_instance, env, ) - | StaticErrorHole(_, d') => go'(d') |> annot(DHAnnot.NonEmptyHole) | Invalid(t) => DHDoc_common.mk_InvalidText(t) | Var(x) when settings.show_lookup_steps => text(x) | Var(x) => @@ -424,7 +422,7 @@ let mk = if (enforce_inline) { fail(); } else { - let bindings = DHPat.bound_vars(infomap, dp); + let bindings = DHPat.bound_vars(dp); let def_doc = go_formattable(ddef); vseps([ hcats([ @@ -499,7 +497,7 @@ let mk = ]); | Fun(dp, d, Some(env'), s) => if (settings.show_fn_bodies) { - let bindings = DHPat.bound_vars(infomap, dp); + let bindings = DHPat.bound_vars(dp); let body_doc = go_formattable( Closure( @@ -509,7 +507,7 @@ let mk = |> DHExp.fresh, ~env= ClosureEnvironment.without_keys( - DHPat.bound_vars(infomap, dp) @ Option.to_list(s), + DHPat.bound_vars(dp) @ Option.to_list(s), env, ), ~recent_subst= @@ -538,7 +536,7 @@ let mk = } | Fun(dp, dbody, None, s) => if (settings.show_fn_bodies) { - let bindings = DHPat.bound_vars(infomap, dp); + let bindings = DHPat.bound_vars(dp); let body_doc = go_formattable( dbody, @@ -572,11 +570,7 @@ let mk = let doc_body = go_formattable( dbody, - ~env= - ClosureEnvironment.without_keys( - DHPat.bound_vars(infomap, dp), - env, - ), + ~env=ClosureEnvironment.without_keys(DHPat.bound_vars(dp), env), ); hcats( [ From caa04d87fc0cd5919796e98dada9ab550e6d5585 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 18 Apr 2024 11:42:22 -0400 Subject: [PATCH 073/103] Remove infomap from more places --- src/haz3lcore/dynamics/Evaluator.re | 83 ++++---- src/haz3lcore/dynamics/EvaluatorError.re | 1 - src/haz3lcore/dynamics/EvaluatorError.rei | 21 -- src/haz3lcore/dynamics/EvaluatorStep.re | 13 +- src/haz3lcore/dynamics/FilterMatcher.re | 13 +- src/haz3lcore/dynamics/Transition.re | 221 ++++++++++++---------- src/haz3lcore/dynamics/ValueChecker.re | 22 +-- 7 files changed, 184 insertions(+), 190 deletions(-) delete mode 100644 src/haz3lcore/dynamics/EvaluatorError.rei diff --git a/src/haz3lcore/dynamics/Evaluator.re b/src/haz3lcore/dynamics/Evaluator.re index 7652f28573..b76fb7d4f4 100644 --- a/src/haz3lcore/dynamics/Evaluator.re +++ b/src/haz3lcore/dynamics/Evaluator.re @@ -22,16 +22,22 @@ module Result = { open Result; module EvaluatorEVMode: { - type result_unfinished = - | BoxedValue(DHExp.t) - | Indet(DHExp.t) - | Uneval(DHExp.t); - let unbox: result_unfinished => DHExp.t; + type status = + | BoxedValue + | Indet + | Uneval; include EV_MODE with - type state = ref(EvaluatorState.t) and type result = result_unfinished; + type state = ref(EvaluatorState.t) and type result = (status, DHExp.t); } = { + type status = + | BoxedValue + | Indet + | Uneval; + + type result = (status, DHExp.t); + type reqstate = | BoxedReady | IndetReady @@ -54,24 +60,11 @@ module EvaluatorEVMode: { let update_test = (state, id, v) => state := EvaluatorState.add_test(state^, id, v); - type result_unfinished = - | BoxedValue(DHExp.t) - | Indet(DHExp.t) - | Uneval(DHExp.t); - - type result = result_unfinished; - - let unbox = - fun - | BoxedValue(x) - | Indet(x) - | Uneval(x) => x; - let req_value = (f, _, x) => switch (f(x)) { - | BoxedValue(x) => (BoxedReady, x) - | Indet(x) => (IndetBlocked, x) - | Uneval(_) => failwith("Unexpected Uneval") + | (BoxedValue, x) => (BoxedReady, x) + | (Indet, x) => (IndetBlocked, x) + | (Uneval, _) => failwith("Unexpected Uneval") }; let rec req_all_value = (f, i) => @@ -85,9 +78,9 @@ module EvaluatorEVMode: { let req_final = (f, _, x) => switch (f(x)) { - | BoxedValue(x) => (BoxedReady, x) - | Indet(x) => (IndetReady, x) - | Uneval(_) => failwith("Unexpected Uneval") + | (BoxedValue, x) => (BoxedReady, x) + | (Indet, x) => (IndetReady, x) + | (Uneval, _) => failwith("Unexpected Uneval") }; let rec req_all_final = (f, i) => @@ -101,9 +94,9 @@ module EvaluatorEVMode: { let req_final_or_value = (f, _, x) => switch (f(x)) { - | BoxedValue(x) => (BoxedReady, (x, true)) - | Indet(x) => (IndetReady, (x, false)) - | Uneval(_) => failwith("Unexpected Uneval") + | (BoxedValue, x) => (BoxedReady, (x, true)) + | (Indet, x) => (IndetReady, (x, false)) + | (Uneval, _) => failwith("Unexpected Uneval") }; let otherwise = (_, c) => (BoxedReady, (), c); @@ -112,14 +105,20 @@ module EvaluatorEVMode: { let (let.) = ((r, x, c), s) => switch (r, s(x)) { - | (BoxedReady, Step({apply, value: true, _})) => BoxedValue(apply()) - | (IndetReady, Step({apply, value: true, _})) => Indet(apply()) - | (BoxedReady, Step({apply, value: false, _})) - | (IndetReady, Step({apply, value: false, _})) => Uneval(apply()) - | (BoxedReady, Constructor) => BoxedValue(c) - | (IndetReady, Constructor) => Indet(c) - | (IndetBlocked, _) => Indet(c) - | (_, Indet) => Indet(c) + | (BoxedReady, Step({expr, state_update, is_value: true, _})) => + state_update(); + (BoxedValue, expr); + | (IndetReady, Step({expr, state_update, is_value: true, _})) => + state_update(); + (Indet, expr); + | (BoxedReady, Step({expr, state_update, is_value: false, _})) + | (IndetReady, Step({expr, state_update, is_value: false, _})) => + state_update(); + (Uneval, expr); + | (BoxedReady, Constructor) => (BoxedValue, c) + | (IndetReady, Constructor) => (Indet, c) + | (IndetBlocked, _) => (Indet, c) + | (_, Indet) => (Indet, c) }; }; module Eval = Transition(EvaluatorEVMode); @@ -127,9 +126,9 @@ module Eval = Transition(EvaluatorEVMode); let rec evaluate = (state, env, d) => { let u = Eval.transition(evaluate, state, env, d); switch (u) { - | BoxedValue(x) => BoxedValue(x) - | Indet(x) => Indet(x) - | Uneval(x) => evaluate(state, env, x) + | (BoxedValue, x) => (BoxedValue, x) + | (Indet, x) => (Indet, x) + | (Uneval, x) => evaluate(state, env, x) }; }; @@ -139,9 +138,9 @@ let evaluate = (env, {d, info_map}: Elaborator.Elaboration.t) => { let result = evaluate(state, env, d); let result = switch (result) { - | BoxedValue(x) => BoxedValue(x |> DHExp.repair_ids) - | Indet(x) => Indet(x |> DHExp.repair_ids) - | Uneval(x) => Indet(x |> DHExp.repair_ids) + | (BoxedValue, x) => BoxedValue(x |> DHExp.repair_ids) + | (Indet, x) => Indet(x |> DHExp.repair_ids) + | (Uneval, x) => Indet(x |> DHExp.repair_ids) }; (state^, result); }; diff --git a/src/haz3lcore/dynamics/EvaluatorError.re b/src/haz3lcore/dynamics/EvaluatorError.re index c0f8dd5449..5f97aeba7e 100644 --- a/src/haz3lcore/dynamics/EvaluatorError.re +++ b/src/haz3lcore/dynamics/EvaluatorError.re @@ -4,7 +4,6 @@ open Sexplib.Std; type t = | OutOfFuel | StepDoesNotMatch - | FreeInvalidVar(Var.t) | BadPatternMatch | CastBVHoleGround(DHExp.t) | InvalidBoxedFun(DHExp.t) diff --git a/src/haz3lcore/dynamics/EvaluatorError.rei b/src/haz3lcore/dynamics/EvaluatorError.rei deleted file mode 100644 index cc576c5d23..0000000000 --- a/src/haz3lcore/dynamics/EvaluatorError.rei +++ /dev/null @@ -1,21 +0,0 @@ -[@deriving (show({with_path: false}), sexp, yojson)] -type t = - | OutOfFuel - | StepDoesNotMatch - | FreeInvalidVar(Var.t) - | BadPatternMatch - | CastBVHoleGround(DHExp.t) - | InvalidBoxedFun(DHExp.t) - | InvalidBoxedBoolLit(DHExp.t) - | InvalidBoxedIntLit(DHExp.t) - | InvalidBoxedFloatLit(DHExp.t) - | InvalidBoxedListLit(DHExp.t) - | InvalidBoxedStringLit(DHExp.t) - | InvalidBoxedSumConstructor(DHExp.t) - | InvalidBoxedTuple(DHExp.t) - | InvalidBuiltin(string) - | BadBuiltinAp(string, list(DHExp.t)) - | InvalidProjection(int); - -[@deriving (show({with_path: false}), sexp, yojson)] -exception Exception(t); diff --git a/src/haz3lcore/dynamics/EvaluatorStep.re b/src/haz3lcore/dynamics/EvaluatorStep.re index fcb1277007..f129f05a04 100644 --- a/src/haz3lcore/dynamics/EvaluatorStep.re +++ b/src/haz3lcore/dynamics/EvaluatorStep.re @@ -138,6 +138,8 @@ module Decompose = { | Constructor => Result.BoxedValue | Indet => Result.Indet | Step(s) => Result.Step([EvalObj.mk(Mark, env, undo, s.kind)]) + // TODO: Actually show these exceptions to the user! + | exception (EvaluatorError.Exception(_)) => Result.Indet } | (_, Result.Step(_) as r, _, _) => r }; @@ -168,7 +170,12 @@ module Decompose = { Term({term: Filter(flt, d1), ids: [DHExp.rep_id(exp)]}), d1, ); - Step({apply: () => d1, kind: CompleteFilter, value: true}); + Step({ + expr: d1, + state_update: () => (), + kind: CompleteFilter, + is_value: true, + }); } ) | _ => @@ -201,7 +208,9 @@ module TakeStep = { let (let.) = (rq: requirements('a, DHExp.t), rl: 'a => rule) => switch (rl(rq)) { - | Step({apply, _}) => Some(apply()) + | Step({expr, state_update, _}) => + state_update(); + Some(expr); | Constructor | Indet => None }; diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index 5094659553..4f7b579774 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -13,7 +13,7 @@ let rec matches_exp = | (Constructor("$e"), _) => failwith("$e in matched expression") | (Constructor("$v"), _) => failwith("$v in matched expression") | (_, Constructor("$v")) => - switch (ValueChecker.check_value(info_map, env, d)) { + switch (ValueChecker.check_value((), env, d)) { | Indet | Value => true | Expr => false @@ -32,13 +32,10 @@ let rec matches_exp = | (Var(dx), Var(fx)) => dx == fx | (Var(dx), _) => - let d = - ClosureEnvironment.lookup(env, dx) - |> Util.OptUtil.get(() => { - print_endline("FreeInvalidVar:" ++ dx); - raise(EvaluatorError.Exception(FreeInvalidVar(dx))); - }); - matches_exp(env, d, f); + switch (ClosureEnvironment.lookup(env, dx)) { + | None => false + | Some(d) => matches_exp(env, d, f) + } | (_, Var(fx)) => switch (ClosureEnvironment.lookup(env, fx)) { | Some(f) => matches_exp(env, d, f) diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index 7c6085d356..be564e0ede 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -12,7 +12,7 @@ open PatternMatch; | Seq(d1, d2) => let. _ = otherwise(d1 => Seq(d1, d2)) and. _ = req_final(req(state, env), 0, d1); - Step({apply: () => d2, kind: Seq, final: false}); + Step({expr: d2, state, kind: Seq, final: false}); Each step semantics starts with a `let. () = otherwise(...)` that defines how @@ -33,9 +33,9 @@ open PatternMatch; secondly a `kind`, that describes the step (which will be used in the stepper) Lastly, the `value` field allows for some speeding up of the evaluator. If you - are unsure, it is always safe to put `value: false`. + are unsure, it is always safe to put `is_value: false`. - `value: true` guarantees: + `is_value: true` guarantees: - if all requirements are values, then the output will be a value - if some requirements are indet, then the output will be indet @@ -84,9 +84,10 @@ let evaluate_extend_env = type rule = | Step({ - apply: unit => DHExp.t, + expr: DHExp.t, + state_update: unit => unit, kind: step_kind, - value: bool, + is_value: bool, }) | Constructor | Indet; @@ -140,6 +141,10 @@ module type EV_MODE = { module Transition = (EV: EV_MODE) => { open EV; open DHExp; + + // Default state update + let state_update = () => (); + let (let.match) = ((env, match_result: PatternMatch.match_result), r) => switch (match_result) { | IndetMatch @@ -160,33 +165,31 @@ module Transition = (EV: EV_MODE) => { switch (term) { | Var(x) => let. _ = otherwise(env, Var(x) |> rewrap); - let to_id = Id.mk(); - Step({ - apply: () => { - let d = - ClosureEnvironment.lookup(env, x) - |> OptUtil.get(() => { - raise(EvaluatorError.Exception(FreeInvalidVar(x))) - }); - d |> fast_copy(to_id); - }, - kind: VarLookup, - value: false, - }); + switch (ClosureEnvironment.lookup(env, x)) { + | Some(d) => + Step({ + expr: d |> fast_copy(Id.mk()), + state_update, + kind: VarLookup, + is_value: true, + }) + | None => Indet + }; | Seq(d1, d2) => let. _ = otherwise(env, d1 => Seq(d1, d2) |> rewrap) and. _ = req_final(req(state, env), d1 => Seq1(d1, d2) |> wrap_ctx, d1); - Step({apply: () => d2, kind: Seq, value: false}); + Step({expr: d2, state_update, kind: Seq, is_value: false}); | Let(dp, d1, d2) => let. _ = otherwise(env, d1 => Let(dp, d1, d2) |> rewrap) and. d1' = req_final(req(state, env), d1 => Let1(dp, d1, d2) |> wrap_ctx, d1); let.match env' = (env, matches(dp, d1')); Step({ - apply: () => Closure(env', d2) |> fresh, + expr: Closure(env', d2) |> fresh, + state_update, kind: LetBind, - value: false, + is_value: false, }); | Fun(_, _, Some(_), _) => let. _ = otherwise(env, d); @@ -194,16 +197,18 @@ module Transition = (EV: EV_MODE) => { | Fun(p, d1, None, v) => let. _ = otherwise(env, d); Step({ - apply: () => Fun(p, d1, Some(env), v) |> rewrap, + expr: Fun(p, d1, Some(env), v) |> rewrap, + state_update, kind: FunClosure, - value: true, + is_value: true, }); | FixF(dp, d1, None) => let. _ = otherwise(env, FixF(dp, d1, None) |> rewrap); Step({ - apply: () => FixF(dp, d1, Some(env)) |> rewrap, + expr: FixF(dp, d1, Some(env)) |> rewrap, + state_update, kind: FixClosure, - value: false, + is_value: false, }); | FixF(dp, d1, Some(env)) => switch (DHPat.get_var(dp)) { @@ -216,9 +221,10 @@ module Transition = (EV: EV_MODE) => { env, ); Step({ - apply: () => Closure(env'', d1) |> fresh, + expr: Closure(env'', d1) |> fresh, + state_update, kind: FixUnwrap, - value: false, + is_value: false, }); // Mutual Recursion case | None => @@ -241,30 +247,32 @@ module Transition = (EV: EV_MODE) => { let env'' = evaluate_extend_env(Environment.of_list(substitutions), env); Step({ - apply: () => Closure(env'', d1) |> fresh, + expr: Closure(env'', d1) |> fresh, + state_update, kind: FixUnwrap, - value: false, + is_value: false, }); } | Test(d) => - let. _ = otherwise(env, d => Test(d) |> rewrap) - and. d' = req_final(req(state, env), d => Test(d) |> wrap_ctx, d); + let. _ = otherwise(env, ((d, _)) => Test(d) |> rewrap) + and. (d', is_value) = + req_final_or_value(req(state, env), d => Test(d) |> wrap_ctx, d); + let result: TestStatus.t = + if (is_value) { + switch (Unboxing.unbox(Bool, d')) { + | DoesNotMatch + | IndetMatch => Indet + | Matches(b) => b ? Pass : Fail + }; + } else { + Indet; + }; Step({ - apply: () => - switch (DHExp.term_of(d')) { - | Bool(true) => - update_test(state, DHExp.rep_id(d), (d', Pass)); - Tuple([]) |> fresh; - | Bool(false) => - update_test(state, DHExp.rep_id(d), (d', Fail)); - Tuple([]) |> fresh; - /* Hack: assume if final and not Bool, then Indet; this won't catch errors in statics */ - | _ => - update_test(state, DHExp.rep_id(d), (d', Indet)); - Tuple([]) |> fresh; - }, + expr: Tuple([]) |> fresh, + state_update: () => + update_test(state, DHExp.rep_id(d), (d', result)), kind: UpdateTest, - value: true, + is_value: true, }); | DeferredAp(d1, ds) => let. _ = otherwise(env, (d1, ds) => DeferredAp(d1, ds) |> rewrap) @@ -296,9 +304,10 @@ module Transition = (EV: EV_MODE) => { | Fun(dp, d3, Some(env'), _) => let.match env'' = (env', matches(dp, d2')); Step({ - apply: () => Closure(env'', d3) |> fresh, + expr: Closure(env'', d3) |> fresh, + state_update, kind: FunAp, - value: false, + is_value: false, }); | Cast( d3', @@ -306,29 +315,36 @@ module Transition = (EV: EV_MODE) => { {term: Arrow(ty1', ty2'), _}, ) => Step({ - apply: () => + expr: Cast( Ap(dir, d3', Cast(d2', ty1', ty1) |> fresh) |> fresh, ty2, ty2', ) |> fresh, + state_update, kind: CastAp, - value: false, + is_value: false, }) | BuiltinFun(ident) => if (d2_is_value) { Step({ - apply: () => { + expr: { let builtin = VarMap.lookup(Builtins.forms_init, ident) |> OptUtil.get(() => { - raise(EvaluatorError.Exception(InvalidBuiltin(ident))) + /* This exception should never be raised because there is + no way for the user to create a BuiltinFun. They are all + inserted into the context before evaluation. */ + raise( + EvaluatorError.Exception(InvalidBuiltin(ident)), + ) }); builtin(d2); }, + state_update, kind: BuiltinAp(ident), - value: false // Not necessarily a value because of InvalidOperations + is_value: false // Not necessarily a value because of InvalidOperations }); } else { Indet; @@ -358,17 +374,19 @@ module Transition = (EV: EV_MODE) => { go(d4s, args); }; Step({ - apply: () => Ap(Forward, d3, Tuple(new_args) |> fresh) |> fresh, + expr: Ap(Forward, d3, Tuple(new_args) |> fresh) |> fresh, + state_update, kind: DeferredAp, - value: false, + is_value: false, }); | _ => Step({ - apply: () => { + expr: { raise(EvaluatorError.Exception(InvalidBoxedFun(d1'))); }, + state_update, kind: InvalidStep, - value: true, + is_value: true, }) }; | Deferral(_) => @@ -386,26 +404,16 @@ module Transition = (EV: EV_MODE) => { let. _ = otherwise(env, c => If(c, d1, d2) |> rewrap) and. c' = req_value(req(state, env), c => If1(c, d1, d2) |> wrap_ctx, c); - switch (DHExp.term_of(c')) { - | Bool(b) => - Step({ - apply: () => { - b ? d1 : d2; - }, - // Attach c' to indicate which branch taken. - kind: Conditional(b), - value: false, - }) - // Use a seperate case for invalid conditionals. Makes extracting the bool from BoolLit (above) easier. - | _ => - Step({ - apply: () => { - raise(EvaluatorError.Exception(InvalidBoxedBoolLit(c'))); - }, - kind: InvalidStep, - value: true, - }) - }; + let-unbox b = (Bool, c'); + Step({ + expr: { + b ? d1 : d2; + }, + state_update, + // Attach c' to indicate which branch taken. + kind: Conditional(b), + is_value: false, + }); | UnOp(Meta(Unquote), _) => let. _ = otherwise(env, d); Indet; @@ -419,9 +427,10 @@ module Transition = (EV: EV_MODE) => { ); let-unbox n = (Int, d1'); Step({ - apply: () => Int(- n) |> fresh, + expr: Int(- n) |> fresh, + state_update, kind: UnOp(Int(Minus)), - value: true, + is_value: true, }); | UnOp(Bool(Not), d1) => let. _ = otherwise(env, d1 => UnOp(Bool(Not), d1) |> rewrap) @@ -433,9 +442,10 @@ module Transition = (EV: EV_MODE) => { ); let-unbox b = (Bool, d1'); Step({ - apply: () => Bool(!b) |> fresh, + expr: Bool(!b) |> fresh, + state_update, kind: UnOp(Bool(Not)), - value: true, + is_value: true, }); | BinOp(Bool(And), d1, d2) => let. _ = otherwise(env, d1 => BinOp(Bool(And), d1, d2) |> rewrap) @@ -447,9 +457,10 @@ module Transition = (EV: EV_MODE) => { ); let-unbox b1 = (Bool, d1'); Step({ - apply: () => b1 ? d2 : Bool(false) |> fresh, + expr: b1 ? d2 : Bool(false) |> fresh, + state_update, kind: BinBoolOp(And), - value: false, + is_value: false, }); | BinOp(Bool(Or), d1, d2) => let. _ = otherwise(env, d1 => BinOp(Bool(Or), d1, d2) |> rewrap) @@ -461,9 +472,10 @@ module Transition = (EV: EV_MODE) => { ); let-unbox b1 = (Bool, d1'); Step({ - apply: () => b1 ? Bool(true) |> fresh : d2, + expr: b1 ? Bool(true) |> fresh : d2, + state_update, kind: BinBoolOp(Or), - value: false, + is_value: false, }); | BinOp(Int(op), d1, d2) => let. _ = otherwise(env, (d1, d2) => BinOp(Int(op), d1, d2) |> rewrap) @@ -482,7 +494,7 @@ module Transition = (EV: EV_MODE) => { let-unbox n1 = (Int, d1'); let-unbox n2 = (Int, d2'); Step({ - apply: () => + expr: ( switch (op) { | Plus => Int(n1 + n2) @@ -509,9 +521,10 @@ module Transition = (EV: EV_MODE) => { } ) |> fresh, + state_update, kind: BinIntOp(op), // False so that InvalidOperations are caught and made indet by the next step - value: false, + is_value: false, }); | BinOp(Float(op), d1, d2) => let. _ = @@ -531,7 +544,7 @@ module Transition = (EV: EV_MODE) => { let-unbox n1 = (Float, d1'); let-unbox n2 = (Float, d2'); Step({ - apply: () => + expr: ( switch (op) { | Plus => Float(n1 +. n2) @@ -548,9 +561,9 @@ module Transition = (EV: EV_MODE) => { } ) |> fresh, - + state_update, kind: BinFloatOp(op), - value: true, + is_value: true, }); | BinOp(String(op), d1, d2) => let. _ = @@ -570,13 +583,14 @@ module Transition = (EV: EV_MODE) => { let-unbox s1 = (String, d1'); let-unbox s2 = (String, d2'); Step({ - apply: () => + expr: switch (op) { | Concat => String(s1 ++ s2) |> fresh | Equals => Bool(s1 == s2) |> fresh }, + state_update, kind: BinStringOp(op), - value: true, + is_value: true, }); | Tuple(ds) => let. _ = otherwise(env, ds => Tuple(ds) |> rewrap) @@ -595,9 +609,10 @@ module Transition = (EV: EV_MODE) => { req_value(req(state, env), d2 => Cons2(d1, d2) |> wrap_ctx, d2); let-unbox ds = (List, d2'); Step({ - apply: () => ListLit([d1', ...ds]) |> fresh, + expr: ListLit([d1', ...ds]) |> fresh, + state_update, kind: ListCons, - value: true, + is_value: true, }); | ListConcat(d1, d2) => let. _ = otherwise(env, (d1, d2) => ListConcat(d1, d2) |> rewrap) @@ -616,9 +631,10 @@ module Transition = (EV: EV_MODE) => { let-unbox ds1 = (List, d1'); let-unbox ds2 = (List, d2'); Step({ - apply: () => ListLit(ds1 @ ds2) |> fresh, + expr: ListLit(ds1 @ ds2) |> fresh, + state_update, kind: ListConcat, - value: true, + is_value: true, }); | ListLit(ds) => let. _ = otherwise(env, ds => ListLit(ds) |> rewrap) @@ -650,9 +666,10 @@ module Transition = (EV: EV_MODE) => { switch (next_rule(rules)) { | Some((env', d2)) => Step({ - apply: () => Closure(evaluate_extend_env(env', env), d2) |> fresh, + expr: Closure(evaluate_extend_env(env', env), d2) |> fresh, + state_update, kind: CaseApply, - value: false, + is_value: false, }) | None => Indet }; @@ -660,7 +677,7 @@ module Transition = (EV: EV_MODE) => { let. _ = otherwise(env, d => Closure(env', d) |> rewrap) and. d' = req_final(req(state, env'), d1 => Closure(env', d1) |> wrap_ctx, d); - Step({apply: () => d', kind: CompleteClosure, value: true}); + Step({expr: d', state_update, kind: CompleteClosure, is_value: true}); | MultiHole(_) => let. _ = otherwise(env, d); // and. _ = @@ -680,7 +697,7 @@ module Transition = (EV: EV_MODE) => { and. d' = req_final(req(state, env), d => Cast(d, t1, t2) |> wrap_ctx, d); switch (Casts.transition(Cast(d', t1, t2) |> rewrap)) { - | Some(d) => Step({apply: () => d, kind: Cast, value: false}) + | Some(d) => Step({expr: d, state_update, kind: Cast, is_value: false}) | None => Constructor }; | FailedCast(d1, t1, t2) => @@ -694,15 +711,15 @@ module Transition = (EV: EV_MODE) => { Indet; | Parens(d) => let. _ = otherwise(env, d); - Step({apply: () => d, kind: RemoveParens, value: false}); + Step({expr: d, state_update, kind: RemoveParens, is_value: false}); | TyAlias(_, _, d) => let. _ = otherwise(env, d); - Step({apply: () => d, kind: RemoveTypeAlias, value: false}); + Step({expr: d, state_update, kind: RemoveTypeAlias, is_value: false}); | Filter(f1, d1) => let. _ = otherwise(env, d1 => Filter(f1, d1) |> rewrap) and. d1 = req_final(req(state, env), d1 => Filter(f1, d1) |> wrap_ctx, d1); - Step({apply: () => d1, kind: CompleteFilter, value: true}); + Step({expr: d1, state_update, kind: CompleteFilter, is_value: true}); }; }; }; diff --git a/src/haz3lcore/dynamics/ValueChecker.re b/src/haz3lcore/dynamics/ValueChecker.re index b2db830cb8..39f43daeed 100644 --- a/src/haz3lcore/dynamics/ValueChecker.re +++ b/src/haz3lcore/dynamics/ValueChecker.re @@ -1,6 +1,5 @@ open DHExp; open Transition; -open Util; type t = | Value @@ -8,9 +7,9 @@ type t = | Expr; module ValueCheckerEVMode: { - include EV_MODE with type result = t and type state = Statics.Map.t; + include EV_MODE with type result = t and type state = unit; } = { - type state = Statics.Map.t; + type state = unit; type result = t; type requirement('a) = ('a, (result, bool)); @@ -86,17 +85,12 @@ module CV = Transition(ValueCheckerEVMode); let rec check_value = (state, env, d) => CV.transition(check_value, state, env, d); -let rec check_value_mod_ctx = (info_map: Statics.Map.t, env, d) => +let rec check_value_mod_ctx = ((), env, d) => switch (DHExp.term_of(d)) { | Var(x) => - check_value_mod_ctx( - info_map, - env, - ClosureEnvironment.lookup(env, x) - |> OptUtil.get(() => { - print_endline("FreeInvalidVar:" ++ x); - raise(EvaluatorError.Exception(FreeInvalidVar(x))); - }), - ) - | _ => CV.transition(check_value_mod_ctx, info_map, env, d) + switch (ClosureEnvironment.lookup(env, x)) { + | Some(v) => check_value_mod_ctx((), env, v) + | None => CV.transition(check_value_mod_ctx, (), env, d) + } + | _ => CV.transition(check_value_mod_ctx, (), env, d) }; From ba6dba5a8dbdf983529f41d7ef74348f273851b5 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 18 Apr 2024 14:14:24 -0400 Subject: [PATCH 074/103] Get infomap out of webworker --- src/haz3lcore/dynamics/Elaborator.re | 5 +- src/haz3lcore/dynamics/Evaluator.re | 4 +- src/haz3lcore/dynamics/EvaluatorState.re | 11 +- src/haz3lcore/dynamics/EvaluatorState.rei | 6 +- src/haz3lcore/dynamics/EvaluatorStep.re | 4 +- src/haz3lcore/dynamics/FilterMatcher.re | 26 +---- src/haz3lcore/dynamics/PatternMatch.re | 3 +- src/haz3lcore/dynamics/Stepper.re | 131 +++++++--------------- src/haz3lcore/dynamics/Unboxing.re | 1 - src/haz3lcore/prog/Interface.re | 12 +- src/haz3lcore/prog/ModelResult.re | 2 +- src/haz3lcore/statics/TermBase.re | 2 + src/haz3lschool/Exercise.re | 1 - src/haz3lweb/Editors.re | 4 +- src/haz3lweb/Update.re | 12 ++ src/haz3lweb/view/Cell.re | 6 +- src/haz3lweb/view/StepperView.re | 2 +- 17 files changed, 82 insertions(+), 150 deletions(-) diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 4edd74dc93..58c1d087b0 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -8,10 +8,7 @@ exception MissingTypeInfo; module Elaboration = { [@deriving (show({with_path: false}), sexp, yojson)] - type t = { - d: DHExp.t, - info_map: Statics.Map.t, - }; + type t = {d: DHExp.t}; }; module ElaborationResult = { diff --git a/src/haz3lcore/dynamics/Evaluator.re b/src/haz3lcore/dynamics/Evaluator.re index b76fb7d4f4..fb877accd7 100644 --- a/src/haz3lcore/dynamics/Evaluator.re +++ b/src/haz3lcore/dynamics/Evaluator.re @@ -132,8 +132,8 @@ let rec evaluate = (state, env, d) => { }; }; -let evaluate = (env, {d, info_map}: Elaborator.Elaboration.t) => { - let state = ref(EvaluatorState.init(info_map)); +let evaluate = (env, {d}: Elaborator.Elaboration.t) => { + let state = ref(EvaluatorState.init); let env = ClosureEnvironment.of_environment(env); let result = evaluate(state, env, d); let result = diff --git a/src/haz3lcore/dynamics/EvaluatorState.re b/src/haz3lcore/dynamics/EvaluatorState.re index 0c83c0047c..bb85612d05 100644 --- a/src/haz3lcore/dynamics/EvaluatorState.re +++ b/src/haz3lcore/dynamics/EvaluatorState.re @@ -2,14 +2,9 @@ type t = { stats: EvaluatorStats.t, tests: TestMap.t, - info_map: Statics.Map.t, }; -let init = info_map => { - stats: EvaluatorStats.initial, - tests: TestMap.empty, - info_map, -}; +let init = {stats: EvaluatorStats.initial, tests: TestMap.empty}; let take_step = ({stats, _} as es) => { ...es, @@ -28,7 +23,3 @@ let add_test = ({tests, _} as es, id, report) => { let get_tests = ({tests, _}) => tests; let put_tests = (tests, es) => {...es, tests}; - -let get_info_map = ({info_map, _}) => info_map; - -let put_info_map = (info_map, es) => {...es, info_map}; diff --git a/src/haz3lcore/dynamics/EvaluatorState.rei b/src/haz3lcore/dynamics/EvaluatorState.rei index b33f989ea7..916ac0586b 100644 --- a/src/haz3lcore/dynamics/EvaluatorState.rei +++ b/src/haz3lcore/dynamics/EvaluatorState.rei @@ -14,7 +14,7 @@ type t; /** [init] is the initial state. */ -let init: Statics.Map.t => t; +let init: t; /** [take_step es] is [es] with the updated step count. @@ -33,7 +33,3 @@ let add_test: (t, Id.t, TestMap.instance_report) => t; let get_tests: t => TestMap.t; let put_tests: (TestMap.t, t) => t; - -let get_info_map: t => Statics.Map.t; - -let put_info_map: (Statics.Map.t, t) => t; diff --git a/src/haz3lcore/dynamics/EvaluatorStep.re b/src/haz3lcore/dynamics/EvaluatorStep.re index f129f05a04..700e405d38 100644 --- a/src/haz3lcore/dynamics/EvaluatorStep.re +++ b/src/haz3lcore/dynamics/EvaluatorStep.re @@ -237,8 +237,8 @@ let decompose = (d: DHExp.t, es: EvaluatorState.t) => { Decompose.Result.unbox(rs); }; -let evaluate_with_history = (d, info_map) => { - let state = ref(EvaluatorState.init(info_map)); +let evaluate_with_history = d => { + let state = ref(EvaluatorState.init); let rec go = d => switch (decompose(d, state^)) { | [] => [] diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index 4f7b579774..7a8f65e46c 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -1,12 +1,5 @@ let rec matches_exp = - ( - info_map: Statics.Map.t, - env: ClosureEnvironment.t, - d: DHExp.t, - f: DHExp.t, - ) - : bool => { - let matches_exp = matches_exp(info_map); + (env: ClosureEnvironment.t, d: DHExp.t, f: DHExp.t): bool => { switch (DHExp.term_of(d), DHExp.term_of(f)) { | (Parens(x), _) => matches_exp(env, x, f) | (_, Parens(x)) => matches_exp(env, d, x) @@ -229,39 +222,32 @@ and matches_pat = (d: Pat.t, f: Pat.t): bool => { and matches_typ = (d: Typ.t, f: Typ.t) => { Typ.eq(d, f); } -and matches_rul = (info_map, env, (dp, d), (fp, f)) => { - matches_pat(dp, fp) && matches_exp(info_map, env, d, f); +and matches_rul = (env, (dp, d), (fp, f)) => { + matches_pat(dp, fp) && matches_exp(env, d, f); }; let matches = ( - info_map, ~env: ClosureEnvironment.t, ~exp: DHExp.t, ~flt: TermBase.StepperFilterKind.filter, ) : option(FilterAction.t) => - if (matches_exp(info_map, env, exp, flt.pat)) { + if (matches_exp(env, exp, flt.pat)) { Some(flt.act); } else { None; }; let matches = - ( - ~env: ClosureEnvironment.t, - ~exp: DHExp.t, - ~exp_info_map: Statics.Map.t, - ~act: FilterAction.t, - flt_env, - ) + (~env: ClosureEnvironment.t, ~exp: DHExp.t, ~act: FilterAction.t, flt_env) : (FilterAction.t, int) => { let len = List.length(flt_env); let rec matches' = (~env, ~exp, ~act, flt_env, idx) => { switch (flt_env) { | [] => (act, idx) | [hd, ...tl] => - switch (matches(exp_info_map, ~env, ~exp, ~flt=hd)) { + switch (matches(~env, ~exp, ~flt=hd)) { | Some(act) => (act, idx) | None => matches'(~env, ~exp, ~act, tl, idx + 1) } diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index 46b3ed9373..17e0877c79 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -55,6 +55,5 @@ let rec matches = (dp: Pat.t, d: DHExp.t): match_result => List.map2(matches, ps, ds) |> List.fold_left(combine_result, Matches(Environment.empty)); | Parens(p) => matches(p, d) - | Cast(p, t1, t2) => - matches(p, Cast(d, t2, t1) |> DHExp.fresh |> Unboxing.fixup_cast) + | Cast(p, t1, t2) => matches(p, Cast(d, t2, t1) |> DHExp.fresh) }; diff --git a/src/haz3lcore/dynamics/Stepper.re b/src/haz3lcore/dynamics/Stepper.re index 0fdc6fee7c..5dfd1e82aa 100644 --- a/src/haz3lcore/dynamics/Stepper.re +++ b/src/haz3lcore/dynamics/Stepper.re @@ -28,15 +28,13 @@ let rec matches = flt: FilterEnvironment.t, ctx: EvalCtx.t, exp: DHExp.t, - exp_info_map: Statics.Map.t, act: FilterAction.t, idx: int, ) : (FilterAction.t, int, EvalCtx.t) => { let composed = EvalCtx.compose(ctx, exp); let (pact, pidx) = (act, idx); - let (mact, midx) = - FilterMatcher.matches(~env, ~exp=composed, ~exp_info_map, ~act, flt); + let (mact, midx) = FilterMatcher.matches(~env, ~exp=composed, ~act, flt); let (act, idx) = switch (ctx) { | Term({term: Filter(_, _), _}) => (pact, pidx) @@ -53,124 +51,107 @@ let rec matches = let rewrap = term => EvalCtx.Term({term, ids}); switch ((term: EvalCtx.term)) { | Closure(env, ctx) => - let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); + let+ ctx = matches(env, flt, ctx, exp, act, idx); Closure(env, ctx) |> rewrap; | Filter(Filter(flt'), ctx) => let flt = flt |> FilterEnvironment.extends(flt'); - let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); + let+ ctx = matches(env, flt, ctx, exp, act, idx); Filter(Filter(flt'), ctx) |> rewrap; | Filter(Residue(idx, act), ctx) => - let (ract, ridx, rctx) = - matches(env, flt, ctx, exp, exp_info_map, act, idx); + let (ract, ridx, rctx) = matches(env, flt, ctx, exp, act, idx); if (ridx == idx && ract |> snd == All) { (ract, ridx, Filter(Residue(idx, act), rctx) |> rewrap); } else { (ract, ridx, rctx); }; | Seq1(ctx, d2) => - let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); + let+ ctx = matches(env, flt, ctx, exp, act, idx); Seq1(ctx, d2) |> rewrap; | Seq2(d1, ctx) => - let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); + let+ ctx = matches(env, flt, ctx, exp, act, idx); Seq2(d1, ctx) |> rewrap; | Let1(d1, ctx, d3) => - let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); + let+ ctx = matches(env, flt, ctx, exp, act, idx); Let1(d1, ctx, d3) |> rewrap; | Let2(d1, d2, ctx) => - let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); + let+ ctx = matches(env, flt, ctx, exp, act, idx); Let2(d1, d2, ctx) |> rewrap; | Fun(dp, ctx, env', name) => let+ ctx = - matches( - Option.value(~default=env, env'), - flt, - ctx, - exp, - exp_info_map, - act, - idx, - ); + matches(Option.value(~default=env, env'), flt, ctx, exp, act, idx); Fun(dp, ctx, env', name) |> rewrap; | FixF(name, ctx, env') => let+ ctx = - matches( - Option.value(~default=env, env'), - flt, - ctx, - exp, - exp_info_map, - act, - idx, - ); + matches(Option.value(~default=env, env'), flt, ctx, exp, act, idx); FixF(name, ctx, env') |> rewrap; | Ap1(dir, ctx, d2) => - let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); + let+ ctx = matches(env, flt, ctx, exp, act, idx); Ap1(dir, ctx, d2) |> rewrap; | Ap2(dir, d1, ctx) => - let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); + let+ ctx = matches(env, flt, ctx, exp, act, idx); Ap2(dir, d1, ctx) |> rewrap; | DeferredAp1(ctx, d2) => - let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); + let+ ctx = matches(env, flt, ctx, exp, act, idx); DeferredAp1(ctx, d2) |> rewrap; | DeferredAp2(d1, ctx, ds) => - let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); + let+ ctx = matches(env, flt, ctx, exp, act, idx); DeferredAp2(d1, ctx, ds) |> rewrap; | If1(ctx, d2, d3) => - let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); + let+ ctx = matches(env, flt, ctx, exp, act, idx); If1(ctx, d2, d3) |> rewrap; | If2(d1, ctx, d3) => - let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); + let+ ctx = matches(env, flt, ctx, exp, act, idx); If2(d1, ctx, d3) |> rewrap; | If3(d1, d2, ctx) => - let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); + let+ ctx = matches(env, flt, ctx, exp, act, idx); If3(d1, d2, ctx) |> rewrap; | UnOp(op, ctx) => - let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); + let+ ctx = matches(env, flt, ctx, exp, act, idx); UnOp(op, ctx) |> rewrap; | BinOp1(op, ctx, d1) => - let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); + let+ ctx = matches(env, flt, ctx, exp, act, idx); BinOp1(op, ctx, d1) |> rewrap; | BinOp2(op, d1, ctx) => - let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); + let+ ctx = matches(env, flt, ctx, exp, act, idx); BinOp2(op, d1, ctx) |> rewrap; | Tuple(ctx, ds) => - let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); + let+ ctx = matches(env, flt, ctx, exp, act, idx); Tuple(ctx, ds) |> rewrap; | Test(ctx) => - let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); + let+ ctx = matches(env, flt, ctx, exp, act, idx); Test(ctx) |> rewrap; | ListLit(ctx, ds) => - let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); + let+ ctx = matches(env, flt, ctx, exp, act, idx); ListLit(ctx, ds) |> rewrap; | Cons1(ctx, d2) => - let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); + let+ ctx = matches(env, flt, ctx, exp, act, idx); Cons1(ctx, d2) |> rewrap; | Cons2(d1, ctx) => - let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); + let+ ctx = matches(env, flt, ctx, exp, act, idx); Cons2(d1, ctx) |> rewrap; | ListConcat1(ctx, d2) => - let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); + let+ ctx = matches(env, flt, ctx, exp, act, idx); ListConcat1(ctx, d2) |> rewrap; | ListConcat2(d1, ctx) => - let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); + let+ ctx = matches(env, flt, ctx, exp, act, idx); ListConcat2(d1, ctx) |> rewrap; | MultiHole(ctx, (dl, dr)) => - let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); + let+ ctx = matches(env, flt, ctx, exp, act, idx); MultiHole(ctx, (dl, dr)) |> rewrap; | Cast(ctx, ty, ty') => - let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); + let+ ctx = matches(env, flt, ctx, exp, act, idx); Cast(ctx, ty, ty') |> rewrap; | FailedCast(ctx, ty, ty') => - let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); + let+ ctx = matches(env, flt, ctx, exp, act, idx); FailedCast(ctx, ty, ty') |> rewrap; | DynamicErrorHole(ctx, error) => - let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); + let+ ctx = matches(env, flt, ctx, exp, act, idx); DynamicErrorHole(ctx, error) |> rewrap; | MatchScrut(ctx, rs) => - let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); + let+ ctx = matches(env, flt, ctx, exp, act, idx); MatchScrut(ctx, rs) |> rewrap; | MatchRule(scr, p, ctx, rs) => - let+ ctx = matches(env, flt, ctx, exp, exp_info_map, act, idx); + let+ ctx = matches(env, flt, ctx, exp, act, idx); MatchRule(scr, p, ctx, rs) |> rewrap; }; }; @@ -186,20 +167,12 @@ let rec matches = }; let should_hide_eval_obj = - (~settings, ~info_map, x: EvalObj.t): (FilterAction.action, EvalObj.t) => + (~settings, x: EvalObj.t): (FilterAction.action, EvalObj.t) => if (should_hide_step(~settings, x.knd)) { (Eval, x); } else { let (act, _, ctx) = - matches( - ClosureEnvironment.empty, - [], - x.ctx, - x.d_loc, - info_map, - (Step, One), - 0, - ); + matches(ClosureEnvironment.empty, [], x.ctx, x.d_loc, (Step, One), 0); switch (act) { | (Eval, _) => (Eval, {...x, ctx}) | (Step, _) => (Step, {...x, ctx}) @@ -211,15 +184,7 @@ let should_hide_step = (~settings, x: step): (FilterAction.action, step) => (Eval, x); } else { let (act, _, ctx) = - matches( - ClosureEnvironment.empty, - [], - x.ctx, - x.d_loc, - EvaluatorState.get_info_map(x.state), - (Step, One), - 0, - ); + matches(ClosureEnvironment.empty, [], x.ctx, x.d_loc, (Step, One), 0); switch (act) { | (Eval, _) => (Eval, {...x, ctx}) | (Step, _) => (Step, {...x, ctx}) @@ -227,13 +192,10 @@ let should_hide_step = (~settings, x: step): (FilterAction.action, step) => }; let get_elab = ({history, _}: t): Elaborator.Elaboration.t => { - let (d, st) = Aba.last_a(history); - {d, info_map: EvaluatorState.get_info_map(st)}; + let (d, _) = Aba.last_a(history); + {d: d}; }; -let get_elab_info_map = ({history, _}: t) => - Aba.last_a(history) |> snd |> EvaluatorState.get_info_map; - let get_next_steps = s => s.next_options; let current_expr = ({history, _}: t) => Aba.hd(history) |> fst; @@ -241,12 +203,11 @@ let current_expr = ({history, _}: t) => Aba.hd(history) |> fst; let current_state = ({history, _}: t) => Aba.hd(history) |> snd; let step_pending = (idx: int, stepper: t) => { - ...stepper, - stepper_state: StepPending(idx), + {...stepper, stepper_state: StepPending(idx)}; }; -let init = ({d, info_map}: Elaborator.Elaboration.t) => { - let state = EvaluatorState.init(info_map); +let init = ({d}: Elaborator.Elaboration.t) => { + let state = EvaluatorState.init; { history: Aba.singleton((d, state)), next_options: decompose(d, state), @@ -259,14 +220,7 @@ let rec evaluate_pending = (~settings, s: t) => { | StepperDone | StepTimeout(_) => s | StepperReady => - let next' = - s.next_options - |> List.map( - should_hide_eval_obj( - ~settings, - ~info_map=EvaluatorState.get_info_map(current_state(s)), - ), - ); + let next' = s.next_options |> List.map(should_hide_eval_obj(~settings)); let next'' = List.mapi((i, x) => (i, x), next'); switch ( List.find_opt(((_, (act, _))) => act == FilterAction.Eval, next'') @@ -287,6 +241,7 @@ let rec evaluate_pending = (~settings, s: t) => { } ) |> DHExp.repair_ids; + let _ = print_endline(d_loc' |> DHExp.show); let d' = EvalCtx.compose(eo.ctx, d_loc'); let new_step = { d, diff --git a/src/haz3lcore/dynamics/Unboxing.re b/src/haz3lcore/dynamics/Unboxing.re index fbfb7af364..49c2aa69e2 100644 --- a/src/haz3lcore/dynamics/Unboxing.re +++ b/src/haz3lcore/dynamics/Unboxing.re @@ -47,7 +47,6 @@ let fixup_cast = Casts.transition_multiple; let rec unbox: type a. (unbox_request(a), DHExp.t) => unboxed(a) = (request, expr) => { - let _ = print_endline(DHExp.show(expr)); switch (request, DHExp.term_of(expr)) { /* Remove parentheses from casts */ | (_, Cast(d, {term: Parens(x), _}, y)) diff --git a/src/haz3lcore/prog/Interface.re b/src/haz3lcore/prog/Interface.re index b47008640b..d9f54f5692 100644 --- a/src/haz3lcore/prog/Interface.re +++ b/src/haz3lcore/prog/Interface.re @@ -53,16 +53,12 @@ let elaborate = (~settings: CoreSettings.t, map, term): DHExp.t => }; let evaluate = - ( - ~settings: CoreSettings.t, - ~env=Builtins.env_init, - elab: Elaborator.Elaboration.t, - ) + (~settings: CoreSettings.t, ~env=Builtins.env_init, elab: DHExp.t) : ProgramResult.t => switch () { - | _ when !settings.dynamics => Off(elab) + | _ when !settings.dynamics => Off({d: elab}) | _ => - switch (Evaluator.evaluate(env, elab)) { + switch (Evaluator.evaluate(env, {d: elab})) { | exception (EvaluatorError.Exception(reason)) => print_endline("EvaluatorError:" ++ EvaluatorError.show(reason)); ResultFail(EvaulatorError(reason)); @@ -84,5 +80,5 @@ let eval_z = let (term, _) = MakeTerm.from_zip_for_sem(z); let info_map = Statics.mk_map_ctx(settings, ctx_init, term); let d = elaborate(~settings, info_map, term); - evaluate(~settings, ~env=env_init, {d, info_map}); + evaluate(~settings, ~env=env_init, d); }; diff --git a/src/haz3lcore/prog/ModelResult.re b/src/haz3lcore/prog/ModelResult.re index 25cee41b13..41d74dc440 100644 --- a/src/haz3lcore/prog/ModelResult.re +++ b/src/haz3lcore/prog/ModelResult.re @@ -42,7 +42,7 @@ let run_pending = (~settings: CoreSettings.t) => Evaluation({ elab, previous, - evaluation: Interface.evaluate(~settings, elab), + evaluation: Interface.evaluate(~settings, elab.d), }) | Evaluation(_) as e => e | Stepper(s) => diff --git a/src/haz3lcore/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index 5a21ff3104..9b6a076210 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -113,6 +113,8 @@ and Exp: { | BinOp(Operators.op_bin, t, t) | BuiltinFun(string) | Match(t, list((Pat.t, t))) + /* INVARIANT: in dynamic expressions, casts must be between + two consistent types. */ | Cast(t, Typ.t, Typ.t) and t = IdTagged.t(term); diff --git a/src/haz3lschool/Exercise.re b/src/haz3lschool/Exercise.re index afe538cc32..4f055bb4de 100644 --- a/src/haz3lschool/Exercise.re +++ b/src/haz3lschool/Exercise.re @@ -723,7 +723,6 @@ module F = (ExerciseEnv: ExerciseEnv) => { stitch_static(settings, stitch_term(state)); let elab = (s: CachedStatics.statics): Elaborator.Elaboration.t => { d: Interface.elaborate(~settings, s.info_map, s.term), - info_map: s.info_map, }; [ (test_validation_key, elab(test_validation)), diff --git a/src/haz3lweb/Editors.re b/src/haz3lweb/Editors.re index 318e1c428f..35d6918946 100644 --- a/src/haz3lweb/Editors.re +++ b/src/haz3lweb/Editors.re @@ -105,13 +105,13 @@ let get_spliced_elabs = let CachedStatics.{term, info_map, _} = lookup_statics(~settings, ~statics, editors); let d = Interface.elaborate(~settings=settings.core, info_map, term); - [(key, {d, info_map})]; + [(key, {d: d})]; | Documentation(name, _) => let key = ScratchSlide.scratch_key(name); let CachedStatics.{term, info_map, _} = lookup_statics(~settings, ~statics, editors); let d = Interface.elaborate(~settings=settings.core, info_map, term); - [(key, {d, info_map})]; + [(key, {d: d})]; | Exercises(_, _, exercise) => Exercise.spliced_elabs(settings.core, exercise) }; diff --git a/src/haz3lweb/Update.re b/src/haz3lweb/Update.re index 260aa6a151..9edf5d1b2a 100644 --- a/src/haz3lweb/Update.re +++ b/src/haz3lweb/Update.re @@ -475,6 +475,18 @@ let rec apply = model.results |> ModelResults.find(key) |> ModelResult.step_forward(idx); + let _ = print_endline("Ouch"); + let _ = + print_endline( + Stepper.show_stepper_state( + ( + fun + | (Stepper(s): ModelResult.t) => s + | _ => failwith("") + )(r). + stepper_state, + ), + ); Ok({...model, results: model.results |> ModelResults.add(key, r)}); | StepperAction(key, StepBackward) => let r = diff --git a/src/haz3lweb/view/Cell.re b/src/haz3lweb/view/Cell.re index 9edb5f0b40..58cbd24771 100644 --- a/src/haz3lweb/view/Cell.re +++ b/src/haz3lweb/view/Cell.re @@ -191,7 +191,7 @@ let live_eval = ~font_metrics, ~width=80, ~result_key, - ~infomap=result.elab.info_map, + ~infomap=Id.Map.empty, dhexp, ); let exn_view = @@ -398,12 +398,12 @@ let locked = editor.state.meta.view_term, ) : DHExp.Bool(true) |> DHExp.fresh; - let elab: Elaborator.Elaboration.t = {d: elab, info_map: statics.info_map}; + let elab: Elaborator.Elaboration.t = {d: elab}; let result: ModelResult.t = settings.core.dynamics ? Evaluation({ elab, - evaluation: Interface.evaluate(~settings=settings.core, elab), + evaluation: Interface.evaluate(~settings=settings.core, elab.d), previous: ResultPending, }) : NoElab; diff --git a/src/haz3lweb/view/StepperView.re b/src/haz3lweb/view/StepperView.re index 9cd98fd9d1..c3ff3c528d 100644 --- a/src/haz3lweb/view/StepperView.re +++ b/src/haz3lweb/view/StepperView.re @@ -114,7 +114,7 @@ let stepper_view = ~hidden_steps, ~result_key, ~next_steps, - ~infomap=Stepper.get_elab(stepper).info_map, + ~infomap=Id.Map.empty, d, ), ], From 99b56f4daa12bebaa1505c9fda566ab1357aa94b Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 18 Apr 2024 17:03:58 -0400 Subject: [PATCH 075/103] Fix implicit fixpoint cast elaboration --- src/haz3lcore/dynamics/Elaborator.re | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 58c1d087b0..5a5abc84fc 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -258,10 +258,7 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { let (p, ty1) = elaborate_pattern(m, p); let (def, ty2) = elaborate(m, def); let (body, ty) = elaborate(m, body); - let fixf = - FixF(p, fresh_cast(def, ty2, ty1), None) - |> DHExp.fresh - |> fresh_cast(_, ty1, ty); + let fixf = FixF(p, fresh_cast(def, ty2, ty1), None) |> DHExp.fresh; Exp.Let(p, fixf, body) |> rewrap |> cast_from(ty); }; | FixF(p, e, env) => From b2a74aa7dd9334f62ca433897e0db10c51bbecf5 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Fri, 19 Apr 2024 10:48:42 -0400 Subject: [PATCH 076/103] Fix cast elaboration bugs --- src/haz3lcore/dynamics/Elaborator.re | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 5a5abc84fc..24fee395df 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -32,11 +32,10 @@ let fresh_cast = (d: DHExp.t, t1: Typ.t, t2: Typ.t): DHExp.t => { }; }; -let fresh_pat_cast = (p: DHPat.t, t1: Typ.t, t2: Typ.t): DHPat.t => +let fresh_pat_cast = (p: DHPat.t, t1: Typ.t, t2: Typ.t): DHPat.t => { Typ.eq(t1, t2) ? p - : { - Cast( + : Cast( DHPat.fresh(Cast(p, t1, Typ.fresh(Unknown(Internal)))) |> Casts.pattern_fixup, Typ.fresh(Unknown(Internal)), @@ -44,7 +43,7 @@ let fresh_pat_cast = (p: DHPat.t, t1: Typ.t, t2: Typ.t): DHPat.t => ) |> DHPat.fresh |> Casts.pattern_fixup; - }; +}; let elaborated_type = (m: Statics.Map.t, uexp: UExp.t): (Typ.t, Ctx.t) => { let (mode, self_ty, ctx) = @@ -274,8 +273,9 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { let (f', tyf) = elaborate(m, f); let (a', tya) = elaborate(m, a); let (tyf1, tyf2) = Typ.matched_arrow(ctx, tyf); + let f'' = fresh_cast(f', tyf, Arrow(tyf1, tyf2) |> Typ.fresh); let a'' = fresh_cast(a', tya, tyf1); - Exp.Ap(dir, f', a'') |> rewrap |> cast_from(tyf2); + Exp.Ap(dir, f'', a'') |> rewrap |> cast_from(tyf2); | DeferredAp(f, args) => let (f', tyf) = elaborate(m, f); let (args', tys) = List.map(elaborate(m), args) |> ListUtil.unzip; From 8871cd476e791061ef8d2ef2b6808e674f99dded Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Mon, 22 Apr 2024 11:28:05 -0400 Subject: [PATCH 077/103] Merge fixup --- src/haz3lcore/assistant/AssistantForms.re | 5 +- src/haz3lcore/dynamics/Casts.re | 7 + src/haz3lcore/dynamics/DHExp.re | 72 +++++ src/haz3lcore/dynamics/Elaborator.re | 17 +- src/haz3lcore/dynamics/EvalCtx.re | 3 + src/haz3lcore/dynamics/FilterMatcher.re | 2 +- src/haz3lcore/dynamics/Stepper.re | 6 +- src/haz3lcore/dynamics/Substitution.re | 6 +- src/haz3lcore/dynamics/Transition.re | 79 ++--- src/haz3lcore/dynamics/Unboxing.re | 4 +- src/haz3lcore/lang/term/TPat.re | 38 ++- src/haz3lcore/lang/term/Typ.re | 298 ++++++++++++++----- src/haz3lcore/statics/Ctx.re | 13 +- src/haz3lcore/statics/Info.re | 36 +-- src/haz3lcore/statics/MakeTerm.re | 4 +- src/haz3lcore/statics/Mode.re | 10 +- src/haz3lcore/statics/Statics.re | 60 ++-- src/haz3lcore/statics/Term.re | 84 +----- src/haz3lcore/statics/TermBase.re | 18 +- src/haz3lcore/zipper/EditorUtil.re | 4 +- src/haz3lschool/SyntaxTest.re | 13 +- src/haz3lweb/explainthis/ExplainThisForm.re | 1 - src/haz3lweb/view/CursorInspector.re | 14 +- src/haz3lweb/view/ExplainThis.re | 6 +- src/haz3lweb/view/Type.re | 13 +- src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 2 +- src/haz3lweb/view/dhcode/layout/HTypDoc.re | 5 +- 27 files changed, 536 insertions(+), 284 deletions(-) diff --git a/src/haz3lcore/assistant/AssistantForms.re b/src/haz3lcore/assistant/AssistantForms.re index 6afac63610..3d26ecafb3 100644 --- a/src/haz3lcore/assistant/AssistantForms.re +++ b/src/haz3lcore/assistant/AssistantForms.re @@ -25,7 +25,10 @@ module Typ = { let of_leading_delim: list((Token.t, Typ.t)) = [ ("case" ++ leading_expander, unk), ("fun" ++ leading_expander, Arrow(unk, unk) |> Typ.fresh), - ("typfun" ++ leading_expander, Forall("", unk) |> Typ.fresh), + ( + "typfun" ++ leading_expander, + Forall(Var("") |> TPat.fresh, unk) |> Typ.fresh, + ), ("if" ++ leading_expander, unk), ("let" ++ leading_expander, unk), ("test" ++ leading_expander, Prod([]) |> Typ.fresh), diff --git a/src/haz3lcore/dynamics/Casts.re b/src/haz3lcore/dynamics/Casts.re index 66a67d5a10..4ff7310aca 100644 --- a/src/haz3lcore/dynamics/Casts.re +++ b/src/haz3lcore/dynamics/Casts.re @@ -33,6 +33,11 @@ let rec ground_cases_of = (ty: Typ.t): ground_cases => { Arrow(Unknown(Internal) |> Typ.fresh, Unknown(Internal) |> Typ.fresh) |> Typ.fresh, ); + let grounded_Forall = + NotGroundOrHole( + Forall(EmptyHole |> TPat.fresh, Unknown(Internal) |> Typ.fresh) + |> Typ.fresh, + ); let grounded_Prod = length => NotGroundOrHole( Prod(ListUtil.replicate(length, Typ.Unknown(Internal) |> Typ.fresh)) @@ -54,6 +59,7 @@ let rec ground_cases_of = (ty: Typ.t): ground_cases => { | String | Var(_) | Rec(_) + | Forall(_, {term: Unknown(_), _}) | Arrow({term: Unknown(_), _}, {term: Unknown(_), _}) | List({term: Unknown(_), _}) => Ground | Parens(ty) => ground_cases_of(ty) @@ -72,6 +78,7 @@ let rec ground_cases_of = (ty: Typ.t): ground_cases => { sm |> ConstructorMap.is_ground(is_hole) ? Ground : NotGroundOrHole(Sum(grounded_Sum()) |> Typ.fresh) | Arrow(_, _) => grounded_Arrow + | Forall(_) => grounded_Forall | List(_) => grounded_List | Ap(_) => failwith("type application in dynamics") }; diff --git a/src/haz3lcore/dynamics/DHExp.re b/src/haz3lcore/dynamics/DHExp.re index 8013bda96d..f2829ec89a 100644 --- a/src/haz3lcore/dynamics/DHExp.re +++ b/src/haz3lcore/dynamics/DHExp.re @@ -74,6 +74,8 @@ let rec strip_casts = | Constructor(_) | DynamicErrorHole(_) | Closure(_) + | TypFun(_) + | TypAp(_) | If(_) => continue(exp) /* Remove casts*/ | FailedCast(d, _, _) @@ -119,6 +121,9 @@ let rec fast_equal = && fast_equal(d1, d2) && ClosureEnvironment.id_equal(env1, env2) && s1 == s2 + | (TypFun(_tpat1, d1, s1), TypFun(_tpat2, d2, s2)) => + _tpat1 == _tpat2 && fast_equal(d1, d2) && s1 == s2 + | (TypAp(d1, ty1), TypAp(d2, ty2)) => fast_equal(d1, d2) && ty1 == ty2 | (Ap(dir1, d11, d21), Ap(dir2, d12, d22)) => dir1 == dir2 && fast_equal(d11, d12) && fast_equal(d21, d22) | (DeferredAp(d1, ds1), DeferredAp(d2, ds2)) => @@ -175,6 +180,8 @@ let rec fast_equal = | (Cast(_), _) | (FailedCast(_), _) | (TyAlias(_), _) + | (TypFun(_), _) + | (TypAp(_), _) | (DynamicErrorHole(_), _) | (DeferredAp(_), _) | (If(_), _) @@ -204,3 +211,68 @@ and filter_fast_equal = (f1, f2) => { | _ => false }; }; + +let assign_name_if_none = (t, name) => { + let (term, rewrap) = unwrap(t); + switch (term) { + | Fun(arg, ty, body, None) => Fun(arg, ty, body, name) |> rewrap + | TypFun(utpat, body, None) => TypFun(utpat, body, name) |> rewrap + | _ => t + }; +}; + +let ty_subst = (s: Typ.t, tpat: TPat.t, exp: t): t => { + switch (TPat.tyvar_of_utpat(tpat)) { + | None => exp + | Some(x) => + Exp.map_term( + ~f_typ=(_, typ) => Typ.subst(s, tpat, typ), + ~f_exp= + (continue, exp) => + switch (term_of(exp)) { + | TypFun(utpat, _, _) => + switch (TPat.tyvar_of_utpat(utpat)) { + | Some(x') when x == x' => exp + | Some(_) + | None => continue(exp) + /* Note that we do not have to worry about capture avoidance, since s will always be closed. */ + } + | Cast(_) + | FixF(_) + | Fun(_) + | TypAp(_) + | ListLit(_) + | Test(_) + | Closure(_) + | Seq(_) + | Let(_) + | Ap(_) + | BuiltinFun(_) + | BinOp(_) + | Cons(_) + | ListConcat(_) + | Tuple(_) + | Match(_) + | DynamicErrorHole(_) + | Filter(_) + | If(_) + | EmptyHole + | Invalid(_) + | Constructor(_) + | Var(_) + | Bool(_) + | Int(_) + | Float(_) + | String(_) + | FailedCast(_, _, _) + | MultiHole(_) + | Deferral(_) + | TyAlias(_) + | DeferredAp(_) + | Parens(_) + | UnOp(_) => continue(exp) + }, + exp, + ) + }; +}; diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 24fee395df..32d23fa5e1 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -53,6 +53,7 @@ let elaborated_type = (m: Statics.Map.t, uexp: UExp.t): (Typ.t, Ctx.t) => { }; switch (mode) { | SynFun + | SynTypFun | Syn => (self_ty, ctx) // We need to remove the synswitches from this type. | Ana(ana_ty) => (Typ.match_synswitch(ana_ty, self_ty), ctx) @@ -72,6 +73,7 @@ let elaborated_pat_type = (m: Statics.Map.t, upat: UPat.t): (Typ.t, Ctx.t) => { }; switch (mode) { | SynFun + | SynTypFun | Syn => (self_ty, ctx) | Ana(ana_ty) => switch (prev_synswitch) { @@ -222,6 +224,11 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { Exp.Fun(p', e', env, n) |> rewrap |> cast_from(Arrow(typ, tye) |> Typ.fresh); + | TypFun(tpat, e, name) => + let (e', tye) = elaborate(m, e); + Exp.TypFun(tpat, e', name) + |> rewrap + |> cast_from(Typ.Forall(tpat, tye) |> Typ.fresh); | Tuple(es) => let (ds, tys) = List.map(elaborate(m), es) |> ListUtil.unzip; Exp.Tuple(ds) |> rewrap |> cast_from(Prod(tys) |> Typ.fresh); @@ -242,8 +249,8 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { }; } ); - switch (Pat.get_recursive_bindings(p)) { - | None => + // TODO: is elaborated_type the right type to use here?? + if (!Statics.is_recursive(ctx, p, def, elaborated_type)) { let def = add_name(Pat.get_var(p), def); let (p, ty1) = elaborate_pattern(m, p); let (def, ty2) = elaborate(m, def); @@ -251,7 +258,7 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { Exp.Let(p, fresh_cast(def, ty2, ty1), body) |> rewrap |> cast_from(ty); - | Some(_) => + } else { // TODO: Add names to mutually recursive functions // TODO: Don't add fixpoint if there already is one let (p, ty1) = elaborate_pattern(m, p); @@ -298,6 +305,10 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { DeferredAp(f'', args'') |> rewrap |> cast_from(Arrow(remaining_arg_ty, tyf2) |> Typ.fresh); + | TypAp(e, ut) => + let (e', tye) = elaborate(m, e); + let (_, tye') = Typ.matched_forall(ctx, tye); + TypAp(e', ut) |> rewrap |> cast_from(tye'); | If(c, t, f) => let (c', tyc) = elaborate(m, c); let (t', tyt) = elaborate(m, t); diff --git a/src/haz3lcore/dynamics/EvalCtx.re b/src/haz3lcore/dynamics/EvalCtx.re index 1253a2a5ca..6b070b104a 100644 --- a/src/haz3lcore/dynamics/EvalCtx.re +++ b/src/haz3lcore/dynamics/EvalCtx.re @@ -148,6 +148,9 @@ let rec compose = (ctx: t, d: DHExp.t): DHExp.t => { | MatchRule(scr, p, ctx, (lr, rr)) => let d = compose(ctx, d); Match(scr, ListUtil.rev_concat(lr, [(p, d), ...rr])) |> wrap; + | TypAp(ctx, ty) => + let d = compose(ctx, d); + TypAp(d, ty) |> wrap; } ); }; diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index 897cc667fb..1787b271a7 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -233,7 +233,7 @@ and matches_typ = (d: Typ.t, f: Typ.t) => { and matches_rul = (env, (dp, d), (fp, f)) => { matches_pat(dp, fp) && matches_exp(env, d, f); } -and matches_utpat = (d: Term.UTPat.t, f: Term.UTPat.t): bool => { +and matches_utpat = (d: TPat.t, f: TPat.t): bool => { switch (d.term, f.term) { | (Invalid(_), _) => false | (_, Invalid(_)) => false diff --git a/src/haz3lcore/dynamics/Stepper.re b/src/haz3lcore/dynamics/Stepper.re index 594949dbff..601d4344cb 100644 --- a/src/haz3lcore/dynamics/Stepper.re +++ b/src/haz3lcore/dynamics/Stepper.re @@ -91,9 +91,9 @@ let rec matches = let+ ctx = matches(env, flt, ctx, exp, act, idx); Ap2(dir, d1, ctx) |> rewrap; | TypAp(ctx, ty) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - TypAp(ctx, ty); - | DeferredAp1(ctx, d2) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + TypAp(ctx, ty) |> rewrap; + | DeferredAp1(ctx, d2) => let+ ctx = matches(env, flt, ctx, exp, act, idx); DeferredAp1(ctx, d2) |> rewrap; | DeferredAp2(d1, ctx, ds) => diff --git a/src/haz3lcore/dynamics/Substitution.re b/src/haz3lcore/dynamics/Substitution.re index e83687c854..4b3fe72bfb 100644 --- a/src/haz3lcore/dynamics/Substitution.re +++ b/src/haz3lcore/dynamics/Substitution.re @@ -45,7 +45,8 @@ let rec subst_var = (m, d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => { let d3 = subst_var(m, d1, x, d3); Fun(dp, d3, env', s) |> rewrap; }; - | TypFun(tpat, d3, s) => TypFun(tpat, subst_var(d1, x, d3), s) + | TypFun(tpat, d3, s) => + TypFun(tpat, subst_var(m, d1, x, d3), s) |> rewrap | Closure(env, d3) => /* Closure shouldn't appear during substitution (which only is called from elaboration currently) */ @@ -121,6 +122,9 @@ let rec subst_var = (m, d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => { let d3 = subst_var(m, d1, x, d3); let d4s = List.map(subst_var(m, d1, x), d4s); DeferredAp(d3, d4s) |> rewrap; + | TypAp(d3, ut) => + let d3 = subst_var(m, d1, x, d3); + TypAp(d3, ut) |> rewrap; }; } diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index 57799febb4..33a6455741 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -278,62 +278,45 @@ module Transition = (EV: EV_MODE) => { is_value: true, }); | TypAp(d, tau) => - let. _ = otherwise(env, d => TypAp(d, tau)) - and. d' = req_value(req(state, env), d => TypAp(d, tau), d); - switch (d') { + let. _ = otherwise(env, d => TypAp(d, tau) |> rewrap) + and. d' = + req_value(req(state, env), d => TypAp(d, tau) |> wrap_ctx, d); + switch (DHExp.term_of(d')) { | TypFun(utpat, tfbody, name) => /* Rule ITTLam */ - switch (Term.UTPat.tyvar_of_utpat(utpat)) { - | Some(tyvar) => - /* Perform substitution */ - Step({ - apply: () => - DHExp.assign_name_if_none( - /* Inherit name for user clarity */ - DHExp.ty_subst(tau, tyvar, tfbody), - Option.map( - x => x ++ "@<" ++ Typ.pretty_print(tau) ++ ">", - name, - ), - ), - kind: TypFunAp, - value: false, - }) - | None => - /* Treat a hole or invalid tyvar name as a unique type variable that doesn't appear anywhere else. Thus instantiating it at anything doesn't produce any substitutions. */ - Step({ - apply: () => - DHExp.assign_name_if_none( - tfbody, - Option.map( - x => x ++ "@<" ++ Typ.pretty_print(tau) ++ ">", - name, - ), + Step({ + expr: + DHExp.assign_name_if_none( + /* Inherit name for user clarity */ + DHExp.ty_subst(tau, utpat, tfbody), + Option.map( + x => x ++ "@<" ++ Typ.pretty_print(tau) ++ ">", + name, ), - kind: TypFunAp, - value: false, - }) - } - | Cast(d'', Forall(x, t), Forall(x', t')) => + ), + state_update, + kind: TypFunAp, + is_value: false, + }) + | Cast( + d'', + {term: Forall(tp1, _), _} as t1, + {term: Forall(tp2, _), _} as t2, + ) => /* Rule ITTApCast */ Step({ - apply: () => + expr: Cast( - TypAp(d'', tau), - Typ.subst(tau, x, t), - Typ.subst(tau, x', t'), - ), + TypAp(d'', tau) |> Exp.fresh, + Typ.subst(tau, tp1, t1), + Typ.subst(tau, tp2, t2), + ) + |> Exp.fresh, + state_update, kind: CastTypAp, - value: false, - }) - | _ => - Step({ - apply: () => { - raise(EvaluatorError.Exception(InvalidBoxedTypFun(d'))); - }, - kind: InvalidStep, - value: true, + is_value: false, }) + | _ => raise(EvaluatorError.Exception(InvalidBoxedTypFun(d'))) }; | DeferredAp(d1, ds) => let. _ = otherwise(env, (d1, ds) => DeferredAp(d1, ds) |> rewrap) diff --git a/src/haz3lcore/dynamics/Unboxing.re b/src/haz3lcore/dynamics/Unboxing.re index 49c2aa69e2..cf722892a1 100644 --- a/src/haz3lcore/dynamics/Unboxing.re +++ b/src/haz3lcore/dynamics/Unboxing.re @@ -138,7 +138,9 @@ let rec unbox: type a. (unbox_request(a), DHExp.t) => unboxed(a) = ListLit(_) | Tuple(_) | Cast(_) | - Ap(_, {term: Constructor(_), _}, _), + Ap(_, {term: Constructor(_), _}, _) | + TypFun(_) | + TypAp(_), ) => switch (request) { | Bool => raise(EvaluatorError.Exception(InvalidBoxedBoolLit(expr))) diff --git a/src/haz3lcore/lang/term/TPat.re b/src/haz3lcore/lang/term/TPat.re index 744964b9df..c3e0671b67 100644 --- a/src/haz3lcore/lang/term/TPat.re +++ b/src/haz3lcore/lang/term/TPat.re @@ -1 +1,37 @@ -include Term.TPat; +[@deriving (show({with_path: false}), sexp, yojson)] +type cls = + | Invalid + | EmptyHole + | MultiHole + | Var; + +include TermBase.TPat; + +let rep_id: t => Id.t = IdTagged.rep_id; +let fresh: term => t = IdTagged.fresh; + +let hole = (tms: list(TermBase.Any.t)) => + switch (tms) { + | [] => EmptyHole + | [_, ..._] => MultiHole(tms) + }; + +let cls_of_term: term => cls = + fun + | Invalid(_) => Invalid + | EmptyHole => EmptyHole + | MultiHole(_) => MultiHole + | Var(_) => Var; + +let show_cls: cls => string = + fun + | Invalid => "Invalid type alias" + | MultiHole => "Broken type alias" + | EmptyHole => "Empty type alias hole" + | Var => "Type alias"; + +let tyvar_of_utpat = ({term, _}: t) => + switch (term) { + | Var(x) => Some(x) + | _ => None + }; diff --git a/src/haz3lcore/lang/term/Typ.re b/src/haz3lcore/lang/term/Typ.re index 6bebfe4770..6c4c4084ef 100644 --- a/src/haz3lcore/lang/term/Typ.re +++ b/src/haz3lcore/lang/term/Typ.re @@ -20,7 +20,8 @@ type cls = | Constructor | Parens | Ap - | Rec; + | Rec + | Forall; include TermBase.Typ; @@ -53,7 +54,8 @@ let cls_of_term: term => cls = | Parens(_) => Parens | Ap(_) => Ap | Sum(_) => Sum - | Rec(_) => Rec; + | Rec(_) => Rec + | Forall(_) => Forall; let show_cls: cls => string = fun @@ -74,7 +76,8 @@ let show_cls: cls => string = | Sum => "Sum type" | Parens => "Parenthesized type" | Ap => "Constructor application" - | Rec => "Recursive Type"; + | Rec => "Recursive type" + | Forall => "Forall type"; let rec is_arrow = (typ: t) => { switch (typ.term) { @@ -90,6 +93,26 @@ let rec is_arrow = (typ: t) => { | Var(_) | Ap(_) | Sum(_) + | Forall(_) + | Rec(_) => false + }; +}; + +let rec is_forall = (typ: t) => { + switch (typ.term) { + | Parens(typ) => is_forall(typ) + | Forall(_) => true + | Unknown(_) + | Int + | Float + | Bool + | String + | Arrow(_) + | List(_) + | Prod(_) + | Var(_) + | Ap(_) + | Sum(_) | Rec(_) => false }; }; @@ -114,8 +137,17 @@ let rec to_typ: (Ctx.t, t) => t = | Sum(uts) => Sum(to_ctr_map(ctx, uts)) |> rewrap | List(u) => List(to_typ(ctx, u)) |> rewrap | Parens(u) => to_typ(ctx, u) - /* The below cases should occur only inside sums */ - | Ap(_) => Unknown(Internal) |> rewrap + | Forall({term: Invalid(_), _} as tpat, tbody) + | Forall({term: EmptyHole, _} as tpat, tbody) + | Forall({term: MultiHole(_), _} as tpat, tbody) => + Forall(tpat, to_typ(ctx, tbody)) |> rewrap + | Forall({term: Var(name), _} as utpat, tbody) => + let ctx = + Ctx.extend_tvar( + ctx, + {name, id: IdTagged.rep_id(utpat), kind: Abstract}, + ); + Forall(utpat, to_typ(ctx, tbody)) |> rewrap; | Rec({term: Invalid(_), _} as tpat, tbody) | Rec({term: EmptyHole, _} as tpat, tbody) | Rec({term: MultiHole(_), _} as tpat, tbody) => @@ -127,6 +159,8 @@ let rec to_typ: (Ctx.t, t) => t = {name, id: IdTagged.rep_id(utpat), kind: Abstract}, ); Rec(utpat, to_typ(ctx, tbody)) |> rewrap; + /* The below cases should occur only inside sums */ + | Ap(_) => Unknown(Internal) |> rewrap }; } and to_variant: @@ -178,42 +212,81 @@ let join_type_provenance = | (SynSwitch, SynSwitch) => SynSwitch }; -let rec subst = (s: t, x: string, ty: t) => { - let (term, rewrap) = unwrap(ty); - switch (term) { - | Int => Int |> rewrap - | Float => Float |> rewrap - | Bool => Bool |> rewrap - | String => String |> rewrap - | Unknown(prov) => Unknown(prov) |> rewrap - | Arrow(ty1, ty2) => Arrow(subst(s, x, ty1), subst(s, x, ty2)) |> rewrap - | Prod(tys) => Prod(List.map(subst(s, x), tys)) |> rewrap - | Sum(sm) => - Sum(ConstructorMap.map(Option.map(subst(s, x)), sm)) |> rewrap - | Rec({term: Var(y), _} as tp, ty) when x == y => Rec(tp, ty) |> rewrap - | Rec(y, ty) => Rec(y, subst(s, x, ty)) |> rewrap - | List(ty) => List(subst(s, x, ty)) |> rewrap - | Var(y) => x == y ? s : Var(y) |> rewrap - | Parens(ty) => Parens(subst(s, x, ty)) |> rewrap - | Ap(t1, t2) => Ap(subst(s, x, t1), subst(s, x, t2)) |> rewrap +let rec free_vars = (~bound=[], ty: t): list(Var.t) => + switch (term_of(ty)) { + | Unknown(_) + | Int + | Float + | Bool + | String => [] + | Ap(t1, t2) => free_vars(~bound, t1) @ free_vars(~bound, t2) + | Var(v) => List.mem(v, bound) ? [] : [v] + | Parens(ty) => free_vars(~bound, ty) + | List(ty) => free_vars(~bound, ty) + | Arrow(t1, t2) => free_vars(~bound, t1) @ free_vars(~bound, t2) + | Sum(sm) => ConstructorMap.free_variables(free_vars(~bound), sm) + | Prod(tys) => ListUtil.flat_map(free_vars(~bound), tys) + | Rec(x, ty) + | Forall(x, ty) => + free_vars(~bound=(x |> TPat.tyvar_of_utpat |> Option.to_list) @ bound, ty) + }; + +let var_count = ref(0); +let fresh_var = (var_name: string) => { + let x = var_count^; + var_count := x + 1; + var_name ++ "_α" ++ string_of_int(x); +}; + +let rec subst = (s: t, x: TPat.t, ty: t) => { + switch (TPat.tyvar_of_utpat(x)) { + | Some(str) => + let (term, rewrap) = unwrap(ty); + switch (term) { + | Int => Int |> rewrap + | Float => Float |> rewrap + | Bool => Bool |> rewrap + | String => String |> rewrap + | Unknown(prov) => Unknown(prov) |> rewrap + | Arrow(ty1, ty2) => + Arrow(subst(s, x, ty1), subst(s, x, ty2)) |> rewrap + | Prod(tys) => Prod(List.map(subst(s, x), tys)) |> rewrap + | Sum(sm) => + Sum(ConstructorMap.map(Option.map(subst(s, x)), sm)) |> rewrap + | Forall(tp2, ty) + when TPat.tyvar_of_utpat(x) == TPat.tyvar_of_utpat(tp2) => + Forall(tp2, ty) |> rewrap + | Forall(tp2, ty) => Forall(tp2, subst(s, x, ty)) |> rewrap + | Rec(tp2, ty) when TPat.tyvar_of_utpat(x) == TPat.tyvar_of_utpat(tp2) => + Rec(tp2, ty) |> rewrap + | Rec(tp2, ty) => Rec(tp2, subst(s, x, ty)) |> rewrap + | List(ty) => List(subst(s, x, ty)) |> rewrap + | Var(y) => str == y ? s : Var(y) |> rewrap + | Parens(ty) => Parens(subst(s, x, ty)) |> rewrap + | Ap(t1, t2) => Ap(subst(s, x, t1), subst(s, x, t2)) |> rewrap + }; + | None => ty }; }; let unroll = (ty: t): t => switch (term_of(ty)) { - | Rec({term: Var(x), _}, ty_body) => subst(ty, x, ty_body) + | Rec(tp, ty_body) => subst(ty, tp, ty_body) | _ => ty }; -/* Type Equality: At the moment, this coincides with alpha equivalence, - but this will change when polymorphic types are implemented */ -let rec eq = (t1: t, t2: t): bool => { +/* Type Equality: This coincides with alpha equivalence for normalized types. + Other types may be equivalent but this will not detect so if they are not normalized. */ +let rec eq_internal = (n: int, t1: t, t2: t) => { switch (term_of(t1), term_of(t2)) { - | (Parens(t1), _) => eq(t1, t2) - | (_, Parens(t2)) => eq(t1, t2) - | (Rec({term: Var(x1), _}, t1), Rec({term: Var(x2), _}, t2)) => - eq(t1, subst(fresh(Var(x1)), x2, t2)) + | (Parens(t1), _) => eq_internal(n, t1, t2) + | (_, Parens(t2)) => eq_internal(n, t1, t2) + | (Rec(x1, t1), Rec(x2, t2)) + | (Forall(x1, t1), Forall(x2, t2)) => + let alpha_subst = subst(Var("=" ++ string_of_int(n)) |> fresh); + eq_internal(n + 1, alpha_subst(x1, t1), alpha_subst(x2, t2)); | (Rec(_), _) => false + | (Forall(_), _) => false | (Int, Int) => true | (Int, _) => false | (Float, Float) => true @@ -222,40 +295,28 @@ let rec eq = (t1: t, t2: t): bool => { | (Bool, _) => false | (String, String) => true | (String, _) => false + | (Ap(t1, t2), Ap(t1', t2')) => + eq_internal(n, t1, t1') && eq_internal(n, t2, t2') + | (Ap(_), _) => false | (Unknown(_), Unknown(_)) => true | (Unknown(_), _) => false - | (Arrow(t1, t2), Arrow(t1', t2')) => eq(t1, t1') && eq(t2, t2') + | (Arrow(t1, t2), Arrow(t1', t2')) => + eq_internal(n, t1, t1') && eq_internal(n, t2, t2') | (Arrow(_), _) => false - | (Prod(tys1), Prod(tys2)) => List.equal(eq, tys1, tys2) + | (Prod(tys1), Prod(tys2)) => List.equal(eq_internal(n), tys1, tys2) | (Prod(_), _) => false - | (List(t1), List(t2)) => eq(t1, t2) + | (List(t1), List(t2)) => eq_internal(n, t1, t2) | (List(_), _) => false - | (Sum(sm1), Sum(sm2)) => ConstructorMap.equal(eq, sm1, sm2) + | (Sum(sm1), Sum(sm2)) => + /* Does not normalize the types. */ + ConstructorMap.equal(eq_internal(n), sm1, sm2) | (Sum(_), _) => false | (Var(n1), Var(n2)) => n1 == n2 | (Var(_), _) => false - | (Ap(t1, t2), Ap(t3, t4)) => eq(t1, t3) && eq(t2, t4) - | (Ap(_), _) => false }; }; -let rec free_vars = (~bound=[], ty: t): list(Var.t) => - switch (term_of(ty)) { - | Unknown(_) - | Int - | Float - | Bool - | String => [] - | Var(v) => List.mem(v, bound) ? [] : [v] - | Parens(ty) - | List(ty) => free_vars(~bound, ty) - | Ap(t1, t2) - | Arrow(t1, t2) => free_vars(~bound, t1) @ free_vars(~bound, t2) - | Sum(sm) => ConstructorMap.free_variables(free_vars(~bound), sm) - | Prod(tys) => ListUtil.flat_map(free_vars(~bound), tys) - | Rec({term: Var(x), _}, ty) => free_vars(~bound=[x, ...bound], ty) - | Rec(_, ty) => free_vars(~bound, ty) - }; +let eq = (t1: t, t2: t): bool => eq_internal(0, t1, t2); /* Lattice join on types. This is a LUB join in the hazel2 sense in that any type dominates Unknown. The optional @@ -294,19 +355,32 @@ let rec join = (~resolve=false, ~fix, ctx: Ctx.t, ty1: t, ty2: t): option(t) => let+ ty_join = join'(ty_name, ty1); !resolve && eq(ty_name, ty_join) ? ty2 : ty_join; /* Note: Ordering of Unknown, Var, and Rec above is load-bearing! */ - | (Rec({term: Var(x1), _} as tp1, ty1), Rec({term: Var(x2), _}, ty2)) => - /* TODO: - This code isn't fully correct, as we may be doing - substitution on open terms; if x1 occurs in ty2, - we should be substituting x1 for a fresh variable - in ty2. This is annoying, and should be obviated - by the forthcoming debruijn index implementation - */ - let ctx = Ctx.extend_dummy_tvar(ctx, x1); - let+ ty_body = - join(~resolve, ~fix, ctx, ty1, subst(Var(x1) |> fresh, x2, ty2)); + | (Rec(tp1, ty1), Rec(tp2, ty2)) => + let ctx = Ctx.extend_dummy_tvar(ctx, tp1); + let ty1' = + switch (TPat.tyvar_of_utpat(tp2)) { + | Some(x2) => subst(Var(x2) |> fresh, tp1, ty1) + | None => ty1 + }; + let+ ty_body = join(~resolve, ~fix, ctx, ty1', ty2); Rec(tp1, ty_body) |> fresh; | (Rec(_), _) => None + | (Forall(x1, ty1), Forall(x2, ty2)) => + let ctx = Ctx.extend_dummy_tvar(ctx, x1); + let ty1' = + switch (TPat.tyvar_of_utpat(x2)) { + | Some(x2) => subst(Var(x2) |> fresh, x1, ty1) + | None => ty1 + }; + let+ ty_body = join(~resolve, ~fix, ctx, ty1', ty2); + Forall(x1, ty_body) |> fresh; + /* Note for above: there is no danger of free variable capture as + subst itself performs capture avoiding substitution. However this + may generate internal type variable names that in corner cases can + be exposed to the user. We preserve the variable name of the + second type to preserve synthesized type variable names, which + come from user annotations. */ + | (Forall(_), _) => None | (Int, Int) => Some(Int |> fresh) | (Int, _) => None | (Float, Float) => Some(Float |> fresh) @@ -352,7 +426,8 @@ let rec match_synswitch = (t1: t, t2: t) => { | (String, _) | (Var(_), _) | (Ap(_), _) - | (Rec(_), _) => t1 + | (Rec(_), _) + | (Forall(_), _) => t1 // These might | (List(ty1), List(ty2)) => List(match_synswitch(ty1, ty2)) |> rewrap1 | (List(_), _) => t1 @@ -413,12 +488,13 @@ let rec normalize = (ctx: Ctx.t, ty: t): t => { | Prod(ts) => Prod(List.map(normalize(ctx), ts)) |> rewrap | Sum(ts) => Sum(ConstructorMap.map(Option.map(normalize(ctx)), ts)) |> rewrap - | Rec({term: Var(name), _} as tpat, ty) => + | Rec(tpat, ty) => /* NOTE: Dummy tvar added has fake id but shouldn't matter as in current implementation Recs do not occur in the surface syntax, so we won't try to jump to them. */ - Rec(tpat, normalize(Ctx.extend_dummy_tvar(ctx, name), ty)) |> rewrap - | Rec(tpat, ty) => Rec(tpat, normalize(ctx, ty)) |> rewrap + Rec(tpat, normalize(Ctx.extend_dummy_tvar(ctx, tpat), ty)) |> rewrap + | Forall(name, ty) => + Forall(name, normalize(Ctx.extend_dummy_tvar(ctx, name), ty)) |> rewrap }; }; @@ -432,6 +508,13 @@ let matched_arrow = (ctx, ty) => | _ => (Unknown(Internal) |> fresh, Unknown(Internal) |> fresh) }; +let matched_forall = (ctx, ty) => + switch (term_of(weak_head_normalize(ctx, ty))) { + | Forall(t, ty) => (Some(t), ty) + | Unknown(SynSwitch) => (None, Unknown(SynSwitch) |> fresh) + | _ => (None, Unknown(Internal) |> fresh) + }; + let matched_prod = (ctx, length, ty) => switch (term_of(weak_head_normalize(ctx, ty))) { | Prod(tys) when List.length(tys) == length => tys @@ -492,3 +575,80 @@ let is_unknown = (ty: t): bool => | Unknown(_) => true | _ => false }; + +/* Does the type require parentheses when on the left of an arrow for printing? */ +let rec needs_parens = (ty: t): bool => + switch (term_of(ty)) { + | Parens(ty) => needs_parens(ty) + | Ap(_) + | Unknown(_) + | Int + | Float + | String + | Bool + | Var(_) => false + | Rec(_, _) + | Forall(_, _) => true + | List(_) => false /* is already wrapped in [] */ + | Arrow(_, _) => true + | Prod(_) + | Sum(_) => true /* disambiguate between (A + B) -> C and A + (B -> C) */ + }; + +let pretty_print_tvar = (tv: TPat.t): string => + switch (IdTagged.term_of(tv)) { + | Var(x) => x + | Invalid(_) + | EmptyHole + | MultiHole(_) => "?" + }; + +/* Essentially recreates haz3lweb/view/Type.re's view_ty but with string output */ +let rec pretty_print = (ty: t): string => + switch (term_of(ty)) { + | Parens(ty) => pretty_print(ty) + | Ap(_) + | Unknown(_) => "?" + | Int => "Int" + | Float => "Float" + | Bool => "Bool" + | String => "String" + | Var(tvar) => tvar + | List(t) => "[" ++ pretty_print(t) ++ "]" + | Arrow(t1, t2) => paren_pretty_print(t1) ++ "->" ++ pretty_print(t2) + | Sum(sm) => + switch (sm) { + | [] => "+?" + | [t0] => "+" ++ ctr_pretty_print(t0) + | [t0, ...ts] => + List.fold_left( + (acc, t) => acc ++ "+" ++ ctr_pretty_print(t), + ctr_pretty_print(t0), + ts, + ) + } + | Prod([]) => "()" + | Prod([t0, ...ts]) => + "(" + ++ List.fold_left( + (acc, t) => acc ++ ", " ++ pretty_print(t), + pretty_print(t0), + ts, + ) + ++ ")" + | Rec(tv, t) => "rec " ++ pretty_print_tvar(tv) ++ "->" ++ pretty_print(t) + | Forall(tv, t) => + "forall " ++ pretty_print_tvar(tv) ++ "->" ++ pretty_print(t) + } +and ctr_pretty_print = + fun + | ConstructorMap.Variant(ctr, _, None) => ctr + | ConstructorMap.Variant(ctr, _, Some(t)) => + ctr ++ "(" ++ pretty_print(t) ++ ")" + | ConstructorMap.BadEntry(_) => "?" +and paren_pretty_print = typ => + if (needs_parens(typ)) { + "(" ++ pretty_print(typ) ++ ")"; + } else { + pretty_print(typ); + }; diff --git a/src/haz3lcore/statics/Ctx.re b/src/haz3lcore/statics/Ctx.re index 466d654118..759cceef71 100644 --- a/src/haz3lcore/statics/Ctx.re +++ b/src/haz3lcore/statics/Ctx.re @@ -37,8 +37,11 @@ let extend_tvar = (ctx: t, tvar_entry: tvar_entry): t => let extend_alias = (ctx: t, name: string, id: Id.t, ty: TermBase.Typ.t): t => extend_tvar(ctx, {name, id, kind: Singleton(ty)}); -let extend_dummy_tvar = (ctx: t, name: string) => - extend_tvar(ctx, {kind: Abstract, name, id: Id.invalid}); +let extend_dummy_tvar = (ctx: t, tvar: TPat.t) => + switch (TPat.tyvar_of_utpat(tvar)) { + | Some(name) => extend_tvar(ctx, {kind: Abstract, name, id: Id.invalid}) + | None => ctx + }; let lookup_tvar = (ctx: t, name: string): option(tvar_entry) => List.find_map( @@ -83,6 +86,12 @@ let is_alias = (ctx: t, name: string): bool => | None => false }; +let is_abstract = (ctx: t, name: string): bool => + switch (lookup_tvar(ctx, name)) { + | Some({kind: Abstract, _}) => true + | _ => false + }; + let add_ctrs = (ctx: t, name: string, id: Id.t, ctrs: TermBase.Typ.sum_map): t => List.filter_map( fun diff --git a/src/haz3lcore/statics/Info.re b/src/haz3lcore/statics/Info.re index 17acf5e23a..7c5681d487 100644 --- a/src/haz3lcore/statics/Info.re +++ b/src/haz3lcore/statics/Info.re @@ -323,13 +323,28 @@ let rec status_common = | (Just(ty), Syn) => NotInHole(Syn(ty)) | (Just(ty), SynFun) => switch ( - Typ.join_fix(ctx, Arrow(Unknown(Internal), Unknown(Internal)), ty) + Typ.join_fix( + ctx, + Arrow( + Unknown(Internal) |> Typ.fresh, + Unknown(Internal) |> Typ.fresh, + ) + |> Typ.fresh, + ty, + ) ) { | Some(_) => NotInHole(Syn(ty)) | None => InHole(Inconsistent(WithArrow(ty))) } | (Just(ty), SynTypFun) => - switch (Typ.join_fix(ctx, Forall("?", Unknown(Internal)), ty)) { + switch ( + Typ.join_fix( + ctx, + Forall(Var("?") |> TPat.fresh, Unknown(Internal) |> Typ.fresh) + |> Typ.fresh, + ty, + ) + ) { | Some(_) => NotInHole(Syn(ty)) | None => InHole(Inconsistent(WithArrow(ty))) } @@ -344,21 +359,6 @@ let rec status_common = | None => InHole(Inconsistent(Expectation({syn, ana}))) | Some(join) => NotInHole(Ana(Consistent({ana, syn, join}))) } - | (Just(syn), SynFun) => - switch ( - Typ.join_fix( - ctx, - Arrow( - Unknown(Internal) |> Typ.fresh, - Unknown(Internal) |> Typ.fresh, - ) - |> Typ.fresh, - syn, - ) - ) { - | None => InHole(Inconsistent(WithArrow(syn))) - | Some(_) => NotInHole(Syn(syn)) - } | (IsConstructor({name, syn_ty}), _) => /* If a ctr is being analyzed against (an arrow type returning) a sum type having that ctr as a variant, its self type is @@ -444,7 +444,7 @@ let status_typ = | false => switch (Ctx.is_abstract(ctx, name)) { | false => InHole(FreeTypeVariable(name)) - | true => NotInHole(Type(Var(name))) + | true => NotInHole(Type(Var(name) |> Typ.fresh)) } | true => NotInHole(TypeAlias(name, Typ.weak_head_normalize(ctx, ty))) } diff --git a/src/haz3lcore/statics/MakeTerm.re b/src/haz3lcore/statics/MakeTerm.re index 2528dff63f..05f4d91438 100644 --- a/src/haz3lcore/statics/MakeTerm.re +++ b/src/haz3lcore/statics/MakeTerm.re @@ -186,7 +186,7 @@ and exp_term: unsorted => (UExp.term, list(Id.t)) = { | (["!"], []) => UnOp(Bool(Not), r) | (["fun", "->"], [Pat(pat)]) => Fun(pat, r, None, None) | (["fix", "->"], [Pat(pat)]) => FixF(pat, r, None) - | (["typfun", "->"], [TPat(tpat)]) => TypFun(tpat, r) + | (["typfun", "->"], [TPat(tpat)]) => TypFun(tpat, r, None) | (["let", "=", "in"], [Pat(pat), Exp(def)]) => Let(pat, def, r) | (["hide", "in"], [Exp(filter)]) => Filter(Filter({act: (Eval, One), pat: filter}), r) @@ -404,7 +404,7 @@ and typ_term: unsorted => (UTyp.term, list(Id.t)) = { ret(Forall(tpat, t)) | Pre(([(_id, (["rec", "->"], [TPat(tpat)]))], []), Typ(t)) => ret(Rec(tpat, t)) - | Pre(tiles, Typ({term: Sum(t0), ids})) as tm => + | Pre(tiles, Typ({term: Sum(t0), ids, _})) as tm => /* Case for leading prefix + preceeding a sum */ switch (tiles) { | ([(_, (["+"], []))], []) => (Sum(t0), ids) diff --git a/src/haz3lcore/statics/Mode.re b/src/haz3lcore/statics/Mode.re index fb861d7df0..1172d45a3e 100644 --- a/src/haz3lcore/statics/Mode.re +++ b/src/haz3lcore/statics/Mode.re @@ -32,8 +32,10 @@ let ty_of: t => Typ.t = | Ana(ty) => ty | Syn => Unknown(SynSwitch) |> Typ.fresh | SynFun => - Arrow(Unknown(SynSwitch) |> Typ.fresh, Unknown(SynSwitch)) - | SynTypFun => Forall("syntypfun", Unknown(SynSwitch) |> Typ.fresh) + Arrow(Unknown(SynSwitch) |> Typ.fresh, Unknown(SynSwitch) |> Typ.fresh) + |> Typ.fresh + | SynTypFun => + Forall(Var("syntypfun") |> TPat.fresh, Unknown(SynSwitch) |> Typ.fresh) |> Typ.fresh; /* TODO: naming the type variable? */ let of_arrow = (ctx: Ctx.t, mode: t): (t, t) => @@ -44,7 +46,7 @@ let of_arrow = (ctx: Ctx.t, mode: t): (t, t) => | Ana(ty) => ty |> Typ.matched_arrow(ctx) |> TupleUtil.map2(ana) }; -let of_forall = (ctx: Ctx.t, name_opt: option(TypVar.t), mode: t): t => +let of_forall = (ctx: Ctx.t, name_opt: option(string), mode: t): t => switch (mode) { | Syn | SynFun @@ -53,7 +55,7 @@ let of_forall = (ctx: Ctx.t, name_opt: option(TypVar.t), mode: t): t => let (name_expected_opt, item) = Typ.matched_forall(ctx, ty); switch (name_opt, name_expected_opt) { | (Some(name), Some(name_expected)) => - Ana(Typ.subst(Var(name), name_expected, item)) + Ana(Typ.subst(Var(name) |> Typ.fresh, name_expected, item)) | _ => Ana(item) }; }; diff --git a/src/haz3lcore/statics/Statics.re b/src/haz3lcore/statics/Statics.re index 926f9b5612..592c8ec295 100644 --- a/src/haz3lcore/statics/Statics.re +++ b/src/haz3lcore/statics/Statics.re @@ -66,19 +66,20 @@ let add_info = (ids: list(Id.t), info: Info.t, m: Map.t): Map.t => ids |> List.fold_left((m, id) => Id.Map.add(id, info, m), m); let is_recursive = (ctx, p, def, syn: Typ.t) => { - switch (Term.UPat.get_num_of_vars(p), Term.UExp.get_num_of_functions(def)) { + switch (Pat.get_num_of_vars(p), Exp.get_num_of_functions(def)) { | (Some(num_vars), Some(num_fns)) when num_vars != 0 && num_vars == num_fns => - switch (Typ.normalize(ctx, syn)) { + switch (Typ.term_of(Typ.normalize(ctx, syn))) { | Unknown(_) | Arrow(_) => num_vars == 1 | Prod(syns) when List.length(syns) == num_vars => syns - |> List.for_all( - fun + |> List.for_all(x => + switch (Typ.term_of(x)) { | Typ.Unknown(_) | Arrow(_) => true - | _ => false, + | _ => false + } ) | _ => false } @@ -355,7 +356,7 @@ and uexp_to_info_map = let (fn, m) = go(~mode=typfn_mode, fn, m); let (_, m) = utyp_to_info_map(~ctx, ~ancestors, utyp, m); let (option_name, ty_body) = Typ.matched_forall(ctx, fn.ty); - let ty = Term.UTyp.to_typ(ctx, utyp); + let ty = Typ.to_typ(ctx, utyp); switch (option_name) { | Some(name) => add(~self=Just(Typ.subst(ty, name, ty_body)), ~co_ctx=fn.co_ctx, m) @@ -385,22 +386,27 @@ and uexp_to_info_map = ~co_ctx=CoCtx.mk(ctx, p.ctx, e.co_ctx), m, ); - | TypFun({term: Var(name), _} as utpat, body) + | TypFun({term: Var(name), _} as utpat, body, _) when !Ctx.shadows_typ(ctx, name) => let mode_body = Mode.of_forall(ctx, Some(name), mode); let m = utpat_to_info_map(~ctx, ~ancestors, utpat, m) |> snd; let ctx_body = - Ctx.extend_tvar( - ctx, - {name, id: Term.UTPat.rep_id(utpat), kind: Abstract}, - ); + Ctx.extend_tvar(ctx, {name, id: TPat.rep_id(utpat), kind: Abstract}); let (body, m) = go'(~ctx=ctx_body, ~mode=mode_body, body, m); - add(~self=Just(Forall(name, body.ty)), ~co_ctx=body.co_ctx, m); - | TypFun(utpat, body) => + add( + ~self=Just(Forall(utpat, body.ty) |> Typ.fresh), + ~co_ctx=body.co_ctx, + m, + ); + | TypFun(utpat, body, _) => let mode_body = Mode.of_forall(ctx, None, mode); let m = utpat_to_info_map(~ctx, ~ancestors, utpat, m) |> snd; let (body, m) = go(~mode=mode_body, body, m); - add(~self=Just(Forall("?", body.ty)), ~co_ctx=body.co_ctx, m); + add( + ~self=Just(Forall(utpat, body.ty) |> Typ.fresh), + ~co_ctx=body.co_ctx, + m, + ); | Let(p, def, body) => let (p_syn, _) = go_pat(~is_synswitch=true, ~co_ctx=CoCtx.empty, ~mode=Syn, p, m); @@ -433,16 +439,20 @@ and uexp_to_info_map = let def_ctx = p_ana'.ctx; let (def_base2, _) = go'(~ctx=def_ctx, ~mode=Ana(p_syn.ty), def, m); let ana_ty_fn = ((ty_fn1, ty_fn2), ty_p) => { - ty_p == Typ.Unknown(SynSwitch) && !Typ.eq(ty_fn1, ty_fn2) + Typ.term_of(ty_p) == Typ.Unknown(SynSwitch) + && !Typ.eq(ty_fn1, ty_fn2) ? ty_fn1 : ty_p; }; let ana = - switch ((def_base.ty, def_base2.ty), p_syn.ty) { + switch ( + (def_base.ty |> Typ.term_of, def_base2.ty |> Typ.term_of), + p_syn.ty |> Typ.term_of, + ) { | ((Prod(ty_fns1), Prod(ty_fns2)), Prod(ty_ps)) => let tys = List.map2(ana_ty_fn, List.combine(ty_fns1, ty_fns2), ty_ps); - Typ.Prod(tys); - | ((ty_fn1, ty_fn2), ty_p) => ana_ty_fn((ty_fn1, ty_fn2), ty_p) + Typ.Prod(tys) |> Typ.fresh; + | ((_, _), _) => ana_ty_fn((def_base.ty, def_base2.ty), p_syn.ty) }; let (def, m) = go'(~ctx=def_ctx, ~mode=Ana(ana), def, m); (def, def_ctx, m, ty_p_ana); @@ -535,7 +545,7 @@ and uexp_to_info_map = tentatively add an abtract type to the ctx, representing the speculative rec parameter. */ let (ty_def, ctx_def, ctx_body) = { - let ty_pre = UTyp.to_typ(Ctx.extend_dummy_tvar(ctx, name), utyp); + let ty_pre = UTyp.to_typ(Ctx.extend_dummy_tvar(ctx, typat), utyp); switch (utyp.term) { | Sum(_) when List.mem(name, Typ.free_vars(ty_pre)) => /* NOTE: When debugging type system issues it may be beneficial to @@ -572,7 +582,7 @@ and uexp_to_info_map = let ({co_ctx, ty: ty_body, _}: Info.exp, m) = go'(~ctx=ctx_body, ~mode, body, m); /* Make sure types don't escape their scope */ - let ty_escape = Typ.subst(ty_def, name, ty_body); + let ty_escape = Typ.subst(ty_def, typat, ty_body); let m = utyp_to_info_map(~ctx=ctx_def, ~ancestors, utyp, m) |> snd; add(~self=Just(ty_escape), ~co_ctx, m); | Var(_) @@ -749,10 +759,7 @@ and utyp_to_info_map = add(m); | Forall({term: Var(name), _} as utpat, tbody) => let body_ctx = - Ctx.extend_tvar( - ctx, - {name, id: Term.UTPat.rep_id(utpat), kind: Abstract}, - ); + Ctx.extend_tvar(ctx, {name, id: TPat.rep_id(utpat), kind: Abstract}); let m = utyp_to_info_map( tbody, @@ -772,10 +779,7 @@ and utyp_to_info_map = add(m); // TODO: check with andrew | Rec({term: Var(name), _} as utpat, tbody) => let body_ctx = - Ctx.extend_tvar( - ctx, - {name, id: Term.UTPat.rep_id(utpat), kind: Abstract}, - ); + Ctx.extend_tvar(ctx, {name, id: TPat.rep_id(utpat), kind: Abstract}); let m = utyp_to_info_map( tbody, diff --git a/src/haz3lcore/statics/Term.re b/src/haz3lcore/statics/Term.re index 858e1e5941..4331965a52 100644 --- a/src/haz3lcore/statics/Term.re +++ b/src/haz3lcore/statics/Term.re @@ -1,45 +1,3 @@ -module TPat = { - [@deriving (show({with_path: false}), sexp, yojson)] - type cls = - | Invalid - | EmptyHole - | MultiHole - | Var; - - include TermBase.TPat; - - let rep_id = ({ids, _}: t) => { - assert(ids != []); - List.hd(ids); - }; - - let hole = (tms: list(TermBase.Any.t)) => - switch (tms) { - | [] => EmptyHole - | [_, ..._] => MultiHole(tms) - }; - - let cls_of_term: term => cls = - fun - | Invalid(_) => Invalid - | EmptyHole => EmptyHole - | MultiHole(_) => MultiHole - | Var(_) => Var; - - let show_cls: cls => string = - fun - | Invalid => "Invalid type alias" - | MultiHole => "Broken type alias" - | EmptyHole => "Empty type alias hole" - | Var => "Type alias"; - - let tyvar_of_utpat = ({ids: _, term}) => - switch (term) { - | Var(x) => Some(x) - | _ => None - }; -}; - module Pat = { [@deriving (show({with_path: false}), sexp, yojson)] type cls = @@ -120,9 +78,8 @@ module Pat = { let rec is_var = (pat: t) => { switch (pat.term) { | Parens(pat) - | TypeAnn(pat, _) => is_var(pat) + | Cast(pat, _, _) => is_var(pat) | Var(_) => true - | Cast(_) | Invalid(_) | EmptyHole | MultiHole(_) @@ -142,8 +99,7 @@ module Pat = { let rec is_fun_var = (pat: t) => { switch (pat.term) { | Parens(pat) => is_fun_var(pat) - | Cast(pat, t1, _) => is_var(pat) && Typ.is_arrow(t1) - | TypeAnn(pat, typ) => + | Cast(pat, typ, _) => is_var(pat) && (UTyp.is_arrow(typ) || Typ.is_forall(typ)) | Invalid(_) | EmptyHole @@ -208,33 +164,9 @@ module Pat = { } ); - let rec is_tuple_of_vars = (pat: t) => - is_var(pat) - || ( - switch (pat.term) { - | Parens(pat) - | TypeAnn(pat, _) => is_tuple_of_vars(pat) - | Tuple(pats) => pats |> List.for_all(is_var) - | Invalid(_) - | EmptyHole - | MultiHole(_) - | Wild - | Int(_) - | Float(_) - | Bool(_) - | String(_) - | Triv - | ListLit(_) - | Cons(_, _) - | Var(_) - | Constructor(_) - | Ap(_) => false - } - ); - let rec get_var = (pat: t) => { switch (pat.term) { - | Parens(pat) + | Parens(pat) => get_var(pat) | Var(x) => Some(x) | Cast(x, _, _) => get_var(x) | Invalid(_) @@ -449,8 +381,8 @@ module Exp = { let rec is_fun = (e: t) => { switch (e.term) { | Parens(e) => is_fun(e) - | TypFun(_) | Cast(e, _, _) => is_fun(e) + | TypFun(_) | Fun(_) | BuiltinFun(_) => true | Invalid(_) @@ -551,7 +483,12 @@ module Exp = { | Invalid(_) | EmptyHole | MultiHole(_) - | Triv + | DynamicErrorHole(_) + | FailedCast(_) + | FixF(_) + | Closure(_) + | BuiltinFun(_) + | Cast(_) | Deferral(_) | Bool(_) | Int(_) @@ -567,7 +504,6 @@ module Exp = { | Ap(_) | TypAp(_) | DeferredAp(_) - | Pipeline(_) | If(_) | Seq(_) | Test(_) diff --git a/src/haz3lcore/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index f4ed28db74..1d9c762f75 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -94,14 +94,14 @@ and Exp: { [@show.opaque] option(ClosureEnvironment.t), option(Var.t), ) - | TypFun(UTPat.t, t) + | TypFun(TPat.t, t, option(Var.t)) | Tuple(list(t)) | Var(Var.t) | Let(Pat.t, t, t) | FixF(Pat.t, t, [@show.opaque] option(ClosureEnvironment.t)) | TyAlias(TPat.t, Typ.t, t) | Ap(Operators.ap_direction, t, t) - | TypAp(t, UTyp.t) + | TypAp(t, Typ.t) | DeferredAp(t, list(t)) | If(t, t, t) | Seq(t, t) @@ -116,7 +116,8 @@ and Exp: { | BuiltinFun(string) | Match(t, list((Pat.t, t))) /* INVARIANT: in dynamic expressions, casts must be between - two consistent types. */ + two consistent types. Both types should be normalized in + dynamics for the cast calculus to work right. */ | Cast(t, Typ.t, Typ.t) and t = IdTagged.t(term); @@ -157,14 +158,14 @@ and Exp: { [@show.opaque] option(ClosureEnvironment.t), option(Var.t), ) - | TypFun(UTPat.t, t) + | TypFun(TPat.t, t, option(string)) | Tuple(list(t)) | Var(Var.t) | Let(Pat.t, t, t) | FixF(Pat.t, t, [@show.opaque] option(ClosureEnvironment.t)) | TyAlias(TPat.t, Typ.t, t) | Ap(Operators.ap_direction, t, t) // note: function is always first then argument; even in pipe mode - | TypAp(t, UTyp.t) + | TypAp(t, Typ.t) | DeferredAp(t, list(t)) | If(t, t, t) | Seq(t, t) @@ -229,6 +230,7 @@ and Exp: { | ListLit(ts) => ListLit(List.map(exp_map_term, ts)) | Fun(p, e, env, f) => Fun(pat_map_term(p), exp_map_term(e), env, f) + | TypFun(tp, e, f) => TypFun(tpat_map_term(tp), exp_map_term(e), f) | Tuple(xs) => Tuple(List.map(exp_map_term, xs)) | Let(p, e1, e2) => Let(pat_map_term(p), exp_map_term(e1), exp_map_term(e2)) @@ -236,6 +238,7 @@ and Exp: { | TyAlias(tp, t, e) => TyAlias(tpat_map_term(tp), typ_map_term(t), exp_map_term(e)) | Ap(op, e1, e2) => Ap(op, exp_map_term(e1), exp_map_term(e2)) + | TypAp(e, t) => TypAp(exp_map_term(e), typ_map_term(t)) | DeferredAp(e, es) => DeferredAp(exp_map_term(e), List.map(exp_map_term, es)) | If(e1, e2, e3) => @@ -393,7 +396,7 @@ and Typ: { | Parens(t) | Ap(t, t) | Rec(TPat.t, t) - | Forall(UTPat.t, t) + | Forall(TPat.t, t) and t = IdTagged.t(term); type sum_map = ConstructorMap.t(t); @@ -441,7 +444,7 @@ and Typ: { | Parens(t) | Ap(t, t) | Rec(TPat.t, t) - | Forall(UTPat.t, t) + | Forall(TPat.t, t) and t = IdTagged.t(term); type sum_map = ConstructorMap.t(t); @@ -494,6 +497,7 @@ and Typ: { ), ) | Rec(tp, t) => Rec(tpat_map_term(tp), typ_map_term(t)) + | Forall(tp, t) => Forall(tpat_map_term(tp), typ_map_term(t)) }, }; x |> f_typ(rec_call); diff --git a/src/haz3lcore/zipper/EditorUtil.re b/src/haz3lcore/zipper/EditorUtil.re index 42729f6176..54388f3410 100644 --- a/src/haz3lcore/zipper/EditorUtil.re +++ b/src/haz3lcore/zipper/EditorUtil.re @@ -60,12 +60,12 @@ let rec append_exp = { | Constructor(_) | Closure(_) | Fun(_) - | TypFun(_) + | TypFun(_) | FixF(_) | Tuple(_) | Var(_) | Ap(_) - | TypAp(_) + | TypAp(_) | DeferredAp(_) | If(_) | Test(_) diff --git a/src/haz3lschool/SyntaxTest.re b/src/haz3lschool/SyntaxTest.re index c8815b110d..d1e72473a7 100644 --- a/src/haz3lschool/SyntaxTest.re +++ b/src/haz3lschool/SyntaxTest.re @@ -14,12 +14,11 @@ type syntax_result = { percentage: float, }; -let rec find_var_upat = (name: string, upat: Term.UPat.t): bool => { +let rec find_var_upat = (name: string, upat: Pat.t): bool => { switch (upat.term) { | Var(x) => x == name | EmptyHole | Wild - | Triv | Invalid(_) | MultiHole(_) | Int(_) @@ -33,7 +32,7 @@ let rec find_var_upat = (name: string, upat: Term.UPat.t): bool => { List.fold_left((acc, up) => {acc || find_var_upat(name, up)}, false, l) | Parens(up) => find_var_upat(name, up) | Ap(up1, up2) => find_var_upat(name, up1) || find_var_upat(name, up2) - | TypeAnn(up, _) => find_var_upat(name, up) + | Cast(up, _, _) => find_var_upat(name, up) }; }; @@ -89,7 +88,7 @@ let rec find_fn = | ListLit(ul) | Tuple(ul) => List.fold_left((acc, u1) => {find_fn(name, u1, acc)}, l, ul) - | TypFun(_, body) + | TypFun(_, body, _) | FixF(_, body, _) | Fun(_, body, _, _) => l |> find_fn(name, body) | TypAp(u1, _) @@ -187,7 +186,7 @@ let rec var_mention = (name: string, uexp: Exp.t): bool => { | Let(p, def, body) => var_mention_upat(name, p) ? false : var_mention(name, def) || var_mention(name, body) - | TypFun(_, u) + | TypFun(_, u, _) | TypAp(u, _) | Test(u) | Parens(u) @@ -248,7 +247,7 @@ let rec var_applied = (name: string, uexp: Exp.t): bool => { | Let(p, def, body) => var_mention_upat(name, p) ? false : var_applied(name, def) || var_applied(name, body) - | TypFun(_, u) + | TypFun(_, u, _) | Test(u) | Parens(u) | UnOp(_, u) @@ -345,7 +344,7 @@ let rec tail_check = (name: string, uexp: Exp.t): bool => { | Cast(u, _, _) | Filter(_, u) | Closure(_, u) - | TypFun(_, u) + | TypFun(_, u, _) | TypAp(u, _) | Parens(u) => tail_check(name, u) | UnOp(_, u) => !var_mention(name, u) diff --git a/src/haz3lweb/explainthis/ExplainThisForm.re b/src/haz3lweb/explainthis/ExplainThisForm.re index 61411d79bb..dc64d3bbf6 100644 --- a/src/haz3lweb/explainthis/ExplainThisForm.re +++ b/src/haz3lweb/explainthis/ExplainThisForm.re @@ -81,7 +81,6 @@ type numeric_bin_op_examples = type example_id = | RecTyp | Deferral - | RecTyp | List(list_examples) | TypFun(typfun_examples) | Fun(fun_examples) diff --git a/src/haz3lweb/view/CursorInspector.re b/src/haz3lweb/view/CursorInspector.re index 5ef3f1447b..d32eafad23 100644 --- a/src/haz3lweb/view/CursorInspector.re +++ b/src/haz3lweb/view/CursorInspector.re @@ -144,7 +144,7 @@ let typ_ok_view = (cls: Cls.t, ok: Info.ok_typ) => Type.view(ty_lookup), ] | Variant(name, sum_ty) => [ - Type.view(Var(name)), + Type.view(Var(name) |> Typ.fresh), text("is a sum type constuctor of type"), Type.view(sum_ty), ] @@ -220,13 +220,19 @@ let tpat_view = (_: Cls.t, status: Info.status_tpat) => div_err([text("Must begin with a capital letter")]) | InHole(NotAVar(_)) => div_err([text("Expected an alias")]) | InHole(ShadowsType(name, BaseTyp)) => - div_err([text("Can't shadow base type"), Type.view(Var(name))]) + div_err([ + text("Can't shadow base type"), + Type.view(Var(name) |> Typ.fresh), + ]) | InHole(ShadowsType(name, TyAlias)) => - div_err([text("Can't shadow existing alias"), Type.view(Var(name))]) + div_err([ + text("Can't shadow existing alias"), + Type.view(Var(name) |> Typ.fresh), + ]) | InHole(ShadowsType(name, TyVar)) => div_err([ text("Can't shadow existing type variable"), - Type.view(Var(name)), + Type.view(Var(name) |> Typ.fresh), ]) }; diff --git a/src/haz3lweb/view/ExplainThis.re b/src/haz3lweb/view/ExplainThis.re index 8f540ba956..3e1eed2a25 100644 --- a/src/haz3lweb/view/ExplainThis.re +++ b/src/haz3lweb/view/ExplainThis.re @@ -563,7 +563,7 @@ let get_doc = ), ListExp.listlits, ) - | TypFun(tpat, body) => + | TypFun(tpat, body, _) => let basic = group_id => { let tpat_id = List.nth(tpat.ids, 0); let body_id = List.nth(body.ids, 0); @@ -587,7 +587,7 @@ let get_doc = }; /* TODO: More could be done here probably for different patterns. */ basic(TypFunctionExp.type_functions_basic); - | Fun(pat, body) => + | Fun(pat, body, _, _) => let basic = group_id => { let pat_id = List.nth(pat.ids, 0); let body_id = List.nth(body.ids, 0); @@ -1587,7 +1587,7 @@ let get_doc = TypAppExp.typfunapp_exp_coloring_ids, ); - | Ap(x, arg) => + | Ap(Forward, x, arg) => let x_id = List.nth(x.ids, 0); let arg_id = List.nth(arg.ids, 0); let basic = (group, format, coloring_ids) => { diff --git a/src/haz3lweb/view/Type.re b/src/haz3lweb/view/Type.re index 0f697495ab..e1104fdbdb 100644 --- a/src/haz3lweb/view/Type.re +++ b/src/haz3lweb/view/Type.re @@ -3,6 +3,12 @@ open Node; open Util.Web; open Haz3lcore; +let tpat_view = (tpat: Haz3lcore.TPat.t): string => + switch (tpat.term) { + | Var(x) => x + | _ => "?" + }; + let ty_view = (cls: string, s: string): Node.t => div(~attr=clss(["typ-view", cls]), [text(s)]); @@ -29,7 +35,12 @@ let rec view_ty = (~strip_outer_parens=false, ty: Haz3lcore.Typ.t): Node.t => | Rec(name, t) => div( ~attr=clss(["typ-view", "Rec"]), - [text("Rec " ++ x ++ ". "), view_ty(t)], + [text("Rec " ++ tpat_view(name) ++ ". "), view_ty(t)], + ) + | Forall(name, t) => + div( + ~attr=clss(["typ-view", "Forall"]), + [text("forall " ++ tpat_view(name) ++ " -> "), view_ty(t)], ) | List(t) => div( diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index 5e40b866a8..82a0cb7b55 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -346,7 +346,7 @@ let mk = ); DHDoc_common.mk_Ap(doc1, doc2); | TypAp(d1, ty) => - let doc1 = go'(d1, TypAp); + let doc1 = go'(d1); let doc2 = DHDoc_Typ.mk(~enforce_inline=true, ty); DHDoc_common.mk_TypAp(doc1, doc2); | Ap(Reverse, d1, d2) => diff --git a/src/haz3lweb/view/dhcode/layout/HTypDoc.re b/src/haz3lweb/view/dhcode/layout/HTypDoc.re index 5e60e541c5..996d01f607 100644 --- a/src/haz3lweb/view/dhcode/layout/HTypDoc.re +++ b/src/haz3lweb/view/dhcode/layout/HTypDoc.re @@ -20,6 +20,7 @@ let precedence = (ty: Typ.t): int => | String | Unknown(_) | Var(_) + | Forall(_) | Rec(_) | Sum(_) => precedence_Sum | List(_) => precedence_Const @@ -125,7 +126,7 @@ let rec mk = (~parenthesize=false, ~enforce_inline: bool, ty: Typ.t): t => { (center, true); | Rec(name, ty) => ( hcats([ - text("rec " ++ name ++ "->{"), + text("rec " ++ Type.tpat_view(name) ++ "->{"), ( (~enforce_inline) => annot(HTypAnnot.Step(0), mk(~enforce_inline, ty)) @@ -137,7 +138,7 @@ let rec mk = (~parenthesize=false, ~enforce_inline: bool, ty: Typ.t): t => { ) | Forall(name, ty) => ( hcats([ - text("forall " ++ name ++ "->{"), + text("forall " ++ Type.tpat_view(name) ++ "->{"), ( (~enforce_inline) => annot(HTypAnnot.Step(0), mk(~enforce_inline, ty)) From 78ac980f3aecfa9a3d341f7e28fdb4682248eb5b Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Wed, 24 Apr 2024 10:56:33 -0400 Subject: [PATCH 078/103] statics + elab performance --- src/haz3lcore/dynamics/Casts.re | 49 +++--- src/haz3lcore/dynamics/Elaborator.re | 170 ++++++++++--------- src/haz3lcore/lang/term/IdTagged.re | 3 + src/haz3lcore/lang/term/Typ.re | 48 +++--- src/haz3lcore/statics/Info.re | 41 +++-- src/haz3lcore/statics/Mode.re | 34 ++-- src/haz3lcore/statics/Statics.re | 102 +++++------ src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 18 +- 8 files changed, 255 insertions(+), 210 deletions(-) diff --git a/src/haz3lcore/dynamics/Casts.re b/src/haz3lcore/dynamics/Casts.re index 4ff7310aca..9d4c9d8c00 100644 --- a/src/haz3lcore/dynamics/Casts.re +++ b/src/haz3lcore/dynamics/Casts.re @@ -27,26 +27,30 @@ type ground_cases = | Ground | NotGroundOrHole(Typ.t) /* the argument is the corresponding ground type */; +let grounded_Arrow = + NotGroundOrHole( + Arrow( + Unknown(Internal) |> Typ.mk_fast, + Unknown(Internal) |> Typ.mk_fast, + ) + |> Typ.mk_fast, + ); +let grounded_Forall = + NotGroundOrHole( + Forall(EmptyHole |> TPat.fresh, Unknown(Internal) |> Typ.mk_fast) + |> Typ.mk_fast, + ); +let grounded_Prod = length => + NotGroundOrHole( + Prod(ListUtil.replicate(length, Typ.Unknown(Internal) |> Typ.mk_fast)) + |> Typ.mk_fast, + ); +let grounded_Sum: unit => Typ.sum_map = + () => [BadEntry(Typ.mk_fast(Unknown(Internal)))]; +let grounded_List = + NotGroundOrHole(List(Unknown(Internal) |> Typ.mk_fast) |> Typ.mk_fast); + let rec ground_cases_of = (ty: Typ.t): ground_cases => { - let grounded_Arrow = - NotGroundOrHole( - Arrow(Unknown(Internal) |> Typ.fresh, Unknown(Internal) |> Typ.fresh) - |> Typ.fresh, - ); - let grounded_Forall = - NotGroundOrHole( - Forall(EmptyHole |> TPat.fresh, Unknown(Internal) |> Typ.fresh) - |> Typ.fresh, - ); - let grounded_Prod = length => - NotGroundOrHole( - Prod(ListUtil.replicate(length, Typ.Unknown(Internal) |> Typ.fresh)) - |> Typ.fresh, - ); - let grounded_Sum: unit => Typ.sum_map = - () => [BadEntry(Typ.fresh(Unknown(Internal)))]; - let grounded_List = - NotGroundOrHole(List(Unknown(Internal) |> Typ.fresh) |> Typ.fresh); let is_hole: Typ.t => bool = fun | {term: Typ.Unknown(_), _} => true @@ -76,7 +80,7 @@ let rec ground_cases_of = (ty: Typ.t): ground_cases => { } | Sum(sm) => sm |> ConstructorMap.is_ground(is_hole) - ? Ground : NotGroundOrHole(Sum(grounded_Sum()) |> Typ.fresh) + ? Ground : NotGroundOrHole(Sum(grounded_Sum()) |> Typ.mk_fast) | Arrow(_, _) => grounded_Arrow | Forall(_) => grounded_Forall | List(_) => grounded_List @@ -165,6 +169,9 @@ let rec transition_multiple = (d: DHExp.t): DHExp.t => { }; }; +// So that we don't have to regenerate its id +let hole = EmptyHole |> DHExp.fresh; + // Hacky way to do transition_multiple on patterns by transferring // the cast to the expression and then back to the pattern. let pattern_fixup = (p: DHPat.t): DHPat.t => { @@ -177,7 +184,7 @@ let pattern_fixup = (p: DHPat.t): DHPat.t => { {term: DHExp.Cast(d1, t1, t2), copied: p.copied, ids: p.ids} |> transition_multiple, ); - | _ => (p, EmptyHole |> DHExp.fresh) + | _ => (p, hole) }; }; let rec rewrap_casts = ((p: DHPat.t, d: DHExp.t)): DHPat.t => { diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 32d23fa5e1..95c93aff8b 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -23,10 +23,10 @@ let fresh_cast = (d: DHExp.t, t1: Typ.t, t2: Typ.t): DHExp.t => { ? d : { let d' = - DHExp.Cast(d, t1, Typ.fresh(Unknown(Internal))) + DHExp.Cast(d, t1, Typ.mk_fast(Unknown(Internal))) |> DHExp.fresh |> Casts.transition_multiple; - DHExp.Cast(d', Typ.fresh(Unknown(Internal)), t2) + DHExp.Cast(d', Typ.mk_fast(Unknown(Internal)), t2) |> DHExp.fresh |> Casts.transition_multiple; }; @@ -36,9 +36,9 @@ let fresh_pat_cast = (p: DHPat.t, t1: Typ.t, t2: Typ.t): DHPat.t => { Typ.eq(t1, t2) ? p : Cast( - DHPat.fresh(Cast(p, t1, Typ.fresh(Unknown(Internal)))) + DHPat.fresh(Cast(p, t1, Typ.mk_fast(Unknown(Internal)))) |> Casts.pattern_fixup, - Typ.fresh(Unknown(Internal)), + Typ.mk_fast(Unknown(Internal)), t2, ) |> DHPat.fresh @@ -90,23 +90,23 @@ let rec elaborate_pattern = let (term, rewrap) = UPat.unwrap(upat); let dpat = switch (term) { - | Int(_) => upat |> cast_from(Int |> Typ.fresh) - | Bool(_) => upat |> cast_from(Bool |> Typ.fresh) - | Float(_) => upat |> cast_from(Float |> Typ.fresh) - | String(_) => upat |> cast_from(String |> Typ.fresh) + | Int(_) => upat |> cast_from(Int |> Typ.mk_fast) + | Bool(_) => upat |> cast_from(Bool |> Typ.mk_fast) + | Float(_) => upat |> cast_from(Float |> Typ.mk_fast) + | String(_) => upat |> cast_from(String |> Typ.mk_fast) | ListLit(ps) => let (ps, tys) = List.map(elaborate_pattern(m), ps) |> ListUtil.unzip; let inner_type = tys - |> Typ.join_all(~empty=Unknown(Internal) |> Typ.fresh, ctx) - |> Option.value(~default=Typ.fresh(Unknown(Internal))); + |> Typ.join_all(~empty=Unknown(Internal) |> Typ.mk_fast, ctx) + |> Option.value(~default=Typ.mk_fast(Unknown(Internal))); ps |> List.map2((p, t) => fresh_pat_cast(p, t, inner_type), _, tys) |> ( ps' => DHPat.ListLit(ps') |> rewrap - |> cast_from(List(inner_type) |> Typ.fresh) + |> cast_from(List(inner_type) |> Typ.mk_fast) ); | Cons(p1, p2) => let (p1', ty1) = elaborate_pattern(m, p1); @@ -114,33 +114,33 @@ let rec elaborate_pattern = let ty2_inner = Typ.matched_list(ctx, ty2); let ty_inner = Typ.join(~fix=false, ctx, ty1, ty2_inner) - |> Option.value(~default=Typ.fresh(Unknown(Internal))); + |> Option.value(~default=Typ.mk_fast(Unknown(Internal))); let p1'' = fresh_pat_cast(p1', ty1, ty_inner); - let p2'' = fresh_pat_cast(p2', ty2, List(ty_inner) |> Typ.fresh); + let p2'' = fresh_pat_cast(p2', ty2, List(ty_inner) |> Typ.mk_fast); DHPat.Cons(p1'', p2'') |> rewrap - |> cast_from(List(ty_inner) |> Typ.fresh); + |> cast_from(List(ty_inner) |> Typ.mk_fast); | Tuple(ps) => let (ps', tys) = List.map(elaborate_pattern(m), ps) |> ListUtil.unzip; - DHPat.Tuple(ps') |> rewrap |> cast_from(Typ.Prod(tys) |> Typ.fresh); + DHPat.Tuple(ps') |> rewrap |> cast_from(Typ.Prod(tys) |> Typ.mk_fast); | Ap(p1, p2) => let (p1', ty1) = elaborate_pattern(m, p1); let (p2', ty2) = elaborate_pattern(m, p2); let (ty1l, ty1r) = Typ.matched_arrow(ctx, ty1); - let p1'' = fresh_pat_cast(p1', ty1, Arrow(ty1l, ty1r) |> Typ.fresh); + let p1'' = fresh_pat_cast(p1', ty1, Arrow(ty1l, ty1r) |> Typ.mk_fast); let p2'' = fresh_pat_cast(p2', ty2, ty1l); DHPat.Ap(p1'', p2'') |> rewrap |> cast_from(ty1r); | Constructor(_) | Invalid(_) | EmptyHole | MultiHole(_) - | Wild => upat |> cast_from(Typ.fresh(Unknown(Internal))) + | Wild => upat |> cast_from(Typ.mk_fast(Unknown(Internal))) | Var(v) => upat |> cast_from( Ctx.lookup_var(ctx, v) |> Option.map((x: Ctx.var_entry) => x.typ) - |> Option.value(~default=Typ.fresh(Unknown(Internal))), + |> Option.value(~default=Typ.mk_fast(Unknown(Internal))), ) // Type annotations should already appear | Parens(p) @@ -175,7 +175,7 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { let dhexp = switch (term) { | Invalid(_) - | EmptyHole => uexp |> cast_from(Typ.fresh(Typ.Unknown(Internal))) + | EmptyHole => uexp |> cast_from(Typ.mk_fast(Typ.Unknown(Internal))) | MultiHole(stuff) => Any.map_term( ~f_exp=(_, exp) => {elaborate(m, exp) |> fst}, @@ -187,57 +187,59 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { stuff => DHExp.MultiHole(stuff) |> rewrap - |> cast_from(Typ.fresh(Typ.Unknown(Internal))) + |> cast_from(Typ.mk_fast(Typ.Unknown(Internal))) ) | DynamicErrorHole(e, err) => let (e', _) = elaborate(m, e); DynamicErrorHole(e', err) |> rewrap - |> cast_from(Typ.fresh(Unknown(Internal))); + |> cast_from(Typ.mk_fast(Unknown(Internal))); | Cast(e, _, _) // We remove these casts because they should be re-inserted in the recursive call | FailedCast(e, _, _) | Parens(e) => let (e', ty) = elaborate(m, e); e' |> cast_from(ty); | Deferral(_) => uexp - | Int(_) => uexp |> cast_from(Int |> Typ.fresh) - | Bool(_) => uexp |> cast_from(Bool |> Typ.fresh) - | Float(_) => uexp |> cast_from(Float |> Typ.fresh) - | String(_) => uexp |> cast_from(String |> Typ.fresh) + | Int(_) => uexp |> cast_from(Int |> Typ.mk_fast) + | Bool(_) => uexp |> cast_from(Bool |> Typ.mk_fast) + | Float(_) => uexp |> cast_from(Float |> Typ.mk_fast) + | String(_) => uexp |> cast_from(String |> Typ.mk_fast) | ListLit(es) => let (ds, tys) = List.map(elaborate(m), es) |> ListUtil.unzip; let inner_type = - Typ.join_all(~empty=Typ.Unknown(Internal) |> Typ.fresh, ctx, tys) - |> Option.value(~default=Typ.fresh(Typ.Unknown(Internal))); + Typ.join_all(~empty=Typ.Unknown(Internal) |> Typ.mk_fast, ctx, tys) + |> Option.value(~default=Typ.mk_fast(Typ.Unknown(Internal))); let ds' = List.map2((d, t) => fresh_cast(d, t, inner_type), ds, tys); - Exp.ListLit(ds') |> rewrap |> cast_from(List(inner_type) |> Typ.fresh); + Exp.ListLit(ds') + |> rewrap + |> cast_from(List(inner_type) |> Typ.mk_fast); | Constructor(c) => uexp |> cast_from( Ctx.lookup_ctr(ctx, c) |> Option.map((x: Ctx.var_entry) => x.typ) - |> Option.value(~default=Typ.fresh(Typ.Unknown(Internal))), + |> Option.value(~default=Typ.mk_fast(Typ.Unknown(Internal))), ) | Fun(p, e, env, n) => let (p', typ) = elaborate_pattern(m, p); let (e', tye) = elaborate(m, e); Exp.Fun(p', e', env, n) |> rewrap - |> cast_from(Arrow(typ, tye) |> Typ.fresh); + |> cast_from(Arrow(typ, tye) |> Typ.mk_fast); | TypFun(tpat, e, name) => let (e', tye) = elaborate(m, e); Exp.TypFun(tpat, e', name) |> rewrap - |> cast_from(Typ.Forall(tpat, tye) |> Typ.fresh); + |> cast_from(Typ.Forall(tpat, tye) |> Typ.mk_fast); | Tuple(es) => let (ds, tys) = List.map(elaborate(m), es) |> ListUtil.unzip; - Exp.Tuple(ds) |> rewrap |> cast_from(Prod(tys) |> Typ.fresh); + Exp.Tuple(ds) |> rewrap |> cast_from(Prod(tys) |> Typ.mk_fast); | Var(v) => uexp |> cast_from( Ctx.lookup_var(ctx, v) |> Option.map((x: Ctx.var_entry) => x.typ) - |> Option.value(~default=Typ.fresh(Typ.Unknown(Internal))), + |> Option.value(~default=Typ.mk_fast(Typ.Unknown(Internal))), ) | Let(p, def, body) => let add_name: (option(string), DHExp.t) => DHExp.t = ( @@ -261,6 +263,7 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { } else { // TODO: Add names to mutually recursive functions // TODO: Don't add fixpoint if there already is one + let def = add_name(Option.map(s => s ++ "+", Pat.get_var(p)), def); let (p, ty1) = elaborate_pattern(m, p); let (def, ty2) = elaborate(m, def); let (body, ty) = elaborate(m, body); @@ -272,7 +275,7 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { let (e', tye) = elaborate(m, e); Exp.FixF(p', fresh_cast(e', tye, typ), env) |> rewrap - |> cast_from(Arrow(typ, typ) |> Typ.fresh); + |> cast_from(Arrow(typ, typ) |> Typ.mk_fast); | TyAlias(_, _, e) => let (e', tye) = elaborate(m, e); e' |> cast_from(tye); @@ -280,7 +283,7 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { let (f', tyf) = elaborate(m, f); let (a', tya) = elaborate(m, a); let (tyf1, tyf2) = Typ.matched_arrow(ctx, tyf); - let f'' = fresh_cast(f', tyf, Arrow(tyf1, tyf2) |> Typ.fresh); + let f'' = fresh_cast(f', tyf, Arrow(tyf1, tyf2) |> Typ.mk_fast); let a'' = fresh_cast(a', tya, tyf1); Exp.Ap(dir, f'', a'') |> rewrap |> cast_from(tyf2); | DeferredAp(f, args) => @@ -292,7 +295,7 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { fresh_cast( f', tyf, - Arrow(Prod(ty_fargs) |> Typ.fresh, tyf2) |> Typ.fresh, + Arrow(Prod(ty_fargs) |> Typ.mk_fast, tyf2) |> Typ.mk_fast, ); let args'' = ListUtil.map3(fresh_cast, args', tys, ty_fargs); let remaining_args = @@ -301,10 +304,10 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { List.combine(args, ty_fargs), ); let remaining_arg_ty = - Prod(List.map(snd, remaining_args)) |> Typ.fresh; + Prod(List.map(snd, remaining_args)) |> Typ.mk_fast; DeferredAp(f'', args'') |> rewrap - |> cast_from(Arrow(remaining_arg_ty, tyf2) |> Typ.fresh); + |> cast_from(Arrow(remaining_arg_ty, tyf2) |> Typ.mk_fast); | TypAp(e, ut) => let (e', tye) = elaborate(m, e); let (_, tye') = Typ.matched_forall(ctx, tye); @@ -315,8 +318,8 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { let (f', tyf) = elaborate(m, f); let ty = Typ.join(~fix=false, ctx, tyt, tyf) - |> Option.value(~default=Typ.fresh(Typ.Unknown(Internal))); - let c'' = fresh_cast(c', tyc, Bool |> Typ.fresh); + |> Option.value(~default=Typ.mk_fast(Typ.Unknown(Internal))); + let c'' = fresh_cast(c', tyc, Bool |> Typ.mk_fast); let t'' = fresh_cast(t', tyt, ty); let f'' = fresh_cast(f', tyf, ty); Exp.If(c'', t'', f'') |> rewrap |> cast_from(ty); @@ -326,9 +329,9 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { Seq(e1', e2') |> rewrap |> cast_from(ty2); | Test(e) => let (e', t) = elaborate(m, e); - Test(fresh_cast(e', t, Bool |> Typ.fresh)) + Test(fresh_cast(e', t, Bool |> Typ.mk_fast)) |> rewrap - |> cast_from(Prod([]) |> Typ.fresh); + |> cast_from(Prod([]) |> Typ.mk_fast); | Filter(kind, e) => let (e', t) = elaborate(m, e); let kind' = @@ -347,10 +350,10 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { let ty2_inner = Typ.matched_list(ctx, ty2); let ty_inner = Typ.join(~fix=false, ctx, ty1, ty2_inner) - |> Option.value(~default=Typ.fresh(Unknown(Internal))); + |> Option.value(~default=Typ.mk_fast(Unknown(Internal))); let e1'' = fresh_cast(e1', ty1, ty_inner); - let e2'' = fresh_cast(e2', ty2, List(ty_inner) |> Typ.fresh); - Cons(e1'', e2'') |> rewrap |> cast_from(List(ty_inner) |> Typ.fresh); + let e2'' = fresh_cast(e2', ty2, List(ty_inner) |> Typ.mk_fast); + Cons(e1'', e2'') |> rewrap |> cast_from(List(ty_inner) |> Typ.mk_fast); | ListConcat(e1, e2) => let (e1', ty1) = elaborate(m, e1); let (e2', ty2) = elaborate(m, e2); @@ -358,12 +361,12 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { let ty_inner2 = Typ.matched_list(ctx, ty2); let ty_inner = Typ.join(~fix=false, ctx, ty_inner1, ty_inner2) - |> Option.value(~default=Typ.fresh(Unknown(Internal))); - let e1'' = fresh_cast(e1', ty1, List(ty_inner) |> Typ.fresh); - let e2'' = fresh_cast(e2', ty2, List(ty_inner) |> Typ.fresh); + |> Option.value(~default=Typ.mk_fast(Unknown(Internal))); + let e1'' = fresh_cast(e1', ty1, List(ty_inner) |> Typ.mk_fast); + let e2'' = fresh_cast(e2', ty2, List(ty_inner) |> Typ.mk_fast); ListConcat(e1'', e2'') |> rewrap - |> cast_from(List(ty_inner) |> Typ.fresh); + |> cast_from(List(ty_inner) |> Typ.mk_fast); | UnOp(Meta(Unquote), e) => switch (e.term) { | Var("e") => Constructor("$e") |> rewrap @@ -371,28 +374,28 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { | _ => DHExp.EmptyHole |> rewrap - |> cast_from(Typ.fresh(Typ.Unknown(Internal))) + |> cast_from(Typ.mk_fast(Typ.Unknown(Internal))) } | UnOp(Int(Minus), e) => let (e', t) = elaborate(m, e); - UnOp(Int(Minus), fresh_cast(e', t, Int |> Typ.fresh)) + UnOp(Int(Minus), fresh_cast(e', t, Int |> Typ.mk_fast)) |> rewrap - |> cast_from(Int |> Typ.fresh); + |> cast_from(Int |> Typ.mk_fast); | UnOp(Bool(Not), e) => let (e', t) = elaborate(m, e); - UnOp(Bool(Not), fresh_cast(e', t, Bool |> Typ.fresh)) + UnOp(Bool(Not), fresh_cast(e', t, Bool |> Typ.mk_fast)) |> rewrap - |> cast_from(Bool |> Typ.fresh); + |> cast_from(Bool |> Typ.mk_fast); | BinOp(Int(Plus | Minus | Times | Power | Divide) as op, e1, e2) => let (e1', t1) = elaborate(m, e1); let (e2', t2) = elaborate(m, e2); BinOp( op, - fresh_cast(e1', t1, Int |> Typ.fresh), - fresh_cast(e2', t2, Int |> Typ.fresh), + fresh_cast(e1', t1, Int |> Typ.mk_fast), + fresh_cast(e2', t2, Int |> Typ.mk_fast), ) |> rewrap - |> cast_from(Int |> Typ.fresh); + |> cast_from(Int |> Typ.mk_fast); | BinOp( Int( LessThan | LessThanOrEqual | GreaterThan | GreaterThanOrEqual | @@ -406,31 +409,31 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { let (e2', t2) = elaborate(m, e2); BinOp( op, - fresh_cast(e1', t1, Int |> Typ.fresh), - fresh_cast(e2', t2, Int |> Typ.fresh), + fresh_cast(e1', t1, Int |> Typ.mk_fast), + fresh_cast(e2', t2, Int |> Typ.mk_fast), ) |> rewrap - |> cast_from(Bool |> Typ.fresh); + |> cast_from(Bool |> Typ.mk_fast); | BinOp(Bool(And | Or) as op, e1, e2) => let (e1', t1) = elaborate(m, e1); let (e2', t2) = elaborate(m, e2); BinOp( op, - fresh_cast(e1', t1, Bool |> Typ.fresh), - fresh_cast(e2', t2, Bool |> Typ.fresh), + fresh_cast(e1', t1, Bool |> Typ.mk_fast), + fresh_cast(e2', t2, Bool |> Typ.mk_fast), ) |> rewrap - |> cast_from(Bool |> Typ.fresh); + |> cast_from(Bool |> Typ.mk_fast); | BinOp(Float(Plus | Minus | Times | Divide | Power) as op, e1, e2) => let (e1', t1) = elaborate(m, e1); let (e2', t2) = elaborate(m, e2); BinOp( op, - fresh_cast(e1', t1, Float |> Typ.fresh), - fresh_cast(e2', t2, Float |> Typ.fresh), + fresh_cast(e1', t1, Float |> Typ.mk_fast), + fresh_cast(e2', t2, Float |> Typ.mk_fast), ) |> rewrap - |> cast_from(Float |> Typ.fresh); + |> cast_from(Float |> Typ.mk_fast); | BinOp( Float( LessThan | LessThanOrEqual | GreaterThan | GreaterThanOrEqual | @@ -444,37 +447,37 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { let (e2', t2) = elaborate(m, e2); BinOp( op, - fresh_cast(e1', t1, Float |> Typ.fresh), - fresh_cast(e2', t2, Float |> Typ.fresh), + fresh_cast(e1', t1, Float |> Typ.mk_fast), + fresh_cast(e2', t2, Float |> Typ.mk_fast), ) |> rewrap - |> cast_from(Bool |> Typ.fresh); + |> cast_from(Bool |> Typ.mk_fast); | BinOp(String(Concat) as op, e1, e2) => let (e1', t1) = elaborate(m, e1); let (e2', t2) = elaborate(m, e2); BinOp( op, - fresh_cast(e1', t1, String |> Typ.fresh), - fresh_cast(e2', t2, String |> Typ.fresh), + fresh_cast(e1', t1, String |> Typ.mk_fast), + fresh_cast(e2', t2, String |> Typ.mk_fast), ) |> rewrap - |> cast_from(String |> Typ.fresh); + |> cast_from(String |> Typ.mk_fast); | BinOp(String(Equals) as op, e1, e2) => let (e1', t1) = elaborate(m, e1); let (e2', t2) = elaborate(m, e2); BinOp( op, - fresh_cast(e1', t1, String |> Typ.fresh), - fresh_cast(e2', t2, String |> Typ.fresh), + fresh_cast(e1', t1, String |> Typ.mk_fast), + fresh_cast(e2', t2, String |> Typ.mk_fast), ) |> rewrap - |> cast_from(Bool |> Typ.fresh); + |> cast_from(Bool |> Typ.mk_fast); | BuiltinFun(fn) => uexp |> cast_from( Ctx.lookup_var(Builtins.ctx_init, fn) |> Option.map((x: Ctx.var_entry) => x.typ) - |> Option.value(~default=Typ.fresh(Typ.Unknown(Internal))), + |> Option.value(~default=Typ.mk_fast(Typ.Unknown(Internal))), ) | Match(e, cases) => let (e', t) = elaborate(m, e); @@ -482,15 +485,15 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { let (ps', ptys) = List.map(elaborate_pattern(m), ps) |> ListUtil.unzip; let joined_pty = - Typ.join_all(~empty=Typ.Unknown(Internal) |> Typ.fresh, ctx, ptys) - |> Option.value(~default=Typ.fresh(Typ.Unknown(Internal))); + Typ.join_all(~empty=Typ.Unknown(Internal) |> Typ.mk_fast, ctx, ptys) + |> Option.value(~default=Typ.mk_fast(Typ.Unknown(Internal))); let ps'' = List.map2((p, t) => fresh_pat_cast(p, t, joined_pty), ps', ptys); let e'' = fresh_cast(e', t, joined_pty); let (es', etys) = List.map(elaborate(m), es) |> ListUtil.unzip; let joined_ety = - Typ.join_all(~empty=Typ.Unknown(Internal) |> Typ.fresh, ctx, etys) - |> Option.value(~default=Typ.fresh(Typ.Unknown(Internal))); + Typ.join_all(~empty=Typ.Unknown(Internal) |> Typ.mk_fast, ctx, etys) + |> Option.value(~default=Typ.mk_fast(Typ.Unknown(Internal))); let es'' = List.map2((e, t) => fresh_cast(e, t, joined_ety), es', etys); Match(e'', List.combine(ps'', es'')) @@ -502,6 +505,13 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { //let dhexp_of_uexp = Core.Memo.general(~cache_size_bound=1000, dhexp_of_uexp); +/* This function gives a new id to all the types + in the expression. It does this to get rid of + all the invalid ids we added to prevent generating + too many new ids */ +let fix_typ_ids = + Exp.map_term(~f_typ=(cont, e) => e |> IdTagged.new_ids |> cont); + let uexp_elab = (m: Statics.Map.t, uexp: UExp.t): ElaborationResult.t => switch (elaborate(m, uexp)) { | exception MissingTypeInfo => DoesNotElaborate diff --git a/src/haz3lcore/lang/term/IdTagged.re b/src/haz3lcore/lang/term/IdTagged.re index 6e0306f805..da290cd828 100644 --- a/src/haz3lcore/lang/term/IdTagged.re +++ b/src/haz3lcore/lang/term/IdTagged.re @@ -20,6 +20,9 @@ let term_of = x => x.term; let unwrap = x => (x.term, term' => {...x, term: term'}); let rep_id = ({ids, _}) => List.hd(ids); let fast_copy = (id, {term, _}) => {ids: [id], term, copied: true}; +let new_ids = + fun + | {ids: _, term, copied} => {ids: [Id.mk()], term, copied}; // let serialization = (f1, f2) => // StructureShareSexp.structure_share_here( diff --git a/src/haz3lcore/lang/term/Typ.re b/src/haz3lcore/lang/term/Typ.re index 6c4c4084ef..6322bea41a 100644 --- a/src/haz3lcore/lang/term/Typ.re +++ b/src/haz3lcore/lang/term/Typ.re @@ -28,6 +28,7 @@ include TermBase.Typ; let term_of: t => term = IdTagged.term_of; let unwrap: t => (term, term => t) = IdTagged.unwrap; let fresh: term => t = IdTagged.fresh; +let mk_fast: term => t = term => {term, ids: [Id.invalid], copied: false}; let rep_id: t => Id.t = IdTagged.rep_id; let hole = (tms: list(TermBase.Any.t)) => @@ -283,7 +284,7 @@ let rec eq_internal = (n: int, t1: t, t2: t) => { | (_, Parens(t2)) => eq_internal(n, t1, t2) | (Rec(x1, t1), Rec(x2, t2)) | (Forall(x1, t1), Forall(x2, t2)) => - let alpha_subst = subst(Var("=" ++ string_of_int(n)) |> fresh); + let alpha_subst = subst(Var("=" ++ string_of_int(n)) |> mk_fast); eq_internal(n + 1, alpha_subst(x1, t1), alpha_subst(x2, t2)); | (Rec(_), _) => false | (Forall(_), _) => false @@ -334,7 +335,7 @@ let rec join = (~resolve=false, ~fix, ctx: Ctx.t, ty1: t, ty2: t): option(t) => casts. Documentation/Dynamics has regression tests */ Some(ty2) | (Unknown(p1), Unknown(p2)) => - Some(Unknown(join_type_provenance(p1, p2)) |> fresh) + Some(Unknown(join_type_provenance(p1, p2)) |> mk_fast) | (Unknown(_), _) => Some(ty2) | (_, Unknown(Internal | SynSwitch)) => Some(ty1) | (Var(n1), Var(n2)) => @@ -359,21 +360,21 @@ let rec join = (~resolve=false, ~fix, ctx: Ctx.t, ty1: t, ty2: t): option(t) => let ctx = Ctx.extend_dummy_tvar(ctx, tp1); let ty1' = switch (TPat.tyvar_of_utpat(tp2)) { - | Some(x2) => subst(Var(x2) |> fresh, tp1, ty1) + | Some(x2) => subst(Var(x2) |> mk_fast, tp1, ty1) | None => ty1 }; let+ ty_body = join(~resolve, ~fix, ctx, ty1', ty2); - Rec(tp1, ty_body) |> fresh; + Rec(tp1, ty_body) |> mk_fast; | (Rec(_), _) => None | (Forall(x1, ty1), Forall(x2, ty2)) => let ctx = Ctx.extend_dummy_tvar(ctx, x1); let ty1' = switch (TPat.tyvar_of_utpat(x2)) { - | Some(x2) => subst(Var(x2) |> fresh, x1, ty1) + | Some(x2) => subst(Var(x2) |> mk_fast, x1, ty1) | None => ty1 }; let+ ty_body = join(~resolve, ~fix, ctx, ty1', ty2); - Forall(x1, ty_body) |> fresh; + Forall(x1, ty_body) |> mk_fast; /* Note for above: there is no danger of free variable capture as subst itself performs capture avoiding substitution. However this may generate internal type variable names that in corner cases can @@ -381,31 +382,31 @@ let rec join = (~resolve=false, ~fix, ctx: Ctx.t, ty1: t, ty2: t): option(t) => second type to preserve synthesized type variable names, which come from user annotations. */ | (Forall(_), _) => None - | (Int, Int) => Some(Int |> fresh) + | (Int, Int) => Some(ty1) | (Int, _) => None - | (Float, Float) => Some(Float |> fresh) + | (Float, Float) => Some(ty1) | (Float, _) => None - | (Bool, Bool) => Some(Bool |> fresh) + | (Bool, Bool) => Some(ty1) | (Bool, _) => None - | (String, String) => Some(String |> fresh) + | (String, String) => Some(ty1) | (String, _) => None | (Arrow(ty1, ty2), Arrow(ty1', ty2')) => let* ty1 = join'(ty1, ty1'); let+ ty2 = join'(ty2, ty2'); - Arrow(ty1, ty2) |> fresh; + Arrow(ty1, ty2) |> mk_fast; | (Arrow(_), _) => None | (Prod(tys1), Prod(tys2)) => let* tys = ListUtil.map2_opt(join', tys1, tys2); let+ tys = OptUtil.sequence(tys); - Prod(tys) |> fresh; + Prod(tys) |> mk_fast; | (Prod(_), _) => None | (Sum(sm1), Sum(sm2)) => let+ sm' = ConstructorMap.join(eq, join(~resolve, ~fix, ctx), sm1, sm2); - Sum(sm') |> fresh; + Sum(sm') |> mk_fast; | (Sum(_), _) => None | (List(ty1), List(ty2)) => let+ ty = join'(ty1, ty2); - List(ty) |> fresh; + List(ty) |> mk_fast; | (List(_), _) => None | (Ap(_), _) => failwith("Type join of ap") }; @@ -502,31 +503,32 @@ let matched_arrow = (ctx, ty) => switch (term_of(weak_head_normalize(ctx, ty))) { | Arrow(ty_in, ty_out) => (ty_in, ty_out) | Unknown(SynSwitch) => ( - Unknown(SynSwitch) |> fresh, - Unknown(SynSwitch) |> fresh, + Unknown(SynSwitch) |> mk_fast, + Unknown(SynSwitch) |> mk_fast, ) - | _ => (Unknown(Internal) |> fresh, Unknown(Internal) |> fresh) + | _ => (Unknown(Internal) |> mk_fast, Unknown(Internal) |> mk_fast) }; let matched_forall = (ctx, ty) => switch (term_of(weak_head_normalize(ctx, ty))) { | Forall(t, ty) => (Some(t), ty) - | Unknown(SynSwitch) => (None, Unknown(SynSwitch) |> fresh) - | _ => (None, Unknown(Internal) |> fresh) + | Unknown(SynSwitch) => (None, Unknown(SynSwitch) |> mk_fast) + | _ => (None, Unknown(Internal) |> mk_fast) }; let matched_prod = (ctx, length, ty) => switch (term_of(weak_head_normalize(ctx, ty))) { | Prod(tys) when List.length(tys) == length => tys - | Unknown(SynSwitch) => List.init(length, _ => Unknown(SynSwitch) |> fresh) - | _ => List.init(length, _ => Unknown(Internal) |> fresh) + | Unknown(SynSwitch) => + List.init(length, _ => Unknown(SynSwitch) |> mk_fast) + | _ => List.init(length, _ => Unknown(Internal) |> mk_fast) }; let matched_list = (ctx, ty) => switch (term_of(weak_head_normalize(ctx, ty))) { | List(ty) => ty - | Unknown(SynSwitch) => Unknown(SynSwitch) |> fresh - | _ => Unknown(Internal) |> fresh + | Unknown(SynSwitch) => Unknown(SynSwitch) |> mk_fast + | _ => Unknown(Internal) |> mk_fast }; let matched_args = (ctx, default_arity, ty) => { diff --git a/src/haz3lcore/statics/Info.re b/src/haz3lcore/statics/Info.re index 7c5681d487..0977609055 100644 --- a/src/haz3lcore/statics/Info.re +++ b/src/haz3lcore/statics/Info.re @@ -326,10 +326,10 @@ let rec status_common = Typ.join_fix( ctx, Arrow( - Unknown(Internal) |> Typ.fresh, - Unknown(Internal) |> Typ.fresh, + Unknown(Internal) |> Typ.mk_fast, + Unknown(Internal) |> Typ.mk_fast, ) - |> Typ.fresh, + |> Typ.mk_fast, ty, ) ) { @@ -340,8 +340,8 @@ let rec status_common = switch ( Typ.join_fix( ctx, - Forall(Var("?") |> TPat.fresh, Unknown(Internal) |> Typ.fresh) - |> Typ.fresh, + Forall(Var("?") |> TPat.fresh, Unknown(Internal) |> Typ.mk_fast) + |> Typ.mk_fast, ty, ) ) { @@ -371,9 +371,9 @@ let rec status_common = } | (BadToken(name), _) => InHole(NoType(BadToken(name))) | (BadTrivAp(ty), _) => InHole(NoType(BadTrivAp(ty))) - | (IsMulti, _) => NotInHole(Syn(Unknown(Internal) |> Typ.fresh)) + | (IsMulti, _) => NotInHole(Syn(Unknown(Internal) |> Typ.mk_fast)) | (NoJoin(wrap, tys), Ana(ana)) => - let syn: Typ.t = Self.join_of(wrap, Unknown(Internal) |> Typ.fresh); + let syn: Typ.t = Self.join_of(wrap, Unknown(Internal) |> Typ.mk_fast); switch (Typ.join_fix(ctx, ana, syn)) { | None => InHole(Inconsistent(Expectation({ana, syn}))) | Some(_) => @@ -444,7 +444,7 @@ let status_typ = | false => switch (Ctx.is_abstract(ctx, name)) { | false => InHole(FreeTypeVariable(name)) - | true => NotInHole(Type(Var(name) |> Typ.fresh)) + | true => NotInHole(Type(Var(name) |> Typ.mk_fast)) } | true => NotInHole(TypeAlias(name, Typ.weak_head_normalize(ctx, ty))) } @@ -455,9 +455,11 @@ let status_typ = let ty_in = UTyp.to_typ(ctx, t2); switch (status_variant, t1.term) { | (Unique, Var(name)) => - NotInHole(Variant(name, Arrow(ty_in, ty_variant) |> Typ.fresh)) + NotInHole(Variant(name, Arrow(ty_in, ty_variant) |> Typ.mk_fast)) | _ => - NotInHole(VariantIncomplete(Arrow(ty_in, ty_variant) |> Typ.fresh)) + NotInHole( + VariantIncomplete(Arrow(ty_in, ty_variant) |> Typ.mk_fast), + ) }; | ConstructorExpected(_) => InHole(WantConstructorFoundAp) | TypeExpected => InHole(WantTypeFoundAp) @@ -525,23 +527,26 @@ let fixed_typ_ok: ok_pat => Typ.t = let fixed_typ_err_common: error_common => Typ.t = fun - | NoType(_) => Unknown(Internal) |> Typ.fresh + | NoType(_) => Unknown(Internal) |> Typ.mk_fast | Inconsistent(Expectation({ana, _})) => ana - | Inconsistent(Internal(_)) => Unknown(Internal) |> Typ.fresh // Should this be some sort of meet? + | Inconsistent(Internal(_)) => Unknown(Internal) |> Typ.mk_fast // Should this be some sort of meet? | Inconsistent(WithArrow(_)) => - Arrow(Unknown(Internal) |> Typ.fresh, Unknown(Internal) |> Typ.fresh) - |> Typ.fresh; + Arrow( + Unknown(Internal) |> Typ.mk_fast, + Unknown(Internal) |> Typ.mk_fast, + ) + |> Typ.mk_fast; let fixed_typ_err: error_exp => Typ.t = fun - | FreeVariable(_) => Unknown(Internal) |> Typ.fresh - | UnusedDeferral => Unknown(Internal) |> Typ.fresh - | BadPartialAp(_) => Unknown(Internal) |> Typ.fresh + | FreeVariable(_) => Unknown(Internal) |> Typ.mk_fast + | UnusedDeferral => Unknown(Internal) |> Typ.mk_fast + | BadPartialAp(_) => Unknown(Internal) |> Typ.mk_fast | Common(err) => fixed_typ_err_common(err); let fixed_typ_err_pat: error_pat => Typ.t = fun - | ExpectedConstructor => Unknown(Internal) |> Typ.fresh + | ExpectedConstructor => Unknown(Internal) |> Typ.mk_fast | Common(err) => fixed_typ_err_common(err); let fixed_typ_pat = (ctx, mode: Mode.t, self: Self.pat): Typ.t => diff --git a/src/haz3lcore/statics/Mode.re b/src/haz3lcore/statics/Mode.re index 1172d45a3e..0c73a50d60 100644 --- a/src/haz3lcore/statics/Mode.re +++ b/src/haz3lcore/statics/Mode.re @@ -30,13 +30,19 @@ let ana: Typ.t => t = ty => Ana(ty); let ty_of: t => Typ.t = fun | Ana(ty) => ty - | Syn => Unknown(SynSwitch) |> Typ.fresh + | Syn => Unknown(SynSwitch) |> Typ.mk_fast | SynFun => - Arrow(Unknown(SynSwitch) |> Typ.fresh, Unknown(SynSwitch) |> Typ.fresh) - |> Typ.fresh + Arrow( + Unknown(SynSwitch) |> Typ.mk_fast, + Unknown(SynSwitch) |> Typ.mk_fast, + ) + |> Typ.mk_fast | SynTypFun => - Forall(Var("syntypfun") |> TPat.fresh, Unknown(SynSwitch) |> Typ.fresh) - |> Typ.fresh; /* TODO: naming the type variable? */ + Forall( + Var("syntypfun") |> TPat.fresh, + Unknown(SynSwitch) |> Typ.mk_fast, + ) + |> Typ.mk_fast; /* TODO: naming the type variable? */ let of_arrow = (ctx: Ctx.t, mode: t): (t, t) => switch (mode) { @@ -55,7 +61,7 @@ let of_forall = (ctx: Ctx.t, name_opt: option(string), mode: t): t => let (name_expected_opt, item) = Typ.matched_forall(ctx, ty); switch (name_opt, name_expected_opt) { | (Some(name), Some(name_expected)) => - Ana(Typ.subst(Var(name) |> Typ.fresh, name_expected, item)) + Ana(Typ.subst(Var(name) |> Typ.mk_fast, name_expected, item)) | _ => Ana(item) }; }; @@ -80,8 +86,8 @@ let of_cons_tl = (ctx: Ctx.t, mode: t, hd_ty: Typ.t): t => switch (mode) { | Syn | SynFun - | SynTypFun => Ana(List(hd_ty) |> Typ.fresh) - | Ana(ty) => Ana(List(Typ.matched_list(ctx, ty)) |> Typ.fresh) + | SynTypFun => Ana(List(hd_ty) |> Typ.mk_fast) + | Ana(ty) => Ana(List(Typ.matched_list(ctx, ty)) |> Typ.mk_fast) }; let of_list = (ctx: Ctx.t, mode: t): t => @@ -96,8 +102,8 @@ let of_list_concat = (ctx: Ctx.t, mode: t): t => switch (mode) { | Syn | SynFun - | SynTypFun => Ana(List(Unknown(SynSwitch) |> Typ.fresh) |> Typ.fresh) - | Ana(ty) => Ana(List(Typ.matched_list(ctx, ty)) |> Typ.fresh) + | SynTypFun => Ana(List(Unknown(SynSwitch) |> Typ.mk_fast) |> Typ.mk_fast) + | Ana(ty) => Ana(List(Typ.matched_list(ctx, ty)) |> Typ.mk_fast) }; let of_list_lit = (ctx: Ctx.t, length, mode: t): list(t) => @@ -114,7 +120,7 @@ let ctr_ana_typ = (ctx: Ctx.t, mode: t, ctr: Constructor.t): option(Typ.t) => { let ty_entry = ConstructorMap.get_entry(ctr, ctrs); switch (ty_entry) { | None => ty_ana - | Some(ty_in) => Arrow(ty_in, ty_ana) |> Typ.fresh + | Some(ty_in) => Arrow(ty_in, ty_ana) |> Typ.mk_fast }; | _ => None }; @@ -129,7 +135,9 @@ let of_ctr_in_ap = (ctx: Ctx.t, mode: t, ctr: Constructor.t): option(t) => is nullary but used as unary; we reflect this by analyzing against an arrow type. Since we can't guess at what the parameter type might have be, we use Unknown. */ - Some(Ana(Arrow(Unknown(Internal) |> Typ.fresh, ty_ana) |> Typ.fresh)) + Some( + Ana(Arrow(Unknown(Internal) |> Typ.mk_fast, ty_ana) |> Typ.mk_fast), + ) | None => None }; @@ -152,6 +160,6 @@ let typap_mode: t = SynTypFun; let of_deferred_ap_args = (length: int, ty_ins: list(Typ.t)): list(t) => ( List.length(ty_ins) == length - ? ty_ins : List.init(length, _ => Typ.Unknown(Internal) |> Typ.fresh) + ? ty_ins : List.init(length, _ => Typ.Unknown(Internal) |> Typ.mk_fast) ) |> List.map(ty => Ana(ty)); diff --git a/src/haz3lcore/statics/Statics.re b/src/haz3lcore/statics/Statics.re index 592c8ec295..bc1cda51ef 100644 --- a/src/haz3lcore/statics/Statics.re +++ b/src/haz3lcore/statics/Statics.re @@ -89,58 +89,58 @@ let is_recursive = (ctx, p, def, syn: Typ.t) => { let typ_exp_binop_bin_int: Operators.op_bin_int => Typ.t = fun - | (Plus | Minus | Times | Power | Divide) as _op => Int |> Typ.fresh + | (Plus | Minus | Times | Power | Divide) as _op => Int |> Typ.mk_fast | ( LessThan | GreaterThan | LessThanOrEqual | GreaterThanOrEqual | Equals | NotEquals ) as _op => - Bool |> Typ.fresh; + Bool |> Typ.mk_fast; let typ_exp_binop_bin_float: Operators.op_bin_float => Typ.t = fun - | (Plus | Minus | Times | Power | Divide) as _op => Float |> Typ.fresh + | (Plus | Minus | Times | Power | Divide) as _op => Float |> Typ.mk_fast | ( LessThan | GreaterThan | LessThanOrEqual | GreaterThanOrEqual | Equals | NotEquals ) as _op => - Bool |> Typ.fresh; + Bool |> Typ.mk_fast; let typ_exp_binop_bin_string: Operators.op_bin_string => Typ.t = fun - | Concat => String |> Typ.fresh - | Equals => Bool |> Typ.fresh; + | Concat => String |> Typ.mk_fast + | Equals => Bool |> Typ.mk_fast; let typ_exp_binop: Operators.op_bin => (Typ.t, Typ.t, Typ.t) = fun | Bool(And | Or) => ( - Bool |> Typ.fresh, - Bool |> Typ.fresh, - Bool |> Typ.fresh, + Bool |> Typ.mk_fast, + Bool |> Typ.mk_fast, + Bool |> Typ.mk_fast, ) | Int(op) => ( - Int |> Typ.fresh, - Int |> Typ.fresh, + Int |> Typ.mk_fast, + Int |> Typ.mk_fast, typ_exp_binop_bin_int(op), ) | Float(op) => ( - Float |> Typ.fresh, - Float |> Typ.fresh, + Float |> Typ.mk_fast, + Float |> Typ.mk_fast, typ_exp_binop_bin_float(op), ) | String(op) => ( - String |> Typ.fresh, - String |> Typ.fresh, + String |> Typ.mk_fast, + String |> Typ.mk_fast, typ_exp_binop_bin_string(op), ); let typ_exp_unop: Operators.op_un => (Typ.t, Typ.t) = fun | Meta(Unquote) => ( - Var("$Meta") |> Typ.fresh, - Unknown(Internal) |> Typ.fresh, + Var("$Meta") |> Typ.mk_fast, + Unknown(Internal) |> Typ.mk_fast, ) - | Bool(Not) => (Bool |> Typ.fresh, Bool |> Typ.fresh) - | Int(Minus) => (Int |> Typ.fresh, Int |> Typ.fresh); + | Bool(Not) => (Bool |> Typ.mk_fast, Bool |> Typ.mk_fast) + | Int(Minus) => (Int |> Typ.mk_fast, Int |> Typ.mk_fast); let rec any_to_info_map = (~ctx: Ctx.t, ~ancestors, any: Any.t, m: Map.t): (CoCtx.t, Map.t) => @@ -239,13 +239,13 @@ and uexp_to_info_map = let (e, m) = go(~mode=Ana(t1), e, m); add(~self=Just(t2), ~co_ctx=e.co_ctx, m); | Invalid(token) => atomic(BadToken(token)) - | EmptyHole => atomic(Just(Unknown(Internal) |> Typ.fresh)) + | EmptyHole => atomic(Just(Unknown(Internal) |> Typ.mk_fast)) | Deferral(position) => add'(~self=IsDeferral(position), ~co_ctx=CoCtx.empty, m) - | Bool(_) => atomic(Just(Bool |> Typ.fresh)) - | Int(_) => atomic(Just(Int |> Typ.fresh)) - | Float(_) => atomic(Just(Float |> Typ.fresh)) - | String(_) => atomic(Just(String |> Typ.fresh)) + | Bool(_) => atomic(Just(Bool |> Typ.mk_fast)) + | Int(_) => atomic(Just(Int |> Typ.mk_fast)) + | Float(_) => atomic(Just(Float |> Typ.mk_fast)) + | String(_) => atomic(Just(String |> Typ.mk_fast)) | ListLit(es) => let ids = List.map(UExp.rep_id, es); let modes = Mode.of_list_lit(ctx, List.length(es), mode); @@ -253,7 +253,7 @@ and uexp_to_info_map = let tys = List.map(Info.exp_ty, es); add( ~self= - Self.listlit(~empty=Unknown(Internal) |> Typ.fresh, ctx, tys, ids), + Self.listlit(~empty=Unknown(Internal) |> Typ.mk_fast, ctx, tys, ids), ~co_ctx=CoCtx.union(List.map(Info.exp_co_ctx, es)), m, ); @@ -261,7 +261,7 @@ and uexp_to_info_map = let (hd, m) = go(~mode=Mode.of_cons_hd(ctx, mode), hd, m); let (tl, m) = go(~mode=Mode.of_cons_tl(ctx, mode, hd.ty), tl, m); add( - ~self=Just(List(hd.ty) |> Typ.fresh), + ~self=Just(List(hd.ty) |> Typ.mk_fast), ~co_ctx=CoCtx.union([hd.co_ctx, tl.co_ctx]), m, ); @@ -295,8 +295,8 @@ and uexp_to_info_map = | _ => e.term }, }; - let ty_in = Typ.Var("$Meta") |> Typ.fresh; - let ty_out = Typ.Unknown(Internal) |> Typ.fresh; + let ty_in = Typ.Var("$Meta") |> Typ.mk_fast; + let ty_out = Typ.Unknown(Internal) |> Typ.mk_fast; let (e, m) = go(~mode=Ana(ty_in), e, m); add(~self=Just(ty_out), ~co_ctx=e.co_ctx, m); | UnOp(op, e) => @@ -318,13 +318,13 @@ and uexp_to_info_map = let modes = Mode.of_prod(ctx, mode, List.length(es)); let (es, m) = map_m_go(m, modes, es); add( - ~self=Just(Prod(List.map(Info.exp_ty, es)) |> Typ.fresh), + ~self=Just(Prod(List.map(Info.exp_ty, es)) |> Typ.mk_fast), ~co_ctx=CoCtx.union(List.map(Info.exp_co_ctx, es)), m, ); | Test(e) => - let (e, m) = go(~mode=Ana(Bool |> Typ.fresh), e, m); - add(~self=Just(Prod([]) |> Typ.fresh), ~co_ctx=e.co_ctx, m); + let (e, m) = go(~mode=Ana(Bool |> Typ.mk_fast), e, m); + add(~self=Just(Prod([]) |> Typ.mk_fast), ~co_ctx=e.co_ctx, m); | Filter(Filter({pat: cond, _}), body) => let (cond, m) = go(~mode, cond, m, ~is_in_filter=true); let (body, m) = go(~mode, body, m); @@ -348,7 +348,7 @@ and uexp_to_info_map = let (arg, m) = go(~mode=Ana(ty_in), arg, m); let self: Self.t = Id.is_nullary_ap_flag(arg.term.ids) - && !Typ.is_consistent(ctx, ty_in, Prod([]) |> Typ.fresh) + && !Typ.is_consistent(ctx, ty_in, Prod([]) |> Typ.mk_fast) ? BadTrivAp(ty_in) : Just(ty_out); add(~self, ~co_ctx=CoCtx.union([fn.co_ctx, arg.co_ctx]), m); | TypAp(fn, utyp) => @@ -382,7 +382,7 @@ and uexp_to_info_map = let (p, m) = go_pat(~is_synswitch=false, ~co_ctx=e.co_ctx, ~mode=mode_pat, p, m); add( - ~self=Just(Arrow(p.ty, e.ty) |> Typ.fresh), + ~self=Just(Arrow(p.ty, e.ty) |> Typ.mk_fast), ~co_ctx=CoCtx.mk(ctx, p.ctx, e.co_ctx), m, ); @@ -394,7 +394,7 @@ and uexp_to_info_map = Ctx.extend_tvar(ctx, {name, id: TPat.rep_id(utpat), kind: Abstract}); let (body, m) = go'(~ctx=ctx_body, ~mode=mode_body, body, m); add( - ~self=Just(Forall(utpat, body.ty) |> Typ.fresh), + ~self=Just(Forall(utpat, body.ty) |> Typ.mk_fast), ~co_ctx=body.co_ctx, m, ); @@ -403,7 +403,7 @@ and uexp_to_info_map = let m = utpat_to_info_map(~ctx, ~ancestors, utpat, m) |> snd; let (body, m) = go(~mode=mode_body, body, m); add( - ~self=Just(Forall(utpat, body.ty) |> Typ.fresh), + ~self=Just(Forall(utpat, body.ty) |> Typ.mk_fast), ~co_ctx=body.co_ctx, m, ); @@ -451,7 +451,7 @@ and uexp_to_info_map = | ((Prod(ty_fns1), Prod(ty_fns2)), Prod(ty_ps)) => let tys = List.map2(ana_ty_fn, List.combine(ty_fns1, ty_fns2), ty_ps); - Typ.Prod(tys) |> Typ.fresh; + Typ.Prod(tys) |> Typ.mk_fast; | ((_, _), _) => ana_ty_fn((def_base.ty, def_base2.ty), p_syn.ty) }; let (def, m) = go'(~ctx=def_ctx, ~mode=Ana(ana), def, m); @@ -486,7 +486,7 @@ and uexp_to_info_map = ); | If(e0, e1, e2) => let branch_ids = List.map(UExp.rep_id, [e1, e2]); - let (cond, m) = go(~mode=Ana(Bool |> Typ.fresh), e0, m); + let (cond, m) = go(~mode=Ana(Bool |> Typ.mk_fast), e0, m); let (cons, m) = go(~mode, e1, m); let (alt, m) = go(~mode, e2, m); add( @@ -552,7 +552,7 @@ and uexp_to_info_map = use a different name than the alias for the recursive parameter */ //let ty_rec = Typ.Rec("α", Typ.subst(Var("α"), name, ty_pre)); let ty_rec = - Typ.Rec(TPat.Var(name) |> IdTagged.fresh, ty_pre) |> Typ.fresh; + Typ.Rec(TPat.Var(name) |> IdTagged.fresh, ty_pre) |> Typ.mk_fast; let ctx_def = Ctx.extend_alias(ctx, name, TPat.rep_id(typat), ty_rec); (ty_rec, ctx_def, ctx_def); @@ -643,17 +643,17 @@ and upat_to_info_map = let (_, m) = multi(~ctx, ~ancestors, m, tms); add(~self=IsMulti, ~ctx, m); | Invalid(token) => atomic(BadToken(token)) - | EmptyHole => atomic(Just(unknown |> Typ.fresh)) - | Int(_) => atomic(Just(Int |> Typ.fresh)) - | Float(_) => atomic(Just(Float |> Typ.fresh)) - | Bool(_) => atomic(Just(Bool |> Typ.fresh)) - | String(_) => atomic(Just(String |> Typ.fresh)) + | EmptyHole => atomic(Just(unknown |> Typ.mk_fast)) + | Int(_) => atomic(Just(Int |> Typ.mk_fast)) + | Float(_) => atomic(Just(Float |> Typ.mk_fast)) + | Bool(_) => atomic(Just(Bool |> Typ.mk_fast)) + | String(_) => atomic(Just(String |> Typ.mk_fast)) | ListLit(ps) => let ids = List.map(UPat.rep_id, ps); let modes = Mode.of_list_lit(ctx, List.length(ps), mode); let (ctx, tys, m) = ctx_fold(ctx, m, ps, modes); add( - ~self=Self.listlit(~empty=unknown |> Typ.fresh, ctx, tys, ids), + ~self=Self.listlit(~empty=unknown |> Typ.mk_fast, ctx, tys, ids), ~ctx, m, ); @@ -661,8 +661,8 @@ and upat_to_info_map = let (hd, m) = go(~ctx, ~mode=Mode.of_cons_hd(ctx, mode), hd, m); let (tl, m) = go(~ctx=hd.ctx, ~mode=Mode.of_cons_tl(ctx, mode, hd.ty), tl, m); - add(~self=Just(List(hd.ty) |> Typ.fresh), ~ctx=tl.ctx, m); - | Wild => atomic(Just(unknown |> Typ.fresh)) + add(~self=Just(List(hd.ty) |> Typ.mk_fast), ~ctx=tl.ctx, m); + | Wild => atomic(Just(unknown |> Typ.mk_fast)) | Var(name) => /* NOTE: The self type assigned to pattern variables (Unknown) may be SynSwitch, but SynSwitch is never added to the context; @@ -671,14 +671,14 @@ and upat_to_info_map = Info.fixed_typ_pat( ctx, mode, - Common(Just(Unknown(Internal) |> Typ.fresh)), + Common(Just(Unknown(Internal) |> Typ.mk_fast)), ); let entry = Ctx.VarEntry({name, id: UPat.rep_id(upat), typ: ctx_typ}); - add(~self=Just(unknown |> Typ.fresh), ~ctx=Ctx.extend(ctx, entry), m); + add(~self=Just(unknown |> Typ.mk_fast), ~ctx=Ctx.extend(ctx, entry), m); | Tuple(ps) => let modes = Mode.of_prod(ctx, mode, List.length(ps)); let (ctx, tys, m) = ctx_fold(ctx, m, ps, modes); - add(~self=Just(Prod(tys) |> Typ.fresh), ~ctx, m); + add(~self=Just(Prod(tys) |> Typ.mk_fast), ~ctx, m); | Parens(p) => let (p, m) = go(~ctx, ~mode, p, m); add(~self=Just(p.ty), ~ctx=p.ctx, m); @@ -738,11 +738,11 @@ and utyp_to_info_map = let t1_mode: Info.typ_expects = switch (expects) { | VariantExpected(m, sum_ty) => - ConstructorExpected(m, Arrow(ty_in, sum_ty) |> Typ.fresh) + ConstructorExpected(m, Arrow(ty_in, sum_ty) |> Typ.mk_fast) | _ => ConstructorExpected( Unique, - Arrow(ty_in, Unknown(Internal) |> Typ.fresh) |> Typ.fresh, + Arrow(ty_in, Unknown(Internal) |> Typ.mk_fast) |> Typ.mk_fast, ) }; let m = go'(~expects=t1_mode, t1, m) |> snd; diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index 82a0cb7b55..e1ffb65cc5 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -537,10 +537,20 @@ let mk = ], ); } else { - switch (s) { - | None => annot(DHAnnot.Collapsed, text("")) - | Some(name) => annot(DHAnnot.Collapsed, text("<" ++ name ++ ">")) - }; + annot( + DHAnnot.Collapsed, + text( + switch (s) { + | None => "" + | Some(name) + when + !settings.show_fixpoints + && String.ends_with(~suffix="+", name) => + "<" ++ String.sub(name, 0, String.length(name) - 1) ++ ">" + | Some(name) => "<" ++ name ++ ">" + }, + ), + ); } | Fun(dp, dbody, None, s) => if (settings.show_fn_bodies) { From 24ca95cb68b4c401148a02463335ddda5f48fba9 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Wed, 24 Apr 2024 11:01:51 -0400 Subject: [PATCH 079/103] Remove attempt at type annotation --- src/haz3lcore/statics/MakeTerm.re | 6 ------ 1 file changed, 6 deletions(-) diff --git a/src/haz3lcore/statics/MakeTerm.re b/src/haz3lcore/statics/MakeTerm.re index 05f4d91438..739f34aa65 100644 --- a/src/haz3lcore/statics/MakeTerm.re +++ b/src/haz3lcore/statics/MakeTerm.re @@ -287,12 +287,6 @@ and exp_term: unsorted => (UExp.term, list(Id.t)) = { | _ => ret(hole(tm)) } } - | Bin(Exp(e), tiles, Typ(ty)) as tm => - switch (tiles) { - | ([(_id, ([":", "=>"], []))], []) => - ret(Cast(e, Unknown(Internal) |> Typ.fresh, ty)) - | _ => ret(hole(tm)) - } | tm => ret(hole(tm)); } and pat = unsorted => { From 882301a24f8ebe9980e67c0db3486617f8b16ffe Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Wed, 24 Apr 2024 12:07:37 -0400 Subject: [PATCH 080/103] Make pattern cast printing nicer --- src/haz3lcore/Unicode.re | 1 + src/haz3lcore/dynamics/Casts.re | 12 +++++++++ src/haz3lcore/dynamics/PatternMatch.re | 11 +++++++- src/haz3lcore/lang/Form.re | 1 - src/haz3lcore/lang/term/Typ.re | 7 +++++- src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 21 ++++++++++------ src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re | 25 +++++++++++++------ src/haz3lweb/view/dhcode/layout/DHDoc_Pat.rei | 12 --------- src/haz3lweb/view/dhcode/layout/DHDoc_Typ.rei | 3 --- .../view/dhcode/layout/DHDoc_common.re | 1 + .../view/dhcode/layout/DHDoc_common.rei | 1 + 11 files changed, 62 insertions(+), 33 deletions(-) delete mode 100644 src/haz3lweb/view/dhcode/layout/DHDoc_Pat.rei delete mode 100644 src/haz3lweb/view/dhcode/layout/DHDoc_Typ.rei diff --git a/src/haz3lcore/Unicode.re b/src/haz3lcore/Unicode.re index 8f02baeb5a..e869072048 100644 --- a/src/haz3lcore/Unicode.re +++ b/src/haz3lcore/Unicode.re @@ -8,6 +8,7 @@ let zwsp = "​"; let typeArrowSym = "→"; // U+2192 "Rightwards Arrow" let castArrowSym = "⇨"; +let castBackArrowSym = "⇦"; let ellipsis = "\xE2\x80\xA6"; diff --git a/src/haz3lcore/dynamics/Casts.re b/src/haz3lcore/dynamics/Casts.re index 9d4c9d8c00..c5cda8ef27 100644 --- a/src/haz3lcore/dynamics/Casts.re +++ b/src/haz3lcore/dynamics/Casts.re @@ -193,6 +193,18 @@ let pattern_fixup = (p: DHPat.t): DHPat.t => { | Cast(d1, t1, t2) => let p1 = rewrap_casts((p, d1)); {term: DHPat.Cast(p1, t1, t2), copied: d.copied, ids: d.ids}; + | FailedCast(d1, t1, t2) => + let p1 = rewrap_casts((p, d1)); + { + term: + DHPat.Cast( + DHPat.Cast(p1, t1, Typ.fresh(Unknown(Internal))) |> DHPat.fresh, + Typ.fresh(Unknown(Internal)), + t2, + ), + copied: d.copied, + ids: d.ids, + }; | _ => failwith("unexpected term in rewrap_casts") }; }; diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index 17e0877c79..7af6aaa7d9 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -55,5 +55,14 @@ let rec matches = (dp: Pat.t, d: DHExp.t): match_result => List.map2(matches, ps, ds) |> List.fold_left(combine_result, Matches(Environment.empty)); | Parens(p) => matches(p, d) - | Cast(p, t1, t2) => matches(p, Cast(d, t2, t1) |> DHExp.fresh) + | Cast(p, t1, t2) => + let _ = print_endline("======="); + let _ = print_endline(Pat.show(p)); + let _ = + print_endline( + DHExp.show( + Cast(d, t2, t1) |> DHExp.fresh |> Casts.transition_multiple, + ), + ); + matches(p, Cast(d, t2, t1) |> DHExp.fresh |> Casts.transition_multiple); }; diff --git a/src/haz3lcore/lang/Form.re b/src/haz3lcore/lang/Form.re index 4549302428..f6669cb550 100644 --- a/src/haz3lcore/lang/Form.re +++ b/src/haz3lcore/lang/Form.re @@ -281,7 +281,6 @@ let forms: list((string, t)) = [ ("cons_exp", mk_infix("::", Exp, P.cons)), ("cons_pat", mk_infix("::", Pat, P.cons)), ("typeann", mk(ss, [":"], mk_bin'(P.ann, Pat, Pat, [], Typ))), - ("exptypeann", mk(ss, [":"], mk_bin'(P.ann, Exp, Exp, [], Typ))), // UNARY PREFIX OPERATORS ("not", mk(ii, ["!"], mk_pre(P.not_, Exp, []))), //TODO: precedence ("typ_sum_single", mk(ss, ["+"], mk_pre(P.or_, Typ, []))), diff --git a/src/haz3lcore/lang/term/Typ.re b/src/haz3lcore/lang/term/Typ.re index 6322bea41a..74940f6db1 100644 --- a/src/haz3lcore/lang/term/Typ.re +++ b/src/haz3lcore/lang/term/Typ.re @@ -28,6 +28,9 @@ include TermBase.Typ; let term_of: t => term = IdTagged.term_of; let unwrap: t => (term, term => t) = IdTagged.unwrap; let fresh: term => t = IdTagged.fresh; +/* fresh assigns a random id, whereas mk_fast assigns Id.invalid, which + is a lot faster, and since we so often make types and throw them away + shortly after, it makes sense to use it. */ let mk_fast: term => t = term => {term, ids: [Id.invalid], copied: false}; let rep_id: t => Id.t = IdTagged.rep_id; @@ -118,7 +121,9 @@ let rec is_forall = (typ: t) => { }; }; -/* Converts a syntactic type into a semantic type */ +/* Converts a syntactic type into a semantic type, specifically + it adds implicit recursive types, and removes duplicate + constructors. */ let rec to_typ: (Ctx.t, t) => t = (ctx, utyp) => { let (term, rewrap) = IdTagged.unwrap(utyp); diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index e1ffb65cc5..0a630288c4 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -64,7 +64,7 @@ let rec precedence = (~show_casts: bool, d: DHExp.t) => { | Deferral(_) | Filter(_) => DHDoc_common.precedence_const | Cast(d1, _, _) => - show_casts ? DHDoc_common.precedence_const : precedence'(d1) + show_casts ? DHDoc_common.precedence_Ap : precedence'(d1) | DeferredAp(_) | Ap(_) | TypAp(_) => DHDoc_common.precedence_Ap @@ -213,7 +213,7 @@ let mk = : hcat(space(), hidden_clause); hcats([ DHDoc_common.Delim.bar_Rule, - DHDoc_Pat.mk(~infomap, dp) + DHDoc_Pat.mk(~infomap, ~show_casts=settings.show_casts, dp) |> DHDoc_common.pad_child( ~inline_padding=(space(), space()), ~enforce_inline=false, @@ -407,7 +407,9 @@ let mk = | TyAlias(_, _, d) => go'(d) | Cast(d, t1, t2) when settings.show_casts => // TODO[Matt]: Roll multiple casts into one cast - let doc = go'(d); + let doc = + go_formattable(d) + |> parenthesize(precedence(d) > DHDoc_common.precedence_Ap); Doc.( hcat( doc, @@ -435,7 +437,7 @@ let mk = vseps([ hcats([ DHDoc_common.Delim.mk("let"), - DHDoc_Pat.mk(~infomap, dp) + DHDoc_Pat.mk(~infomap, ~show_casts=settings.show_casts, dp) |> DHDoc_common.pad_child( ~inline_padding=(space(), space()), ~enforce_inline, @@ -524,7 +526,7 @@ let mk = hcats( [ DHDoc_common.Delim.sym_Fun, - DHDoc_Pat.mk(~infomap, dp) + DHDoc_Pat.mk(~infomap, ~show_casts=settings.show_casts, dp) |> DHDoc_common.pad_child( ~inline_padding=(space(), space()), ~enforce_inline, @@ -565,7 +567,7 @@ let mk = hcats( [ DHDoc_common.Delim.sym_Fun, - DHDoc_Pat.mk(~infomap, dp) + DHDoc_Pat.mk(~infomap, ~show_casts=settings.show_casts, dp) |> DHDoc_common.pad_child( ~inline_padding=(space(), space()), ~enforce_inline, @@ -607,7 +609,12 @@ let mk = [ DHDoc_common.Delim.fix_FixF, space(), - DHDoc_Pat.mk(~infomap, dp, ~enforce_inline=true), + DHDoc_Pat.mk( + ~infomap, + dp, + ~show_casts=settings.show_casts, + ~enforce_inline=true, + ), ] @ [ space(), diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re index e3bb88e74b..95743d8f3e 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re @@ -18,18 +18,19 @@ let precedence = (dp: Pat.t) => | Cons(_) => DHDoc_common.precedence_Cons | Ap(_) => DHDoc_common.precedence_Ap | Parens(_) => DHDoc_common.precedence_const - | Cast(_) => DHDoc_common.precedence_Times + | Cast(_) => DHDoc_common.precedence_Ap }; let rec mk = ( ~infomap: Statics.Map.t, ~parenthesize=false, + ~show_casts, ~enforce_inline: bool, dp: Pat.t, ) : DHDoc.t => { - let mk' = mk(~enforce_inline, ~infomap); + let mk' = mk(~enforce_inline, ~infomap, ~show_casts); let mk_left_associative_operands = (precedence_op, dp1, dp2) => ( mk'(~parenthesize=precedence(dp1) > precedence_op, dp1), mk'(~parenthesize=precedence(dp2) >= precedence_op, dp2), @@ -60,15 +61,23 @@ let rec mk = | Tuple([]) => DHDoc_common.Delim.triv | Tuple(ds) => DHDoc_common.mk_Tuple(List.map(mk', ds)) // TODO: Print type annotations - | Cast(dp, t1, t2) => + | Cast(dp, t1, t2) when show_casts => Doc.hcats([ mk'(dp), - Doc.text(":"), - DHDoc_Typ.mk(~enforce_inline, t1), - Doc.text("<-"), - DHDoc_Typ.mk(~enforce_inline, t2), + Doc.annot( + DHAnnot.CastDecoration, + Doc.hcats([ + DHDoc_common.Delim.open_Cast, + DHDoc_Typ.mk(~enforce_inline=true, t1), + DHDoc_common.Delim.back_arrow_Cast, + DHDoc_Typ.mk(~enforce_inline=true, t2), + DHDoc_common.Delim.close_Cast, + ]), + ), ]) - | Parens(dp) => mk(~enforce_inline, ~parenthesize=true, ~infomap, dp) + | Cast(dp, _, _) => mk'(~parenthesize, dp) + | Parens(dp) => + mk(~enforce_inline, ~parenthesize=true, ~infomap, ~show_casts, dp) | Ap(dp1, dp2) => let (doc1, doc2) = mk_left_associative_operands(DHDoc_common.precedence_Ap, dp1, dp2); diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.rei b/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.rei deleted file mode 100644 index a64fa9d575..0000000000 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.rei +++ /dev/null @@ -1,12 +0,0 @@ -open Haz3lcore; - -let precedence: Pat.t => int; - -let mk: - ( - ~infomap: Statics.Map.t, - ~parenthesize: bool=?, - ~enforce_inline: bool, - Pat.t - ) => - DHDoc.t; diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Typ.rei b/src/haz3lweb/view/dhcode/layout/DHDoc_Typ.rei deleted file mode 100644 index 5ea2583ae4..0000000000 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Typ.rei +++ /dev/null @@ -1,3 +0,0 @@ -open Haz3lcore; - -let mk: (~enforce_inline: bool, Typ.t) => DHDoc.t; diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_common.re b/src/haz3lweb/view/dhcode/layout/DHDoc_common.re index ce3ea7bfe7..ff55cfe7d5 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_common.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_common.re @@ -78,6 +78,7 @@ module Delim = { let open_Cast = mk("<"); let arrow_Cast = mk(Unicode.castArrowSym); + let back_arrow_Cast = mk(Unicode.castBackArrowSym); let close_Cast = mk(">"); let open_FailedCast = open_Cast |> Doc.annot(DHAnnot.FailedCastDelim); diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_common.rei b/src/haz3lweb/view/dhcode/layout/DHDoc_common.rei index 05bf9c542e..c7d3af3622 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_common.rei +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_common.rei @@ -55,6 +55,7 @@ module Delim: { let open_Cast: DHDoc.t; let arrow_Cast: DHDoc.t; + let back_arrow_Cast: DHDoc.t; let close_Cast: DHDoc.t; let open_FailedCast: Pretty.Doc.t(DHAnnot.t); From 4fe9d9cc2f762677ce1f4308561313f737df0572 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Mon, 29 Apr 2024 16:06:55 -0400 Subject: [PATCH 081/103] Fix fixpoint elaboration --- src/haz3lcore/dynamics/Elaborator.re | 50 ++++++++++++++++++---------- src/haz3lcore/dynamics/Transition.re | 2 ++ 2 files changed, 34 insertions(+), 18 deletions(-) diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 95c93aff8b..9827fc4acd 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -51,13 +51,20 @@ let elaborated_type = (m: Statics.Map.t, uexp: UExp.t): (Typ.t, Ctx.t) => { | Some(Info.InfoExp({mode, ty, ctx, _})) => (mode, ty, ctx) | _ => raise(MissingTypeInfo) }; - switch (mode) { - | SynFun - | SynTypFun - | Syn => (self_ty, ctx) - // We need to remove the synswitches from this type. - | Ana(ana_ty) => (Typ.match_synswitch(ana_ty, self_ty), ctx) - }; + let elab_ty = + switch (mode) { + | Syn => self_ty + | SynFun => + let (ty1, ty2) = Typ.matched_arrow(ctx, self_ty); + Typ.Arrow(ty1, ty2) |> Typ.mk_fast; + | SynTypFun => + let (tpat, ty) = Typ.matched_forall(ctx, self_ty); + let tpat = Option.value(tpat, ~default=TPat.fresh(EmptyHole)); + Typ.Forall(tpat, ty) |> Typ.mk_fast; + // We need to remove the synswitches from this type. + | Ana(ana_ty) => Typ.match_synswitch(ana_ty, self_ty) + }; + (elab_ty, ctx); }; let elaborated_pat_type = (m: Statics.Map.t, upat: UPat.t): (Typ.t, Ctx.t) => { @@ -71,16 +78,23 @@ let elaborated_pat_type = (m: Statics.Map.t, upat: UPat.t): (Typ.t, Ctx.t) => { ) | _ => raise(MissingTypeInfo) }; - switch (mode) { - | SynFun - | SynTypFun - | Syn => (self_ty, ctx) - | Ana(ana_ty) => - switch (prev_synswitch) { - | None => (ana_ty, ctx) - | Some(syn_ty) => (Typ.match_synswitch(syn_ty, ana_ty), ctx) - } - }; + let elab_ty = + switch (mode) { + | Syn => self_ty + | SynFun => + let (ty1, ty2) = Typ.matched_arrow(ctx, self_ty); + Typ.Arrow(ty1, ty2) |> Typ.mk_fast; + | SynTypFun => + let (tpat, ty) = Typ.matched_forall(ctx, self_ty); + let tpat = Option.value(tpat, ~default=TPat.fresh(EmptyHole)); + Typ.Forall(tpat, ty) |> Typ.mk_fast; + | Ana(ana_ty) => + switch (prev_synswitch) { + | None => ana_ty + | Some(syn_ty) => Typ.match_synswitch(syn_ty, ana_ty) + } + }; + (elab_ty, ctx); }; let rec elaborate_pattern = @@ -275,7 +289,7 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { let (e', tye) = elaborate(m, e); Exp.FixF(p', fresh_cast(e', tye, typ), env) |> rewrap - |> cast_from(Arrow(typ, typ) |> Typ.mk_fast); + |> cast_from(typ); | TyAlias(_, _, e) => let (e', tye) = elaborate(m, e); e' |> cast_from(tye); diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index 33a6455741..b1662d34d9 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -423,6 +423,8 @@ module Transition = (EV: EV_MODE) => { kind: DeferredAp, is_value: false, }); + | Cast(_) + | FailedCast(_) => Indet | _ => Step({ expr: { From d62f22099e00247626c4470810eaf8e1faef8264 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 2 May 2024 09:12:37 -0400 Subject: [PATCH 082/103] Get tests working --- src/haz3lcore/dynamics/DHExp.re | 127 --------- src/haz3lcore/dynamics/Elaborator.re | 6 +- src/haz3lcore/dynamics/FilterMatcher.re | 2 +- src/haz3lcore/lang/term/TPat.re | 6 - src/haz3lcore/lang/term/Typ.re | 72 +---- src/haz3lcore/statics/TermBase.re | 319 +++++++++++++++++++++ test/Test_Elaboration.re | 359 +++++++++--------------- 7 files changed, 456 insertions(+), 435 deletions(-) diff --git a/src/haz3lcore/dynamics/DHExp.re b/src/haz3lcore/dynamics/DHExp.re index f2829ec89a..d39b9c9874 100644 --- a/src/haz3lcore/dynamics/DHExp.re +++ b/src/haz3lcore/dynamics/DHExp.re @@ -85,133 +85,6 @@ let rec strip_casts = _, ); -let rec fast_equal = - ({term: d1, _} as d1exp: t, {term: d2, _} as d2exp: t): bool => { - switch (d1, d2) { - /* Primitive forms: regular structural equality */ - | (Var(_), _) - /* TODO: Not sure if this is right... */ - | (Bool(_), _) - | (Int(_), _) - | (Float(_), _) - | (Deferral(_), _) - | (Constructor(_), _) => d1 == d2 - | (String(s1), String(s2)) => String.equal(s1, s2) - | (String(_), _) => false - - | (Parens(x), _) => fast_equal(x, d2exp) - | (_, Parens(x)) => fast_equal(d1exp, x) - - /* Non-hole forms: recurse */ - | (Test(d1), Test(d2)) => fast_equal(d1, d2) - | (Seq(d11, d21), Seq(d12, d22)) => - fast_equal(d11, d12) && fast_equal(d21, d22) - | (Filter(f1, d1), Filter(f2, d2)) => - filter_fast_equal(f1, f2) && fast_equal(d1, d2) - | (Let(dp1, d11, d21), Let(dp2, d12, d22)) => - dp1 == dp2 && fast_equal(d11, d12) && fast_equal(d21, d22) - | (FixF(f1, d1, sigma1), FixF(f2, d2, sigma2)) => - f1 == f2 - && fast_equal(d1, d2) - && Option.equal(ClosureEnvironment.id_equal, sigma1, sigma2) - | (Fun(dp1, d1, None, s1), Fun(dp2, d2, None, s2)) => - dp1 == dp2 && fast_equal(d1, d2) && s1 == s2 - | (Fun(dp1, d1, Some(env1), s1), Fun(dp2, d2, Some(env2), s2)) => - dp1 == dp2 - && fast_equal(d1, d2) - && ClosureEnvironment.id_equal(env1, env2) - && s1 == s2 - | (TypFun(_tpat1, d1, s1), TypFun(_tpat2, d2, s2)) => - _tpat1 == _tpat2 && fast_equal(d1, d2) && s1 == s2 - | (TypAp(d1, ty1), TypAp(d2, ty2)) => fast_equal(d1, d2) && ty1 == ty2 - | (Ap(dir1, d11, d21), Ap(dir2, d12, d22)) => - dir1 == dir2 && fast_equal(d11, d12) && fast_equal(d21, d22) - | (DeferredAp(d1, ds1), DeferredAp(d2, ds2)) => - fast_equal(d1, d2) - && List.length(ds1) == List.length(ds2) - && List.for_all2(fast_equal, ds1, ds2) - | (Cons(d11, d21), Cons(d12, d22)) => - fast_equal(d11, d12) && fast_equal(d21, d22) - | (ListConcat(d11, d21), ListConcat(d12, d22)) => - fast_equal(d11, d12) && fast_equal(d21, d22) - | (Tuple(ds1), Tuple(ds2)) => - List.length(ds1) == List.length(ds2) - && List.for_all2(fast_equal, ds1, ds2) - | (BuiltinFun(f1), BuiltinFun(f2)) => f1 == f2 - | (ListLit(ds1), ListLit(ds2)) => - List.length(ds1) == List.length(ds2) - && List.for_all2(fast_equal, ds1, ds2) - | (UnOp(op1, d1), UnOp(op2, d2)) => op1 == op2 && fast_equal(d1, d2) - | (BinOp(op1, d11, d21), BinOp(op2, d12, d22)) => - op1 == op2 && fast_equal(d11, d12) && fast_equal(d21, d22) - | (TyAlias(tp1, ut1, d1), TyAlias(tp2, ut2, d2)) => - tp1 == tp2 && ut1 == ut2 && fast_equal(d1, d2) - | (Cast(d1, ty11, ty21), Cast(d2, ty12, ty22)) - | (FailedCast(d1, ty11, ty21), FailedCast(d2, ty12, ty22)) => - fast_equal(d1, d2) && ty11 == ty12 && ty21 == ty22 - | (DynamicErrorHole(d1, reason1), DynamicErrorHole(d2, reason2)) => - fast_equal(d1, d2) && reason1 == reason2 - | (Match(s1, rs1), Match(s2, rs2)) => - fast_equal(s1, s2) - && List.length(rs2) == List.length(rs2) - && List.for_all2( - ((k1, v1), (k2, v2)) => k1 == k2 && fast_equal(v1, v2), - rs1, - rs2, - ) - | (If(d11, d12, d13), If(d21, d22, d23)) => - fast_equal(d11, d21) && fast_equal(d12, d22) && fast_equal(d13, d23) - /* We can group these all into a `_ => false` clause; separating - these so that we get exhaustiveness checking. */ - | (Seq(_), _) - | (Filter(_), _) - | (Let(_), _) - | (FixF(_), _) - | (Fun(_), _) - | (Test(_), _) - | (Ap(_), _) - | (BuiltinFun(_), _) - | (Cons(_), _) - | (ListConcat(_), _) - | (ListLit(_), _) - | (Tuple(_), _) - | (UnOp(_), _) - | (BinOp(_), _) - | (Cast(_), _) - | (FailedCast(_), _) - | (TyAlias(_), _) - | (TypFun(_), _) - | (TypAp(_), _) - | (DynamicErrorHole(_), _) - | (DeferredAp(_), _) - | (If(_), _) - | (Match(_), _) => false - - /* Hole forms: when checking environments, only check that - environment ID's are equal, don't check structural equality. - - (This resolves a performance issue with many nested holes.) */ - | (EmptyHole, EmptyHole) => true - | (MultiHole(_), MultiHole(_)) => rep_id(d1exp) == rep_id(d2exp) - | (Invalid(text1), Invalid(text2)) => text1 == text2 - | (Closure(sigma1, d1), Closure(sigma2, d2)) => - ClosureEnvironment.id_equal(sigma1, sigma2) && fast_equal(d1, d2) - | (EmptyHole, _) - | (MultiHole(_), _) - | (Invalid(_), _) - | (Closure(_), _) => false - }; -} -and filter_fast_equal = (f1, f2) => { - switch (f1, f2) { - | (Filter(f1), Filter(f2)) => - fast_equal(f1.pat, f2.pat) && f1.act == f2.act - | (Residue(idx1, act1), Residue(idx2, act2)) => - idx1 == idx2 && act1 == act2 - | _ => false - }; -}; - let assign_name_if_none = (t, name) => { let (term, rewrap) = unwrap(t); switch (term) { diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 9827fc4acd..30d4446e0d 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -265,10 +265,9 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { }; } ); - // TODO: is elaborated_type the right type to use here?? - if (!Statics.is_recursive(ctx, p, def, elaborated_type)) { + let (p, ty1) = elaborate_pattern(m, p); + if (!Statics.is_recursive(ctx, p, def, ty1)) { let def = add_name(Pat.get_var(p), def); - let (p, ty1) = elaborate_pattern(m, p); let (def, ty2) = elaborate(m, def); let (body, ty) = elaborate(m, body); Exp.Let(p, fresh_cast(def, ty2, ty1), body) @@ -278,7 +277,6 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { // TODO: Add names to mutually recursive functions // TODO: Don't add fixpoint if there already is one let def = add_name(Option.map(s => s ++ "+", Pat.get_var(p)), def); - let (p, ty1) = elaborate_pattern(m, p); let (def, ty2) = elaborate(m, def); let (body, ty) = elaborate(m, body); let fixf = FixF(p, fresh_cast(def, ty2, ty1), None) |> DHExp.fresh; diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index 1787b271a7..22d2141242 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -41,7 +41,7 @@ let rec matches_exp = | (Deferral(_), _) => false | (Filter(df, dd), Filter(ff, fd)) => - DHExp.filter_fast_equal(df, ff) && matches_exp(env, dd, fd) + TermBase.StepperFilterKind.fast_equal(df, ff) && matches_exp(env, dd, fd) | (Filter(_), _) => false | (Bool(dv), Bool(fv)) => dv == fv diff --git a/src/haz3lcore/lang/term/TPat.re b/src/haz3lcore/lang/term/TPat.re index c3e0671b67..3dade36b54 100644 --- a/src/haz3lcore/lang/term/TPat.re +++ b/src/haz3lcore/lang/term/TPat.re @@ -29,9 +29,3 @@ let show_cls: cls => string = | MultiHole => "Broken type alias" | EmptyHole => "Empty type alias hole" | Var => "Type alias"; - -let tyvar_of_utpat = ({term, _}: t) => - switch (term) { - | Var(x) => Some(x) - | _ => None - }; diff --git a/src/haz3lcore/lang/term/Typ.re b/src/haz3lcore/lang/term/Typ.re index 74940f6db1..2f58e9422b 100644 --- a/src/haz3lcore/lang/term/Typ.re +++ b/src/haz3lcore/lang/term/Typ.re @@ -244,37 +244,6 @@ let fresh_var = (var_name: string) => { var_name ++ "_α" ++ string_of_int(x); }; -let rec subst = (s: t, x: TPat.t, ty: t) => { - switch (TPat.tyvar_of_utpat(x)) { - | Some(str) => - let (term, rewrap) = unwrap(ty); - switch (term) { - | Int => Int |> rewrap - | Float => Float |> rewrap - | Bool => Bool |> rewrap - | String => String |> rewrap - | Unknown(prov) => Unknown(prov) |> rewrap - | Arrow(ty1, ty2) => - Arrow(subst(s, x, ty1), subst(s, x, ty2)) |> rewrap - | Prod(tys) => Prod(List.map(subst(s, x), tys)) |> rewrap - | Sum(sm) => - Sum(ConstructorMap.map(Option.map(subst(s, x)), sm)) |> rewrap - | Forall(tp2, ty) - when TPat.tyvar_of_utpat(x) == TPat.tyvar_of_utpat(tp2) => - Forall(tp2, ty) |> rewrap - | Forall(tp2, ty) => Forall(tp2, subst(s, x, ty)) |> rewrap - | Rec(tp2, ty) when TPat.tyvar_of_utpat(x) == TPat.tyvar_of_utpat(tp2) => - Rec(tp2, ty) |> rewrap - | Rec(tp2, ty) => Rec(tp2, subst(s, x, ty)) |> rewrap - | List(ty) => List(subst(s, x, ty)) |> rewrap - | Var(y) => str == y ? s : Var(y) |> rewrap - | Parens(ty) => Parens(subst(s, x, ty)) |> rewrap - | Ap(t1, t2) => Ap(subst(s, x, t1), subst(s, x, t2)) |> rewrap - }; - | None => ty - }; -}; - let unroll = (ty: t): t => switch (term_of(ty)) { | Rec(tp, ty_body) => subst(ty, tp, ty_body) @@ -283,46 +252,7 @@ let unroll = (ty: t): t => /* Type Equality: This coincides with alpha equivalence for normalized types. Other types may be equivalent but this will not detect so if they are not normalized. */ -let rec eq_internal = (n: int, t1: t, t2: t) => { - switch (term_of(t1), term_of(t2)) { - | (Parens(t1), _) => eq_internal(n, t1, t2) - | (_, Parens(t2)) => eq_internal(n, t1, t2) - | (Rec(x1, t1), Rec(x2, t2)) - | (Forall(x1, t1), Forall(x2, t2)) => - let alpha_subst = subst(Var("=" ++ string_of_int(n)) |> mk_fast); - eq_internal(n + 1, alpha_subst(x1, t1), alpha_subst(x2, t2)); - | (Rec(_), _) => false - | (Forall(_), _) => false - | (Int, Int) => true - | (Int, _) => false - | (Float, Float) => true - | (Float, _) => false - | (Bool, Bool) => true - | (Bool, _) => false - | (String, String) => true - | (String, _) => false - | (Ap(t1, t2), Ap(t1', t2')) => - eq_internal(n, t1, t1') && eq_internal(n, t2, t2') - | (Ap(_), _) => false - | (Unknown(_), Unknown(_)) => true - | (Unknown(_), _) => false - | (Arrow(t1, t2), Arrow(t1', t2')) => - eq_internal(n, t1, t1') && eq_internal(n, t2, t2') - | (Arrow(_), _) => false - | (Prod(tys1), Prod(tys2)) => List.equal(eq_internal(n), tys1, tys2) - | (Prod(_), _) => false - | (List(t1), List(t2)) => eq_internal(n, t1, t2) - | (List(_), _) => false - | (Sum(sm1), Sum(sm2)) => - /* Does not normalize the types. */ - ConstructorMap.equal(eq_internal(n), sm1, sm2) - | (Sum(_), _) => false - | (Var(n1), Var(n2)) => n1 == n2 - | (Var(_), _) => false - }; -}; - -let eq = (t1: t, t2: t): bool => eq_internal(0, t1, t2); +let eq = (t1: t, t2: t): bool => fast_equal(t1, t2); /* Lattice join on types. This is a LUB join in the hazel2 sense in that any type dominates Unknown. The optional diff --git a/src/haz3lcore/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index 1d9c762f75..4fb9476c23 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -27,6 +27,8 @@ module rec Any: { t ) => t; + + let fast_equal: (t, t) => bool; } = { [@deriving (show({with_path: false}), sexp, yojson)] type t = @@ -67,6 +69,24 @@ module rec Any: { }; x |> f_any(rec_call); }; + + let fast_equal = (x, y) => + switch (x, y) { + | (Exp(x), Exp(y)) => Exp.fast_equal(x, y) + | (Pat(x), Pat(y)) => Pat.fast_equal(x, y) + | (Typ(x), Typ(y)) => Typ.fast_equal(x, y) + | (TPat(x), TPat(y)) => TPat.fast_equal(x, y) + | (Rul(x), Rul(y)) => Rul.fast_equal(x, y) + | (Nul (), Nul ()) => true + | (Any (), Any ()) => true + | (Exp(_), _) + | (Pat(_), _) + | (Typ(_), _) + | (TPat(_), _) + | (Rul(_), _) + | (Nul (), _) + | (Any (), _) => false + }; } and Exp: { [@deriving (show({with_path: false}), sexp, yojson)] @@ -132,6 +152,8 @@ and Exp: { t ) => t; + + let fast_equal: (t, t) => bool; } = { [@deriving (show({with_path: false}), sexp, yojson)] type deferral_position = @@ -268,6 +290,118 @@ and Exp: { }; x |> f_exp(rec_call); }; + + let rec fast_equal = (e1, e2) => + switch (e1 |> IdTagged.term_of, e2 |> IdTagged.term_of) { + | (DynamicErrorHole(x, _), _) + | (Parens(x), _) => fast_equal(x, e2) + | (_, DynamicErrorHole(x, _)) + | (_, Parens(x)) => fast_equal(e1, x) + | (EmptyHole, EmptyHole) => true + | (Invalid(s1), Invalid(s2)) => s1 == s2 + | (MultiHole(xs), MultiHole(ys)) when List.length(xs) == List.length(ys) => + List.equal(Any.fast_equal, xs, ys) + | (FailedCast(e1, t1, t2), FailedCast(e2, t3, t4)) => + Exp.fast_equal(e1, e2) + && Typ.fast_equal(t1, t3) + && Typ.fast_equal(t2, t4) + | (Deferral(d1), Deferral(d2)) => d1 == d2 + | (Bool(b1), Bool(b2)) => b1 == b2 + | (Int(i1), Int(i2)) => i1 == i2 + | (Float(f1), Float(f2)) => f1 == f2 + | (String(s1), String(s2)) => s1 == s2 + | (ListLit(xs), ListLit(ys)) => + List.length(xs) == List.length(ys) && List.equal(fast_equal, xs, ys) + | (Constructor(c1), Constructor(c2)) => c1 == c2 + | (Fun(p1, e1, env1, _), Fun(p2, e2, env2, _)) => + Pat.fast_equal(p1, p2) + && fast_equal(e1, e2) + && Option.equal(ClosureEnvironment.id_equal, env1, env2) + | (TypFun(tp1, e1, _), TypFun(tp2, e2, _)) => + TPat.fast_equal(tp1, tp2) && fast_equal(e1, e2) + | (Tuple(xs), Tuple(ys)) => + List.length(xs) == List.length(ys) && List.equal(fast_equal, xs, ys) + | (Var(v1), Var(v2)) => v1 == v2 + | (Let(p1, e1, e2), Let(p2, e3, e4)) => + Pat.fast_equal(p1, p2) && fast_equal(e1, e3) && fast_equal(e2, e4) + | (FixF(p1, e1, c1), FixF(p2, e2, c2)) => + Pat.fast_equal(p1, p2) + && fast_equal(e1, e2) + && Option.equal(ClosureEnvironment.id_equal, c1, c2) + | (TyAlias(tp1, t1, e1), TyAlias(tp2, t2, e2)) => + TPat.fast_equal(tp1, tp2) + && Typ.fast_equal(t1, t2) + && fast_equal(e1, e2) + | (Ap(d1, e1, e2), Ap(d2, e3, e4)) => + d1 == d2 && fast_equal(e1, e3) && fast_equal(e2, e4) + | (TypAp(e1, t1), TypAp(e2, t2)) => + fast_equal(e1, e2) && Typ.fast_equal(t1, t2) + | (DeferredAp(e1, es1), DeferredAp(e2, es2)) => + List.length(es1) == List.length(es2) + && fast_equal(e1, e2) + && List.equal(fast_equal, es1, es2) + | (If(e1, e2, e3), If(e4, e5, e6)) => + fast_equal(e1, e4) && fast_equal(e2, e5) && fast_equal(e3, e6) + | (Seq(e1, e2), Seq(e3, e4)) => + fast_equal(e1, e3) && fast_equal(e2, e4) + | (Test(e1), Test(e2)) => fast_equal(e1, e2) + | (Filter(f1, e1), Filter(f2, e2)) => + StepperFilterKind.fast_equal(f1, f2) && fast_equal(e1, e2) + | (Closure(c1, e1), Closure(c2, e2)) => + ClosureEnvironment.id_equal(c1, c2) && fast_equal(e1, e2) + | (Cons(e1, e2), Cons(e3, e4)) => + fast_equal(e1, e3) && fast_equal(e2, e4) + | (ListConcat(e1, e2), ListConcat(e3, e4)) => + fast_equal(e1, e3) && fast_equal(e2, e4) + | (UnOp(o1, e1), UnOp(o2, e2)) => o1 == o2 && fast_equal(e1, e2) + | (BinOp(o1, e1, e2), BinOp(o2, e3, e4)) => + o1 == o2 && fast_equal(e1, e3) && fast_equal(e2, e4) + | (BuiltinFun(f1), BuiltinFun(f2)) => f1 == f2 + | (Match(e1, rls1), Match(e2, rls2)) => + fast_equal(e1, e2) + && List.length(rls1) == List.length(rls2) + && List.for_all2( + ((p1, e1), (p2, e2)) => + Pat.fast_equal(p1, p2) && fast_equal(e1, e2), + rls1, + rls2, + ) + | (Cast(e1, t1, t2), Cast(e2, t3, t4)) => + fast_equal(e1, e2) && Typ.fast_equal(t1, t3) && Typ.fast_equal(t2, t4) + | (Invalid(_), _) + | (FailedCast(_), _) + | (Deferral(_), _) + | (Bool(_), _) + | (Int(_), _) + | (Float(_), _) + | (String(_), _) + | (ListLit(_), _) + | (Constructor(_), _) + | (Fun(_), _) + | (TypFun(_), _) + | (Tuple(_), _) + | (Var(_), _) + | (Let(_), _) + | (FixF(_), _) + | (TyAlias(_), _) + | (Ap(_), _) + | (TypAp(_), _) + | (DeferredAp(_), _) + | (If(_), _) + | (Seq(_), _) + | (Test(_), _) + | (Filter(_), _) + | (Closure(_), _) + | (Cons(_), _) + | (ListConcat(_), _) + | (UnOp(_), _) + | (BinOp(_), _) + | (BuiltinFun(_), _) + | (Match(_), _) + | (Cast(_), _) + | (MultiHole(_), _) + | (EmptyHole, _) => false + }; } and Pat: { [@deriving (show({with_path: false}), sexp, yojson)] @@ -301,6 +435,8 @@ and Pat: { t ) => t; + + let fast_equal: (t, t) => bool; } = { [@deriving (show({with_path: false}), sexp, yojson)] type term = @@ -363,6 +499,48 @@ and Pat: { }; x |> f_pat(rec_call); }; + + let rec fast_equal = (p1, p2) => + switch (p1 |> IdTagged.term_of, p2 |> IdTagged.term_of) { + | (Parens(x), _) => fast_equal(x, p2) + | (_, Parens(x)) => fast_equal(p1, x) + | (EmptyHole, EmptyHole) => true + | (MultiHole(xs), MultiHole(ys)) => + List.length(xs) == List.length(ys) + && List.equal(Any.fast_equal, xs, ys) + | (Invalid(s1), Invalid(s2)) => s1 == s2 + | (Wild, Wild) => true + | (Bool(b1), Bool(b2)) => b1 == b2 + | (Int(i1), Int(i2)) => i1 == i2 + | (Float(f1), Float(f2)) => f1 == f2 + | (String(s1), String(s2)) => s1 == s2 + | (Constructor(c1), Constructor(c2)) => c1 == c2 + | (Var(v1), Var(v2)) => v1 == v2 + | (ListLit(xs), ListLit(ys)) => + List.length(xs) == List.length(ys) && List.equal(fast_equal, xs, ys) + | (Cons(x1, y1), Cons(x2, y2)) => + fast_equal(x1, x2) && fast_equal(y1, y2) + | (Tuple(xs), Tuple(ys)) => + List.length(xs) == List.length(ys) && List.equal(fast_equal, xs, ys) + | (Ap(x1, y1), Ap(x2, y2)) => fast_equal(x1, x2) && fast_equal(y1, y2) + | (Cast(x1, t1, t2), Cast(x2, u1, u2)) => + fast_equal(x1, x2) && Typ.fast_equal(t1, u1) && Typ.fast_equal(t2, u2) + | (EmptyHole, _) + | (MultiHole(_), _) + | (Invalid(_), _) + | (Wild, _) + | (Bool(_), _) + | (Int(_), _) + | (Float(_), _) + | (String(_), _) + | (ListLit(_), _) + | (Constructor(_), _) + | (Cons(_), _) + | (Var(_), _) + | (Tuple(_), _) + | (Ap(_), _) + | (Cast(_), _) => false + }; } and Typ: { [@deriving (show({with_path: false}), sexp, yojson)] @@ -412,6 +590,10 @@ and Typ: { t ) => t; + + let subst: (t, TPat.t, t) => t; + + let fast_equal: (t, t) => bool; } = { [@deriving (show({with_path: false}), sexp, yojson)] type type_hole = @@ -502,6 +684,86 @@ and Typ: { }; x |> f_typ(rec_call); }; + + let rec subst = (s: t, x: TPat.t, ty: t) => { + switch (TPat.tyvar_of_utpat(x)) { + | Some(str) => + let (term, rewrap) = IdTagged.unwrap(ty); + switch (term) { + | Int => Int |> rewrap + | Float => Float |> rewrap + | Bool => Bool |> rewrap + | String => String |> rewrap + | Unknown(prov) => Unknown(prov) |> rewrap + | Arrow(ty1, ty2) => + Arrow(subst(s, x, ty1), subst(s, x, ty2)) |> rewrap + | Prod(tys) => Prod(List.map(subst(s, x), tys)) |> rewrap + | Sum(sm) => + Sum(ConstructorMap.map(Option.map(subst(s, x)), sm)) |> rewrap + | Forall(tp2, ty) + when TPat.tyvar_of_utpat(x) == TPat.tyvar_of_utpat(tp2) => + Forall(tp2, ty) |> rewrap + | Forall(tp2, ty) => Forall(tp2, subst(s, x, ty)) |> rewrap + | Rec(tp2, ty) when TPat.tyvar_of_utpat(x) == TPat.tyvar_of_utpat(tp2) => + Rec(tp2, ty) |> rewrap + | Rec(tp2, ty) => Rec(tp2, subst(s, x, ty)) |> rewrap + | List(ty) => List(subst(s, x, ty)) |> rewrap + | Var(y) => str == y ? s : Var(y) |> rewrap + | Parens(ty) => Parens(subst(s, x, ty)) |> rewrap + | Ap(t1, t2) => Ap(subst(s, x, t1), subst(s, x, t2)) |> rewrap + }; + | None => ty + }; + }; + + /* Type Equality: This coincides with alpha equivalence for normalized types. + Other types may be equivalent but this will not detect so if they are not normalized. */ + + let rec eq_internal = (n: int, t1: t, t2: t) => { + switch (IdTagged.term_of(t1), IdTagged.term_of(t2)) { + | (Parens(t1), _) => eq_internal(n, t1, t2) + | (_, Parens(t2)) => eq_internal(n, t1, t2) + | (Rec(x1, t1), Rec(x2, t2)) + | (Forall(x1, t1), Forall(x2, t2)) => + let alpha_subst = + subst({ + term: Var("=" ++ string_of_int(n)), + copied: false, + ids: [Id.invalid], + }); + eq_internal(n + 1, alpha_subst(x1, t1), alpha_subst(x2, t2)); + | (Rec(_), _) => false + | (Forall(_), _) => false + | (Int, Int) => true + | (Int, _) => false + | (Float, Float) => true + | (Float, _) => false + | (Bool, Bool) => true + | (Bool, _) => false + | (String, String) => true + | (String, _) => false + | (Ap(t1, t2), Ap(t1', t2')) => + eq_internal(n, t1, t1') && eq_internal(n, t2, t2') + | (Ap(_), _) => false + | (Unknown(_), Unknown(_)) => true + | (Unknown(_), _) => false + | (Arrow(t1, t2), Arrow(t1', t2')) => + eq_internal(n, t1, t1') && eq_internal(n, t2, t2') + | (Arrow(_), _) => false + | (Prod(tys1), Prod(tys2)) => List.equal(eq_internal(n), tys1, tys2) + | (Prod(_), _) => false + | (List(t1), List(t2)) => eq_internal(n, t1, t2) + | (List(_), _) => false + | (Sum(sm1), Sum(sm2)) => + /* Does not normalize the types. */ + ConstructorMap.equal(eq_internal(n), sm1, sm2) + | (Sum(_), _) => false + | (Var(n1), Var(n2)) => n1 == n2 + | (Var(_), _) => false + }; + }; + + let fast_equal = eq_internal(0); } and TPat: { [@deriving (show({with_path: false}), sexp, yojson)] @@ -523,6 +785,10 @@ and TPat: { t ) => t; + + let tyvar_of_utpat: t => option(string); + + let fast_equal: (t, t) => bool; } = { [@deriving (show({with_path: false}), sexp, yojson)] type term = @@ -556,6 +822,26 @@ and TPat: { }; x |> f_tpat(rec_call); }; + + let tyvar_of_utpat = ({term, _}: t) => + switch (term) { + | Var(x) => Some(x) + | _ => None + }; + + let fast_equal = (tp1: t, tp2: t) => + switch (tp1 |> IdTagged.term_of, tp2 |> IdTagged.term_of) { + | (EmptyHole, EmptyHole) => true + | (Invalid(s1), Invalid(s2)) => s1 == s2 + | (MultiHole(xs), MultiHole(ys)) => + List.length(xs) == List.length(ys) + && List.equal(Any.fast_equal, xs, ys) + | (Var(x), Var(y)) => x == y + | (EmptyHole, _) + | (Invalid(_), _) + | (MultiHole(_), _) + | (Var(_), _) => false + }; } and Rul: { [@deriving (show({with_path: false}), sexp, yojson)] @@ -576,6 +862,8 @@ and Rul: { t ) => t; + + let fast_equal: (t, t) => bool; } = { [@deriving (show({with_path: false}), sexp, yojson)] type term = @@ -618,6 +906,26 @@ and Rul: { }; x |> f_rul(rec_call); }; + + let fast_equal = (r1: t, r2: t) => + switch (r1 |> IdTagged.term_of, r2 |> IdTagged.term_of) { + | (Invalid(s1), Invalid(s2)) => s1 == s2 + | (Hole(xs), Hole(ys)) => + List.length(xs) == List.length(ys) + && List.equal(Any.fast_equal, xs, ys) + | (Rules(e1, rls1), Rules(e2, rls2)) => + Exp.fast_equal(e1, e2) + && List.length(rls1) == List.length(rls2) + && List.for_all2( + ((p1, e1), (p2, e2)) => + Pat.fast_equal(p1, p2) && Exp.fast_equal(e1, e2), + rls1, + rls2, + ) + | (Invalid(_), _) + | (Hole(_), _) + | (Rules(_), _) => false + }; } and Environment: { @@ -771,6 +1079,8 @@ and StepperFilterKind: { t; let map: (Exp.t => Exp.t, t) => t; + + let fast_equal: (t, t) => bool; } = { [@deriving (show({with_path: false}), sexp, yojson)] type filter = { @@ -805,4 +1115,13 @@ and StepperFilterKind: { | Filter({pat: e, act}) => Filter({pat: exp_map_term(e), act}) | Residue(i, a) => Residue(i, a); }; + + let fast_equal = (f1, f2) => + switch (f1, f2) { + | (Filter({pat: e1, act: a1}), Filter({pat: e2, act: a2})) => + Exp.fast_equal(e1, e2) && a1 == a2 + | (Residue(i1, a1), Residue(i2, a2)) => i1 == i2 && a1 == a2 + | (Filter(_), _) + | (Residue(_), _) => false + }; }; diff --git a/test/Test_Elaboration.re b/test/Test_Elaboration.re index 98d1db0fdd..a2db9c0de4 100644 --- a/test/Test_Elaboration.re +++ b/test/Test_Elaboration.re @@ -1,279 +1,186 @@ open Alcotest; open Haz3lcore; -let dhexp_eq = (d1: option(DHExp.t), d2: option(DHExp.t)): bool => - switch (d1, d2) { - | (Some(d1), Some(d2)) => DHExp.fast_equal(d1, d2) - | _ => false - }; - -let dhexp_print = (d: option(DHExp.t)): string => - switch (d) { - | None => "None" - | Some(d) => DHExp.show(d) - }; - /*Create a testable type for dhexp which requires an equal function (dhexp_eq) and a print function (dhexp_print) */ -let dhexp_typ = testable(Fmt.using(dhexp_print, Fmt.string), dhexp_eq); +let dhexp_typ = testable(Fmt.using(Exp.show, Fmt.string), DHExp.fast_equal); let ids = List.init(12, _ => Id.mk()); let id_at = x => x |> List.nth(ids); let mk_map = CoreSettings.on |> Interface.Statics.mk_map; -let dhexp_of_uexp = u => Elaborator.dhexp_of_uexp(mk_map(u), u, false); +let dhexp_of_uexp = u => Elaborator.elaborate(mk_map(u), u) |> fst; let alco_check = dhexp_typ |> Alcotest.check; -let u1: Term.UExp.t = {ids: [id_at(0)], term: Int(8)}; +let u1: Exp.t = {ids: [id_at(0)], term: Int(8), copied: false}; let single_integer = () => - alco_check("Integer literal 8", Some(IntLit(8)), dhexp_of_uexp(u1)); + alco_check("Integer literal 8", u1, dhexp_of_uexp(u1)); -let u2: Term.UExp.t = {ids: [id_at(0)], term: EmptyHole}; -let empty_hole = () => - alco_check( - "Empty hole", - Some(EmptyHole(id_at(0), 0)), - dhexp_of_uexp(u2), - ); +let u2: Exp.t = {ids: [id_at(0)], term: EmptyHole, copied: false}; +let empty_hole = () => alco_check("Empty hole", u2, dhexp_of_uexp(u2)); -let u3: Term.UExp.t = { +let u3: Exp.t = { ids: [id_at(0)], - term: Parens({ids: [id_at(1)], term: Var("y")}), + term: Parens({ids: [id_at(1)], term: Var("y"), copied: false}), + copied: false, }; -let d3: DHExp.t = - NonEmptyHole(TypeInconsistent, id_at(1), 0, FreeVar(id_at(1), 0, "y")); -let free_var = () => - alco_check( - "Nonempty hole with free variable", - Some(d3), - dhexp_of_uexp(u3), - ); -let u4: Term.UExp.t = { - ids: [id_at(0)], - term: - Let( - { - ids: [id_at(1)], - term: - Tuple([ - {ids: [id_at(2)], term: Var("a")}, - {ids: [id_at(3)], term: Var("b")}, - ]), - }, - { - ids: [id_at(4)], - term: - Tuple([ - {ids: [id_at(5)], term: Int(4)}, - {ids: [id_at(6)], term: Int(6)}, - ]), - }, - { - ids: [id_at(7)], - term: - BinOp( - Int(Minus), - {ids: [id_at(8)], term: Var("a")}, - {ids: [id_at(9)], term: Var("b")}, - ), - }, - ), -}; -let d4: DHExp.t = +let free_var = () => alco_check("free variable", u3, dhexp_of_uexp(u3)); + +let u4: Exp.t = Let( - Tuple([Var("a"), Var("b")]), - Tuple([IntLit(4), IntLit(6)]), - BinIntOp(Minus, BoundVar("a"), BoundVar("b")), - ); + Tuple([Var("a") |> Pat.fresh, Var("b") |> Pat.fresh]) |> Pat.fresh, + Tuple([Int(4) |> Exp.fresh, Int(6) |> Exp.fresh]) |> Exp.fresh, + BinOp(Int(Minus), Var("a") |> Exp.fresh, Var("b") |> Exp.fresh) + |> Exp.fresh, + ) + |> Exp.fresh; + let let_exp = () => - alco_check( - "Let expression for tuple (a, b)", - Some(d4), - dhexp_of_uexp(u4), - ); + alco_check("Let expression for tuple (a, b)", u4, dhexp_of_uexp(u4)); + +let u5 = + BinOp(Int(Plus), Bool(false) |> Exp.fresh, Var("y") |> Exp.fresh) + |> Exp.fresh; + +let d5 = + BinOp( + Int(Plus), + FailedCast(Bool(false) |> Exp.fresh, Bool |> Typ.fresh, Int |> Typ.fresh) + |> Exp.fresh, + Cast( + Var("y") |> Exp.fresh, + Unknown(Internal) |> Typ.fresh, + Int |> Typ.fresh, + ) + |> Exp.fresh, + ) + |> Exp.fresh; -let u5: Term.UExp.t = { - ids: [id_at(0)], - term: - BinOp( - Int(Plus), - {ids: [id_at(1)], term: Bool(false)}, - {ids: [id_at(2)], term: Var("y")}, - ), -}; -let d5: DHExp.t = - BinIntOp( - Plus, - NonEmptyHole(TypeInconsistent, id_at(1), 0, BoolLit(false)), - NonEmptyHole(TypeInconsistent, id_at(2), 0, FreeVar(id_at(2), 0, "y")), - ); let bin_op = () => alco_check( "Inconsistent binary integer operation (plus)", - Some(d5), + d5, dhexp_of_uexp(u5), ); -let u6: Term.UExp.t = { - ids: [id_at(0)], - term: - If( - {ids: [id_at(1)], term: Bool(false)}, - {ids: [id_at(2)], term: Int(8)}, - {ids: [id_at(3)], term: Int(6)}, - ), -}; -let d6: DHExp.t = - IfThenElse(DH.ConsistentIf, BoolLit(false), IntLit(8), IntLit(6)); +let u6: Exp.t = + If(Bool(false) |> Exp.fresh, Int(8) |> Exp.fresh, Int(6) |> Exp.fresh) + |> Exp.fresh; + let consistent_if = () => alco_check( "Consistent case with rules (BoolLit(true), IntLit(8)) and (BoolLit(false), IntLit(6))", - Some(d6), + u6, dhexp_of_uexp(u6), ); -let u7: Term.UExp.t = { - ids: [id_at(0)], - term: - Ap( - { - ids: [id_at(1)], - term: - Fun( - {ids: [id_at(2)], term: Var("x")}, - { - ids: [id_at(3)], - term: - BinOp( - Int(Plus), - {ids: [id_at(4)], term: Int(4)}, - {ids: [id_at(5)], term: Var("x")}, - ), - }, - ), - }, - {ids: [id_at(6)], term: Var("y")}, - ), -}; -let d7: DHExp.t = +let u7: Exp.t = Ap( + Forward, Fun( - Var("x"), - Unknown(Internal), - BinIntOp( - Plus, - IntLit(4), - Cast(BoundVar("x"), Unknown(Internal), Int), - ), + Var("x") |> Pat.fresh, + BinOp(Int(Plus), Int(4) |> Exp.fresh, Int(5) |> Exp.fresh) + |> Exp.fresh, None, - ), - NonEmptyHole(TypeInconsistent, id_at(6), 0, FreeVar(id_at(6), 0, "y")), - ); + None, + ) + |> Exp.fresh, + Var("y") |> Exp.fresh, + ) + |> Exp.fresh; + let ap_fun = () => - alco_check( - "Application of a function of a free variable wrapped inside a nonempty hole constructor", - Some(d7), - dhexp_of_uexp(u7), - ); + alco_check("Application of a function", u7, dhexp_of_uexp(u7)); + +let u8: Exp.t = + Match( + BinOp(Int(Equals), Int(4) |> Exp.fresh, Int(3) |> Exp.fresh) + |> Exp.fresh, + [ + (Bool(true) |> Pat.fresh, Int(24) |> Exp.fresh), + (Bool(false) |> Pat.fresh, Bool(false) |> Exp.fresh), + ], + ) + |> Exp.fresh; + +let d8: Exp.t = + Match( + BinOp(Int(Equals), Int(4) |> Exp.fresh, Int(3) |> Exp.fresh) + |> Exp.fresh, + [ + ( + Bool(true) |> Pat.fresh, + Cast( + Int(24) |> Exp.fresh, + Int |> Typ.fresh, + Unknown(Internal) |> Typ.fresh, + ) + |> Exp.fresh, + ), + ( + Bool(false) |> Pat.fresh, + Cast( + Bool(false) |> Exp.fresh, + Bool |> Typ.fresh, + Unknown(Internal) |> Typ.fresh, + ) + |> Exp.fresh, + ), + ], + ) + |> Exp.fresh; -let u8: Term.UExp.t = { - ids: [id_at(0)], - term: - Match( - { - ids: [id_at(1)], - term: - BinOp( - Int(Equals), - {ids: [id_at(2)], term: Int(4)}, - {ids: [id_at(3)], term: Int(3)}, - ), - }, - [ - ( - {ids: [id_at(6)], term: Bool(true)}, - {ids: [id_at(4)], term: Int(24)}, - ), - ( - {ids: [id_at(7)], term: Bool(false)}, - {ids: [id_at(5)], term: Bool(false)}, - ), - ], - ), -}; -let d8scrut: DHExp.t = BinIntOp(Equals, IntLit(4), IntLit(3)); -let d8rules = - DHExp.[ - Rule(BoolLit(true), IntLit(24)), - Rule(BoolLit(false), BoolLit(false)), - ]; -let d8a: DHExp.t = - InconsistentBranches(id_at(0), 0, Case(d8scrut, d8rules, 0)); -let d8: DHExp.t = NonEmptyHole(TypeInconsistent, id_at(0), 0, d8a); let inconsistent_case = () => alco_check( "Inconsistent branches where the first branch is an integer and second branch is a boolean", - Some(d8), + d8, dhexp_of_uexp(u8), ); -let u9: Term.UExp.t = { - ids: [id_at(0)], - term: - Let( - { - ids: [id_at(1)], - term: - TypeAnn( - {ids: [id_at(2)], term: Var("f")}, - { - ids: [id_at(3)], - term: - Arrow( - {ids: [id_at(4)], term: Int}, - {ids: [id_at(5)], term: Int}, - ), - }, - ), - }, - { - ids: [id_at(6)], - term: - Fun( - {ids: [id_at(7)], term: Var("x")}, - { - ids: [id_at(8)], - term: - BinOp( - Int(Plus), - {ids: [id_at(9)], term: Int(1)}, - {ids: [id_at(10)], term: Var("x")}, - ), - }, - ), - }, - {ids: [id_at(11)], term: Int(55)}, - ), -}; -let d9: DHExp.t = +let u9: Exp.t = Let( - Var("f"), + Cast( + Var("f") |> Pat.fresh, + Arrow(Int |> Typ.fresh, Int |> Typ.fresh) |> Typ.fresh, + Unknown(Internal) |> Typ.fresh, + ) + |> Pat.fresh, + Fun( + Var("x") |> Pat.fresh, + BinOp(Int(Plus), Int(1) |> Exp.fresh, Var("x") |> Exp.fresh) + |> Exp.fresh, + None, + None, + ) + |> Exp.fresh, + Int(55) |> Exp.fresh, + ) + |> Exp.fresh; + +let d9: Exp.t = + Let( + Var("f") |> Pat.fresh, FixF( - "f", - Arrow(Int, Int), + Var("f") |> Pat.fresh, Fun( - Var("x"), - Int, - BinIntOp(Plus, IntLit(1), BoundVar("x")), + Var("x") |> Pat.fresh, + BinOp(Int(Plus), Int(1) |> Exp.fresh, Var("x") |> Exp.fresh) + |> Exp.fresh, + None, Some("f+"), - ), - ), - IntLit(55), - ); + ) + |> Exp.fresh, + None, + ) + |> Exp.fresh, + Int(55) |> Exp.fresh, + ) + |> Exp.fresh; + let let_fun = () => alco_check( "Let expression for function which wraps a fix point constructor around the function", - Some(d9), + d9, dhexp_of_uexp(u9), ); From 35cf7b9a43b6ea9f505251f6a399e5f2e9f477aa Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 2 May 2024 10:17:35 -0400 Subject: [PATCH 083/103] Fix constructor casting issues --- src/haz3lcore/dynamics/Casts.re | 11 ++++++- src/haz3lcore/dynamics/Elaborator.re | 38 +++++++++++++++++++------ src/haz3lcore/dynamics/PatternMatch.re | 10 +------ src/haz3lcore/dynamics/Unboxing.re | 8 ++++-- src/haz3lcore/statics/ConstructorMap.re | 3 +- 5 files changed, 49 insertions(+), 21 deletions(-) diff --git a/src/haz3lcore/dynamics/Casts.re b/src/haz3lcore/dynamics/Casts.re index c5cda8ef27..0ea32adcba 100644 --- a/src/haz3lcore/dynamics/Casts.re +++ b/src/haz3lcore/dynamics/Casts.re @@ -144,7 +144,16 @@ let rec transition = (~recursive=false, d: DHExp.t): option(DHExp.t) => { |> DHExp.fresh, ) - | (Ground, NotGroundOrHole(_)) + | (Ground, NotGroundOrHole(_)) => + switch (DHExp.term_of(d1)) { + | Cast(d2, t3, _) => + if (Typ.eq(t3, t2)) { + Some(d2); + } else { + None; + } + | _ => None + } | (NotGroundOrHole(_), Ground) => /* can't do anything when casting between diseq, non-hole types */ None diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 30d4446e0d..e2e5172bc7 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -35,7 +35,12 @@ let fresh_cast = (d: DHExp.t, t1: Typ.t, t2: Typ.t): DHExp.t => { let fresh_pat_cast = (p: DHPat.t, t1: Typ.t, t2: Typ.t): DHPat.t => { Typ.eq(t1, t2) ? p - : Cast( + : { + let _ = print_endline("=====vvvvv==="); + let _ = print_endline(Typ.show(t1)); + let _ = print_endline(Typ.show(t2)); + let _ = print_endline("=====^^^^^==="); + Cast( DHPat.fresh(Cast(p, t1, Typ.mk_fast(Unknown(Internal)))) |> Casts.pattern_fixup, Typ.mk_fast(Unknown(Internal)), @@ -43,6 +48,7 @@ let fresh_pat_cast = (p: DHPat.t, t1: Typ.t, t2: Typ.t): DHPat.t => { ) |> DHPat.fresh |> Casts.pattern_fixup; + }; }; let elaborated_type = (m: Statics.Map.t, uexp: UExp.t): (Typ.t, Ctx.t) => { @@ -64,7 +70,7 @@ let elaborated_type = (m: Statics.Map.t, uexp: UExp.t): (Typ.t, Ctx.t) => { // We need to remove the synswitches from this type. | Ana(ana_ty) => Typ.match_synswitch(ana_ty, self_ty) }; - (elab_ty, ctx); + (elab_ty |> Typ.normalize(ctx), ctx); }; let elaborated_pat_type = (m: Statics.Map.t, upat: UPat.t): (Typ.t, Ctx.t) => { @@ -94,7 +100,7 @@ let elaborated_pat_type = (m: Statics.Map.t, upat: UPat.t): (Typ.t, Ctx.t) => { | Some(syn_ty) => Typ.match_synswitch(syn_ty, ana_ty) } }; - (elab_ty, ctx); + (elab_ty |> Typ.normalize(ctx), ctx); }; let rec elaborate_pattern = @@ -144,7 +150,6 @@ let rec elaborate_pattern = let p1'' = fresh_pat_cast(p1', ty1, Arrow(ty1l, ty1r) |> Typ.mk_fast); let p2'' = fresh_pat_cast(p2', ty2, ty1l); DHPat.Ap(p1'', p2'') |> rewrap |> cast_from(ty1r); - | Constructor(_) | Invalid(_) | EmptyHole | MultiHole(_) @@ -153,7 +158,7 @@ let rec elaborate_pattern = upat |> cast_from( Ctx.lookup_var(ctx, v) - |> Option.map((x: Ctx.var_entry) => x.typ) + |> Option.map((x: Ctx.var_entry) => x.typ |> Typ.normalize(ctx)) |> Option.value(~default=Typ.mk_fast(Unknown(Internal))), ) // Type annotations should already appear @@ -161,6 +166,18 @@ let rec elaborate_pattern = | Cast(p, _, _) => let (p', ty) = elaborate_pattern(m, p); p' |> cast_from(ty); + | Constructor(c) => + upat + |> cast_from( + Ctx.lookup_ctr(ctx, c) + |> Option.map((x: Ctx.var_entry) => x.typ |> Typ.normalize(ctx)) + |> Option.value( + ~default= + Typ.mk_fast( + Typ.Sum([BadEntry(Typ.mk_fast(Unknown(Internal)))]), + ), + ), + ) }; (dpat, elaborated_type); }; @@ -231,8 +248,13 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { uexp |> cast_from( Ctx.lookup_ctr(ctx, c) - |> Option.map((x: Ctx.var_entry) => x.typ) - |> Option.value(~default=Typ.mk_fast(Typ.Unknown(Internal))), + |> Option.map((x: Ctx.var_entry) => x.typ |> Typ.normalize(ctx)) + |> Option.value( + ~default= + Typ.mk_fast( + Typ.Sum([BadEntry(Typ.mk_fast(Unknown(Internal)))]), + ), + ), ) | Fun(p, e, env, n) => let (p', typ) = elaborate_pattern(m, p); @@ -252,7 +274,7 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { uexp |> cast_from( Ctx.lookup_var(ctx, v) - |> Option.map((x: Ctx.var_entry) => x.typ) + |> Option.map((x: Ctx.var_entry) => x.typ |> Typ.normalize(ctx)) |> Option.value(~default=Typ.mk_fast(Typ.Unknown(Internal))), ) | Let(p, def, body) => diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index 7af6aaa7d9..4a19eb4e61 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -56,13 +56,5 @@ let rec matches = (dp: Pat.t, d: DHExp.t): match_result => |> List.fold_left(combine_result, Matches(Environment.empty)); | Parens(p) => matches(p, d) | Cast(p, t1, t2) => - let _ = print_endline("======="); - let _ = print_endline(Pat.show(p)); - let _ = - print_endline( - DHExp.show( - Cast(d, t2, t1) |> DHExp.fresh |> Casts.transition_multiple, - ), - ); - matches(p, Cast(d, t2, t1) |> DHExp.fresh |> Casts.transition_multiple); + matches(p, Cast(d, t2, t1) |> DHExp.fresh |> Casts.transition_multiple) }; diff --git a/src/haz3lcore/dynamics/Unboxing.re b/src/haz3lcore/dynamics/Unboxing.re index cf722892a1..c049dcd39d 100644 --- a/src/haz3lcore/dynamics/Unboxing.re +++ b/src/haz3lcore/dynamics/Unboxing.re @@ -105,7 +105,9 @@ let rec unbox: type a. (unbox_request(a), DHExp.t) => unboxed(a) = | (SumNoArg(_), Constructor(_)) => DoesNotMatch | (SumNoArg(_), Ap(_, {term: Constructor(_), _}, _)) => DoesNotMatch | (SumNoArg(name), Cast(d1, {term: Sum(_), _}, {term: Sum(s2), _})) - when ConstructorMap.has_constructor_no_args(name, s2) => + when + ConstructorMap.has_constructor_no_args(name, s2) + || ConstructorMap.has_bad_entry(s2) => let* d1 = unbox(SumNoArg(name), d1); Matches(d1); | (SumNoArg(_), Cast(_, {term: Sum(_), _}, {term: Sum(_), _})) => @@ -117,7 +119,9 @@ let rec unbox: type a. (unbox_request(a), DHExp.t) => unboxed(a) = Matches(d3) | (SumWithArg(_), Ap(_, {term: Constructor(_), _}, _)) => DoesNotMatch | (SumWithArg(name), Cast(d1, {term: Sum(_), _}, {term: Sum(s2), _})) - when ConstructorMap.get_entry(name, s2) != None => + when + ConstructorMap.get_entry(name, s2) != None + || ConstructorMap.has_bad_entry(s2) => let* d1 = unbox(SumWithArg(name), d1); Matches(d1 |> fixup_cast); | (SumWithArg(_), Cast(_, {term: Sum(_), _}, {term: Sum(_), _})) => diff --git a/src/haz3lcore/statics/ConstructorMap.re b/src/haz3lcore/statics/ConstructorMap.re index 7284e35b2d..65c7859f3c 100644 --- a/src/haz3lcore/statics/ConstructorMap.re +++ b/src/haz3lcore/statics/ConstructorMap.re @@ -143,6 +143,7 @@ let equal = (eq: ('a, 'a) => bool, m1: t('a), m2: t('a)) => { switch (x, y) { | (Variant(_, _, Some(value1)), Variant(_, _, Some(value2))) => eq(value1, value2) + | (Variant(_, _, None), Variant(_, _, None)) => true | (BadEntry(x), BadEntry(y)) => eq(x, y) | _ => false }, @@ -174,6 +175,6 @@ let has_constructor_no_args = ctr => List.exists( fun | Variant(ctr', _, None) when Constructor.equal(ctr, ctr') => true - | Variant(_) + | Variant(_) => false | BadEntry(_) => false, ); From b38f781cb2ebf0dba213150b65177bdb0516fdd9 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 2 May 2024 10:23:27 -0400 Subject: [PATCH 084/103] Fix TypFun casting --- src/haz3lcore/dynamics/Elaborator.re | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index e2e5172bc7..db9b7e3551 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -344,8 +344,15 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { |> cast_from(Arrow(remaining_arg_ty, tyf2) |> Typ.mk_fast); | TypAp(e, ut) => let (e', tye) = elaborate(m, e); - let (_, tye') = Typ.matched_forall(ctx, tye); - TypAp(e', ut) |> rewrap |> cast_from(tye'); + let (tpat, tye') = Typ.matched_forall(ctx, tye); + let ut' = Typ.normalize(ctx, ut); + let tye'' = + Typ.subst( + ut', + tpat |> Option.value(~default=TPat.fresh(EmptyHole)), + tye', + ); + TypAp(e', ut) |> rewrap |> cast_from(tye''); | If(c, t, f) => let (c', tyc) = elaborate(m, c); let (t', tyt) = elaborate(m, t); From e93ec4751cbfdd8f85604f2e2399848fa7092c9e Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 2 May 2024 10:53:54 -0400 Subject: [PATCH 085/103] Fixpoint printing --- src/haz3lcore/dynamics/Transition.re | 7 ++++++- src/haz3lcore/statics/TermBase.re | 2 +- src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 9 ++++++++- 3 files changed, 15 insertions(+), 3 deletions(-) diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index b1662d34d9..4dd679dd1c 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -173,7 +173,7 @@ module Transition = (EV: EV_MODE) => { expr: d |> fast_copy(Id.mk()), state_update, kind: VarLookup, - is_value: true, + is_value: false, }) | None => Indet }; @@ -425,6 +425,11 @@ module Transition = (EV: EV_MODE) => { }); | Cast(_) | FailedCast(_) => Indet + | FixF(_) => + print_endline(Exp.show(d1)); + print_endline(Exp.show(d1')); + print_endline("FIXF"); + failwith("FixF in Ap"); | _ => Step({ expr: { diff --git a/src/haz3lcore/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index 4fb9476c23..2a38f0d2b0 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -118,7 +118,7 @@ and Exp: { | Tuple(list(t)) | Var(Var.t) | Let(Pat.t, t, t) - | FixF(Pat.t, t, [@show.opaque] option(ClosureEnvironment.t)) + | FixF(Pat.t, t, option(ClosureEnvironment.t)) | TyAlias(TPat.t, Typ.t, t) | Ap(Operators.ap_direction, t, t) | TypAp(t, Typ.t) diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index 0a630288c4..c0e6b9065a 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -624,7 +624,14 @@ let mk = ], ); | FixF(_, {term: Fun(_, _, _, Some(x)), _}, _) => - annot(DHAnnot.Collapsed, text("<" ++ x ++ ">")) + if (String.ends_with(~suffix="+", x)) { + annot( + DHAnnot.Collapsed, + text("<" ++ String.sub(x, 0, String.length(x) - 1) ++ ">"), + ); + } else { + annot(DHAnnot.Collapsed, text("<" ++ x ++ ">")); + } | FixF(_, _, _) => annot(DHAnnot.Collapsed, text("")) }; }; From f42c61d5cb4d8133d4c790e0ed500ef24ebee13b Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 2 May 2024 10:57:18 -0400 Subject: [PATCH 086/103] Fix history toggle --- src/haz3lweb/view/StepperView.re | 30 ++++++++++++++++-------------- 1 file changed, 16 insertions(+), 14 deletions(-) diff --git a/src/haz3lweb/view/StepperView.re b/src/haz3lweb/view/StepperView.re index c3ff3c528d..843dbc702b 100644 --- a/src/haz3lweb/view/StepperView.re +++ b/src/haz3lweb/view/StepperView.re @@ -199,20 +199,22 @@ let stepper_view = @ hidden_steps; }; ( - List.map(previous_step(~hidden=false), tl) - |> List.flatten - |> List.rev_append( - _, - ( - settings.show_hidden_steps - ? hd - |> Stepper.hidden_steps_of_info - |> List.map(previous_step(~hidden=true)) - |> List.flatten - : [] - ) - @ [current], - ) + ( + settings.stepper_history + ? List.map(previous_step(~hidden=false), tl) + |> List.flatten + |> List.rev_append( + _, + settings.show_hidden_steps + ? hd + |> Stepper.hidden_steps_of_info + |> List.map(previous_step(~hidden=true)) + |> List.flatten + : [], + ) + : [] + ) + @ [current] ) @ (settings.show_settings ? settings_modal(~inject, settings) : []); }; From 14e8446524d543445a21e252a0fc5e23dbd9cf8e Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 2 May 2024 11:19:24 -0400 Subject: [PATCH 087/103] Fix duplicate ids --- src/haz3lcore/dynamics/Stepper.re | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/haz3lcore/dynamics/Stepper.re b/src/haz3lcore/dynamics/Stepper.re index 601d4344cb..52321db8dd 100644 --- a/src/haz3lcore/dynamics/Stepper.re +++ b/src/haz3lcore/dynamics/Stepper.re @@ -239,7 +239,7 @@ let rec evaluate_pending = (~settings, s: t) => { let d_loc' = ( switch (take_step(state_ref, eo.env, eo.d_loc)) { - | Some(d) => d + | Some(d) => d |> DHExp.repair_ids | None => raise(Exception) } ) From 91c11ae9f05fda7d9a8e19929b85d42f8f2593cd Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Tue, 7 May 2024 17:00:12 -0400 Subject: [PATCH 088/103] Update DHExp comment --- src/haz3lcore/dynamics/DHExp.re | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/haz3lcore/dynamics/DHExp.re b/src/haz3lcore/dynamics/DHExp.re index d39b9c9874..98b6c26305 100644 --- a/src/haz3lcore/dynamics/DHExp.re +++ b/src/haz3lcore/dynamics/DHExp.re @@ -1,8 +1,8 @@ /* DHExp.re This module is specifically for dynamic expressions. They are stored - using the same data structure as user expressions, but dynamic - expressions are specifically paired with a `Satic.Map.t`. + using the same data structure as user expressions, have been modified + slightly as described in Elaborator.re. */ include Exp; From 5e616820bdb3cf176eccea86bed7e13288b21a74 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Tue, 7 May 2024 17:58:44 -0400 Subject: [PATCH 089/103] Address the easiest of Andrew's comments --- src/haz3lcore/lang/Form.re | 2 +- src/haz3lcore/lang/Precedence.re | 1 - src/haz3lcore/lang/term/IdTagged.re | 16 +--- src/haz3lcore/lang/term/Typ.re | 2 +- src/haz3lcore/statics/Statics.re | 3 - src/haz3lcore/zipper/EditorUtil.re | 96 ++++++++++---------- src/haz3lweb/Update.re | 12 --- src/haz3lweb/util/WorkerClient.re | 2 - src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 10 -- 9 files changed, 52 insertions(+), 92 deletions(-) diff --git a/src/haz3lcore/lang/Form.re b/src/haz3lcore/lang/Form.re index ec105da653..d8908a78c5 100644 --- a/src/haz3lcore/lang/Form.re +++ b/src/haz3lcore/lang/Form.re @@ -282,7 +282,7 @@ let forms: list((string, t)) = [ ("cons_pat", mk_infix("::", Pat, P.cons)), ("typeann", mk(ss, [":"], mk_bin'(P.ann, Pat, Pat, [], Typ))), // UNARY PREFIX OPERATORS - ("not", mk(ii, ["!"], mk_pre(P.not_, Exp, []))), //TODO: precedence + ("not", mk(ii, ["!"], mk_pre(P.not_, Exp, []))), ("typ_sum_single", mk(ss, ["+"], mk_pre(P.or_, Typ, []))), ("unary_minus", mk(ss, ["-"], mk_pre(P.neg, Exp, []))), ("unquote", mk(ss, ["$"], mk_pre(P.unquote, Exp, []))), diff --git a/src/haz3lcore/lang/Precedence.re b/src/haz3lcore/lang/Precedence.re index e809621df7..a4f5aea296 100644 --- a/src/haz3lcore/lang/Precedence.re +++ b/src/haz3lcore/lang/Precedence.re @@ -14,7 +14,6 @@ let ap = 2; let neg = 3; let power = 4; let mult = 5; - let not_ = 5; let plus = 6; let cons = 7; diff --git a/src/haz3lcore/lang/term/IdTagged.re b/src/haz3lcore/lang/term/IdTagged.re index da290cd828..59919ad182 100644 --- a/src/haz3lcore/lang/term/IdTagged.re +++ b/src/haz3lcore/lang/term/IdTagged.re @@ -4,10 +4,12 @@ include Sexplib.Std; type t('a) = { [@show.opaque] ids: list(Id.t), + [@show.opaque] /* UExp invariant: copied should always be false, and the id should be unique DHExp invariant: if copied is true, then this term and its children may not - have unique ids. */ - [@show.opaque] + have unique ids. The flag is used to avoid deep-copying expressions during + evaluation, while keeping track of where we will need to replace the ids + at the end of evaluation to keep them unique.*/ copied: bool, term: 'a, }; @@ -23,13 +25,3 @@ let fast_copy = (id, {term, _}) => {ids: [id], term, copied: true}; let new_ids = fun | {ids: _, term, copied} => {ids: [Id.mk()], term, copied}; - -// let serialization = (f1, f2) => -// StructureShareSexp.structure_share_here( -// rep_id, -// sexp_of_t(f1), -// t_of_sexp(f2), -// ); - -// let sexp_of_t = f1 => serialization(f1, Obj.magic()) |> fst; -// let t_of_sexp = f2 => serialization(Obj.magic(), f2) |> snd; diff --git a/src/haz3lcore/lang/term/Typ.re b/src/haz3lcore/lang/term/Typ.re index 2f58e9422b..c571ef9d00 100644 --- a/src/haz3lcore/lang/term/Typ.re +++ b/src/haz3lcore/lang/term/Typ.re @@ -348,7 +348,7 @@ let rec join = (~resolve=false, ~fix, ctx: Ctx.t, ty1: t, ty2: t): option(t) => }; /* REQUIRES NORMALIZED TYPES - Remove synswitches from t1 by maching against t2 */ + Remove synswitches from t1 by matching against t2 */ let rec match_synswitch = (t1: t, t2: t) => { let (term1, rewrap1) = unwrap(t1); switch (term1, term_of(t2)) { diff --git a/src/haz3lcore/statics/Statics.re b/src/haz3lcore/statics/Statics.re index 1cd72a6304..3e02a1a84f 100644 --- a/src/haz3lcore/statics/Statics.re +++ b/src/haz3lcore/statics/Statics.re @@ -34,9 +34,6 @@ module Map = { [@deriving (show({with_path: false}), sexp, yojson)] type t = Id.Map.t(Info.t); - // let (sexp_of_t, t_of_sexp) = - // StructureShareSexp.structure_share_in(sexp_of_t, t_of_sexp); - let error_ids = (term_ranges: TermRanges.t, info_map: t): list(Id.t) => Id.Map.fold( (id, info, acc) => diff --git a/src/haz3lcore/zipper/EditorUtil.re b/src/haz3lcore/zipper/EditorUtil.re index 54388f3410..1624f6a970 100644 --- a/src/haz3lcore/zipper/EditorUtil.re +++ b/src/haz3lcore/zipper/EditorUtil.re @@ -41,56 +41,52 @@ let editors_of_strings = (~read_only=false, xs: list(string)) => { (i, List.map(((_, oe)) => Option.get(oe), aes)); }; -let rec append_exp = { +let rec append_exp = (e1: Exp.t, e2: Exp.t): Exp.t => { Exp.( - (e1: Exp.t, e2: Exp.t) => ( - { - switch (e1.term) { - | EmptyHole - | Invalid(_) - | MultiHole(_) - | DynamicErrorHole(_) - | FailedCast(_) - | Deferral(_) - | Bool(_) - | Int(_) - | Float(_) - | String(_) - | ListLit(_) - | Constructor(_) - | Closure(_) - | Fun(_) - | TypFun(_) - | FixF(_) - | Tuple(_) - | Var(_) - | Ap(_) - | TypAp(_) - | DeferredAp(_) - | If(_) - | Test(_) - | Parens(_) - | Cons(_) - | ListConcat(_) - | UnOp(_) - | BinOp(_) - | BuiltinFun(_) - | Cast(_) - | Match(_) => Exp.{ids: [Id.mk()], copied: false, term: Seq(e1, e2)} - | Seq(e11, e12) => - let e12' = append_exp(e12, e2); - {ids: e1.ids, copied: false, term: Seq(e11, e12')}; - | Filter(kind, ebody) => - let ebody' = append_exp(ebody, e2); - {ids: e1.ids, copied: false, term: Filter(kind, ebody')}; - | Let(p, edef, ebody) => - let ebody' = append_exp(ebody, e2); - {ids: e1.ids, copied: false, term: Let(p, edef, ebody')}; - | TyAlias(tp, tdef, ebody) => - let ebody' = append_exp(ebody, e2); - {ids: e1.ids, copied: false, term: TyAlias(tp, tdef, ebody')}; - }; - }: Exp.t - ) + switch (e1.term) { + | EmptyHole + | Invalid(_) + | MultiHole(_) + | DynamicErrorHole(_) + | FailedCast(_) + | Deferral(_) + | Bool(_) + | Int(_) + | Float(_) + | String(_) + | ListLit(_) + | Constructor(_) + | Closure(_) + | Fun(_) + | TypFun(_) + | FixF(_) + | Tuple(_) + | Var(_) + | Ap(_) + | TypAp(_) + | DeferredAp(_) + | If(_) + | Test(_) + | Parens(_) + | Cons(_) + | ListConcat(_) + | UnOp(_) + | BinOp(_) + | BuiltinFun(_) + | Cast(_) + | Match(_) => Exp.{ids: [Id.mk()], copied: false, term: Seq(e1, e2)} + | Seq(e11, e12) => + let e12' = append_exp(e12, e2); + {ids: e1.ids, copied: false, term: Seq(e11, e12')}; + | Filter(kind, ebody) => + let ebody' = append_exp(ebody, e2); + {ids: e1.ids, copied: false, term: Filter(kind, ebody')}; + | Let(p, edef, ebody) => + let ebody' = append_exp(ebody, e2); + {ids: e1.ids, copied: false, term: Let(p, edef, ebody')}; + | TyAlias(tp, tdef, ebody) => + let ebody' = append_exp(ebody, e2); + {ids: e1.ids, copied: false, term: TyAlias(tp, tdef, ebody')}; + } ); }; diff --git a/src/haz3lweb/Update.re b/src/haz3lweb/Update.re index 9edf5d1b2a..260aa6a151 100644 --- a/src/haz3lweb/Update.re +++ b/src/haz3lweb/Update.re @@ -475,18 +475,6 @@ let rec apply = model.results |> ModelResults.find(key) |> ModelResult.step_forward(idx); - let _ = print_endline("Ouch"); - let _ = - print_endline( - Stepper.show_stepper_state( - ( - fun - | (Stepper(s): ModelResult.t) => s - | _ => failwith("") - )(r). - stepper_state, - ), - ); Ok({...model, results: model.results |> ModelResults.add(key, r)}); | StepperAction(key, StepBackward) => let r = diff --git a/src/haz3lweb/util/WorkerClient.re b/src/haz3lweb/util/WorkerClient.re index bb87fc5ada..92faffe6a9 100644 --- a/src/haz3lweb/util/WorkerClient.re +++ b/src/haz3lweb/util/WorkerClient.re @@ -46,8 +46,6 @@ let request = setupWorkerMessageHandler(workerRef.contents); - // print_endline(Request.serialize(req)); - workerRef.contents##postMessage(Request.serialize(req)); let onTimeout = (): unit => { diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index c0e6b9065a..4d22fa5324 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -116,16 +116,6 @@ let mk = d: DHExp.t, ) : DHDoc.t => { - // // print_endline(""); - // // let _ = - // // List.map( - // // ((x, y)) => { - // // print_endline(Id.show(y)); - // // print_endline(show_step_kind(x.knd)); - // // }, - // // hidden_steps, - // // ); - // let _ = print_endline("============"); let precedence = precedence(~show_casts=settings.show_casts); let rec go = ( From d3bb38e21e7ef2df04430bf2d42c5fade2acfa85 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Tue, 7 May 2024 17:58:44 -0400 Subject: [PATCH 090/103] Address the easiest of Andrew's comments --- src/haz3lcore/dynamics/Elaborator.re | 4 - src/haz3lcore/lang/Form.re | 2 +- src/haz3lcore/lang/Precedence.re | 1 - src/haz3lcore/lang/term/IdTagged.re | 16 +--- src/haz3lcore/lang/term/Typ.re | 2 +- src/haz3lcore/statics/Statics.re | 3 - src/haz3lcore/zipper/EditorUtil.re | 96 ++++++++++---------- src/haz3lweb/Update.re | 12 --- src/haz3lweb/util/WorkerClient.re | 2 - src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 10 -- 10 files changed, 52 insertions(+), 96 deletions(-) diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index db9b7e3551..37cc2962e6 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -36,10 +36,6 @@ let fresh_pat_cast = (p: DHPat.t, t1: Typ.t, t2: Typ.t): DHPat.t => { Typ.eq(t1, t2) ? p : { - let _ = print_endline("=====vvvvv==="); - let _ = print_endline(Typ.show(t1)); - let _ = print_endline(Typ.show(t2)); - let _ = print_endline("=====^^^^^==="); Cast( DHPat.fresh(Cast(p, t1, Typ.mk_fast(Unknown(Internal)))) |> Casts.pattern_fixup, diff --git a/src/haz3lcore/lang/Form.re b/src/haz3lcore/lang/Form.re index ec105da653..d8908a78c5 100644 --- a/src/haz3lcore/lang/Form.re +++ b/src/haz3lcore/lang/Form.re @@ -282,7 +282,7 @@ let forms: list((string, t)) = [ ("cons_pat", mk_infix("::", Pat, P.cons)), ("typeann", mk(ss, [":"], mk_bin'(P.ann, Pat, Pat, [], Typ))), // UNARY PREFIX OPERATORS - ("not", mk(ii, ["!"], mk_pre(P.not_, Exp, []))), //TODO: precedence + ("not", mk(ii, ["!"], mk_pre(P.not_, Exp, []))), ("typ_sum_single", mk(ss, ["+"], mk_pre(P.or_, Typ, []))), ("unary_minus", mk(ss, ["-"], mk_pre(P.neg, Exp, []))), ("unquote", mk(ss, ["$"], mk_pre(P.unquote, Exp, []))), diff --git a/src/haz3lcore/lang/Precedence.re b/src/haz3lcore/lang/Precedence.re index e809621df7..a4f5aea296 100644 --- a/src/haz3lcore/lang/Precedence.re +++ b/src/haz3lcore/lang/Precedence.re @@ -14,7 +14,6 @@ let ap = 2; let neg = 3; let power = 4; let mult = 5; - let not_ = 5; let plus = 6; let cons = 7; diff --git a/src/haz3lcore/lang/term/IdTagged.re b/src/haz3lcore/lang/term/IdTagged.re index da290cd828..59919ad182 100644 --- a/src/haz3lcore/lang/term/IdTagged.re +++ b/src/haz3lcore/lang/term/IdTagged.re @@ -4,10 +4,12 @@ include Sexplib.Std; type t('a) = { [@show.opaque] ids: list(Id.t), + [@show.opaque] /* UExp invariant: copied should always be false, and the id should be unique DHExp invariant: if copied is true, then this term and its children may not - have unique ids. */ - [@show.opaque] + have unique ids. The flag is used to avoid deep-copying expressions during + evaluation, while keeping track of where we will need to replace the ids + at the end of evaluation to keep them unique.*/ copied: bool, term: 'a, }; @@ -23,13 +25,3 @@ let fast_copy = (id, {term, _}) => {ids: [id], term, copied: true}; let new_ids = fun | {ids: _, term, copied} => {ids: [Id.mk()], term, copied}; - -// let serialization = (f1, f2) => -// StructureShareSexp.structure_share_here( -// rep_id, -// sexp_of_t(f1), -// t_of_sexp(f2), -// ); - -// let sexp_of_t = f1 => serialization(f1, Obj.magic()) |> fst; -// let t_of_sexp = f2 => serialization(Obj.magic(), f2) |> snd; diff --git a/src/haz3lcore/lang/term/Typ.re b/src/haz3lcore/lang/term/Typ.re index 2f58e9422b..c571ef9d00 100644 --- a/src/haz3lcore/lang/term/Typ.re +++ b/src/haz3lcore/lang/term/Typ.re @@ -348,7 +348,7 @@ let rec join = (~resolve=false, ~fix, ctx: Ctx.t, ty1: t, ty2: t): option(t) => }; /* REQUIRES NORMALIZED TYPES - Remove synswitches from t1 by maching against t2 */ + Remove synswitches from t1 by matching against t2 */ let rec match_synswitch = (t1: t, t2: t) => { let (term1, rewrap1) = unwrap(t1); switch (term1, term_of(t2)) { diff --git a/src/haz3lcore/statics/Statics.re b/src/haz3lcore/statics/Statics.re index 1cd72a6304..3e02a1a84f 100644 --- a/src/haz3lcore/statics/Statics.re +++ b/src/haz3lcore/statics/Statics.re @@ -34,9 +34,6 @@ module Map = { [@deriving (show({with_path: false}), sexp, yojson)] type t = Id.Map.t(Info.t); - // let (sexp_of_t, t_of_sexp) = - // StructureShareSexp.structure_share_in(sexp_of_t, t_of_sexp); - let error_ids = (term_ranges: TermRanges.t, info_map: t): list(Id.t) => Id.Map.fold( (id, info, acc) => diff --git a/src/haz3lcore/zipper/EditorUtil.re b/src/haz3lcore/zipper/EditorUtil.re index 54388f3410..1624f6a970 100644 --- a/src/haz3lcore/zipper/EditorUtil.re +++ b/src/haz3lcore/zipper/EditorUtil.re @@ -41,56 +41,52 @@ let editors_of_strings = (~read_only=false, xs: list(string)) => { (i, List.map(((_, oe)) => Option.get(oe), aes)); }; -let rec append_exp = { +let rec append_exp = (e1: Exp.t, e2: Exp.t): Exp.t => { Exp.( - (e1: Exp.t, e2: Exp.t) => ( - { - switch (e1.term) { - | EmptyHole - | Invalid(_) - | MultiHole(_) - | DynamicErrorHole(_) - | FailedCast(_) - | Deferral(_) - | Bool(_) - | Int(_) - | Float(_) - | String(_) - | ListLit(_) - | Constructor(_) - | Closure(_) - | Fun(_) - | TypFun(_) - | FixF(_) - | Tuple(_) - | Var(_) - | Ap(_) - | TypAp(_) - | DeferredAp(_) - | If(_) - | Test(_) - | Parens(_) - | Cons(_) - | ListConcat(_) - | UnOp(_) - | BinOp(_) - | BuiltinFun(_) - | Cast(_) - | Match(_) => Exp.{ids: [Id.mk()], copied: false, term: Seq(e1, e2)} - | Seq(e11, e12) => - let e12' = append_exp(e12, e2); - {ids: e1.ids, copied: false, term: Seq(e11, e12')}; - | Filter(kind, ebody) => - let ebody' = append_exp(ebody, e2); - {ids: e1.ids, copied: false, term: Filter(kind, ebody')}; - | Let(p, edef, ebody) => - let ebody' = append_exp(ebody, e2); - {ids: e1.ids, copied: false, term: Let(p, edef, ebody')}; - | TyAlias(tp, tdef, ebody) => - let ebody' = append_exp(ebody, e2); - {ids: e1.ids, copied: false, term: TyAlias(tp, tdef, ebody')}; - }; - }: Exp.t - ) + switch (e1.term) { + | EmptyHole + | Invalid(_) + | MultiHole(_) + | DynamicErrorHole(_) + | FailedCast(_) + | Deferral(_) + | Bool(_) + | Int(_) + | Float(_) + | String(_) + | ListLit(_) + | Constructor(_) + | Closure(_) + | Fun(_) + | TypFun(_) + | FixF(_) + | Tuple(_) + | Var(_) + | Ap(_) + | TypAp(_) + | DeferredAp(_) + | If(_) + | Test(_) + | Parens(_) + | Cons(_) + | ListConcat(_) + | UnOp(_) + | BinOp(_) + | BuiltinFun(_) + | Cast(_) + | Match(_) => Exp.{ids: [Id.mk()], copied: false, term: Seq(e1, e2)} + | Seq(e11, e12) => + let e12' = append_exp(e12, e2); + {ids: e1.ids, copied: false, term: Seq(e11, e12')}; + | Filter(kind, ebody) => + let ebody' = append_exp(ebody, e2); + {ids: e1.ids, copied: false, term: Filter(kind, ebody')}; + | Let(p, edef, ebody) => + let ebody' = append_exp(ebody, e2); + {ids: e1.ids, copied: false, term: Let(p, edef, ebody')}; + | TyAlias(tp, tdef, ebody) => + let ebody' = append_exp(ebody, e2); + {ids: e1.ids, copied: false, term: TyAlias(tp, tdef, ebody')}; + } ); }; diff --git a/src/haz3lweb/Update.re b/src/haz3lweb/Update.re index 9edf5d1b2a..260aa6a151 100644 --- a/src/haz3lweb/Update.re +++ b/src/haz3lweb/Update.re @@ -475,18 +475,6 @@ let rec apply = model.results |> ModelResults.find(key) |> ModelResult.step_forward(idx); - let _ = print_endline("Ouch"); - let _ = - print_endline( - Stepper.show_stepper_state( - ( - fun - | (Stepper(s): ModelResult.t) => s - | _ => failwith("") - )(r). - stepper_state, - ), - ); Ok({...model, results: model.results |> ModelResults.add(key, r)}); | StepperAction(key, StepBackward) => let r = diff --git a/src/haz3lweb/util/WorkerClient.re b/src/haz3lweb/util/WorkerClient.re index bb87fc5ada..92faffe6a9 100644 --- a/src/haz3lweb/util/WorkerClient.re +++ b/src/haz3lweb/util/WorkerClient.re @@ -46,8 +46,6 @@ let request = setupWorkerMessageHandler(workerRef.contents); - // print_endline(Request.serialize(req)); - workerRef.contents##postMessage(Request.serialize(req)); let onTimeout = (): unit => { diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index c0e6b9065a..4d22fa5324 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -116,16 +116,6 @@ let mk = d: DHExp.t, ) : DHDoc.t => { - // // print_endline(""); - // // let _ = - // // List.map( - // // ((x, y)) => { - // // print_endline(Id.show(y)); - // // print_endline(show_step_kind(x.knd)); - // // }, - // // hidden_steps, - // // ); - // let _ = print_endline("============"); let precedence = precedence(~show_casts=settings.show_casts); let rec go = ( From a956b0d12efb20f90c2c1dce0b375656a4982f3e Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 9 May 2024 12:09:23 -0400 Subject: [PATCH 091/103] Typ.mk_fast -> Typ.temp --- src/haz3lcore/dynamics/Casts.re | 21 ++-- src/haz3lcore/dynamics/Elaborator.re | 175 +++++++++++++-------------- src/haz3lcore/lang/term/Typ.re | 41 +++---- src/haz3lcore/statics/Info.re | 42 +++---- src/haz3lcore/statics/Mode.re | 34 ++---- src/haz3lcore/statics/Statics.re | 104 ++++++++-------- 6 files changed, 193 insertions(+), 224 deletions(-) diff --git a/src/haz3lcore/dynamics/Casts.re b/src/haz3lcore/dynamics/Casts.re index 0ea32adcba..170d057e76 100644 --- a/src/haz3lcore/dynamics/Casts.re +++ b/src/haz3lcore/dynamics/Casts.re @@ -29,26 +29,23 @@ type ground_cases = let grounded_Arrow = NotGroundOrHole( - Arrow( - Unknown(Internal) |> Typ.mk_fast, - Unknown(Internal) |> Typ.mk_fast, - ) - |> Typ.mk_fast, + Arrow(Unknown(Internal) |> Typ.temp, Unknown(Internal) |> Typ.temp) + |> Typ.temp, ); let grounded_Forall = NotGroundOrHole( - Forall(EmptyHole |> TPat.fresh, Unknown(Internal) |> Typ.mk_fast) - |> Typ.mk_fast, + Forall(EmptyHole |> TPat.fresh, Unknown(Internal) |> Typ.temp) + |> Typ.temp, ); let grounded_Prod = length => NotGroundOrHole( - Prod(ListUtil.replicate(length, Typ.Unknown(Internal) |> Typ.mk_fast)) - |> Typ.mk_fast, + Prod(ListUtil.replicate(length, Typ.Unknown(Internal) |> Typ.temp)) + |> Typ.temp, ); let grounded_Sum: unit => Typ.sum_map = - () => [BadEntry(Typ.mk_fast(Unknown(Internal)))]; + () => [BadEntry(Typ.temp(Unknown(Internal)))]; let grounded_List = - NotGroundOrHole(List(Unknown(Internal) |> Typ.mk_fast) |> Typ.mk_fast); + NotGroundOrHole(List(Unknown(Internal) |> Typ.temp) |> Typ.temp); let rec ground_cases_of = (ty: Typ.t): ground_cases => { let is_hole: Typ.t => bool = @@ -80,7 +77,7 @@ let rec ground_cases_of = (ty: Typ.t): ground_cases => { } | Sum(sm) => sm |> ConstructorMap.is_ground(is_hole) - ? Ground : NotGroundOrHole(Sum(grounded_Sum()) |> Typ.mk_fast) + ? Ground : NotGroundOrHole(Sum(grounded_Sum()) |> Typ.temp) | Arrow(_, _) => grounded_Arrow | Forall(_) => grounded_Forall | List(_) => grounded_List diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 37cc2962e6..ae74663288 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -23,10 +23,10 @@ let fresh_cast = (d: DHExp.t, t1: Typ.t, t2: Typ.t): DHExp.t => { ? d : { let d' = - DHExp.Cast(d, t1, Typ.mk_fast(Unknown(Internal))) + DHExp.Cast(d, t1, Typ.temp(Unknown(Internal))) |> DHExp.fresh |> Casts.transition_multiple; - DHExp.Cast(d', Typ.mk_fast(Unknown(Internal)), t2) + DHExp.Cast(d', Typ.temp(Unknown(Internal)), t2) |> DHExp.fresh |> Casts.transition_multiple; }; @@ -37,9 +37,9 @@ let fresh_pat_cast = (p: DHPat.t, t1: Typ.t, t2: Typ.t): DHPat.t => { ? p : { Cast( - DHPat.fresh(Cast(p, t1, Typ.mk_fast(Unknown(Internal)))) + DHPat.fresh(Cast(p, t1, Typ.temp(Unknown(Internal)))) |> Casts.pattern_fixup, - Typ.mk_fast(Unknown(Internal)), + Typ.temp(Unknown(Internal)), t2, ) |> DHPat.fresh @@ -58,11 +58,11 @@ let elaborated_type = (m: Statics.Map.t, uexp: UExp.t): (Typ.t, Ctx.t) => { | Syn => self_ty | SynFun => let (ty1, ty2) = Typ.matched_arrow(ctx, self_ty); - Typ.Arrow(ty1, ty2) |> Typ.mk_fast; + Typ.Arrow(ty1, ty2) |> Typ.temp; | SynTypFun => let (tpat, ty) = Typ.matched_forall(ctx, self_ty); let tpat = Option.value(tpat, ~default=TPat.fresh(EmptyHole)); - Typ.Forall(tpat, ty) |> Typ.mk_fast; + Typ.Forall(tpat, ty) |> Typ.temp; // We need to remove the synswitches from this type. | Ana(ana_ty) => Typ.match_synswitch(ana_ty, self_ty) }; @@ -85,11 +85,11 @@ let elaborated_pat_type = (m: Statics.Map.t, upat: UPat.t): (Typ.t, Ctx.t) => { | Syn => self_ty | SynFun => let (ty1, ty2) = Typ.matched_arrow(ctx, self_ty); - Typ.Arrow(ty1, ty2) |> Typ.mk_fast; + Typ.Arrow(ty1, ty2) |> Typ.temp; | SynTypFun => let (tpat, ty) = Typ.matched_forall(ctx, self_ty); let tpat = Option.value(tpat, ~default=TPat.fresh(EmptyHole)); - Typ.Forall(tpat, ty) |> Typ.mk_fast; + Typ.Forall(tpat, ty) |> Typ.temp; | Ana(ana_ty) => switch (prev_synswitch) { | None => ana_ty @@ -106,23 +106,23 @@ let rec elaborate_pattern = let (term, rewrap) = UPat.unwrap(upat); let dpat = switch (term) { - | Int(_) => upat |> cast_from(Int |> Typ.mk_fast) - | Bool(_) => upat |> cast_from(Bool |> Typ.mk_fast) - | Float(_) => upat |> cast_from(Float |> Typ.mk_fast) - | String(_) => upat |> cast_from(String |> Typ.mk_fast) + | Int(_) => upat |> cast_from(Int |> Typ.temp) + | Bool(_) => upat |> cast_from(Bool |> Typ.temp) + | Float(_) => upat |> cast_from(Float |> Typ.temp) + | String(_) => upat |> cast_from(String |> Typ.temp) | ListLit(ps) => let (ps, tys) = List.map(elaborate_pattern(m), ps) |> ListUtil.unzip; let inner_type = tys - |> Typ.join_all(~empty=Unknown(Internal) |> Typ.mk_fast, ctx) - |> Option.value(~default=Typ.mk_fast(Unknown(Internal))); + |> Typ.join_all(~empty=Unknown(Internal) |> Typ.temp, ctx) + |> Option.value(~default=Typ.temp(Unknown(Internal))); ps |> List.map2((p, t) => fresh_pat_cast(p, t, inner_type), _, tys) |> ( ps' => DHPat.ListLit(ps') |> rewrap - |> cast_from(List(inner_type) |> Typ.mk_fast) + |> cast_from(List(inner_type) |> Typ.temp) ); | Cons(p1, p2) => let (p1', ty1) = elaborate_pattern(m, p1); @@ -130,32 +130,32 @@ let rec elaborate_pattern = let ty2_inner = Typ.matched_list(ctx, ty2); let ty_inner = Typ.join(~fix=false, ctx, ty1, ty2_inner) - |> Option.value(~default=Typ.mk_fast(Unknown(Internal))); + |> Option.value(~default=Typ.temp(Unknown(Internal))); let p1'' = fresh_pat_cast(p1', ty1, ty_inner); - let p2'' = fresh_pat_cast(p2', ty2, List(ty_inner) |> Typ.mk_fast); + let p2'' = fresh_pat_cast(p2', ty2, List(ty_inner) |> Typ.temp); DHPat.Cons(p1'', p2'') |> rewrap - |> cast_from(List(ty_inner) |> Typ.mk_fast); + |> cast_from(List(ty_inner) |> Typ.temp); | Tuple(ps) => let (ps', tys) = List.map(elaborate_pattern(m), ps) |> ListUtil.unzip; - DHPat.Tuple(ps') |> rewrap |> cast_from(Typ.Prod(tys) |> Typ.mk_fast); + DHPat.Tuple(ps') |> rewrap |> cast_from(Typ.Prod(tys) |> Typ.temp); | Ap(p1, p2) => let (p1', ty1) = elaborate_pattern(m, p1); let (p2', ty2) = elaborate_pattern(m, p2); let (ty1l, ty1r) = Typ.matched_arrow(ctx, ty1); - let p1'' = fresh_pat_cast(p1', ty1, Arrow(ty1l, ty1r) |> Typ.mk_fast); + let p1'' = fresh_pat_cast(p1', ty1, Arrow(ty1l, ty1r) |> Typ.temp); let p2'' = fresh_pat_cast(p2', ty2, ty1l); DHPat.Ap(p1'', p2'') |> rewrap |> cast_from(ty1r); | Invalid(_) | EmptyHole | MultiHole(_) - | Wild => upat |> cast_from(Typ.mk_fast(Unknown(Internal))) + | Wild => upat |> cast_from(Typ.temp(Unknown(Internal))) | Var(v) => upat |> cast_from( Ctx.lookup_var(ctx, v) |> Option.map((x: Ctx.var_entry) => x.typ |> Typ.normalize(ctx)) - |> Option.value(~default=Typ.mk_fast(Unknown(Internal))), + |> Option.value(~default=Typ.temp(Unknown(Internal))), ) // Type annotations should already appear | Parens(p) @@ -169,8 +169,8 @@ let rec elaborate_pattern = |> Option.map((x: Ctx.var_entry) => x.typ |> Typ.normalize(ctx)) |> Option.value( ~default= - Typ.mk_fast( - Typ.Sum([BadEntry(Typ.mk_fast(Unknown(Internal)))]), + Typ.temp( + Typ.Sum([BadEntry(Typ.temp(Unknown(Internal)))]), ), ), ) @@ -202,7 +202,7 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { let dhexp = switch (term) { | Invalid(_) - | EmptyHole => uexp |> cast_from(Typ.mk_fast(Typ.Unknown(Internal))) + | EmptyHole => uexp |> cast_from(Typ.temp(Typ.Unknown(Internal))) | MultiHole(stuff) => Any.map_term( ~f_exp=(_, exp) => {elaborate(m, exp) |> fst}, @@ -214,32 +214,30 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { stuff => DHExp.MultiHole(stuff) |> rewrap - |> cast_from(Typ.mk_fast(Typ.Unknown(Internal))) + |> cast_from(Typ.temp(Typ.Unknown(Internal))) ) | DynamicErrorHole(e, err) => let (e', _) = elaborate(m, e); DynamicErrorHole(e', err) |> rewrap - |> cast_from(Typ.mk_fast(Unknown(Internal))); + |> cast_from(Typ.temp(Unknown(Internal))); | Cast(e, _, _) // We remove these casts because they should be re-inserted in the recursive call | FailedCast(e, _, _) | Parens(e) => let (e', ty) = elaborate(m, e); e' |> cast_from(ty); | Deferral(_) => uexp - | Int(_) => uexp |> cast_from(Int |> Typ.mk_fast) - | Bool(_) => uexp |> cast_from(Bool |> Typ.mk_fast) - | Float(_) => uexp |> cast_from(Float |> Typ.mk_fast) - | String(_) => uexp |> cast_from(String |> Typ.mk_fast) + | Int(_) => uexp |> cast_from(Int |> Typ.temp) + | Bool(_) => uexp |> cast_from(Bool |> Typ.temp) + | Float(_) => uexp |> cast_from(Float |> Typ.temp) + | String(_) => uexp |> cast_from(String |> Typ.temp) | ListLit(es) => let (ds, tys) = List.map(elaborate(m), es) |> ListUtil.unzip; let inner_type = - Typ.join_all(~empty=Typ.Unknown(Internal) |> Typ.mk_fast, ctx, tys) - |> Option.value(~default=Typ.mk_fast(Typ.Unknown(Internal))); + Typ.join_all(~empty=Typ.Unknown(Internal) |> Typ.temp, ctx, tys) + |> Option.value(~default=Typ.temp(Typ.Unknown(Internal))); let ds' = List.map2((d, t) => fresh_cast(d, t, inner_type), ds, tys); - Exp.ListLit(ds') - |> rewrap - |> cast_from(List(inner_type) |> Typ.mk_fast); + Exp.ListLit(ds') |> rewrap |> cast_from(List(inner_type) |> Typ.temp); | Constructor(c) => uexp |> cast_from( @@ -247,8 +245,8 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { |> Option.map((x: Ctx.var_entry) => x.typ |> Typ.normalize(ctx)) |> Option.value( ~default= - Typ.mk_fast( - Typ.Sum([BadEntry(Typ.mk_fast(Unknown(Internal)))]), + Typ.temp( + Typ.Sum([BadEntry(Typ.temp(Unknown(Internal)))]), ), ), ) @@ -257,21 +255,21 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { let (e', tye) = elaborate(m, e); Exp.Fun(p', e', env, n) |> rewrap - |> cast_from(Arrow(typ, tye) |> Typ.mk_fast); + |> cast_from(Arrow(typ, tye) |> Typ.temp); | TypFun(tpat, e, name) => let (e', tye) = elaborate(m, e); Exp.TypFun(tpat, e', name) |> rewrap - |> cast_from(Typ.Forall(tpat, tye) |> Typ.mk_fast); + |> cast_from(Typ.Forall(tpat, tye) |> Typ.temp); | Tuple(es) => let (ds, tys) = List.map(elaborate(m), es) |> ListUtil.unzip; - Exp.Tuple(ds) |> rewrap |> cast_from(Prod(tys) |> Typ.mk_fast); + Exp.Tuple(ds) |> rewrap |> cast_from(Prod(tys) |> Typ.temp); | Var(v) => uexp |> cast_from( Ctx.lookup_var(ctx, v) |> Option.map((x: Ctx.var_entry) => x.typ |> Typ.normalize(ctx)) - |> Option.value(~default=Typ.mk_fast(Typ.Unknown(Internal))), + |> Option.value(~default=Typ.temp(Typ.Unknown(Internal))), ) | Let(p, def, body) => let add_name: (option(string), DHExp.t) => DHExp.t = ( @@ -313,7 +311,7 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { let (f', tyf) = elaborate(m, f); let (a', tya) = elaborate(m, a); let (tyf1, tyf2) = Typ.matched_arrow(ctx, tyf); - let f'' = fresh_cast(f', tyf, Arrow(tyf1, tyf2) |> Typ.mk_fast); + let f'' = fresh_cast(f', tyf, Arrow(tyf1, tyf2) |> Typ.temp); let a'' = fresh_cast(a', tya, tyf1); Exp.Ap(dir, f'', a'') |> rewrap |> cast_from(tyf2); | DeferredAp(f, args) => @@ -325,7 +323,7 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { fresh_cast( f', tyf, - Arrow(Prod(ty_fargs) |> Typ.mk_fast, tyf2) |> Typ.mk_fast, + Arrow(Prod(ty_fargs) |> Typ.temp, tyf2) |> Typ.temp, ); let args'' = ListUtil.map3(fresh_cast, args', tys, ty_fargs); let remaining_args = @@ -333,11 +331,10 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { ((arg, _)) => Exp.is_deferral(arg), List.combine(args, ty_fargs), ); - let remaining_arg_ty = - Prod(List.map(snd, remaining_args)) |> Typ.mk_fast; + let remaining_arg_ty = Prod(List.map(snd, remaining_args)) |> Typ.temp; DeferredAp(f'', args'') |> rewrap - |> cast_from(Arrow(remaining_arg_ty, tyf2) |> Typ.mk_fast); + |> cast_from(Arrow(remaining_arg_ty, tyf2) |> Typ.temp); | TypAp(e, ut) => let (e', tye) = elaborate(m, e); let (tpat, tye') = Typ.matched_forall(ctx, tye); @@ -355,8 +352,8 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { let (f', tyf) = elaborate(m, f); let ty = Typ.join(~fix=false, ctx, tyt, tyf) - |> Option.value(~default=Typ.mk_fast(Typ.Unknown(Internal))); - let c'' = fresh_cast(c', tyc, Bool |> Typ.mk_fast); + |> Option.value(~default=Typ.temp(Typ.Unknown(Internal))); + let c'' = fresh_cast(c', tyc, Bool |> Typ.temp); let t'' = fresh_cast(t', tyt, ty); let f'' = fresh_cast(f', tyf, ty); Exp.If(c'', t'', f'') |> rewrap |> cast_from(ty); @@ -366,9 +363,9 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { Seq(e1', e2') |> rewrap |> cast_from(ty2); | Test(e) => let (e', t) = elaborate(m, e); - Test(fresh_cast(e', t, Bool |> Typ.mk_fast)) + Test(fresh_cast(e', t, Bool |> Typ.temp)) |> rewrap - |> cast_from(Prod([]) |> Typ.mk_fast); + |> cast_from(Prod([]) |> Typ.temp); | Filter(kind, e) => let (e', t) = elaborate(m, e); let kind' = @@ -387,10 +384,10 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { let ty2_inner = Typ.matched_list(ctx, ty2); let ty_inner = Typ.join(~fix=false, ctx, ty1, ty2_inner) - |> Option.value(~default=Typ.mk_fast(Unknown(Internal))); + |> Option.value(~default=Typ.temp(Unknown(Internal))); let e1'' = fresh_cast(e1', ty1, ty_inner); - let e2'' = fresh_cast(e2', ty2, List(ty_inner) |> Typ.mk_fast); - Cons(e1'', e2'') |> rewrap |> cast_from(List(ty_inner) |> Typ.mk_fast); + let e2'' = fresh_cast(e2', ty2, List(ty_inner) |> Typ.temp); + Cons(e1'', e2'') |> rewrap |> cast_from(List(ty_inner) |> Typ.temp); | ListConcat(e1, e2) => let (e1', ty1) = elaborate(m, e1); let (e2', ty2) = elaborate(m, e2); @@ -398,12 +395,12 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { let ty_inner2 = Typ.matched_list(ctx, ty2); let ty_inner = Typ.join(~fix=false, ctx, ty_inner1, ty_inner2) - |> Option.value(~default=Typ.mk_fast(Unknown(Internal))); - let e1'' = fresh_cast(e1', ty1, List(ty_inner) |> Typ.mk_fast); - let e2'' = fresh_cast(e2', ty2, List(ty_inner) |> Typ.mk_fast); + |> Option.value(~default=Typ.temp(Unknown(Internal))); + let e1'' = fresh_cast(e1', ty1, List(ty_inner) |> Typ.temp); + let e2'' = fresh_cast(e2', ty2, List(ty_inner) |> Typ.temp); ListConcat(e1'', e2'') |> rewrap - |> cast_from(List(ty_inner) |> Typ.mk_fast); + |> cast_from(List(ty_inner) |> Typ.temp); | UnOp(Meta(Unquote), e) => switch (e.term) { | Var("e") => Constructor("$e") |> rewrap @@ -411,28 +408,28 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { | _ => DHExp.EmptyHole |> rewrap - |> cast_from(Typ.mk_fast(Typ.Unknown(Internal))) + |> cast_from(Typ.temp(Typ.Unknown(Internal))) } | UnOp(Int(Minus), e) => let (e', t) = elaborate(m, e); - UnOp(Int(Minus), fresh_cast(e', t, Int |> Typ.mk_fast)) + UnOp(Int(Minus), fresh_cast(e', t, Int |> Typ.temp)) |> rewrap - |> cast_from(Int |> Typ.mk_fast); + |> cast_from(Int |> Typ.temp); | UnOp(Bool(Not), e) => let (e', t) = elaborate(m, e); - UnOp(Bool(Not), fresh_cast(e', t, Bool |> Typ.mk_fast)) + UnOp(Bool(Not), fresh_cast(e', t, Bool |> Typ.temp)) |> rewrap - |> cast_from(Bool |> Typ.mk_fast); + |> cast_from(Bool |> Typ.temp); | BinOp(Int(Plus | Minus | Times | Power | Divide) as op, e1, e2) => let (e1', t1) = elaborate(m, e1); let (e2', t2) = elaborate(m, e2); BinOp( op, - fresh_cast(e1', t1, Int |> Typ.mk_fast), - fresh_cast(e2', t2, Int |> Typ.mk_fast), + fresh_cast(e1', t1, Int |> Typ.temp), + fresh_cast(e2', t2, Int |> Typ.temp), ) |> rewrap - |> cast_from(Int |> Typ.mk_fast); + |> cast_from(Int |> Typ.temp); | BinOp( Int( LessThan | LessThanOrEqual | GreaterThan | GreaterThanOrEqual | @@ -446,31 +443,31 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { let (e2', t2) = elaborate(m, e2); BinOp( op, - fresh_cast(e1', t1, Int |> Typ.mk_fast), - fresh_cast(e2', t2, Int |> Typ.mk_fast), + fresh_cast(e1', t1, Int |> Typ.temp), + fresh_cast(e2', t2, Int |> Typ.temp), ) |> rewrap - |> cast_from(Bool |> Typ.mk_fast); + |> cast_from(Bool |> Typ.temp); | BinOp(Bool(And | Or) as op, e1, e2) => let (e1', t1) = elaborate(m, e1); let (e2', t2) = elaborate(m, e2); BinOp( op, - fresh_cast(e1', t1, Bool |> Typ.mk_fast), - fresh_cast(e2', t2, Bool |> Typ.mk_fast), + fresh_cast(e1', t1, Bool |> Typ.temp), + fresh_cast(e2', t2, Bool |> Typ.temp), ) |> rewrap - |> cast_from(Bool |> Typ.mk_fast); + |> cast_from(Bool |> Typ.temp); | BinOp(Float(Plus | Minus | Times | Divide | Power) as op, e1, e2) => let (e1', t1) = elaborate(m, e1); let (e2', t2) = elaborate(m, e2); BinOp( op, - fresh_cast(e1', t1, Float |> Typ.mk_fast), - fresh_cast(e2', t2, Float |> Typ.mk_fast), + fresh_cast(e1', t1, Float |> Typ.temp), + fresh_cast(e2', t2, Float |> Typ.temp), ) |> rewrap - |> cast_from(Float |> Typ.mk_fast); + |> cast_from(Float |> Typ.temp); | BinOp( Float( LessThan | LessThanOrEqual | GreaterThan | GreaterThanOrEqual | @@ -484,37 +481,37 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { let (e2', t2) = elaborate(m, e2); BinOp( op, - fresh_cast(e1', t1, Float |> Typ.mk_fast), - fresh_cast(e2', t2, Float |> Typ.mk_fast), + fresh_cast(e1', t1, Float |> Typ.temp), + fresh_cast(e2', t2, Float |> Typ.temp), ) |> rewrap - |> cast_from(Bool |> Typ.mk_fast); + |> cast_from(Bool |> Typ.temp); | BinOp(String(Concat) as op, e1, e2) => let (e1', t1) = elaborate(m, e1); let (e2', t2) = elaborate(m, e2); BinOp( op, - fresh_cast(e1', t1, String |> Typ.mk_fast), - fresh_cast(e2', t2, String |> Typ.mk_fast), + fresh_cast(e1', t1, String |> Typ.temp), + fresh_cast(e2', t2, String |> Typ.temp), ) |> rewrap - |> cast_from(String |> Typ.mk_fast); + |> cast_from(String |> Typ.temp); | BinOp(String(Equals) as op, e1, e2) => let (e1', t1) = elaborate(m, e1); let (e2', t2) = elaborate(m, e2); BinOp( op, - fresh_cast(e1', t1, String |> Typ.mk_fast), - fresh_cast(e2', t2, String |> Typ.mk_fast), + fresh_cast(e1', t1, String |> Typ.temp), + fresh_cast(e2', t2, String |> Typ.temp), ) |> rewrap - |> cast_from(Bool |> Typ.mk_fast); + |> cast_from(Bool |> Typ.temp); | BuiltinFun(fn) => uexp |> cast_from( Ctx.lookup_var(Builtins.ctx_init, fn) |> Option.map((x: Ctx.var_entry) => x.typ) - |> Option.value(~default=Typ.mk_fast(Typ.Unknown(Internal))), + |> Option.value(~default=Typ.temp(Typ.Unknown(Internal))), ) | Match(e, cases) => let (e', t) = elaborate(m, e); @@ -522,15 +519,15 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { let (ps', ptys) = List.map(elaborate_pattern(m), ps) |> ListUtil.unzip; let joined_pty = - Typ.join_all(~empty=Typ.Unknown(Internal) |> Typ.mk_fast, ctx, ptys) - |> Option.value(~default=Typ.mk_fast(Typ.Unknown(Internal))); + Typ.join_all(~empty=Typ.Unknown(Internal) |> Typ.temp, ctx, ptys) + |> Option.value(~default=Typ.temp(Typ.Unknown(Internal))); let ps'' = List.map2((p, t) => fresh_pat_cast(p, t, joined_pty), ps', ptys); let e'' = fresh_cast(e', t, joined_pty); let (es', etys) = List.map(elaborate(m), es) |> ListUtil.unzip; let joined_ety = - Typ.join_all(~empty=Typ.Unknown(Internal) |> Typ.mk_fast, ctx, etys) - |> Option.value(~default=Typ.mk_fast(Typ.Unknown(Internal))); + Typ.join_all(~empty=Typ.Unknown(Internal) |> Typ.temp, ctx, etys) + |> Option.value(~default=Typ.temp(Typ.Unknown(Internal))); let es'' = List.map2((e, t) => fresh_cast(e, t, joined_ety), es', etys); Match(e'', List.combine(ps'', es'')) diff --git a/src/haz3lcore/lang/term/Typ.re b/src/haz3lcore/lang/term/Typ.re index c571ef9d00..17a500b820 100644 --- a/src/haz3lcore/lang/term/Typ.re +++ b/src/haz3lcore/lang/term/Typ.re @@ -28,10 +28,10 @@ include TermBase.Typ; let term_of: t => term = IdTagged.term_of; let unwrap: t => (term, term => t) = IdTagged.unwrap; let fresh: term => t = IdTagged.fresh; -/* fresh assigns a random id, whereas mk_fast assigns Id.invalid, which +/* fresh assigns a random id, whereas temp assigns Id.invalid, which is a lot faster, and since we so often make types and throw them away shortly after, it makes sense to use it. */ -let mk_fast: term => t = term => {term, ids: [Id.invalid], copied: false}; +let temp: term => t = term => {term, ids: [Id.invalid], copied: false}; let rep_id: t => Id.t = IdTagged.rep_id; let hole = (tms: list(TermBase.Any.t)) => @@ -270,7 +270,7 @@ let rec join = (~resolve=false, ~fix, ctx: Ctx.t, ty1: t, ty2: t): option(t) => casts. Documentation/Dynamics has regression tests */ Some(ty2) | (Unknown(p1), Unknown(p2)) => - Some(Unknown(join_type_provenance(p1, p2)) |> mk_fast) + Some(Unknown(join_type_provenance(p1, p2)) |> temp) | (Unknown(_), _) => Some(ty2) | (_, Unknown(Internal | SynSwitch)) => Some(ty1) | (Var(n1), Var(n2)) => @@ -295,21 +295,21 @@ let rec join = (~resolve=false, ~fix, ctx: Ctx.t, ty1: t, ty2: t): option(t) => let ctx = Ctx.extend_dummy_tvar(ctx, tp1); let ty1' = switch (TPat.tyvar_of_utpat(tp2)) { - | Some(x2) => subst(Var(x2) |> mk_fast, tp1, ty1) + | Some(x2) => subst(Var(x2) |> temp, tp1, ty1) | None => ty1 }; let+ ty_body = join(~resolve, ~fix, ctx, ty1', ty2); - Rec(tp1, ty_body) |> mk_fast; + Rec(tp1, ty_body) |> temp; | (Rec(_), _) => None | (Forall(x1, ty1), Forall(x2, ty2)) => let ctx = Ctx.extend_dummy_tvar(ctx, x1); let ty1' = switch (TPat.tyvar_of_utpat(x2)) { - | Some(x2) => subst(Var(x2) |> mk_fast, x1, ty1) + | Some(x2) => subst(Var(x2) |> temp, x1, ty1) | None => ty1 }; let+ ty_body = join(~resolve, ~fix, ctx, ty1', ty2); - Forall(x1, ty_body) |> mk_fast; + Forall(x1, ty_body) |> temp; /* Note for above: there is no danger of free variable capture as subst itself performs capture avoiding substitution. However this may generate internal type variable names that in corner cases can @@ -328,20 +328,20 @@ let rec join = (~resolve=false, ~fix, ctx: Ctx.t, ty1: t, ty2: t): option(t) => | (Arrow(ty1, ty2), Arrow(ty1', ty2')) => let* ty1 = join'(ty1, ty1'); let+ ty2 = join'(ty2, ty2'); - Arrow(ty1, ty2) |> mk_fast; + Arrow(ty1, ty2) |> temp; | (Arrow(_), _) => None | (Prod(tys1), Prod(tys2)) => let* tys = ListUtil.map2_opt(join', tys1, tys2); let+ tys = OptUtil.sequence(tys); - Prod(tys) |> mk_fast; + Prod(tys) |> temp; | (Prod(_), _) => None | (Sum(sm1), Sum(sm2)) => let+ sm' = ConstructorMap.join(eq, join(~resolve, ~fix, ctx), sm1, sm2); - Sum(sm') |> mk_fast; + Sum(sm') |> temp; | (Sum(_), _) => None | (List(ty1), List(ty2)) => let+ ty = join'(ty1, ty2); - List(ty) |> mk_fast; + List(ty) |> temp; | (List(_), _) => None | (Ap(_), _) => failwith("Type join of ap") }; @@ -438,32 +438,31 @@ let matched_arrow = (ctx, ty) => switch (term_of(weak_head_normalize(ctx, ty))) { | Arrow(ty_in, ty_out) => (ty_in, ty_out) | Unknown(SynSwitch) => ( - Unknown(SynSwitch) |> mk_fast, - Unknown(SynSwitch) |> mk_fast, + Unknown(SynSwitch) |> temp, + Unknown(SynSwitch) |> temp, ) - | _ => (Unknown(Internal) |> mk_fast, Unknown(Internal) |> mk_fast) + | _ => (Unknown(Internal) |> temp, Unknown(Internal) |> temp) }; let matched_forall = (ctx, ty) => switch (term_of(weak_head_normalize(ctx, ty))) { | Forall(t, ty) => (Some(t), ty) - | Unknown(SynSwitch) => (None, Unknown(SynSwitch) |> mk_fast) - | _ => (None, Unknown(Internal) |> mk_fast) + | Unknown(SynSwitch) => (None, Unknown(SynSwitch) |> temp) + | _ => (None, Unknown(Internal) |> temp) }; let matched_prod = (ctx, length, ty) => switch (term_of(weak_head_normalize(ctx, ty))) { | Prod(tys) when List.length(tys) == length => tys - | Unknown(SynSwitch) => - List.init(length, _ => Unknown(SynSwitch) |> mk_fast) - | _ => List.init(length, _ => Unknown(Internal) |> mk_fast) + | Unknown(SynSwitch) => List.init(length, _ => Unknown(SynSwitch) |> temp) + | _ => List.init(length, _ => Unknown(Internal) |> temp) }; let matched_list = (ctx, ty) => switch (term_of(weak_head_normalize(ctx, ty))) { | List(ty) => ty - | Unknown(SynSwitch) => Unknown(SynSwitch) |> mk_fast - | _ => Unknown(Internal) |> mk_fast + | Unknown(SynSwitch) => Unknown(SynSwitch) |> temp + | _ => Unknown(Internal) |> temp }; let matched_args = (ctx, default_arity, ty) => { diff --git a/src/haz3lcore/statics/Info.re b/src/haz3lcore/statics/Info.re index 0977609055..b72ce87a79 100644 --- a/src/haz3lcore/statics/Info.re +++ b/src/haz3lcore/statics/Info.re @@ -325,11 +325,8 @@ let rec status_common = switch ( Typ.join_fix( ctx, - Arrow( - Unknown(Internal) |> Typ.mk_fast, - Unknown(Internal) |> Typ.mk_fast, - ) - |> Typ.mk_fast, + Arrow(Unknown(Internal) |> Typ.temp, Unknown(Internal) |> Typ.temp) + |> Typ.temp, ty, ) ) { @@ -340,8 +337,8 @@ let rec status_common = switch ( Typ.join_fix( ctx, - Forall(Var("?") |> TPat.fresh, Unknown(Internal) |> Typ.mk_fast) - |> Typ.mk_fast, + Forall(Var("?") |> TPat.fresh, Unknown(Internal) |> Typ.temp) + |> Typ.temp, ty, ) ) { @@ -371,9 +368,9 @@ let rec status_common = } | (BadToken(name), _) => InHole(NoType(BadToken(name))) | (BadTrivAp(ty), _) => InHole(NoType(BadTrivAp(ty))) - | (IsMulti, _) => NotInHole(Syn(Unknown(Internal) |> Typ.mk_fast)) + | (IsMulti, _) => NotInHole(Syn(Unknown(Internal) |> Typ.temp)) | (NoJoin(wrap, tys), Ana(ana)) => - let syn: Typ.t = Self.join_of(wrap, Unknown(Internal) |> Typ.mk_fast); + let syn: Typ.t = Self.join_of(wrap, Unknown(Internal) |> Typ.temp); switch (Typ.join_fix(ctx, ana, syn)) { | None => InHole(Inconsistent(Expectation({ana, syn}))) | Some(_) => @@ -444,7 +441,7 @@ let status_typ = | false => switch (Ctx.is_abstract(ctx, name)) { | false => InHole(FreeTypeVariable(name)) - | true => NotInHole(Type(Var(name) |> Typ.mk_fast)) + | true => NotInHole(Type(Var(name) |> Typ.temp)) } | true => NotInHole(TypeAlias(name, Typ.weak_head_normalize(ctx, ty))) } @@ -455,11 +452,9 @@ let status_typ = let ty_in = UTyp.to_typ(ctx, t2); switch (status_variant, t1.term) { | (Unique, Var(name)) => - NotInHole(Variant(name, Arrow(ty_in, ty_variant) |> Typ.mk_fast)) + NotInHole(Variant(name, Arrow(ty_in, ty_variant) |> Typ.temp)) | _ => - NotInHole( - VariantIncomplete(Arrow(ty_in, ty_variant) |> Typ.mk_fast), - ) + NotInHole(VariantIncomplete(Arrow(ty_in, ty_variant) |> Typ.temp)) }; | ConstructorExpected(_) => InHole(WantConstructorFoundAp) | TypeExpected => InHole(WantTypeFoundAp) @@ -527,26 +522,23 @@ let fixed_typ_ok: ok_pat => Typ.t = let fixed_typ_err_common: error_common => Typ.t = fun - | NoType(_) => Unknown(Internal) |> Typ.mk_fast + | NoType(_) => Unknown(Internal) |> Typ.temp | Inconsistent(Expectation({ana, _})) => ana - | Inconsistent(Internal(_)) => Unknown(Internal) |> Typ.mk_fast // Should this be some sort of meet? + | Inconsistent(Internal(_)) => Unknown(Internal) |> Typ.temp // Should this be some sort of meet? | Inconsistent(WithArrow(_)) => - Arrow( - Unknown(Internal) |> Typ.mk_fast, - Unknown(Internal) |> Typ.mk_fast, - ) - |> Typ.mk_fast; + Arrow(Unknown(Internal) |> Typ.temp, Unknown(Internal) |> Typ.temp) + |> Typ.temp; let fixed_typ_err: error_exp => Typ.t = fun - | FreeVariable(_) => Unknown(Internal) |> Typ.mk_fast - | UnusedDeferral => Unknown(Internal) |> Typ.mk_fast - | BadPartialAp(_) => Unknown(Internal) |> Typ.mk_fast + | FreeVariable(_) => Unknown(Internal) |> Typ.temp + | UnusedDeferral => Unknown(Internal) |> Typ.temp + | BadPartialAp(_) => Unknown(Internal) |> Typ.temp | Common(err) => fixed_typ_err_common(err); let fixed_typ_err_pat: error_pat => Typ.t = fun - | ExpectedConstructor => Unknown(Internal) |> Typ.mk_fast + | ExpectedConstructor => Unknown(Internal) |> Typ.temp | Common(err) => fixed_typ_err_common(err); let fixed_typ_pat = (ctx, mode: Mode.t, self: Self.pat): Typ.t => diff --git a/src/haz3lcore/statics/Mode.re b/src/haz3lcore/statics/Mode.re index 0c73a50d60..5a85dbecd9 100644 --- a/src/haz3lcore/statics/Mode.re +++ b/src/haz3lcore/statics/Mode.re @@ -30,19 +30,13 @@ let ana: Typ.t => t = ty => Ana(ty); let ty_of: t => Typ.t = fun | Ana(ty) => ty - | Syn => Unknown(SynSwitch) |> Typ.mk_fast + | Syn => Unknown(SynSwitch) |> Typ.temp | SynFun => - Arrow( - Unknown(SynSwitch) |> Typ.mk_fast, - Unknown(SynSwitch) |> Typ.mk_fast, - ) - |> Typ.mk_fast + Arrow(Unknown(SynSwitch) |> Typ.temp, Unknown(SynSwitch) |> Typ.temp) + |> Typ.temp | SynTypFun => - Forall( - Var("syntypfun") |> TPat.fresh, - Unknown(SynSwitch) |> Typ.mk_fast, - ) - |> Typ.mk_fast; /* TODO: naming the type variable? */ + Forall(Var("syntypfun") |> TPat.fresh, Unknown(SynSwitch) |> Typ.temp) + |> Typ.temp; /* TODO: naming the type variable? */ let of_arrow = (ctx: Ctx.t, mode: t): (t, t) => switch (mode) { @@ -61,7 +55,7 @@ let of_forall = (ctx: Ctx.t, name_opt: option(string), mode: t): t => let (name_expected_opt, item) = Typ.matched_forall(ctx, ty); switch (name_opt, name_expected_opt) { | (Some(name), Some(name_expected)) => - Ana(Typ.subst(Var(name) |> Typ.mk_fast, name_expected, item)) + Ana(Typ.subst(Var(name) |> Typ.temp, name_expected, item)) | _ => Ana(item) }; }; @@ -86,8 +80,8 @@ let of_cons_tl = (ctx: Ctx.t, mode: t, hd_ty: Typ.t): t => switch (mode) { | Syn | SynFun - | SynTypFun => Ana(List(hd_ty) |> Typ.mk_fast) - | Ana(ty) => Ana(List(Typ.matched_list(ctx, ty)) |> Typ.mk_fast) + | SynTypFun => Ana(List(hd_ty) |> Typ.temp) + | Ana(ty) => Ana(List(Typ.matched_list(ctx, ty)) |> Typ.temp) }; let of_list = (ctx: Ctx.t, mode: t): t => @@ -102,8 +96,8 @@ let of_list_concat = (ctx: Ctx.t, mode: t): t => switch (mode) { | Syn | SynFun - | SynTypFun => Ana(List(Unknown(SynSwitch) |> Typ.mk_fast) |> Typ.mk_fast) - | Ana(ty) => Ana(List(Typ.matched_list(ctx, ty)) |> Typ.mk_fast) + | SynTypFun => Ana(List(Unknown(SynSwitch) |> Typ.temp) |> Typ.temp) + | Ana(ty) => Ana(List(Typ.matched_list(ctx, ty)) |> Typ.temp) }; let of_list_lit = (ctx: Ctx.t, length, mode: t): list(t) => @@ -120,7 +114,7 @@ let ctr_ana_typ = (ctx: Ctx.t, mode: t, ctr: Constructor.t): option(Typ.t) => { let ty_entry = ConstructorMap.get_entry(ctr, ctrs); switch (ty_entry) { | None => ty_ana - | Some(ty_in) => Arrow(ty_in, ty_ana) |> Typ.mk_fast + | Some(ty_in) => Arrow(ty_in, ty_ana) |> Typ.temp }; | _ => None }; @@ -135,9 +129,7 @@ let of_ctr_in_ap = (ctx: Ctx.t, mode: t, ctr: Constructor.t): option(t) => is nullary but used as unary; we reflect this by analyzing against an arrow type. Since we can't guess at what the parameter type might have be, we use Unknown. */ - Some( - Ana(Arrow(Unknown(Internal) |> Typ.mk_fast, ty_ana) |> Typ.mk_fast), - ) + Some(Ana(Arrow(Unknown(Internal) |> Typ.temp, ty_ana) |> Typ.temp)) | None => None }; @@ -160,6 +152,6 @@ let typap_mode: t = SynTypFun; let of_deferred_ap_args = (length: int, ty_ins: list(Typ.t)): list(t) => ( List.length(ty_ins) == length - ? ty_ins : List.init(length, _ => Typ.Unknown(Internal) |> Typ.mk_fast) + ? ty_ins : List.init(length, _ => Typ.Unknown(Internal) |> Typ.temp) ) |> List.map(ty => Ana(ty)); diff --git a/src/haz3lcore/statics/Statics.re b/src/haz3lcore/statics/Statics.re index 3e02a1a84f..0460d9294a 100644 --- a/src/haz3lcore/statics/Statics.re +++ b/src/haz3lcore/statics/Statics.re @@ -88,58 +88,50 @@ let is_recursive = (ctx, p, def, syn: Typ.t) => { let typ_exp_binop_bin_int: Operators.op_bin_int => Typ.t = fun - | (Plus | Minus | Times | Power | Divide) as _op => Int |> Typ.mk_fast + | (Plus | Minus | Times | Power | Divide) as _op => Int |> Typ.temp | ( LessThan | GreaterThan | LessThanOrEqual | GreaterThanOrEqual | Equals | NotEquals ) as _op => - Bool |> Typ.mk_fast; + Bool |> Typ.temp; let typ_exp_binop_bin_float: Operators.op_bin_float => Typ.t = fun - | (Plus | Minus | Times | Power | Divide) as _op => Float |> Typ.mk_fast + | (Plus | Minus | Times | Power | Divide) as _op => Float |> Typ.temp | ( LessThan | GreaterThan | LessThanOrEqual | GreaterThanOrEqual | Equals | NotEquals ) as _op => - Bool |> Typ.mk_fast; + Bool |> Typ.temp; let typ_exp_binop_bin_string: Operators.op_bin_string => Typ.t = fun - | Concat => String |> Typ.mk_fast - | Equals => Bool |> Typ.mk_fast; + | Concat => String |> Typ.temp + | Equals => Bool |> Typ.temp; let typ_exp_binop: Operators.op_bin => (Typ.t, Typ.t, Typ.t) = fun - | Bool(And | Or) => ( - Bool |> Typ.mk_fast, - Bool |> Typ.mk_fast, - Bool |> Typ.mk_fast, - ) - | Int(op) => ( - Int |> Typ.mk_fast, - Int |> Typ.mk_fast, - typ_exp_binop_bin_int(op), - ) + | Bool(And | Or) => (Bool |> Typ.temp, Bool |> Typ.temp, Bool |> Typ.temp) + | Int(op) => (Int |> Typ.temp, Int |> Typ.temp, typ_exp_binop_bin_int(op)) | Float(op) => ( - Float |> Typ.mk_fast, - Float |> Typ.mk_fast, + Float |> Typ.temp, + Float |> Typ.temp, typ_exp_binop_bin_float(op), ) | String(op) => ( - String |> Typ.mk_fast, - String |> Typ.mk_fast, + String |> Typ.temp, + String |> Typ.temp, typ_exp_binop_bin_string(op), ); let typ_exp_unop: Operators.op_un => (Typ.t, Typ.t) = fun | Meta(Unquote) => ( - Var("$Meta") |> Typ.mk_fast, - Unknown(Internal) |> Typ.mk_fast, + Var("$Meta") |> Typ.temp, + Unknown(Internal) |> Typ.temp, ) - | Bool(Not) => (Bool |> Typ.mk_fast, Bool |> Typ.mk_fast) - | Int(Minus) => (Int |> Typ.mk_fast, Int |> Typ.mk_fast); + | Bool(Not) => (Bool |> Typ.temp, Bool |> Typ.temp) + | Int(Minus) => (Int |> Typ.temp, Int |> Typ.temp); let rec any_to_info_map = (~ctx: Ctx.t, ~ancestors, any: Any.t, m: Map.t): (CoCtx.t, Map.t) => @@ -238,13 +230,13 @@ and uexp_to_info_map = let (e, m) = go(~mode=Ana(t1), e, m); add(~self=Just(t2), ~co_ctx=e.co_ctx, m); | Invalid(token) => atomic(BadToken(token)) - | EmptyHole => atomic(Just(Unknown(Internal) |> Typ.mk_fast)) + | EmptyHole => atomic(Just(Unknown(Internal) |> Typ.temp)) | Deferral(position) => add'(~self=IsDeferral(position), ~co_ctx=CoCtx.empty, m) - | Bool(_) => atomic(Just(Bool |> Typ.mk_fast)) - | Int(_) => atomic(Just(Int |> Typ.mk_fast)) - | Float(_) => atomic(Just(Float |> Typ.mk_fast)) - | String(_) => atomic(Just(String |> Typ.mk_fast)) + | Bool(_) => atomic(Just(Bool |> Typ.temp)) + | Int(_) => atomic(Just(Int |> Typ.temp)) + | Float(_) => atomic(Just(Float |> Typ.temp)) + | String(_) => atomic(Just(String |> Typ.temp)) | ListLit(es) => let ids = List.map(UExp.rep_id, es); let modes = Mode.of_list_lit(ctx, List.length(es), mode); @@ -252,7 +244,7 @@ and uexp_to_info_map = let tys = List.map(Info.exp_ty, es); add( ~self= - Self.listlit(~empty=Unknown(Internal) |> Typ.mk_fast, ctx, tys, ids), + Self.listlit(~empty=Unknown(Internal) |> Typ.temp, ctx, tys, ids), ~co_ctx=CoCtx.union(List.map(Info.exp_co_ctx, es)), m, ); @@ -260,7 +252,7 @@ and uexp_to_info_map = let (hd, m) = go(~mode=Mode.of_cons_hd(ctx, mode), hd, m); let (tl, m) = go(~mode=Mode.of_cons_tl(ctx, mode, hd.ty), tl, m); add( - ~self=Just(List(hd.ty) |> Typ.mk_fast), + ~self=Just(List(hd.ty) |> Typ.temp), ~co_ctx=CoCtx.union([hd.co_ctx, tl.co_ctx]), m, ); @@ -295,8 +287,8 @@ and uexp_to_info_map = | _ => e.term }, }; - let ty_in = Typ.Var("$Meta") |> Typ.mk_fast; - let ty_out = Typ.Unknown(Internal) |> Typ.mk_fast; + let ty_in = Typ.Var("$Meta") |> Typ.temp; + let ty_out = Typ.Unknown(Internal) |> Typ.temp; let (e, m) = go(~mode=Ana(ty_in), e, m); add(~self=Just(ty_out), ~co_ctx=e.co_ctx, m); | UnOp(op, e) => @@ -318,13 +310,13 @@ and uexp_to_info_map = let modes = Mode.of_prod(ctx, mode, List.length(es)); let (es, m) = map_m_go(m, modes, es); add( - ~self=Just(Prod(List.map(Info.exp_ty, es)) |> Typ.mk_fast), + ~self=Just(Prod(List.map(Info.exp_ty, es)) |> Typ.temp), ~co_ctx=CoCtx.union(List.map(Info.exp_co_ctx, es)), m, ); | Test(e) => - let (e, m) = go(~mode=Ana(Bool |> Typ.mk_fast), e, m); - add(~self=Just(Prod([]) |> Typ.mk_fast), ~co_ctx=e.co_ctx, m); + let (e, m) = go(~mode=Ana(Bool |> Typ.temp), e, m); + add(~self=Just(Prod([]) |> Typ.temp), ~co_ctx=e.co_ctx, m); | Filter(Filter({pat: cond, _}), body) => let (cond, m) = go(~mode, cond, m, ~is_in_filter=true); let (body, m) = go(~mode, body, m); @@ -348,7 +340,7 @@ and uexp_to_info_map = let (arg, m) = go(~mode=Ana(ty_in), arg, m); let self: Self.t = Id.is_nullary_ap_flag(arg.term.ids) - && !Typ.is_consistent(ctx, ty_in, Prod([]) |> Typ.mk_fast) + && !Typ.is_consistent(ctx, ty_in, Prod([]) |> Typ.temp) ? BadTrivAp(ty_in) : Just(ty_out); add(~self, ~co_ctx=CoCtx.union([fn.co_ctx, arg.co_ctx]), m); | TypAp(fn, utyp) => @@ -382,7 +374,7 @@ and uexp_to_info_map = let (p, m) = go_pat(~is_synswitch=false, ~co_ctx=e.co_ctx, ~mode=mode_pat, p, m); add( - ~self=Just(Arrow(p.ty, e.ty) |> Typ.mk_fast), + ~self=Just(Arrow(p.ty, e.ty) |> Typ.temp), ~co_ctx=CoCtx.mk(ctx, p.ctx, e.co_ctx), m, ); @@ -394,7 +386,7 @@ and uexp_to_info_map = Ctx.extend_tvar(ctx, {name, id: TPat.rep_id(utpat), kind: Abstract}); let (body, m) = go'(~ctx=ctx_body, ~mode=mode_body, body, m); add( - ~self=Just(Forall(utpat, body.ty) |> Typ.mk_fast), + ~self=Just(Forall(utpat, body.ty) |> Typ.temp), ~co_ctx=body.co_ctx, m, ); @@ -403,7 +395,7 @@ and uexp_to_info_map = let m = utpat_to_info_map(~ctx, ~ancestors, utpat, m) |> snd; let (body, m) = go(~mode=mode_body, body, m); add( - ~self=Just(Forall(utpat, body.ty) |> Typ.mk_fast), + ~self=Just(Forall(utpat, body.ty) |> Typ.temp), ~co_ctx=body.co_ctx, m, ); @@ -451,7 +443,7 @@ and uexp_to_info_map = | ((Prod(ty_fns1), Prod(ty_fns2)), Prod(ty_ps)) => let tys = List.map2(ana_ty_fn, List.combine(ty_fns1, ty_fns2), ty_ps); - Typ.Prod(tys) |> Typ.mk_fast; + Typ.Prod(tys) |> Typ.temp; | ((_, _), _) => ana_ty_fn((def_base.ty, def_base2.ty), p_syn.ty) }; let (def, m) = go'(~ctx=def_ctx, ~mode=Ana(ana), def, m); @@ -486,7 +478,7 @@ and uexp_to_info_map = ); | If(e0, e1, e2) => let branch_ids = List.map(UExp.rep_id, [e1, e2]); - let (cond, m) = go(~mode=Ana(Bool |> Typ.mk_fast), e0, m); + let (cond, m) = go(~mode=Ana(Bool |> Typ.temp), e0, m); let (cons, m) = go(~mode, e1, m); let (alt, m) = go(~mode, e2, m); add( @@ -552,7 +544,7 @@ and uexp_to_info_map = use a different name than the alias for the recursive parameter */ //let ty_rec = Typ.Rec("α", Typ.subst(Var("α"), name, ty_pre)); let ty_rec = - Typ.Rec(TPat.Var(name) |> IdTagged.fresh, ty_pre) |> Typ.mk_fast; + Typ.Rec(TPat.Var(name) |> IdTagged.fresh, ty_pre) |> Typ.temp; let ctx_def = Ctx.extend_alias(ctx, name, TPat.rep_id(typat), ty_rec); (ty_rec, ctx_def, ctx_def); @@ -643,17 +635,17 @@ and upat_to_info_map = let (_, m) = multi(~ctx, ~ancestors, m, tms); add(~self=IsMulti, ~ctx, m); | Invalid(token) => atomic(BadToken(token)) - | EmptyHole => atomic(Just(unknown |> Typ.mk_fast)) - | Int(_) => atomic(Just(Int |> Typ.mk_fast)) - | Float(_) => atomic(Just(Float |> Typ.mk_fast)) - | Bool(_) => atomic(Just(Bool |> Typ.mk_fast)) - | String(_) => atomic(Just(String |> Typ.mk_fast)) + | EmptyHole => atomic(Just(unknown |> Typ.temp)) + | Int(_) => atomic(Just(Int |> Typ.temp)) + | Float(_) => atomic(Just(Float |> Typ.temp)) + | Bool(_) => atomic(Just(Bool |> Typ.temp)) + | String(_) => atomic(Just(String |> Typ.temp)) | ListLit(ps) => let ids = List.map(UPat.rep_id, ps); let modes = Mode.of_list_lit(ctx, List.length(ps), mode); let (ctx, tys, m) = ctx_fold(ctx, m, ps, modes); add( - ~self=Self.listlit(~empty=unknown |> Typ.mk_fast, ctx, tys, ids), + ~self=Self.listlit(~empty=unknown |> Typ.temp, ctx, tys, ids), ~ctx, m, ); @@ -661,8 +653,8 @@ and upat_to_info_map = let (hd, m) = go(~ctx, ~mode=Mode.of_cons_hd(ctx, mode), hd, m); let (tl, m) = go(~ctx=hd.ctx, ~mode=Mode.of_cons_tl(ctx, mode, hd.ty), tl, m); - add(~self=Just(List(hd.ty) |> Typ.mk_fast), ~ctx=tl.ctx, m); - | Wild => atomic(Just(unknown |> Typ.mk_fast)) + add(~self=Just(List(hd.ty) |> Typ.temp), ~ctx=tl.ctx, m); + | Wild => atomic(Just(unknown |> Typ.temp)) | Var(name) => /* NOTE: The self type assigned to pattern variables (Unknown) may be SynSwitch, but SynSwitch is never added to the context; @@ -671,14 +663,14 @@ and upat_to_info_map = Info.fixed_typ_pat( ctx, mode, - Common(Just(Unknown(Internal) |> Typ.mk_fast)), + Common(Just(Unknown(Internal) |> Typ.temp)), ); let entry = Ctx.VarEntry({name, id: UPat.rep_id(upat), typ: ctx_typ}); - add(~self=Just(unknown |> Typ.mk_fast), ~ctx=Ctx.extend(ctx, entry), m); + add(~self=Just(unknown |> Typ.temp), ~ctx=Ctx.extend(ctx, entry), m); | Tuple(ps) => let modes = Mode.of_prod(ctx, mode, List.length(ps)); let (ctx, tys, m) = ctx_fold(ctx, m, ps, modes); - add(~self=Just(Prod(tys) |> Typ.mk_fast), ~ctx, m); + add(~self=Just(Prod(tys) |> Typ.temp), ~ctx, m); | Parens(p) => let (p, m) = go(~ctx, ~mode, p, m); add(~self=Just(p.ty), ~ctx=p.ctx, m); @@ -738,11 +730,11 @@ and utyp_to_info_map = let t1_mode: Info.typ_expects = switch (expects) { | VariantExpected(m, sum_ty) => - ConstructorExpected(m, Arrow(ty_in, sum_ty) |> Typ.mk_fast) + ConstructorExpected(m, Arrow(ty_in, sum_ty) |> Typ.temp) | _ => ConstructorExpected( Unique, - Arrow(ty_in, Unknown(Internal) |> Typ.mk_fast) |> Typ.mk_fast, + Arrow(ty_in, Unknown(Internal) |> Typ.temp) |> Typ.temp, ) }; let m = go'(~expects=t1_mode, t1, m) |> snd; From fd0c58395240ceff7a06f2895047ff3533da37c3 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 9 May 2024 15:12:57 -0400 Subject: [PATCH 092/103] Remove to_typ --- src/haz3lcore/dynamics/Elaborator.re | 7 +-- src/haz3lcore/dynamics/Unboxing.re | 7 +-- src/haz3lcore/lang/term/Typ.re | 71 +------------------------ src/haz3lcore/statics/ConstructorMap.re | 51 ++++++++++++++---- src/haz3lcore/statics/Ctx.re | 37 ++++++++----- src/haz3lcore/statics/Info.re | 25 ++++----- src/haz3lcore/statics/MakeTerm.re | 18 ++++++- src/haz3lcore/statics/Statics.re | 30 +++++------ src/haz3lweb/view/Type.re | 10 +++- 9 files changed, 119 insertions(+), 137 deletions(-) diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index ae74663288..2a1ec42453 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -243,12 +243,7 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { |> cast_from( Ctx.lookup_ctr(ctx, c) |> Option.map((x: Ctx.var_entry) => x.typ |> Typ.normalize(ctx)) - |> Option.value( - ~default= - Typ.temp( - Typ.Sum([BadEntry(Typ.temp(Unknown(Internal)))]), - ), - ), + |> Option.value(~default=Typ.temp(Typ.Unknown(Internal))), ) | Fun(p, e, env, n) => let (p', typ) = elaborate_pattern(m, p); diff --git a/src/haz3lcore/dynamics/Unboxing.re b/src/haz3lcore/dynamics/Unboxing.re index c049dcd39d..80596c64f8 100644 --- a/src/haz3lcore/dynamics/Unboxing.re +++ b/src/haz3lcore/dynamics/Unboxing.re @@ -130,6 +130,9 @@ let rec unbox: type a. (unbox_request(a), DHExp.t) => unboxed(a) = /* Any cast from unknown is indet */ | (_, Cast(_, {term: Unknown(_), _}, _)) => IndetMatch + /* Any failed cast is indet */ + | (_, FailedCast(_)) => IndetMatch + /* Forms that are the wrong type of value - these cases indicate an error in elaboration or in the cast calculus. */ | ( @@ -163,9 +166,7 @@ let rec unbox: type a. (unbox_request(a), DHExp.t) => unboxed(a) = /* Forms that are not yet or will never be a value */ | ( _, - Invalid(_) | EmptyHole | MultiHole(_) | DynamicErrorHole(_) | - FailedCast(_) | - Var(_) | + Invalid(_) | EmptyHole | MultiHole(_) | DynamicErrorHole(_) | Var(_) | Let(_) | Fun(_, _, _, None) | FixF(_) | diff --git a/src/haz3lcore/lang/term/Typ.re b/src/haz3lcore/lang/term/Typ.re index 17a500b820..1c02d4bb0c 100644 --- a/src/haz3lcore/lang/term/Typ.re +++ b/src/haz3lcore/lang/term/Typ.re @@ -121,75 +121,6 @@ let rec is_forall = (typ: t) => { }; }; -/* Converts a syntactic type into a semantic type, specifically - it adds implicit recursive types, and removes duplicate - constructors. */ -let rec to_typ: (Ctx.t, t) => t = - (ctx, utyp) => { - let (term, rewrap) = IdTagged.unwrap(utyp); - switch (term) { - | Unknown(_) - | Bool - | Int - | Float - | String => utyp - | Var(name) => - switch (Ctx.lookup_tvar(ctx, name)) { - | Some(_) => Var(name) |> rewrap - | None => Unknown(Hole(Invalid(name))) |> rewrap - } - | Arrow(u1, u2) => Arrow(to_typ(ctx, u1), to_typ(ctx, u2)) |> rewrap - | Prod(us) => Prod(List.map(to_typ(ctx), us)) |> rewrap - | Sum(uts) => Sum(to_ctr_map(ctx, uts)) |> rewrap - | List(u) => List(to_typ(ctx, u)) |> rewrap - | Parens(u) => to_typ(ctx, u) - | Forall({term: Invalid(_), _} as tpat, tbody) - | Forall({term: EmptyHole, _} as tpat, tbody) - | Forall({term: MultiHole(_), _} as tpat, tbody) => - Forall(tpat, to_typ(ctx, tbody)) |> rewrap - | Forall({term: Var(name), _} as utpat, tbody) => - let ctx = - Ctx.extend_tvar( - ctx, - {name, id: IdTagged.rep_id(utpat), kind: Abstract}, - ); - Forall(utpat, to_typ(ctx, tbody)) |> rewrap; - | Rec({term: Invalid(_), _} as tpat, tbody) - | Rec({term: EmptyHole, _} as tpat, tbody) - | Rec({term: MultiHole(_), _} as tpat, tbody) => - Rec(tpat, to_typ(ctx, tbody)) |> rewrap - | Rec({term: Var(name), _} as utpat, tbody) => - let ctx = - Ctx.extend_tvar( - ctx, - {name, id: IdTagged.rep_id(utpat), kind: Abstract}, - ); - Rec(utpat, to_typ(ctx, tbody)) |> rewrap; - /* The below cases should occur only inside sums */ - | Ap(_) => Unknown(Internal) |> rewrap - }; - } -and to_variant: - (Ctx.t, ConstructorMap.variant(t)) => ConstructorMap.variant(t) = - ctx => - fun - | Variant(ctr, ids, u) => - ConstructorMap.Variant(ctr, ids, Option.map(to_typ(ctx), u)) - | BadEntry(u) => ConstructorMap.BadEntry(to_typ(ctx, u)) -and to_ctr_map = (ctx: Ctx.t, uts: list(ConstructorMap.variant(t))) => { - uts - |> List.map(to_variant(ctx)) - |> ListUtil.dedup_f( - (x: ConstructorMap.variant(t), y: ConstructorMap.variant(t)) => - switch (x, y) { - | (Variant(c1, _, _), Variant(c2, _, _)) => c1 == c2 - | (Variant(_), BadEntry(_)) - | (BadEntry(_), Variant(_)) - | (BadEntry(_), BadEntry(_)) => false - } - ); -}; - /* Functions below this point assume that types have been through the to_typ function above */ [@deriving (show({with_path: false}), sexp, yojson)] @@ -375,7 +306,7 @@ let rec match_synswitch = (t1: t, t2: t) => { Prod(tys) |> rewrap1; | (Prod(_), _) => t1 | (Sum(sm1), Sum(sm2)) => - let sm' = ConstructorMap.match_synswitch(match_synswitch, sm1, sm2); + let sm' = ConstructorMap.match_synswitch(match_synswitch, eq, sm1, sm2); Sum(sm') |> rewrap1; | (Sum(_), _) => t1 }; diff --git a/src/haz3lcore/statics/ConstructorMap.re b/src/haz3lcore/statics/ConstructorMap.re index 65c7859f3c..9a17e9aedc 100644 --- a/src/haz3lcore/statics/ConstructorMap.re +++ b/src/haz3lcore/statics/ConstructorMap.re @@ -6,9 +6,31 @@ type variant('a) = | Variant(Constructor.t, list(Id.t), option('a)) | BadEntry('a); +// Invariant: Must not have duplicate constructors [@deriving (show({with_path: false}), sexp, yojson)] type t('a) = list(variant('a)); +let mk = + ( + ~mk_bad: (Constructor.t, list(Id.t), option('a)) => 'a, + with_duplicates: list(variant('a)), + ) + : t('a) => { + let rec go = (xs, seen: list(Constructor.t)) => { + switch (xs) { + | [] => [] + | [BadEntry(x), ...xs] => [BadEntry(x), ...go(xs, seen)] + | [Variant(ctr, ids, value), ...xs] => + if (List.mem(ctr, seen)) { + [BadEntry(mk_bad(ctr, ids, value)), ...go(xs, seen)]; + } else { + [Variant(ctr, ids, value), ...go(xs, List.cons(ctr, seen))]; + } + }; + }; + go(with_duplicates, []); +}; + let equal_constructor = (eq: ('a, 'a) => bool, x: variant('a), y: variant('a)): bool => switch (x, y) { @@ -90,9 +112,7 @@ let join_entry = | (Variant(ctr1, ids1, None), Variant(ctr2, _, None)) when Constructor.equal(ctr1, ctr2) => Some(Variant(ctr1, ids1, None)) - | (BadEntry(x), BadEntry(y)) => - let+ value = join(x, y); - BadEntry(value); + | (BadEntry(x), BadEntry(_)) => Some(BadEntry(x)) | _ => None }; @@ -125,14 +145,23 @@ let join = }; let match_synswitch = - (match_synswitch: ('a, 'a) => 'a, m1: t('a), m2: t('a)): t('a) => { - List.map( - fun - | (Variant(ctr, ids, Some(value1)), Variant(_, _, Some(value2))) => - Variant(ctr, ids, Some(match_synswitch(value1, value2))) - | (v, _) => v, - List.combine(m1, m2), - ); + ( + match_synswitch: ('a, 'a) => 'a, + eq: ('a, 'a) => bool, + m1: t('a), + m2: t('a), + ) + : t('a) => { + let (inter, left, _) = venn_regions(same_constructor(eq), m1, m2); + let inter' = + List.map( + fun + | (Variant(ctr, ids, Some(value1)), Variant(_, _, Some(value2))) => + Variant(ctr, ids, Some(match_synswitch(value1, value2))) + | (v, _) => v, + inter, + ); + inter' @ left; }; let equal = (eq: ('a, 'a) => bool, m1: t('a), m2: t('a)) => { diff --git a/src/haz3lcore/statics/Ctx.re b/src/haz3lcore/statics/Ctx.re index 759cceef71..db1a7bf664 100644 --- a/src/haz3lcore/statics/Ctx.re +++ b/src/haz3lcore/statics/Ctx.re @@ -43,20 +43,21 @@ let extend_dummy_tvar = (ctx: t, tvar: TPat.t) => | None => ctx }; -let lookup_tvar = (ctx: t, name: string): option(tvar_entry) => +let lookup_tvar = (ctx: t, name: string): option(kind) => List.find_map( fun - | TVarEntry(v) when v.name == name => Some(v) + | TVarEntry(v) when v.name == name => Some(v.kind) | _ => None, ctx, ); -let lookup_alias = (ctx: t, t: string): option(TermBase.Typ.t) => - switch (lookup_tvar(ctx, t)) { - | Some({kind: Singleton(ty), _}) => Some(ty) - | Some({kind: Abstract, _}) - | None => None - }; +let lookup_tvar_id = (ctx: t, name: string): option(Id.t) => + List.find_map( + fun + | TVarEntry(v) when v.name == name => Some(v.id) + | _ => None, + ctx, + ); let get_id: entry => Id.t = fun @@ -81,15 +82,25 @@ let lookup_ctr = (ctx: t, name: string): option(var_entry) => ); let is_alias = (ctx: t, name: string): bool => - switch (lookup_alias(ctx, name)) { - | Some(_) => true + switch (lookup_tvar(ctx, name)) { + | Some(Singleton(_)) => true + | Some(Abstract) | None => false }; let is_abstract = (ctx: t, name: string): bool => switch (lookup_tvar(ctx, name)) { - | Some({kind: Abstract, _}) => true - | _ => false + | Some(Abstract) => true + | Some(Singleton(_)) + | None => false + }; + +let lookup_alias = (ctx: t, name: string): option(TermBase.Typ.t) => + switch (lookup_tvar(ctx, name)) { + | Some(Singleton(ty)) => Some(ty) + | Some(Abstract) => None + | None => + Some(TermBase.Typ.Unknown(Hole(Invalid(name))) |> IdTagged.fresh) }; let add_ctrs = (ctx: t, name: string, id: Id.t, ctrs: TermBase.Typ.sum_map): t => @@ -165,4 +176,4 @@ let filter_duplicates = (ctx: t): t => |> (((ctx, _, _)) => List.rev(ctx)); let shadows_typ = (ctx: t, name: string): bool => - Form.is_base_typ(name) || lookup_alias(ctx, name) != None; + Form.is_base_typ(name) || lookup_tvar(ctx, name) != None; diff --git a/src/haz3lcore/statics/Info.re b/src/haz3lcore/statics/Info.re index b72ce87a79..47cd163b4f 100644 --- a/src/haz3lcore/statics/Info.re +++ b/src/haz3lcore/statics/Info.re @@ -218,13 +218,12 @@ type pat = { [@deriving (show({with_path: false}), sexp, yojson)] type typ = { - term: UTyp.t, + term: Typ.t, ancestors, ctx: Ctx.t, expects: typ_expects, cls: Cls.t, status: status_typ, - ty: Typ.t, }; [@deriving (show({with_path: false}), sexp, yojson)] @@ -423,9 +422,8 @@ let status_exp = (ctx: Ctx.t, mode: Mode.t, self: Self.exp): status_exp => separate sort. It also determines semantic properties such as whether or not a type variable reference is free, and whether a ctr name is a dupe. */ -let status_typ = - (ctx: Ctx.t, expects: typ_expects, term: Typ.t, ty: Typ.t): status_typ => - switch (term.term) { +let status_typ = (ctx: Ctx.t, expects: typ_expects, ty: Typ.t): status_typ => + switch (ty.term) { | Unknown(Hole(Invalid(token))) => InHole(BadToken(token)) | Unknown(Hole(EmptyHole)) => NotInHole(Type(ty)) | Var(name) => @@ -446,16 +444,15 @@ let status_typ = | true => NotInHole(TypeAlias(name, Typ.weak_head_normalize(ctx, ty))) } } - | Ap(t1, t2) => + | Ap(t1, ty_in) => switch (expects) { | VariantExpected(status_variant, ty_variant) => - let ty_in = UTyp.to_typ(ctx, t2); switch (status_variant, t1.term) { | (Unique, Var(name)) => NotInHole(Variant(name, Arrow(ty_in, ty_variant) |> Typ.temp)) | _ => NotInHole(VariantIncomplete(Arrow(ty_in, ty_variant) |> Typ.temp)) - }; + } | ConstructorExpected(_) => InHole(WantConstructorFoundAp) | TypeExpected => InHole(WantTypeFoundAp) } @@ -497,8 +494,8 @@ let is_error = (ci: t): bool => { | InHole(_) => true | NotInHole(_) => false } - | InfoTyp({expects, ctx, term, ty, _}) => - switch (status_typ(ctx, expects, term, ty)) { + | InfoTyp({expects, ctx, term, _}) => + switch (status_typ(ctx, expects, term)) { | InHole(_) => true | NotInHole(_) => false } @@ -593,9 +590,8 @@ let derived_typ = (~utyp: UTyp.t, ~ctx, ~ancestors, ~expects): typ => { Cls.Typ(Constructor) | (_, cls) => Cls.Typ(cls) }; - let ty = UTyp.to_typ(ctx, utyp); - let status = status_typ(ctx, expects, utyp, ty); - {cls, ctx, ancestors, status, expects, ty, term: utyp}; + let status = status_typ(ctx, expects, utyp); + {cls, ctx, ancestors, status, expects, term: utyp}; }; /* Add derivable attributes for type patterns */ @@ -617,8 +613,7 @@ let get_binding_site = (info: t): option(Id.t) => { let+ entry = Ctx.lookup_ctr(ctx, name); entry.id; | InfoTyp({term: {term: Var(name), _}, ctx, _}) => - let+ entry = Ctx.lookup_tvar(ctx, name); - entry.id; + Ctx.lookup_tvar_id(ctx, name) | _ => None }; }; diff --git a/src/haz3lcore/statics/MakeTerm.re b/src/haz3lcore/statics/MakeTerm.re index 739f34aa65..22eeabb2d2 100644 --- a/src/haz3lcore/statics/MakeTerm.re +++ b/src/haz3lcore/statics/MakeTerm.re @@ -109,6 +109,14 @@ let parse_sum_term: UTyp.t => ConstructorMap.variant(UTyp.t) = Variant(ctr, ids_ctr @ ids_ap, Some(u)) | t => BadEntry(t); +let mk_bad = (ctr, ids, value) => { + let t: Typ.t = {ids, copied: false, term: Var(ctr)}; + switch (value) { + | None => t + | Some(u) => Ap(t, u) |> Typ.fresh + }; +}; + let rec go_s = (s: Sort.t, skel: Skel.t, seg: Segment.t): t => switch (s) { | Pat => Pat(pat(unsorted(skel, seg))) @@ -406,13 +414,19 @@ and typ_term: unsorted => (UTyp.term, list(Id.t)) = { } | Pre(tiles, Typ(t)) as tm => switch (tiles) { - | ([(_, (["+"], []))], []) => ret(Sum([parse_sum_term(t)])) + | ([(_, (["+"], []))], []) => + ret(Sum([parse_sum_term(t)] |> ConstructorMap.mk(~mk_bad))) | _ => ret(hole(tm)) } | Bin(Typ(t1), tiles, Typ(t2)) as tm when is_typ_bsum(tiles) != None => switch (is_typ_bsum(tiles)) { | Some(between_kids) => - ret(Sum(List.map(parse_sum_term, [t1] @ between_kids @ [t2]))) + ret( + Sum( + List.map(parse_sum_term, [t1] @ between_kids @ [t2]) + |> ConstructorMap.mk(~mk_bad), + ), + ) | None => ret(hole(tm)) } | Bin(Typ(l), tiles, Typ(r)) as tm => diff --git a/src/haz3lcore/statics/Statics.re b/src/haz3lcore/statics/Statics.re index 0460d9294a..25a91cdba9 100644 --- a/src/haz3lcore/statics/Statics.re +++ b/src/haz3lcore/statics/Statics.re @@ -348,10 +348,9 @@ and uexp_to_info_map = let (fn, m) = go(~mode=typfn_mode, fn, m); let (_, m) = utyp_to_info_map(~ctx, ~ancestors, utyp, m); let (option_name, ty_body) = Typ.matched_forall(ctx, fn.ty); - let ty = Typ.to_typ(ctx, utyp); switch (option_name) { | Some(name) => - add(~self=Just(Typ.subst(ty, name, ty_body)), ~co_ctx=fn.co_ctx, m) + add(~self=Just(Typ.subst(utyp, name, ty_body)), ~co_ctx=fn.co_ctx, m) | None => add(~self=Just(ty_body), ~co_ctx=fn.co_ctx, m) /* invalid name matches with no free type variables. */ }; | DeferredAp(fn, args) => @@ -537,21 +536,21 @@ and uexp_to_info_map = tentatively add an abtract type to the ctx, representing the speculative rec parameter. */ let (ty_def, ctx_def, ctx_body) = { - let ty_pre = UTyp.to_typ(Ctx.extend_dummy_tvar(ctx, typat), utyp); switch (utyp.term) { - | Sum(_) when List.mem(name, Typ.free_vars(ty_pre)) => + | Sum(_) when List.mem(name, Typ.free_vars(utyp)) => /* NOTE: When debugging type system issues it may be beneficial to use a different name than the alias for the recursive parameter */ //let ty_rec = Typ.Rec("α", Typ.subst(Var("α"), name, ty_pre)); let ty_rec = - Typ.Rec(TPat.Var(name) |> IdTagged.fresh, ty_pre) |> Typ.temp; + Typ.Rec(TPat.Var(name) |> IdTagged.fresh, utyp) |> Typ.temp; let ctx_def = Ctx.extend_alias(ctx, name, TPat.rep_id(typat), ty_rec); (ty_rec, ctx_def, ctx_def); - | _ => - let ty = UTyp.to_typ(ctx, utyp); - (ty, ctx, Ctx.extend_alias(ctx, name, TPat.rep_id(typat), ty)); - }; + | _ => ( + utyp, + ctx, + Ctx.extend_alias(ctx, name, TPat.rep_id(typat), utyp), + ) /* NOTE(yuchen): Below is an alternative implementation that attempts to add a rec whenever type alias is present. It may cause trouble to the runtime, so precede with caution. */ @@ -565,6 +564,7 @@ and uexp_to_info_map = // let ty = Term.UTyp.to_typ(ctx, utyp); // (ty, ctx, Ctx.add_alias(ctx, name, utpat_id(typat), ty)); // }; + }; }; let ctx_body = switch (Typ.get_sum_constructors(ctx, ty_def)) { @@ -683,8 +683,8 @@ and upat_to_info_map = add(~self=Just(ty_out), ~ctx=arg.ctx, m); | Cast(p, ann, _) => let (ann, m) = utyp_to_info_map(~ctx, ~ancestors, ann, m); - let (p, m) = go(~ctx, ~mode=Ana(ann.ty), p, m); - add(~self=Just(ann.ty), ~ctx=p.ctx, m); + let (p, m) = go(~ctx, ~mode=Ana(ann.term), p, m); + add(~self=Just(ann.term), ~ctx=p.ctx, m); }; } and utyp_to_info_map = @@ -726,25 +726,23 @@ and utyp_to_info_map = let m = map_m(go, ts, m) |> snd; add(m); | Ap(t1, t2) => - let ty_in = UTyp.to_typ(ctx, t2); let t1_mode: Info.typ_expects = switch (expects) { | VariantExpected(m, sum_ty) => - ConstructorExpected(m, Arrow(ty_in, sum_ty) |> Typ.temp) + ConstructorExpected(m, Arrow(t2, sum_ty) |> Typ.temp) | _ => ConstructorExpected( Unique, - Arrow(ty_in, Unknown(Internal) |> Typ.temp) |> Typ.temp, + Arrow(t2, Unknown(Internal) |> Typ.temp) |> Typ.temp, ) }; let m = go'(~expects=t1_mode, t1, m) |> snd; let m = go'(~expects=TypeExpected, t2, m) |> snd; add(m); | Sum(variants) => - let ty_sum = UTyp.to_typ(ctx, utyp); let (m, _) = List.fold_left( - variant_to_info_map(~ctx, ~ancestors, ~ty_sum), + variant_to_info_map(~ctx, ~ancestors, ~ty_sum=utyp), (m, []), variants, ); diff --git a/src/haz3lweb/view/Type.re b/src/haz3lweb/view/Type.re index e1104fdbdb..857aff3c91 100644 --- a/src/haz3lweb/view/Type.re +++ b/src/haz3lweb/view/Type.re @@ -95,7 +95,15 @@ let rec view_ty = (~strip_outer_parens=false, ty: Haz3lcore.Typ.t): Node.t => ctr_view(t0) @ ts_views; }, ) - | Ap(_) => failwith("type application in view") + | Ap(_) => + div( + ~attr= + Attr.many([ + clss(["typ-view", "atom", "unknown"]), + Attr.title(Typ.show_type_provenance(Internal)), + ]), + [text("?") /*, prov_view(prov)*/], + ) } and ctr_view = fun From a5dda32644ebb0b9e5907bd8523e7b06a6b033d0 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 9 May 2024 15:26:35 -0400 Subject: [PATCH 093/103] Explain map_term --- src/haz3lcore/statics/TermBase.re | 39 ++++++++++++++++++++++++++++++- 1 file changed, 38 insertions(+), 1 deletion(-) diff --git a/src/haz3lcore/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index 2a38f0d2b0..c653cda128 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -3,7 +3,44 @@ open Sexplib.Std; let continue = x => x; let stop = (_, x) => x; -/* TODO[Matt]: Explain map_term */ +/* + This megafile contains the definitions of the expression data types in + Hazel. They are all in one file because they are mutually recursive, and + OCaml doesn't let us have mutually recursive files. Any definition that + is not mutually recursive across the whole data structure should be + defined in Any.re, Exp.re, Typ.re, Pat.re, TPat.re, etc... + + Each module has: + + - A type definition for the term + + - A map_term function that allows you to apply a function to every term in + the data structure with the following type: + + map_term: + ( + ~f_exp: (Exp.t => Exp.t, Exp.t) => Exp.t=?, + ~f_pat: (Pat.t => Pat.t, Pat.t) => Pat.t=?, + ~f_typ: (Typ.t => Typ.t, Typ.t) => Typ.t=?, + ~f_tpat: (TPat.t => TPat.t, TPat.t) => TPat.t=?, + ~f_rul: (Rul.t => Rul.t, Rul.t) => Rul.t=?, + ~f_any: (Any.t => Any.t, Any.t) => Any.t=?, + t + ) => + t; + + Each argument to `map_term` specifies what should happen at each node in the + data structure. Each function takes two arguments: a `continue` function that + allows the map to continue on all the children nodes, and the current node + itself. If you don't explicitly call the `continue` function, the map will + not traverse the children nodes. If you don't provide a function for a + specific kind of node, the map will simply continue at that node without + any additional action. + + - A fast_equal function that compares two terms for equality, it performs + structural equality except for the case of closures, where it just compares + the id of the closure. + */ module rec Any: { [@deriving (show({with_path: false}), sexp, yojson)] From 860a01516003c201a89edf0bbbbc58a35883af8b Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 9 May 2024 15:29:38 -0400 Subject: [PATCH 094/103] Remove some more comments --- src/haz3lweb/explainthis/data/FixFExp.re | 3 --- src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 1 - 2 files changed, 4 deletions(-) diff --git a/src/haz3lweb/explainthis/data/FixFExp.re b/src/haz3lweb/explainthis/data/FixFExp.re index b5693342ef..b106b6be8e 100644 --- a/src/haz3lweb/explainthis/data/FixFExp.re +++ b/src/haz3lweb/explainthis/data/FixFExp.re @@ -2,9 +2,6 @@ open Haz3lcore; open ExplainThisForm; open Example; -/* (A) Use this file as an example for adding a new form to ExplainThis. - * You should be able to copy-paste this file and modify it to add a new form */ - let single = (~pat_id: Id.t, ~body_id: Id.t): Simple.t => { /* (B) You'll need to add new cases to ExplainThisForm.re for the new form * to represent a group_id and form_id. This Simple style is specialized diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index 4d22fa5324..a808cf0966 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -282,7 +282,6 @@ let mk = env, ) | MultiHole(_ds) => - //ds |> List.map(go') |> Doc.hcats DHDoc_common.mk_EmptyHole( ~selected=Some(DHExp.rep_id(d)) == selected_hole_instance, env, From 89a506cb01a28036ac9ae93bd4c8cbeb924a91be Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Fri, 10 May 2024 13:14:01 -0400 Subject: [PATCH 095/103] Fix divide by zero bug --- src/haz3lcore/dynamics/Transition.re | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index 4dd679dd1c..fc4c6c991d 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -559,7 +559,7 @@ module Transition = (EV: EV_MODE) => { | Times => Int(n1 * n2) | Divide when n2 == 0 => DynamicErrorHole( - BinOp(Int(op), d1', d1') |> rewrap, + BinOp(Int(op), d1', d2') |> rewrap, DivideByZero, ) | Divide => Int(n1 / n2) From d35375dd8368ee17a42de6eb04c37180a527ef3c Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 16 May 2024 15:23:07 -0400 Subject: [PATCH 096/103] Fixed match types not working through parentheses --- src/haz3lcore/lang/term/Typ.re | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/src/haz3lcore/lang/term/Typ.re b/src/haz3lcore/lang/term/Typ.re index 1c02d4bb0c..bea76ed4c6 100644 --- a/src/haz3lcore/lang/term/Typ.re +++ b/src/haz3lcore/lang/term/Typ.re @@ -365,8 +365,9 @@ let rec normalize = (ctx: Ctx.t, ty: t): t => { }; }; -let matched_arrow = (ctx, ty) => +let rec matched_arrow = (ctx, ty) => switch (term_of(weak_head_normalize(ctx, ty))) { + | Parens(ty) => matched_arrow(ctx, ty) | Arrow(ty_in, ty_out) => (ty_in, ty_out) | Unknown(SynSwitch) => ( Unknown(SynSwitch) |> temp, @@ -375,39 +376,44 @@ let matched_arrow = (ctx, ty) => | _ => (Unknown(Internal) |> temp, Unknown(Internal) |> temp) }; -let matched_forall = (ctx, ty) => +let rec matched_forall = (ctx, ty) => switch (term_of(weak_head_normalize(ctx, ty))) { + | Parens(ty) => matched_forall(ctx, ty) | Forall(t, ty) => (Some(t), ty) | Unknown(SynSwitch) => (None, Unknown(SynSwitch) |> temp) | _ => (None, Unknown(Internal) |> temp) }; -let matched_prod = (ctx, length, ty) => +let rec matched_prod = (ctx, length, ty) => switch (term_of(weak_head_normalize(ctx, ty))) { + | Parens(ty) => matched_prod(ctx, length, ty) | Prod(tys) when List.length(tys) == length => tys | Unknown(SynSwitch) => List.init(length, _ => Unknown(SynSwitch) |> temp) | _ => List.init(length, _ => Unknown(Internal) |> temp) }; -let matched_list = (ctx, ty) => +let rec matched_list = (ctx, ty) => switch (term_of(weak_head_normalize(ctx, ty))) { + | Parens(ty) => matched_list(ctx, ty) | List(ty) => ty | Unknown(SynSwitch) => Unknown(SynSwitch) |> temp | _ => Unknown(Internal) |> temp }; -let matched_args = (ctx, default_arity, ty) => { +let rec matched_args = (ctx, default_arity, ty) => { let ty' = weak_head_normalize(ctx, ty); switch (term_of(ty')) { + | Parens(ty) => matched_args(ctx, default_arity, ty) | Prod([_, ..._] as tys) => tys | Unknown(_) => List.init(default_arity, _ => ty') | _ => [ty'] }; }; -let get_sum_constructors = (ctx: Ctx.t, ty: t): option(sum_map) => { +let rec get_sum_constructors = (ctx: Ctx.t, ty: t): option(sum_map) => { let ty = weak_head_normalize(ctx, ty); switch (term_of(ty)) { + | Parens(ty) => get_sum_constructors(ctx, ty) | Sum(sm) => Some(sm) | Rec(_) => /* Note: We must unroll here to get right ctr types; @@ -437,8 +443,9 @@ let get_sum_constructors = (ctx: Ctx.t, ty: t): option(sum_map) => { }; }; -let is_unknown = (ty: t): bool => +let rec is_unknown = (ty: t): bool => switch (ty |> term_of) { + | Parens(x) => is_unknown(x) | Unknown(_) => true | _ => false }; From 25090f1dc5d59b971bfa843849fde73bc05ee700 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 16 May 2024 16:14:32 -0400 Subject: [PATCH 097/103] Fix constructor elaboration --- src/haz3lcore/dynamics/Elaborator.re | 41 ++++++++++++++++------------ 1 file changed, 24 insertions(+), 17 deletions(-) diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 2a1ec42453..e7aafc384b 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -163,17 +163,18 @@ let rec elaborate_pattern = let (p', ty) = elaborate_pattern(m, p); p' |> cast_from(ty); | Constructor(c) => - upat - |> cast_from( - Ctx.lookup_ctr(ctx, c) - |> Option.map((x: Ctx.var_entry) => x.typ |> Typ.normalize(ctx)) - |> Option.value( - ~default= - Typ.temp( - Typ.Sum([BadEntry(Typ.temp(Unknown(Internal)))]), - ), - ), - ) + let mode = + switch (Id.Map.find_opt(Pat.rep_id(upat), m)) { + | Some(Info.InfoPat({mode, _})) => mode + | _ => raise(MissingTypeInfo) + }; + let t = + switch (Mode.ctr_ana_typ(ctx, mode, c), Ctx.lookup_ctr(ctx, c)) { + | (Some(ana_ty), _) => ana_ty + | (_, Some({typ: syn_ty, _})) => syn_ty + | _ => Unknown(Internal) |> Typ.temp + }; + upat |> cast_from(t); }; (dpat, elaborated_type); }; @@ -239,12 +240,18 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { let ds' = List.map2((d, t) => fresh_cast(d, t, inner_type), ds, tys); Exp.ListLit(ds') |> rewrap |> cast_from(List(inner_type) |> Typ.temp); | Constructor(c) => - uexp - |> cast_from( - Ctx.lookup_ctr(ctx, c) - |> Option.map((x: Ctx.var_entry) => x.typ |> Typ.normalize(ctx)) - |> Option.value(~default=Typ.temp(Typ.Unknown(Internal))), - ) + let mode = + switch (Id.Map.find_opt(Exp.rep_id(uexp), m)) { + | Some(Info.InfoExp({mode, _})) => mode + | _ => raise(MissingTypeInfo) + }; + let t = + switch (Mode.ctr_ana_typ(ctx, mode, c), Ctx.lookup_ctr(ctx, c)) { + | (Some(ana_ty), _) => ana_ty + | (_, Some({typ: syn_ty, _})) => syn_ty + | _ => Unknown(Internal) |> Typ.temp + }; + uexp |> cast_from(t); | Fun(p, e, env, n) => let (p', typ) = elaborate_pattern(m, p); let (e', tye) = elaborate(m, e); From 16e0ad27890728df1e7c25cf1c97631e673ce7b8 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 16 May 2024 16:19:53 -0400 Subject: [PATCH 098/103] Move test check marks back --- src/haz3lcore/dynamics/Transition.re | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index fc4c6c991d..e7d727bd0d 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -256,10 +256,10 @@ module Transition = (EV: EV_MODE) => { is_value: false, }); } - | Test(d) => + | Test(d'') => let. _ = otherwise(env, ((d, _)) => Test(d) |> rewrap) and. (d', is_value) = - req_final_or_value(req(state, env), d => Test(d) |> wrap_ctx, d); + req_final_or_value(req(state, env), d => Test(d) |> wrap_ctx, d''); let result: TestStatus.t = if (is_value) { switch (Unboxing.unbox(Bool, d')) { From 9c2bd7a1dc860a4a7ddddbf160787a8af1e09f84 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Mon, 20 May 2024 09:56:08 -0400 Subject: [PATCH 099/103] Fix sum cast accumulation --- src/haz3lcore/dynamics/Elaborator.re | 7 +++++-- src/haz3lcore/dynamics/Unboxing.re | 23 +++++++++++++++-------- 2 files changed, 20 insertions(+), 10 deletions(-) diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index e7aafc384b..29212da50f 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -174,7 +174,7 @@ let rec elaborate_pattern = | (_, Some({typ: syn_ty, _})) => syn_ty | _ => Unknown(Internal) |> Typ.temp }; - upat |> cast_from(t); + upat |> cast_from(t |> Typ.normalize(ctx)); }; (dpat, elaborated_type); }; @@ -193,6 +193,9 @@ let rec elaborate_pattern = the "elaborated type" at the top, so you should fresh_cast EVERYWHERE just in case. + Important invariant: any cast in an elaborated expression should have + normalized types. + [Matt] A lot of these fresh_cast calls are redundant, however if you want to remove one, I'd ask you instead comment it out and leave a comment explaining why it's redundant. */ @@ -251,7 +254,7 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { | (_, Some({typ: syn_ty, _})) => syn_ty | _ => Unknown(Internal) |> Typ.temp }; - uexp |> cast_from(t); + uexp |> cast_from(t |> Typ.normalize(ctx)); | Fun(p, e, env, n) => let (p', typ) = elaborate_pattern(m, p); let (e', tye) = elaborate(m, e); diff --git a/src/haz3lcore/dynamics/Unboxing.re b/src/haz3lcore/dynamics/Unboxing.re index 80596c64f8..cfface7fc9 100644 --- a/src/haz3lcore/dynamics/Unboxing.re +++ b/src/haz3lcore/dynamics/Unboxing.re @@ -118,14 +118,21 @@ let rec unbox: type a. (unbox_request(a), DHExp.t) => unboxed(a) = when name1 == name2 => Matches(d3) | (SumWithArg(_), Ap(_, {term: Constructor(_), _}, _)) => DoesNotMatch - | (SumWithArg(name), Cast(d1, {term: Sum(_), _}, {term: Sum(s2), _})) - when - ConstructorMap.get_entry(name, s2) != None - || ConstructorMap.has_bad_entry(s2) => - let* d1 = unbox(SumWithArg(name), d1); - Matches(d1 |> fixup_cast); - | (SumWithArg(_), Cast(_, {term: Sum(_), _}, {term: Sum(_), _})) => - IndetMatch + | (SumWithArg(name), Cast(d1, {term: Sum(s1), _}, {term: Sum(s2), _})) => + let get_entry_or_bad = s => + switch (ConstructorMap.get_entry(name, s)) { + | Some(x) => Some(x) + | None when ConstructorMap.has_bad_entry(s) => + Some(Typ.temp(Unknown(Internal))) + | None => None + }; + switch (get_entry_or_bad(s1), get_entry_or_bad(s2)) { + | (Some(x), Some(y)) => + let* d1 = unbox(SumWithArg(name), d1); + Matches(Cast(d1, x, y) |> Exp.fresh |> fixup_cast); + | _ => IndetMatch + }; + // There should be some sort of failure here when the cast doesn't go through. /* Any cast from unknown is indet */ | (_, Cast(_, {term: Unknown(_), _}, _)) => IndetMatch From 8447c01348a3b592ab970d86d0ce5fad344e8891 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Tue, 28 May 2024 10:37:27 -0400 Subject: [PATCH 100/103] Fix builtins throwing errors --- src/haz3lcore/dynamics/Transition.re | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index e7d727bd0d..073bc80804 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -384,7 +384,7 @@ module Transition = (EV: EV_MODE) => { EvaluatorError.Exception(InvalidBuiltin(ident)), ) }); - builtin(d2); + builtin(d2'); }, state_update, kind: BuiltinAp(ident), From 098f032d0aad48eb93dc5ca619ad419868db3ddb Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Fri, 7 Jun 2024 11:49:40 -0400 Subject: [PATCH 101/103] delete TypeAssignment.re --- src/haz3lcore/dynamics/TypeAssignment.re | 276 ----------------------- 1 file changed, 276 deletions(-) delete mode 100644 src/haz3lcore/dynamics/TypeAssignment.re diff --git a/src/haz3lcore/dynamics/TypeAssignment.re b/src/haz3lcore/dynamics/TypeAssignment.re deleted file mode 100644 index 81f489d8fe..0000000000 --- a/src/haz3lcore/dynamics/TypeAssignment.re +++ /dev/null @@ -1,276 +0,0 @@ -// open Util; -// open OptUtil.Syntax; -// let equal_typ_case = (l: list(Typ.t)): option(Typ.t) => { -// switch (l) { -// | [] => None -// | _ => -// let ty = List.hd(l); -// List.fold_left((acc, t) => {acc && Typ.eq(t, ty)}, true, l) -// ? Some(ty) : None; -// }; -// }; -// let arrow_aux = (ty: Typ.t): Typ.t => { -// switch (ty) { -// | Unknown(Internal) => Arrow(Unknown(Internal), Unknown(Internal)) -// | _ => ty -// }; -// }; -// let delta_ty = (id: MetaVar.t, m: Statics.Map.t): option(Typ.t) => { -// switch (Id.Map.find_opt(id, m)) { -// | Some(InfoExp({mode, ctx, _})) => -// switch (mode) { -// | Syn -// | SynFun => Some(Unknown(Internal)) -// | Ana(ana_ty) => Some(Typ.normalize(ctx, ana_ty)) -// } -// | _ => None -// }; -// }; -// let ground = (ty: Typ.t): bool => { -// switch (ty) { -// | Bool -// | Int -// | Float -// | String -// | Prod([]) -// | Arrow(Unknown(Internal), Unknown(Internal)) => true -// | _ => false -// }; -// }; -// let rec dhpat_extend_ctx = -// (m: Statics.Map.t, dhpat: DHPat.t, ty: Typ.t, ctx: Ctx.t): Ctx.t => { -// switch (dhpat.term, ty) { -// | (Var(name), _) => -// let entry = Ctx.VarEntry({name, id: Id.invalid, typ: ty}); -// Ctx.extend(ctx, entry); -// | (Tuple(l1), Prod(l2)) => -// if (List.length(l1) == List.length(l2)) { -// List.fold_left2( -// (acc, dhp, typ) => {dhpat_extend_ctx(m, dhp, typ, acc)}, -// ctx, -// l1, -// l2, -// ); -// } else { -// ctx; -// } -// | (Cons(dhp1, dhp2), List(typ)) => -// ctx |> dhpat_extend_ctx(m, dhp1, typ) |> dhpat_extend_ctx(m, dhp2, ty) -// | (ListLit(l), List(typ2)) => -// let typ1 = Typ.matched_list(fixed_pat_typ(m, upat)); -// if (Typ.eq(typ1, typ2)) { -// List.fold_left( -// (acc, dhp) => {dhpat_extend_ctx(m, dhp, typ1, acc)}, -// ctx, -// l, -// ); -// } else { -// ctx; -// }; -// (); -// | (Ap(Constructor(_, typ), dhp), _) => -// let (ty1, ty2) = Typ.matched_arrow(ctx, typ); -// if (Typ.eq(ty2, ty)) { -// ctx |> dhpat_extend_ctx(dhp, ty1); -// } else { -// ctx; -// }; -// | _ => ctx -// }; -// }; -// let rec typ_of_dhexp = -// (ctx: Ctx.t, m: Statics.Map.t, dh: DHExp.t): option(Typ.t) => { -// switch (dh) { -// | EmptyHole(id, _) => delta_ty(id, m) -// | NonEmptyHole(_, id, _, d) => -// switch (typ_of_dhexp(ctx, m, d)) { -// | None => None -// | Some(_) => delta_ty(id, m) -// } -// | ExpandingKeyword(_) => None -// | FreeVar(_) => Some(Unknown(Internal)) -// | InvalidText(_) => None -// | InconsistentBranches(_, _, Case(d_scrut, d_rules, _)) => -// let* ty' = typ_of_dhexp(ctx, m, d_scrut); -// let typ_cases = -// d_rules -// |> List.map(rule_prj) -// |> List.map(((dhp, de)) => { -// typ_of_dhexp(dhpat_extend_ctx(dhp, ty', ctx), m, de) -// }) -// |> OptUtil.sequence; -// switch (typ_cases) { -// | None => None -// | Some(_) => Some(Typ.Unknown(Internal)) -// }; -// | Closure(_, d) => typ_of_dhexp(ctx, m, d) -// | Filter(_, d) => typ_of_dhexp(ctx, m, d) -// | BoundVar(name) => -// let+ var = Ctx.lookup_var(ctx, name); -// var.typ; -// | Sequence(d1, d2) => -// let* _ = typ_of_dhexp(ctx, m, d1); -// typ_of_dhexp(ctx, m, d2); -// | Let(dhp, de, db) => -// let* ty1 = typ_of_dhexp(ctx, m, de); -// typ_of_dhexp(dhpat_extend_ctx(dhp, ty1, ctx), m, db); -// | FixF(name, ty1, d) => -// let entry = Ctx.VarEntry({name, id: Id.invalid, typ: ty1}); -// typ_of_dhexp(Ctx.extend(ctx, entry), m, d); -// | Fun(dhp, ty1, d, _) => -// let+ ty2 = typ_of_dhexp(dhpat_extend_ctx(dhp, ty1, ctx), m, d); -// Typ.Arrow(ty1, ty2); -// | Ap(d1, d2) => -// let* ty1 = typ_of_dhexp(ctx, m, d1); -// let* ty2 = typ_of_dhexp(ctx, m, d2); -// switch (arrow_aux(ty1)) { -// | Arrow(tyl, tyr) when Typ.eq(tyl, ty2) => Some(tyr) -// | _ => None -// }; -// | ApBuiltin(_) -// | BuiltinFun(_) => None -// | Test(_, dtest) => -// let* ty = typ_of_dhexp(ctx, m, dtest); -// Typ.eq(ty, Bool) ? Some(Typ.Prod([])) : None; -// | BoolLit(_) => Some(Bool) -// | IntLit(_) => Some(Int) -// | FloatLit(_) => Some(Float) -// | StringLit(_) => Some(String) -// | BinBoolOp(_, d1, d2) => -// let* ty1 = typ_of_dhexp(ctx, m, d1); -// let* ty2 = typ_of_dhexp(ctx, m, d2); -// Typ.eq(ty1, Bool) && Typ.eq(ty2, Bool) ? Some(Typ.Bool) : None; -// | BinIntOp(op, d1, d2) => -// let* ty1 = typ_of_dhexp(ctx, m, d1); -// let* ty2 = typ_of_dhexp(ctx, m, d2); -// if (Typ.eq(ty1, Int) && Typ.eq(ty2, Int)) { -// switch (op) { -// | Minus -// | Plus -// | Times -// | Power -// | Divide => Some(Typ.Int) -// | LessThan -// | LessThanOrEqual -// | GreaterThan -// | GreaterThanOrEqual -// | Equals -// | NotEquals => Some(Typ.Bool) -// }; -// } else { -// None; -// }; -// | BinFloatOp(op, d1, d2) => -// let* ty1 = typ_of_dhexp(ctx, m, d1); -// let* ty2 = typ_of_dhexp(ctx, m, d2); -// if (Typ.eq(ty1, Float) && Typ.eq(ty2, Float)) { -// switch (op) { -// | Minus -// | Plus -// | Times -// | Power -// | Divide => Some(Typ.Float) -// | LessThan -// | LessThanOrEqual -// | GreaterThan -// | GreaterThanOrEqual -// | Equals -// | NotEquals => Some(Typ.Bool) -// }; -// } else { -// None; -// }; -// | BinStringOp(op, d1, d2) => -// let* ty1 = typ_of_dhexp(ctx, m, d1); -// let* ty2 = typ_of_dhexp(ctx, m, d2); -// if (Typ.eq(ty1, String) && Typ.eq(ty2, String)) { -// switch (op) { -// | Concat => Some(Typ.String) -// | Equals => Some(Typ.Bool) -// }; -// } else { -// None; -// }; -// | ListLit(_, _, ty, _) => Some(List(ty)) -// | Cons(d1, d2) => -// let* ty1 = typ_of_dhexp(ctx, m, d1); -// let* ty2 = typ_of_dhexp(ctx, m, d2); -// switch (ty2) { -// | List(Unknown(Internal)) => Some(Typ.List(ty1)) -// | List(ty3) when Typ.eq(ty3, ty1) => Some(ty2) -// | _ => None -// }; -// | ListConcat(d1, d2) => -// let* ty1 = typ_of_dhexp(ctx, m, d1); -// let* ty2 = typ_of_dhexp(ctx, m, d2); -// switch (ty1, ty2) { -// | (List(Unknown(Internal)), _) -// | (_, List(Unknown(Internal))) => Some(Typ.List(Unknown(Internal))) -// | (List(ty1), List(ty2)) when Typ.eq(ty1, ty2) => Some(Typ.List(ty1)) -// | _ => None -// }; -// | Tuple(dhs) => -// let+ typ_list = -// dhs |> List.map(typ_of_dhexp(ctx, m)) |> OptUtil.sequence; -// Typ.Prod(typ_list); -// | Prj(dh, i) => -// let* ty = typ_of_dhexp(ctx, m, dh); -// switch (ty) { -// | Prod(l) when List.length(l) != 0 => Some(List.nth(l, i)) -// | _ => None -// }; -// | Constructor(_, typ) => Some(typ) -// | ConsistentCase(Case(d_scrut, d_rules, _)) => -// let* ty' = typ_of_dhexp(ctx, m, d_scrut); -// let* typ_cases: list(Typ.t) = -// d_rules -// |> List.map(rule_prj) -// |> List.map(((dhp, de)) => { -// typ_of_dhexp(dhpat_extend_ctx(dhp, ty', ctx), m, de) -// }) -// |> OptUtil.sequence; -// Typ.join_all(~empty=Unknown(Internal), ctx, typ_cases); -// | Cast(d, ty1, ty2) => -// let* _ = Typ.join(~fix=true, ctx, ty1, ty2); -// let* tyd = typ_of_dhexp(ctx, m, d); -// Typ.eq(tyd, ty1) ? Some(ty2) : None; -// | FailedCast(d, ty1, ty2) => -// if (ground(ty1) && ground(ty2) && !Typ.eq(ty1, ty2)) { -// let* tyd = typ_of_dhexp(ctx, m, d); -// Typ.eq(tyd, ty1) ? Some(ty2) : None; -// } else { -// None; -// } -// | InvalidOperation(_) => None -// | IfThenElse(ConsistentIf, d_scrut, d1, d2) => -// let* ty = typ_of_dhexp(ctx, m, d_scrut); -// if (Typ.eq(ty, Bool)) { -// let* ty1 = typ_of_dhexp(ctx, m, d1); -// let* ty2 = typ_of_dhexp(ctx, m, d2); -// Typ.join_all(~empty=Unknown(Internal), ctx, [ty1, ty2]); -// } else { -// None; -// }; -// | IfThenElse(InconsistentIf, d_scrut, d1, d2) => -// let* ty = typ_of_dhexp(ctx, m, d_scrut); -// if (Typ.eq(ty, Bool)) { -// let* _ = typ_of_dhexp(ctx, m, d1); -// let+ _ = typ_of_dhexp(ctx, m, d2); -// Typ.Unknown(Internal); -// } else { -// None; -// }; -// }; -// }; -// let property_test = (uexp_typ: Typ.t, dhexp: DHExp.t, m: Statics.Map.t): bool => { -// let dhexp_typ = typ_of_dhexp(Builtins.ctx_init, m, dhexp); -// print_endline(Typ.show(uexp_typ)); -// switch (dhexp_typ) { -// | None => -// print_endline("Got none"); -// false; -// | Some(dh_typ) => -// print_endline(Typ.show(dh_typ)); -// Typ.eq(dh_typ, uexp_typ); -// }; -// }; From 8a183c782980dbe861ddc1749203fcaeff26679b Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Thu, 13 Jun 2024 15:20:21 -0400 Subject: [PATCH 102/103] Fix tests --- test/Test_Elaboration.re | 15 +++++---------- 1 file changed, 5 insertions(+), 10 deletions(-) diff --git a/test/Test_Elaboration.re b/test/Test_Elaboration.re index e955ff82a6..184aa2fc03 100644 --- a/test/Test_Elaboration.re +++ b/test/Test_Elaboration.re @@ -160,17 +160,12 @@ let u9: Exp.t = let d9: Exp.t = Let( Var("f") |> Pat.fresh, - FixF( - Var("f") |> Pat.fresh, - Fun( - Var("x") |> Pat.fresh, - BinOp(Int(Plus), Int(1) |> Exp.fresh, Var("x") |> Exp.fresh) - |> Exp.fresh, - None, - Some("f"), - ) + Fun( + Var("x") |> Pat.fresh, + BinOp(Int(Plus), Int(1) |> Exp.fresh, Var("x") |> Exp.fresh) |> Exp.fresh, None, + Some("f"), ) |> Exp.fresh, Int(55) |> Exp.fresh, @@ -179,7 +174,7 @@ let d9: Exp.t = let let_fun = () => alco_check( - "Let expression for function which wraps a fix point constructor around the function", + "Let expression for function which is not recursive", d9, dhexp_of_uexp(u9), ); From 436559f2c3416dd99b761b3e237aa341a0d5cc23 Mon Sep 17 00:00:00 2001 From: Matt Keenan Date: Fri, 14 Jun 2024 16:41:42 -0400 Subject: [PATCH 103/103] Fix named typfun showing up as anonymous --- src/haz3lcore/dynamics/Elaborator.re | 1 + 1 file changed, 1 insertion(+) diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 238cb2c203..37ed75ca0c 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -287,6 +287,7 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { let (term, rewrap) = DHExp.unwrap(exp); switch (term) { | Fun(p, e, ctx, _) => Fun(p, e, ctx, name) |> rewrap + | TypFun(tpat, e, _) => TypFun(tpat, e, name) |> rewrap | _ => exp }; }