diff --git a/Makefile b/Makefile index 71bee9edcc..97966cf4a1 100644 --- a/Makefile +++ b/Makefile @@ -27,7 +27,7 @@ dev-helper: dev: setup-instructor dev-helper -dev-student: setup-student dev +dev-student: setup-student dev-helper fmt: dune fmt --auto-promote @@ -42,7 +42,7 @@ release: setup-instructor dune build @src/fmt --auto-promote src --profile release release-student: setup-student - dune build @src/fmt --auto-promote src --profile dev + dune build @src/fmt --auto-promote src --profile dev # Uses dev profile for performance reasons. It may be worth it to retest since the ocaml upgrade echo-html-dir: @echo $(HTML_DIR) 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/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/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 2080d9427f..3d26ecafb3 100644 --- a/src/haz3lcore/assistant/AssistantForms.re +++ b/src/haz3lcore/assistant/AssistantForms.re @@ -11,33 +11,36 @@ 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)), - ("typfun" ++ leading_expander, Forall("", unk)), + ("fun" ++ leading_expander, Arrow(unk, 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([])), + ("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), @@ -72,7 +75,7 @@ module Typ = { fun | InfoExp({mode, _}) | InfoPat({mode, _}) => Mode.ty_of(mode) - | _ => Unknown(Internal); + | _ => Unknown(Internal) |> Typ.fresh; let filter_by = ( @@ -194,7 +197,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, IdTagged.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 60172fa698..4479989fd5 100644 --- a/src/haz3lcore/dynamics/Builtins.re +++ b/src/haz3lcore/dynamics/Builtins.re @@ -22,98 +22,140 @@ 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 = { /* 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 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 - | FloatLit(f) => Ok(BoolLit(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 - | FloatLit(f) => Ok(BoolLit(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 - | FloatLit(f) => Ok(BoolLit(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 - | IntLit(n) => Ok(StringLit(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 - | FloatLit(f) => Ok(StringLit(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 - | BoolLit(b) => Ok(StringLit(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 - | FloatLit(f) => Ok(IntLit(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 - | IntLit(n) => Ok(FloatLit(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 - | IntLit(n) => Ok(IntLit(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 - | FloatLit(f) => Ok(FloatLit(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 +174,110 @@ module Pervasives = { let of_string = (convert: string => option('a), wrap: 'a => DHExp.t, name: string) => - unary( - fun - | StringLit(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(Forward, d', d) |> DHExp.fresh; + let d' = DynamicErrorHole(d', InvalidOfString) |> DHExp.fresh; + Ok(d'); } - | d => Error(InvalidBoxedStringLit(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) |> 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([IntLit(n), IntLit(m)]) => - switch (m) { - | 0 => - InvalidOperation( - DHExp.Ap(DHExp.BuiltinFun(name), d1), - DivideByZero, - ) - | _ => IntLit(n mod m) - } - | d1 => raise(EvaluatorError.Exception(InvalidBoxedTuple(d1))) - }; + binary( + (d1, d2) => + switch (term_of(d1), term_of(d2)) { + | (Int(_), Int(0)) => + Ok( + fresh( + DynamicErrorHole( + DHExp.Ap(Forward, 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 - | StringLit(s) => Ok(IntLit(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([StringLit(s1), StringLit(s2)]) => - Ok(IntLit(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 - | StringLit(s) => Ok(StringLit(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 - | StringLit(s) => Some(s) - | _ => None; + d => + switch (term_of(d)) { + | String(s) => Some(s) + | _ => None + }; let string_concat = - unary( - fun - | Tuple([StringLit(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(StringLit(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([StringLit(s), IntLit(idx), IntLit(len)]) as d => - try(Ok(StringLit(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(DynamicErrorHole(d2, IndexOutOfBounds) |> fresh) } - | d => Error(InvalidBoxedTuple(d)), + | (String(_), Int(_), _) => Error(InvalidBoxedIntLit(d3)) + | (String(_), _, _) => Error(InvalidBoxedIntLit(d2)) + | (_, _, _) => Error(InvalidBoxedIntLit(d1)) + } ); }; @@ -253,37 +321,50 @@ 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"), ); }; 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", id: Id.invalid, - kind: Kind.Singleton(Sum(meta_cons_map)), + kind: Ctx.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) @@ -303,7 +384,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/Casts.re b/src/haz3lcore/dynamics/Casts.re new file mode 100644 index 0000000000..170d057e76 --- /dev/null +++ b/src/haz3lcore/dynamics/Casts.re @@ -0,0 +1,218 @@ +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 grounded_Arrow = + NotGroundOrHole( + Arrow(Unknown(Internal) |> Typ.temp, Unknown(Internal) |> Typ.temp) + |> Typ.temp, + ); +let grounded_Forall = + NotGroundOrHole( + Forall(EmptyHole |> TPat.fresh, Unknown(Internal) |> Typ.temp) + |> Typ.temp, + ); +let grounded_Prod = length => + NotGroundOrHole( + Prod(ListUtil.replicate(length, Typ.Unknown(Internal) |> Typ.temp)) + |> Typ.temp, + ); +let grounded_Sum: unit => Typ.sum_map = + () => [BadEntry(Typ.temp(Unknown(Internal)))]; +let grounded_List = + NotGroundOrHole(List(Unknown(Internal) |> Typ.temp) |> Typ.temp); + +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(_) + | Forall(_, {term: Unknown(_), _}) + | 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.temp) + | Arrow(_, _) => grounded_Arrow + | Forall(_) => grounded_Forall + | 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 + + | (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, t3, t2) |> DHExp.fresh); // Rule ITCastFail + } + | _ => None + } + + | (Hole, NotGroundOrHole(t2_grounded)) => + /* ITExpand rule */ + 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 */ + Some( + DHExp.Cast(Cast(d1, t1, t1_grounded) |> DHExp.fresh, t1_grounded, t2) + |> DHExp.fresh, + ) + + | (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 + + | (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; + } + }; + | _ => None + }; +}; + +let rec transition_multiple = (d: DHExp.t): DHExp.t => { + switch (transition(~recursive=true, d)) { + | Some(d'') => transition_multiple(d'') + | None => d + }; +}; + +// 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 => { + 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, hole) + }; + }; + 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}; + | 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") + }; + }; + p |> unwrap_casts |> rewrap_casts; +}; 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/Constraint.re b/src/haz3lcore/dynamics/Constraint.re index 01a3ddad5f..3fcff59bea 100644 --- a/src/haz3lcore/dynamics/Constraint.re +++ b/src/haz3lcore/dynamics/Constraint.re @@ -129,10 +129,11 @@ let of_ap = (ctx, mode, ctr: option(Constructor.t), arg: t, syn_ty): t => }; switch (ty) { | Some(ty) => - switch (Typ.weak_head_normalize(ctx, ty)) { - | Rec(_, Sum(map)) + switch (Typ.weak_head_normalize(ctx, ty) |> Typ.term_of) { + | Rec(_, {term: Sum(map), _}) | Sum(map) => - let num_variants = ConstructorMap.cardinal(map); + let num_variants = + ConstructorMap.get_constructors(map) |> List.length; switch (ConstructorMap.nth(map, name)) { | Some(nth) => arg |> ctr_of_nth_variant(num_variants, nth) | None => Falsity diff --git a/src/haz3lcore/dynamics/DH.re b/src/haz3lcore/dynamics/DH.re deleted file mode 100644 index 7399f1d98c..0000000000 --- a/src/haz3lcore/dynamics/DH.re +++ /dev/null @@ -1,640 +0,0 @@ -open Util; - -[@deriving (show({with_path: false}), sexp, yojson)] -type if_consistency = - | ConsistentIf - | InconsistentIf; - -module rec DHExp: { - [@deriving (show({with_path: false}), sexp, yojson)] - type t = - | EmptyHole(MetaVar.t, HoleInstanceId.t) - | NonEmptyHole(ErrStatus.HoleReason.t, MetaVar.t, HoleInstanceId.t, t) - | FreeVar(MetaVar.t, HoleInstanceId.t, Var.t) - | InvalidText(MetaVar.t, HoleInstanceId.t, string) - | InconsistentBranches(MetaVar.t, HoleInstanceId.t, case) - | Closure([@opaque] ClosureEnvironment.t, t) - | Filter(DHFilter.t, t) - | Undefined - | 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)) - | TypFun(Term.UTPat.t, t, option(Var.t)) - | TypAp(t, Typ.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, Typ.t) - | 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 - and case = - | Case(t, list(rule), int) - and rule = - | Rule(DHPat.t, t); - - let constructor_string: t => string; - - let mk_tuple: list(t) => t; - - let cast: (t, Typ.t, Typ.t) => t; - - let apply_casts: (t, list((Typ.t, Typ.t))) => t; - let strip_casts: t => t; - - let fast_equal: (t, t) => bool; - - let assign_name_if_none: (t, option(Var.t)) => t; - let ty_subst: (Typ.t, TypVar.t, t) => t; -} = { - [@deriving (show({with_path: false}), sexp, yojson)] - type t = - /* Hole types */ - | EmptyHole(MetaVar.t, HoleInstanceId.t) - | NonEmptyHole(ErrStatus.HoleReason.t, MetaVar.t, HoleInstanceId.t, t) - | FreeVar(MetaVar.t, HoleInstanceId.t, Var.t) - | InvalidText(MetaVar.t, HoleInstanceId.t, string) - | InconsistentBranches(MetaVar.t, HoleInstanceId.t, case) - /* Generalized closures */ - | Closure(ClosureEnvironment.t, t) - | Filter(DHFilter.t, t) - /* Other expressions forms */ - | Undefined - | 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)) - | TypFun(Term.UTPat.t, t, option(Var.t)) - | TypAp(t, Typ.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, Typ.t) - | ConsistentCase(case) - | Cast(t, Typ.t, Typ.t) - | FailedCast(t, Typ.t, Typ.t) - | InvalidOperation(t, InvalidOperationError.t) - | IfThenElse(if_consistency, t, t, t) - and case = - | Case(t, list(rule), int) - and rule = - | Rule(DHPat.t, t); - - let constructor_string = (d: t): string => - switch (d) { - | EmptyHole(_, _) => "EmptyHole" - | NonEmptyHole(_, _, _, _) => "NonEmptyHole" - | FreeVar(_, _, _) => "FreeVar" - | InvalidText(_) => "InvalidText" - | Undefined => "Undefined" - | BoundVar(_) => "BoundVar" - | Sequence(_, _) => "Sequence" - | Filter(_, _) => "Filter" - | Let(_, _, _) => "Let" - | FixF(_, _, _) => "FixF" - | Fun(_, _, _, _) => "Fun" - | TypFun(_) => "TypFun" - | Closure(_, _) => "Closure" - | Ap(_, _) => "Ap" - | TypAp(_) => "TypAp" - | ApBuiltin(_, _) => "ApBuiltin" - | BuiltinFun(_) => "BuiltinFun" - | Test(_) => "Test" - | BoolLit(_) => "BoolLit" - | IntLit(_) => "IntLit" - | FloatLit(_) => "FloatLit" - | StringLit(_) => "StringLit" - | BinBoolOp(_, _, _) => "BinBoolOp" - | BinIntOp(_, _, _) => "BinIntOp" - | BinFloatOp(_, _, _) => "BinFloatOp" - | BinStringOp(_, _, _) => "BinStringOp" - | ListLit(_) => "ListLit" - | Cons(_, _) => "Cons" - | ListConcat(_, _) => "ListConcat" - | Tuple(_) => "Tuple" - | Prj(_) => "Prj" - | Constructor(_) => "Constructor" - | ConsistentCase(_) => "ConsistentCase" - | InconsistentBranches(_, _, _) => "InconsistentBranches" - | Cast(_, _, _) => "Cast" - | FailedCast(_, _, _) => "FailedCast" - | InvalidOperation(_) => "InvalidOperation" - | IfThenElse(_, _, _, _) => "IfThenElse" - }; - - 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 => - if (Typ.eq(t1, t2) || t2 == Unknown(SynSwitch)) { - d; - } else { - 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); - - let rec strip_casts = - fun - | Closure(ei, d) => Closure(ei, strip_casts(d)) - | 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)) - | Sequence(a, b) => Sequence(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) - | TypFun(a, b, c) => TypFun(a, strip_casts(b), c) - | Ap(a, b) => Ap(strip_casts(a), strip_casts(b)) - | TypAp(a, b) => TypAp(strip_casts(a), b) - | 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)) - | 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), - ) - | EmptyHole(_) as d - | FreeVar(_) as d - | InvalidText(_) as d - | Undefined as d - | BoundVar(_) as d - | BoolLit(_) as d - | IntLit(_) as d - | FloatLit(_) as d - | StringLit(_) 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), - ) - and strip_casts_rule = (Rule(a, d)) => Rule(a, strip_casts(d)); - - let rec fast_equal = (d1: t, d2: t): bool => { - switch (d1, d2) { - | (Undefined, _) - /* Primitive forms: regular structural equality */ - | (BoundVar(_), _) - /* TODO: Not sure if this is right... */ - | (BoolLit(_), _) - | (IntLit(_), _) - | (FloatLit(_), _) - | (Constructor(_), _) => d1 == d2 - | (StringLit(s1), StringLit(s2)) => String.equal(s1, s2) - | (StringLit(_), _) => false - - /* Non-hole forms: recurse */ - | (Test(id1, d1), Test(id2, d2)) => id1 == id2 && fast_equal(d1, d2) - | (Sequence(d11, d21), Sequence(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) - | (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, s1), Fun(dp2, ty2, d2, s2)) => - dp1 == dp2 && ty1 == ty2 && fast_equal(d1, d2) && 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(d11, d21), Ap(d12, 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) - | (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)) => - 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)) => - 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)) => - 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)) => - 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(_), _) - | (Filter(_), _) - | (Let(_), _) - | (FixF(_), _) - | (Fun(_), _) - | (TypFun(_), _) - | (Test(_), _) - | (Ap(_), _) - | (TypAp(_), _) - | (ApBuiltin(_), _) - | (BuiltinFun(_), _) - | (Cons(_), _) - | (ListConcat(_), _) - | (ListLit(_), _) - | (Tuple(_), _) - | (Prj(_), _) - | (BinBoolOp(_), _) - | (BinIntOp(_), _) - | (BinFloatOp(_), _) - | (BinStringOp(_), _) - | (Cast(_), _) - | (FailedCast(_), _) - | (InvalidOperation(_), _) - | (IfThenElse(_), _) - | (ConsistentCase(_), _) => 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(u1, i1), EmptyHole(u2, i2)) => u1 == u2 && i1 == i2 - | (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 - | (InvalidText(u1, i1, text1), InvalidText(u2, i2, text2)) => - 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(_), _) - | (FreeVar(_), _) - | (InvalidText(_), _) - | (Closure(_), _) - | (InconsistentBranches(_), _) => 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; - }; - - let assign_name_if_none = (t, name) => - switch (t) { - | Fun(arg, ty, body, None) => Fun(arg, ty, body, name) - | TypFun(utpat, body, None) => TypFun(utpat, body, name) - | _ => t - }; - - let rec ty_subst = (s: Typ.t, x: TypVar.t, exp: DHExp.t): t => { - let re = e2 => ty_subst(s, x, e2); - let t_re = ty => Typ.subst(s, x, ty); - switch (exp) { - | Cast(t, t1, t2) => Cast(re(t), t_re(t1), t_re(t2)) - | FixF(arg, ty, body) => FixF(arg, t_re(ty), re(body)) - | Fun(arg, ty, body, var) => Fun(arg, t_re(ty), re(body), var) - | TypAp(tfun, ty) => TypAp(re(tfun), t_re(ty)) - | ListLit(mv, mvi, t, lst) => - ListLit(mv, mvi, t_re(t), List.map(re, lst)) - | TypFun(utpat, body, var) => - switch (Term.UTPat.tyvar_of_utpat(utpat)) { - | Some(x') when x == x' => exp - | _ => - /* Note that we do not have to worry about capture avoidance, since s will always be closed. */ - TypFun(utpat, re(body), var) - } - | NonEmptyHole(errstat, mv, hid, t) => - NonEmptyHole(errstat, mv, hid, re(t)) - | Test(id, t) => Test(id, re(t)) - | InconsistentBranches(mv, hid, case) => - InconsistentBranches(mv, hid, ty_subst_case(s, x, case)) - | Closure(ce, t) => Closure(ce, re(t)) - | Sequence(t1, t2) => Sequence(re(t1), re(t2)) - | Let(dhpat, t1, t2) => Let(dhpat, re(t1), re(t2)) - | Ap(t1, t2) => Ap(re(t1), re(t2)) - | ApBuiltin(s, args) => ApBuiltin(s, re(args)) - | BinBoolOp(op, t1, t2) => BinBoolOp(op, re(t1), re(t2)) - | BinIntOp(op, t1, t2) => BinIntOp(op, re(t1), re(t2)) - | BinFloatOp(op, t1, t2) => BinFloatOp(op, re(t1), re(t2)) - | BinStringOp(op, t1, t2) => BinStringOp(op, re(t1), re(t2)) - | Cons(t1, t2) => Cons(re(t1), re(t2)) - | ListConcat(t1, t2) => ListConcat(re(t1), re(t2)) - | Tuple(args) => Tuple(List.map(re, args)) - | Prj(t, n) => Prj(re(t), n) - | ConsistentCase(case) => ConsistentCase(ty_subst_case(s, x, case)) - | InvalidOperation(t, err) => InvalidOperation(re(t), err) - | Filter(filt, exp) => Filter(DHFilter.map(re, filt), re(exp)) - | IfThenElse(consis, i, t, e) => - IfThenElse(consis, re(i), re(t), re(e)) - - | BuiltinFun(_) - | EmptyHole(_) - | FreeVar(_, _, _) - | InvalidText(_, _, _) - | Constructor(_) - | Undefined - | BoundVar(_) - | BoolLit(_) - | IntLit(_) - | FloatLit(_) - | StringLit(_) - | FailedCast(_, _, _) => exp - }; - } - and ty_subst_case = (s, x, Case(t, rules, n)) => - Case( - ty_subst(s, x, t), - List.map( - (DHExp.Rule(dhpat, t)) => DHExp.Rule(dhpat, ty_subst(s, x, t)), - rules, - ), - n, - ); - //TODO: Inconsistent cases: need to check again for inconsistency? -} - -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) => { - switch (f1, f2) { - | (Filter(flt1), Filter(flt2)) => Filter.fast_equal(flt1, flt2) - | (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/DHExp.re b/src/haz3lcore/dynamics/DHExp.re index ca152a800e..f7651ba963 100644 --- a/src/haz3lcore/dynamics/DHExp.re +++ b/src/haz3lcore/dynamics/DHExp.re @@ -1 +1,153 @@ -include DH.DHExp; +/* DHExp.re + + This module is specifically for dynamic expressions. They are stored + using the same data structure as user expressions, have been modified + slightly as described in Elaborator.re. + */ + +include Exp; + +let term_of: t => term = IdTagged.term_of; +let fast_copy: (Id.t, t) => t = IdTagged.fast_copy; + +let mk = (ids, term): t => { + {ids, copied: true, term}; +}; + +// TODO: make this function emit a map of changes +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, + ); + +// 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); + }, + _, + ); + +// Also strips static error holes - kinda like unelaboration +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(_) + | Deferral(_) + | DeferredAp(_) + | Test(_) + | BuiltinFun(_) + | UnOp(_) + | BinOp(_) + | Match(_) + | Parens(_) + | EmptyHole + | Invalid(_) + | Var(_) + | Bool(_) + | Int(_) + | Float(_) + | String(_) + | Constructor(_) + | DynamicErrorHole(_) + | Closure(_) + | TypFun(_) + | TypAp(_) + | Undefined + | If(_) => continue(exp) + /* Remove casts*/ + | FailedCast(d, _, _) + | Cast(d, _, _) => strip_casts(d) + } + }, + _, + ); + +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(_) + | Undefined + | Constructor(_) + | Var(_) + | Bool(_) + | Int(_) + | Float(_) + | String(_) + | FailedCast(_, _, _) + | MultiHole(_) + | Deferral(_) + | TyAlias(_) + | DeferredAp(_) + | Parens(_) + | UnOp(_) => continue(exp) + }, + exp, + ) + }; +}; diff --git a/src/haz3lcore/dynamics/DHPat.re b/src/haz3lcore/dynamics/DHPat.re index fe5a3e51ee..f9e4adbddb 100644 --- a/src/haz3lcore/dynamics/DHPat.re +++ b/src/haz3lcore/dynamics/DHPat.re @@ -1,68 +1,54 @@ -open Util; +include Pat; -[@deriving (show({with_path: false}), sexp, yojson)] -type t = - | EmptyHole(MetaVar.t, MetaVarInst.t) - | NonEmptyHole(ErrStatus.HoleReason.t, MetaVar.t, MetaVarInst.t, t) - | Wild - | 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)) - | Constructor(string, Typ.t) - | Ap(t, t); - -let mk_tuple: list(t) => t = - fun - | [] - | [_] => failwith("mk_tuple: expected at least 2 elements") - | dps => Tuple(dps); +/* 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. */ /** * Whether dp contains the variable x outside of a hole. */ -let rec binds_var = (x: Var.t, dp: t): bool => - switch (dp) { - | EmptyHole(_, _) - | NonEmptyHole(_, _, _, _) - | Wild - | InvalidText(_) - | BadConstructor(_) - | IntLit(_) - | FloatLit(_) - | BoolLit(_) - | StringLit(_) - | Constructor(_) => 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 + | Cast(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) { - | EmptyHole(_, _) - | NonEmptyHole(_, _, _, _) + switch (dp |> term_of) { + | EmptyHole + | MultiHole(_) | Wild - | InvalidText(_) - | BadConstructor(_) - | IntLit(_) - | FloatLit(_) - | BoolLit(_) - | StringLit(_) + | 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)) + | ListLit(dps) => List.flatten(List.map(bound_vars, dps)) | Ap(_, dp1) => bound_vars(dp1) }; diff --git a/src/haz3lcore/dynamics/Delta.re b/src/haz3lcore/dynamics/Delta.re index 37dce8bad1..fee0455685 100644 --- a/src/haz3lcore/dynamics/Delta.re +++ b/src/haz3lcore/dynamics/Delta.re @@ -7,6 +7,6 @@ type hole_sort = type val_ty = (hole_sort, Typ.t, Ctx.t); [@deriving sexp] -type t = MetaVarMap.t(val_ty); +type t = Id.Map.t(val_ty); -let empty: t = (MetaVarMap.empty: t); +let empty: t = (Id.Map.empty: t); diff --git a/src/haz3lcore/dynamics/Delta.rei b/src/haz3lcore/dynamics/Delta.rei index c0e9010fd7..ce58db058d 100644 --- a/src/haz3lcore/dynamics/Delta.rei +++ b/src/haz3lcore/dynamics/Delta.rei @@ -7,6 +7,6 @@ type hole_sort = type val_ty = (hole_sort, Typ.t, Ctx.t); [@deriving sexp] -type t = MetaVarMap.t(val_ty); +type t = Id.Map.t(val_ty); let empty: t; diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index d2f9767ccb..c1f3aa12d7 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -1,5 +1,15 @@ +/* + A nice property would be that elaboration is idempotent... + */ + open Util; -open OptUtil.Syntax; + +exception MissingTypeInfo; + +module Elaboration = { + [@deriving (show({with_path: false}), sexp, yojson)] + type t = {d: DHExp.t}; +}; module ElaborationResult = { [@deriving sexp] @@ -8,499 +18,558 @@ 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 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.temp(Unknown(Internal))) + |> DHExp.fresh + |> Casts.transition_multiple; + DHExp.Cast(d', Typ.temp(Unknown(Internal)), t2) + |> DHExp.fresh + |> Casts.transition_multiple; + }; +}; -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) - | _ => None - }; +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.temp(Unknown(Internal)))) + |> Casts.pattern_fixup, + Typ.temp(Unknown(Internal)), + t2, + ) + |> DHPat.fresh + |> Casts.pattern_fixup; + }; +}; -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)) { - | Some(InfoPat({ty, _})) => Some(ty) - | _ => None - }; +let elaborated_type = (m: Statics.Map.t, uexp: UExp.t): (Typ.t, Ctx.t, 'a) => { + let (mode, self_ty, ctx, co_ctx) = + switch (Id.Map.find_opt(Exp.rep_id(uexp), m)) { + | Some(Info.InfoExp({mode, ty, ctx, co_ctx, _})) => ( + mode, + ty, + ctx, + co_ctx, + ) + | _ => raise(MissingTypeInfo) + }; + let elab_ty = + switch (mode) { + | Syn => self_ty + | SynFun => + let (ty1, ty2) = Typ.matched_arrow(ctx, self_ty); + 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.temp; + // We need to remove the synswitches from this type. + | Ana(ana_ty) => Typ.match_synswitch(ana_ty, self_ty) + }; + (elab_ty |> Typ.normalize(ctx), ctx, co_ctx); +}; -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.cast(d, Unknown(prov), Arrow(Unknown(prov), Unknown(prov))) - | Arrow(_) => d - | _ => failwith("Elaborator.wrap: SynFun non-arrow-type") - } - | SynTypFun => - switch (self_ty) { - | Unknown(prov) => - /* ? |> forall _. ? */ - DHExp.cast(d, Unknown(prov), Forall("_", Unknown(prov))) - | Forall(_) => d - | _ => failwith("Elaborator.wrap: SynTypFun non-forall-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) { - | ListLit(_) - | ListConcat(_) - | Cons(_) => - switch (ana_ty) { - | Unknown(prov) => DHExp.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); - | TypFun(_) => - switch (ana_ty) { - | Unknown(prov) => - DHExp.cast(d, Forall("grounded_forall", Unknown(prov)), ana_ty) - | _ => d - } - | Tuple(ds) => - switch (ana_ty) { - | Unknown(prov) => - let us = List.init(List.length(ds), _ => Typ.Unknown(prov)); - DHExp.cast(d, Prod(us), Unknown(prov)); - | _ => d - } - | Ap(NonEmptyHole(_, _, _, Constructor(_)), _) - | Ap(Constructor(_), _) - | TypAp(Constructor(_), _) - | Constructor(_) => - switch (ana_ty, self_ty) { - | (Unknown(prov), Rec(_, Sum(_))) - | (Unknown(prov), Sum(_)) => DHExp.cast(d, self_ty, Unknown(prov)) - | _ => 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) + }; + let elab_ty = + switch (mode) { + | Syn => self_ty + | SynFun => + let (ty1, ty2) = Typ.matched_arrow(ctx, self_ty); + 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.temp; + | Ana(ana_ty) => + switch (prev_synswitch) { + | None => ana_ty + | Some(syn_ty) => Typ.match_synswitch(syn_ty, ana_ty) } - /* Forms with special ana rules but no particular typing requirements */ - | ConsistentCase(_) - | InconsistentBranches(_) - | IfThenElse(_) - | Sequence(_) - | Let(_) - | FixF(_) => d - /* Hole-like forms: Don't cast */ - | InvalidText(_) - | FreeVar(_) - | EmptyHole(_) - | NonEmptyHole(_) => d - /* DHExp-specific forms: Don't cast */ - | Undefined - | Cast(_) - | Closure(_) - | Filter(_) - | FailedCast(_) - | InvalidOperation(_) => d - /* Normal cases: wrap */ - | BoundVar(_) - | Ap(_) - | ApBuiltin(_) - | BuiltinFun(_) - | Prj(_) - | BoolLit(_) - | IntLit(_) - | FloatLit(_) - | StringLit(_) - | BinBoolOp(_) - | BinIntOp(_) - | BinFloatOp(_) - | BinStringOp(_) - | Test(_) - | TypAp(_) => - // TODO: check with andrew - DHExp.cast(d, self_ty, ana_ty) }; - }; + (elab_ty |> Typ.normalize(ctx), ctx); +}; -/* 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 => - 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) - }; - cast(ctx, mode, self_ty, d); - | InHole(_) => NonEmptyHole(TypeInconsistent, u, 0, d) - }; +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.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.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.temp) + ); + | 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.temp(Unknown(Internal))); + let p1'' = fresh_pat_cast(p1', ty1, ty_inner); + let p2'' = fresh_pat_cast(p2', ty2, List(ty_inner) |> Typ.temp); + DHPat.Cons(p1'', p2'') + |> rewrap + |> 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.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.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.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.temp(Unknown(Internal))), + ) + // Type annotations should already appear + | Parens(p) + | Cast(p, _, _) => + let (p', ty) = elaborate_pattern(m, p); + p' |> cast_from(ty |> Typ.normalize(ctx)); + | Constructor(c, _) => + 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 + }; + let t = t |> Typ.normalize(ctx); + Constructor(c, t) |> rewrap |> cast_from(t); + }; + (dpat, elaborated_type); +}; -let rec dhexp_of_uexp = - (m: Statics.Map.t, uexp: Term.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)) { - | Some(InfoExp({mode, self, ctx, ancestors, co_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+ d: DHExp.t = - switch (uexp.term) { - | Invalid(t) => Some(DHExp.InvalidText(id, 0, t)) - | EmptyHole => Some(DHExp.EmptyHole(id, 0)) - | 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)) - | Undefined => Some(Undefined) - | Triv => Some(Tuple([])) - | Deferral(_) => Some(DHExp.InvalidText(id, 0, "_")) - | Bool(b) => Some(BoolLit(b)) - | Int(n) => Some(IntLit(n)) - | Float(n) => Some(FloatLit(n)) - | String(s) => Some(StringLit(s)) - | 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); - | Fun(p, body) => - let* dp = dhpat_of_upat(m, p); - let* d1 = dhexp_of_uexp(m, body); - let+ ty = fixed_pat_typ(m, p); - let ty = Typ.normalize(ctx, ty); - DHExp.Fun(dp, ty, d1, None); - | TypFun(tpat, body) => - let+ d1 = dhexp_of_uexp(m, body); - DHExp.TypFun(tpat, d1, None); - | Tuple(es) => - let+ ds = es |> List.map(dhexp_of_uexp(m)) |> OptUtil.sequence; - DHExp.Tuple(ds); - | Cons(e1, e2) => - let* dc1 = dhexp_of_uexp(m, e1); - let+ dc2 = dhexp_of_uexp(m, e2); - DHExp.Cons(dc1, dc2); - | ListConcat(e1, e2) => - let* dc1 = dhexp_of_uexp(m, e1); - let+ dc2 = dhexp_of_uexp(m, e2); - DHExp.ListConcat(dc1, dc2); - | UnOp(Meta(Unquote), e) => - switch (e.term) { - | Var("e") when in_filter => - Some(Constructor("$e", Unknown(Internal))) - | Var("v") when in_filter => - Some(Constructor("$v", Unknown(Internal))) - | _ => Some(DHExp.EmptyHole(id, 0)) - } - | UnOp(Int(Minus), e) => - let+ dc = dhexp_of_uexp(m, e); - DHExp.BinIntOp(Minus, IntLit(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)), - ]; - let d = DHExp.ConsistentCase(DHExp.Case(d_scrut, d_rules, 0)); - /* Manually construct cast (case is not otherwise cast) */ - switch (mode) { - | Ana(ana_ty) => DHExp.cast(d, Bool, ana_ty) - | _ => d +/* 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.] + + 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. + + 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. */ +let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { + let (elaborated_type, ctx, co_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(_) + | Undefined + | EmptyHole => uexp |> cast_from(Typ.temp(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 + |> cast_from(Typ.temp(Typ.Unknown(Internal))) + ) + | DynamicErrorHole(e, err) => + let (e', _) = elaborate(m, e); + DynamicErrorHole(e', err) + |> rewrap + |> 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.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.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.temp); + | Constructor(c, _) => + let mode = + switch (Id.Map.find_opt(Exp.rep_id(uexp), m)) { + | Some(Info.InfoExp({mode, _})) => mode + | _ => raise(MissingTypeInfo) }; - | 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); - | 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); - | Test(test) => - let+ dtest = dhexp_of_uexp(m, test); - DHExp.Test(id, dtest); - | 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); - | Var(name) => - switch (err_status) { - | InHole(FreeVariable(_)) => Some(FreeVar(id, 0, name)) - | _ => Some(BoundVar(name)) - } - | Constructor(name) => - switch (err_status) { - | InHole(Common(NoType(FreeConstructor(_)))) => - Some(FreeVar(id, 0, name)) - | _ => - let ty = - switch (Ctx.lookup_ctr(ctx, name)) { - | None => Typ.Unknown(Internal) - | Some({typ, _}) => Typ.normalize(ctx, typ) - }; - switch (mode) { - | Ana(ana_ty) => - Some(Constructor(name, Typ.normalize(ctx, ana_ty))) - | _ => Some(Constructor(name, ty)) + 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 + }; + let t = t |> Typ.normalize(ctx); + Constructor(c, t) |> rewrap |> cast_from(t); + | 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.temp); + | TypFun(tpat, e, name) => + let (e', tye) = elaborate(m, e); + Exp.TypFun(tpat, e', name) + |> rewrap + |> 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.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.temp(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 + | TypFun(tpat, e, _) => TypFun(tpat, e, name) |> rewrap + | _ => exp }; } - | 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) - | TypFun(tpat, e, _) => DHExp.TypFun(tpat, e, name) - | d => d + ); + let (p, ty1) = elaborate_pattern(m, p); + let is_recursive = + Statics.is_recursive(ctx, p, def, ty1) + && Pat.get_bindings(p) + |> Option.get + |> List.exists(f => VarMap.lookup(co_ctx, f) != None); + if (!is_recursive) { + let def = add_name(Pat.get_var(p), def); + 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); + } 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 (def, ty2) = elaborate(m, def); + let (body, ty) = elaborate(m, body); + 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) => + 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(typ); + | 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 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) => + 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.temp, tyf2) |> Typ.temp, ); - 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); - let is_recursive = - Statics.is_recursive(ctx, p, def, ty) - && Term.UPat.get_bindings(p) - |> Option.get - |> List.exists(f => VarMap.lookup(co_ctx, f) != None); - if (!is_recursive) { - /* not recursive */ - DHExp.Let( - dp, - add_name(Term.UPat.get_var(p), ddef), - dbody, - ); - } else { - let ty = Typ.normalize(ctx, ty); - switch (Term.UPat.get_bindings(p) |> Option.get) { - | [f] => - /* simple recursion */ - Let(dp, FixF(f, ty, add_name(Some(f ++ "+"), ddef)), dbody) - | fs => - /* mutual recursion */ - let ddef = - switch (ddef) { - | Tuple(a) => - DHExp.Tuple( - List.map2(s => add_name(Some(s ++ "+")), fs, a), - ) - | _ => ddef - }; - 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 (_, substituted_def) = - fs - |> List.fold_left( - ((i, ddef), f) => { - let ddef = - Substitution.subst_var( - DHExp.Prj(self_var, i), - f, - ddef, - ); - (i + 1, ddef); - }, - (0, ddef), - ); - Let(dp, FixF(self_id, ty, substituted_def), dbody); - }; - }; - | 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); - | TypAp(fn, uty_arg) => - let+ d_fn = dhexp_of_uexp(m, fn); - DHExp.TypAp(d_fn, Term.UTyp.to_typ(ctx, uty_arg)); - | DeferredAp(fn, args) => - switch (err_status) { - | InHole(BadPartialAp(NoDeferredArgs)) => dhexp_of_uexp(m, fn) - | InHole(BadPartialAp(ArityMismatch(_))) => - Some(DHExp.InvalidText(id, 0, "")) - | _ => - let mk_tuple = (ctor, xs) => - List.length(xs) == 1 ? List.hd(xs) : ctor(xs); - let* ty_fn = fixed_exp_typ(m, fn); - 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: Term.UExp.t, ty)) => - if (Term.UExp.is_deferral(e)) { - // Internal variable name for deferrals - let name = - "__deferred__" ++ string_of_int(List.length(pats)); - let var: Term.UExp.t = {ids: e.ids, term: Var(name)}; - let var_entry = - Ctx.VarEntry({ - name, - id: Term.UExp.rep_id(e), - typ: ty, - }); - ( - pats @ [DHPat.Var(name)], - ty_args @ [ty], - ap_args @ [var], - Ctx.extend(ap_ctx, var_entry), - ); - } else { - (pats, ty_args, ap_args @ [e], ap_ctx); - }, - ([], [], [], ctx), - ); - let (pat, ty_arg) = ( - mk_tuple(x => DHPat.Tuple(x), pats), - mk_tuple(x => Typ.Prod(x), ty_args), - ); - let arg: Term.UExp.t = {ids: [Id.mk()], term: Tuple(ap_args)}; - let body: Term.UExp.t = {ids: [Id.mk()], term: Ap(fn, arg)}; - let (_info, m) = - Statics.uexp_to_info_map( - ~ctx=ap_ctx, - ~mode=Ana(ty_ret), - ~ancestors, - body, - m, - ); - let+ dbody = dhexp_of_uexp(m, body); - DHExp.Fun(pat, Arrow(ty_arg, ty_ret), dbody, None); - } - | 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(_)))) => - DHExp.IfThenElse(DH.InconsistentIf, c', d1, d2) - | _ => DHExp.IfThenElse(DH.ConsistentIf, c', d1, d2) - }; - | Match(scrut, rules) => - let* d_scrut = dhexp_of_uexp(m, scrut); - let+ d_rules = - List.map( - ((p, e)) => { - let* d_p = dhpat_of_upat(m, p); - let+ d_e = dhexp_of_uexp(m, e); - DHExp.Rule(d_p, d_e); - }, - rules, - ) - |> OptUtil.sequence; - let d = DHExp.Case(d_scrut, d_rules, 0); - switch (err_status) { - | InHole(Common(Inconsistent(Internal(_)))) - | InHole(InexhaustiveMatch(Some(Inconsistent(Internal(_))))) => - DHExp.InconsistentBranches(id, 0, d) - | _ => ConsistentCase(d) + 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.temp; + DeferredAp(f'', args'') + |> rewrap + |> 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); + 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); + let (f', tyf) = elaborate(m, f); + let ty = + Typ.join(~fix=false, ctx, tyt, tyf) + |> 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); + | 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.temp)) + |> rewrap + |> cast_from(Prod([]) |> Typ.temp); + | 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}) }; - | 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 - }; -} -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, _})) => - // NOTE: for the current implementation, redundancy is considered a static error - // but not a runtime error. - let self = - switch (self) { - | Redundant(self) => self - | _ => self - }; - 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)) - }; - switch (upat.term) { - | Invalid(t) => Some(DHPat.InvalidText(u, 0, t)) - | EmptyHole => Some(EmptyHole(u, 0)) - | MultiHole(_) => - // 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)) - | Triv => wrap(Tuple([])) - | 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)); - | Constructor(name) => - switch (err_status) { - | InHole(Common(NoType(FreeConstructor(_)))) => - Some(BadConstructor(u, 0, name)) + 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.temp(Unknown(Internal))); + let e1'' = fresh_cast(e1', ty1, ty_inner); + 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); + 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.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.temp); + | UnOp(Meta(Unquote), e) => + switch (e.term) { + // TODO: confirm whether these types are correct + | Var("e") => + Constructor("$e", Unknown(Internal) |> Typ.temp) |> rewrap + | Var("v") => + Constructor("$v", Unknown(Internal) |> Typ.temp) |> rewrap | _ => - let ty = - switch (Ctx.lookup_ctr(ctx, name)) { - | None => Typ.Unknown(Internal) - | Some({typ, _}) => Typ.normalize(ctx, typ) - }; - let dc = - switch (mode) { - | Ana(ana_ty) => - DHPat.Constructor(name, Typ.normalize(ctx, ana_ty)) - | _ => DHPat.Constructor(name, ty) - }; - wrap(dc); + DHExp.EmptyHole + |> rewrap + |> cast_from(Typ.temp(Typ.Unknown(Internal))) } - | 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)); - | Tuple(ps) => - let* ds = ps |> List.map(dhpat_of_upat(m)) |> OptUtil.sequence; - wrap(DHPat.Tuple(ds)); - | Var(name) => Some(Var(name)) - | 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)); - | TypeAnn(p, _ty) => - let* dp = dhpat_of_upat(m, p); - wrap(dp); + | UnOp(Int(Minus), e) => + let (e', t) = elaborate(m, e); + UnOp(Int(Minus), fresh_cast(e', t, Int |> Typ.temp)) + |> rewrap + |> cast_from(Int |> Typ.temp); + | UnOp(Bool(Not), e) => + let (e', t) = elaborate(m, e); + UnOp(Bool(Not), fresh_cast(e', t, Bool |> Typ.temp)) + |> rewrap + |> 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.temp), + fresh_cast(e2', t2, Int |> Typ.temp), + ) + |> rewrap + |> cast_from(Int |> Typ.temp); + | 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.temp), + fresh_cast(e2', t2, Int |> Typ.temp), + ) + |> rewrap + |> 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.temp), + fresh_cast(e2', t2, Bool |> Typ.temp), + ) + |> rewrap + |> 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.temp), + fresh_cast(e2', t2, Float |> Typ.temp), + ) + |> rewrap + |> cast_from(Float |> Typ.temp); + | 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.temp), + fresh_cast(e2', t2, Float |> Typ.temp), + ) + |> rewrap + |> 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.temp), + fresh_cast(e2', t2, String |> Typ.temp), + ) + |> rewrap + |> 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.temp), + fresh_cast(e2', t2, String |> Typ.temp), + ) + |> rewrap + |> 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.temp(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.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.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'')) + |> rewrap + |> cast_from(joined_ety); }; - | Some(InfoExp(_) | InfoTyp(_) | InfoTPat(_) | Secondary(_)) - | None => None - }; + (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: Term.UExp.t): ElaborationResult.t => - switch (dhexp_of_uexp(m, uexp, false)) { - | None => DoesNotElaborate - | Some(d) => - //let d = uexp_elab_wrap_builtins(d); - let ty = - switch (fixed_exp_typ(m, uexp)) { - | Some(ty) => ty - | None => Typ.Unknown(Internal) - }; - Elaborates(d, ty, Delta.empty); +/* 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 + | (d, ty) => Elaborates(d, ty, Delta.empty) }; 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/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/EvalCtx.re b/src/haz3lcore/dynamics/EvalCtx.re index b845ffe49b..bed931c8d3 100644 --- a/src/haz3lcore/dynamics/EvalCtx.re +++ b/src/haz3lcore/dynamics/EvalCtx.re @@ -1,263 +1,156 @@ open Util; -open DH; - -[@deriving (show({with_path: false}), sexp, yojson)] -type cls = - | Mark - | Closure - | FilterPattern - | Filter - | Sequence1 - | Sequence2 - | Let1 - | Let2 - | TypAp - | Ap1 - | Ap2 - | Fun - | FixF - | BinBoolOp1 - | BinBoolOp2 - | BinIntOp1 - | BinIntOp2 - | BinFloatOp1 - | BinFloatOp2 - | BinStringOp1 - | BinStringOp2 - | IfThenElse1 - | IfThenElse2 - | IfThenElse3 - | Tuple(int) - | ListLit(int) - | ApBuiltin - | Test - | Cons1 - | Cons2 - | ListConcat1 - | ListConcat2 - | Prj - | NonEmptyHole - | Cast - | FailedCast - | InvalidOperation - | ConsistentCase - | ConsistentCaseRule(int) - | InconsistentBranches - | InconsistentBranchesRule(int) - | FailedCastCast - // Used when entering a bound variable expression in substitution mode - | BoundVar; - [@deriving (show({with_path: false}), sexp, yojson)] -type t = - | Mark +type term = | Closure([@show.opaque] ClosureEnvironment.t, t) - | Filter(DH.DHFilter.t, t) - | Sequence1(t, DHExp.t) - | Sequence2(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) + | Filter(TermBase.StepperFilterKind.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)) | TypAp(t, Typ.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) + | 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) + | 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))) - | ApBuiltin(string, t) - | Test(KeywordID.t, t) - | ListLit( - MetaVar.t, - MetaVarInst.t, - Typ.t, - t, - (list(DHExp.t), list(DHExp.t)), - ) + | Test(t) + | ListLit(t, (list(DHExp.t), list(DHExp.t))) + | MultiHole(t, (list(Any.t), list(Any.t))) | Cons1(t, DHExp.t) | 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) - | InvalidOperation(t, InvalidOperationError.t) - | ConsistentCase(case) - | ConsistentCaseRule( - DHExp.t, - DHPat.t, - t, - (list(DHExp.rule), list(DHExp.rule)), - int, - ) - | InconsistentBranches(MetaVar.t, HoleInstanceId.t, case) - | InconsistentBranchesRule( + | DynamicErrorHole(t, InvalidOperationError.t) + | MatchScrut(t, list((UPat.t, DHExp.t))) + | MatchRule( DHExp.t, - MetaVar.t, - HoleInstanceId.t, - DHPat.t, + UPat.t, t, - (list(DHExp.rule), list(DHExp.rule)), - int, + (list((UPat.t, DHExp.t)), list((UPat.t, DHExp.t))), ) -and case = - | Case(t, list(rule), int) -and rule = DHExp.rule; - -let rec fuzzy_mark = - fun - | Mark => true - | Closure(_, x) - | Test(_, x) - | Cast(x, _, _) - | FailedCast(x, _, _) - | Filter(_, x) => fuzzy_mark(x) - | Sequence1(_) - | Sequence2(_) - | Let1(_) - | Let2(_) - | Fun(_) - | FixF(_) - | TypAp(_) - | Ap1(_) - | Ap2(_) - | IfThenElse1(_) - | IfThenElse2(_) - | IfThenElse3(_) - | BinBoolOp1(_) - | BinBoolOp2(_) - | BinIntOp1(_) - | BinIntOp2(_) - | BinFloatOp1(_) - | BinFloatOp2(_) - | BinStringOp1(_) - | BinStringOp2(_) - | Tuple(_) - | ApBuiltin(_) - | ListLit(_) - | Cons1(_) - | Cons2(_) - | ListConcat1(_) - | ListConcat2(_) - | Prj(_) - | NonEmptyHole(_) - | InvalidOperation(_) - | ConsistentCase(_) - | ConsistentCaseRule(_) - | InconsistentBranches(_) - | InconsistentBranchesRule(_) => false; +and t = + | Mark + | Term({ + term, + ids: list(Id.t), + }); -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)), +let rec compose = (ctx: t, d: DHExp.t): DHExp.t => { + 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; + | 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; + | If2(d1, ctx, d3) => + let d' = compose(ctx, d); + If(d1, d', d3) |> wrap; + | If3(d1, d2, ctx) => + let d' = compose(ctx, d); + If(d1, d2, d') |> wrap; + | Test(ctx) => + let d1 = compose(ctx, d); + Test(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; + | 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(ctx, (ld, rd)) => + let d = compose(ctx, d); + ListLit(ListUtil.rev_concat(ld, [d, ...rd])) |> wrap; + | MultiHole(ctx, (ld, rd)) => + let d = compose(ctx, d); + 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; + | Let2(dp, d1, ctx) => + let d = compose(ctx, d); + Let(dp, d1, d) |> wrap; + | Fun(dp, ctx, env, v) => + let d = compose(ctx, d); + Fun(dp, d, env, v) |> wrap; + | FixF(v, ctx, env) => + let d = compose(ctx, d); + FixF(v, d, env) |> 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; + | DynamicErrorHole(ctx, err) => + let d = compose(ctx, d); + DynamicErrorHole(d, err) |> wrap; + | MatchScrut(ctx, rules) => + let d = compose(ctx, d); + Match(d, rules) |> wrap; + | 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; + } ); - raise(EvaluatorError.Exception(StepDoesNotMatch)); - | (BoundVar, c) - | (NonEmptyHole, NonEmptyHole(_, _, _, c)) - | (Closure, Closure(_, c)) - | (Filter, Filter(_, c)) - | (Sequence1, Sequence1(c, _)) - | (Sequence2, Sequence2(_, c)) - | (Let1, Let1(_, c, _)) - | (Let2, Let2(_, _, c)) - | (Fun, Fun(_, _, c, _)) - | (FixF, FixF(_, _, c)) - | (TypAp, TypAp(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)) - | (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; - } - | (ConsistentCaseRule(n), ConsistentCaseRule(_, _, c, (ld, _), _)) - | ( - InconsistentBranchesRule(n), - InconsistentBranchesRule(_, _, _, _, 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) - | (Ap1, Ap2(_, _)) - | (Ap2, Ap1(_, _)) - | (IfThenElse1, IfThenElse2(_)) - | (IfThenElse1, IfThenElse3(_)) - | (IfThenElse2, IfThenElse1(_)) - | (IfThenElse2, IfThenElse3(_)) - | (IfThenElse3, IfThenElse1(_)) - | (IfThenElse3, IfThenElse2(_)) - | (Let1, Let2(_)) - | (Let2, Let1(_)) - | (BinBoolOp1, BinBoolOp2(_)) - | (BinBoolOp2, BinBoolOp1(_)) - | (BinIntOp1, BinIntOp2(_)) - | (BinIntOp2, BinIntOp1(_)) - | (BinFloatOp1, BinFloatOp2(_)) - | (BinFloatOp2, BinFloatOp1(_)) - | (BinStringOp1, BinStringOp2(_)) - | (BinStringOp2, BinStringOp1(_)) - | (Cons1, Cons2(_)) - | (Cons2, Cons1(_)) - | (Sequence1, Sequence2(_)) - | (Sequence2, Sequence1(_)) - | (ListConcat1, ListConcat2(_)) - | (ListConcat2, ListConcat1(_)) => None - | (FilterPattern, _) => 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/Evaluator.re b/src/haz3lcore/dynamics/Evaluator.re index 5395627ff3..fb877accd7 100644 --- a/src/haz3lcore/dynamics/Evaluator.re +++ b/src/haz3lcore/dynamics/Evaluator.re @@ -1,17 +1,43 @@ -open EvaluatorResult; open Transition; -module EvaluatorEVMode: { - type result_unfinished = +module Result = { + [@deriving (show({with_path: false}), sexp, yojson)] + type t = | BoxedValue(DHExp.t) - | Indet(DHExp.t) - | Uneval(DHExp.t); - let unbox: result_unfinished => 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 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 @@ -34,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) => @@ -65,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) => @@ -79,20 +92,33 @@ 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)); 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); @@ -100,21 +126,21 @@ 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) }; }; -let evaluate = (env, d): (EvaluatorState.t, EvaluatorResult.t) => { +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 = 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/Evaluator.rei b/src/haz3lcore/dynamics/Evaluator.rei deleted file mode 100644 index 0589b7fe3f..0000000000 --- a/src/haz3lcore/dynamics/Evaluator.rei +++ /dev/null @@ -1,34 +0,0 @@ -/** - // 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: - (Environment.t, DHExp.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/EvaluatorError.re b/src/haz3lcore/dynamics/EvaluatorError.re index db60bdfba7..1ae23a7e7a 100644 --- a/src/haz3lcore/dynamics/EvaluatorError.re +++ b/src/haz3lcore/dynamics/EvaluatorError.re @@ -4,7 +4,6 @@ open Util; type t = | OutOfFuel | StepDoesNotMatch - | FreeInvalidVar(Var.t) | BadPatternMatch | CastBVHoleGround(DHExp.t) | InvalidBoxedTypFun(DHExp.t) @@ -14,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 deleted file mode 100644 index 4fc4e59dde..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) - | InvalidBoxedTypFun(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(DHExp.t)) - | InvalidProjection(int); - -[@deriving (show({with_path: false}), sexp, yojson)] -exception Exception(t); diff --git a/src/haz3lcore/dynamics/EvaluatorPost.re b/src/haz3lcore/dynamics/EvaluatorPost.re deleted file mode 100644 index 3dfeb258c0..0000000000 --- a/src/haz3lcore/dynamics/EvaluatorPost.re +++ /dev/null @@ -1,623 +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 (show({with_path: false}), sexp, yojson)] -type error = - | ClosureInsideClosure - | FixFOutsideClosureEnv - | UnevalOutsideClosure - | InvalidClosureBody - | PostprocessedNonHoleInClosure - | PostprocessedHoleOutsideClosure; - -[@deriving (show({with_path: false}), sexp, yojson)] -exception Exception(error); - -/** - Postprocess inside evaluation boundary. - */ -let rec pp_eval = (d: DHExp.t): m(DHExp.t) => - switch (d) { - /* Non-hole expressions: recurse through subexpressions */ - | Test(_) - | BoolLit(_) - | IntLit(_) - | FloatLit(_) - | StringLit(_) - | Undefined - | Constructor(_) => d |> return - - | Sequence(d1, d2) => - let* d1' = pp_eval(d1); - let+ d2' = pp_eval(d2); - Sequence(d1', d2'); - - | Filter(f, dbody) => - let+ dbody' = pp_eval(dbody); - Filter(f, dbody'); - - | Ap(d1, d2) => - let* d1' = pp_eval(d1); - let* d2' = pp_eval(d2); - Ap(d1', d2') |> return; - - | TypAp(d1, ty) => - let* d1' = pp_eval(d1); - TypAp(d1', ty) |> return; - - | ApBuiltin(f, d1) => - let* d1' = pp_eval(d1); - ApBuiltin(f, d1') |> return; - - | BinBoolOp(op, d1, d2) => - let* d1' = pp_eval(d1); - let* d2' = pp_eval(d2); - BinBoolOp(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); - Cons(d1', d2') |> return; - - | ListConcat(d1, d2) => - let* d1' = pp_eval(d1); - let* d2' = pp_eval(d2); - ListConcat(d1', d2') |> 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); - - | Tuple(ds) => - let+ ds = - ds - |> List.fold_left( - (ds, d) => { - let* ds = ds; - let+ d = pp_eval(d); - ds @ [d]; - }, - return([]), - ); - Tuple(ds); - - | Prj(d, n) => - let+ d = pp_eval(d); - Prj(d, n); - - | Cast(d', ty1, ty2) => - let* d'' = pp_eval(d'); - Cast(d'', ty1, ty2) |> return; - - | FailedCast(d', ty1, ty2) => - let* d'' = pp_eval(d'); - FailedCast(d'', ty1, ty2) |> return; - - | InvalidOperation(d', reason) => - let* d'' = pp_eval(d'); - InvalidOperation(d'', reason) |> return; - - | IfThenElse(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; - - /* These expression forms should not exist outside closure in evaluated result */ - | BoundVar(_) - | Let(_) - | ConsistentCase(_) - | Fun(_) - | TypFun(_) - | EmptyHole(_) - | NonEmptyHole(_) - | FreeVar(_) - | InvalidText(_) - | InconsistentBranches(_) => 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. - */ - | Closure(env, d) => - let* env = - Util.TimeUtil.measure_time("pp_eval_env/Closure", true, () => - pp_eval_env(env) - ); - switch (d) { - /* Non-hole constructs inside closures. */ - | Fun(dp, ty, d, s) => - let* d = pp_uneval(env, d); - Fun(dp, ty, d, s) |> return; - - | TypFun(tpat, d1, s) => - let* d1' = pp_uneval(env, d1); - TypFun(tpat, d1', 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; - - | ConsistentCase(Case(scrut, rules, i)) => - /* 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) - ); - ConsistentCase(Case(scrut, rules, i)) |> 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)) |> return; - - | InconsistentBranches(u, _, Case(scrut, rules, case_i)) => - let* scrut = pp_eval(scrut); - let* i = hii_add_instance(u, env); - Closure(env, InconsistentBranches(u, i, Case(scrut, rules, case_i))) - |> return; - - | EmptyHole(_) - | 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' = - switch (d) { - | FixF(f, ty, d1) => - let+ d1 = pp_uneval(env', d1); - FixF(f, ty, d1); - | d => 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) => - switch (d) { - /* Bound variables should be looked up within the closure - environment. If lookup fails, then variable is not bound. */ - | BoundVar(x) => - switch (ClosureEnvironment.lookup(env, x)) { - | Some(d') => d' |> return - | None => d |> return - } - - /* Non-hole expressions: expand recursively */ - | BoolLit(_) - | IntLit(_) - | FloatLit(_) - | StringLit(_) - | Undefined - | Constructor(_) => d |> return - - | Test(id, d1) => - let+ d1' = pp_uneval(env, d1); - Test(id, d1'); - - | Sequence(d1, d2) => - let* d1' = pp_uneval(env, d1); - let+ d2' = pp_uneval(env, d2); - Sequence(d1', d2'); - - | Filter(flt, dbody) => - let+ dbody' = pp_uneval(env, dbody); - Filter(flt, dbody'); - | Let(dp, d1, d2) => - let* d1' = pp_uneval(env, d1); - let* d2' = pp_uneval(env, d2); - Let(dp, d1', d2') |> return; - - | FixF(f, ty, d1) => - let* d1' = pp_uneval(env, d1); - FixF(f, ty, d1') |> return; - - | Fun(dp, ty, d', s) => - let* d'' = pp_uneval(env, d'); - Fun(dp, ty, d'', s) |> return; - - | TypFun(tpat, d1, s) => - let* d1' = pp_uneval(env, d1); - TypFun(tpat, d1', s) |> return; - - | Ap(d1, d2) => - let* d1' = pp_uneval(env, d1); - let* d2' = pp_uneval(env, d2); - Ap(d1', d2') |> return; - - | TypAp(d1, ty) => - let* d1' = pp_uneval(env, d1); - TypAp(d1', ty) |> return; - - | ApBuiltin(f, d1) => - let* d1' = pp_uneval(env, d1); - 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) => - let* d1' = pp_uneval(env, d1); - let* d2' = pp_uneval(env, d2); - BinStringOp(op, d1', d2') |> return; - - | IfThenElse(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; - - | Cons(d1, d2) => - let* d1' = pp_uneval(env, d1); - let* d2' = pp_uneval(env, d2); - Cons(d1', d2') |> return; - - | ListConcat(d1, d2) => - let* d1' = pp_uneval(env, d1); - let* d2' = pp_uneval(env, d2); - ListConcat(d1', d2') |> 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); - - | Tuple(ds) => - let+ ds = - ds - |> List.fold_left( - (ds, d) => { - let* ds = ds; - let+ d = pp_uneval(env, d); - ds @ [d]; - }, - return([]), - ); - Tuple(ds); - - | Prj(d, n) => - let+ d = pp_uneval(env, d); - Prj(d, n); - - | Cast(d', ty1, ty2) => - let* d'' = pp_uneval(env, d'); - Cast(d'', ty1, ty2) |> return; - - | FailedCast(d', ty1, ty2) => - let* d'' = pp_uneval(env, d'); - FailedCast(d'', ty1, ty2) |> return; - - | InvalidOperation(d', reason) => - let* d'' = pp_uneval(env, d'); - InvalidOperation(d'', reason) |> return; - - | ConsistentCase(Case(scrut, rules, i)) => - let* scrut' = pp_uneval(env, scrut); - let* rules' = pp_uneval_rules(env, rules); - ConsistentCase(Case(scrut', rules', i)) |> return; - - /* Closures shouldn't exist inside other closures */ - | 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)) |> 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; - - | FreeVar(u, _, x) => - let* i = hii_add_instance(u, env); - Closure(env, FreeVar(u, i, x)) |> return; - - | InvalidText(u, _, text) => - let* i = hii_add_instance(u, env); - Closure(env, InvalidText(u, i, text)) |> return; - - | InconsistentBranches(u, _, Case(scrut, rules, case_i)) => - 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; - } - -and pp_uneval_rules = - (env: ClosureEnvironment.t, rules: list(DHExp.rule)) - : m(list(DHExp.rule)) => { - rules - |> List.map((Rule(dp, d)) => { - let* d' = pp_uneval(env, d); - Rule(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 (d) { - | Constructor(_) - | BoolLit(_) - | IntLit(_) - | FloatLit(_) - | StringLit(_) - | BuiltinFun(_) - | Undefined - | BoundVar(_) => hii - | Test(_, d) - | FixF(_, _, d) - | Fun(_, _, d, _) - | TypFun(_, d, _) - | TypAp(d, _) - | Prj(d, _) - | Cast(d, _, _) - | FailedCast(d, _, _) - | InvalidOperation(d, _) => track_children_of_hole(hii, parent, d) - | Sequence(d1, d2) - | Let(_, d1, d2) - | Ap(d1, d2) - | BinBoolOp(_, d1, d2) - | BinIntOp(_, d1, d2) - | BinFloatOp(_, d1, d2) - | BinStringOp(_, 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, - ) - | IfThenElse(_, 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); - - | ConsistentCase(Case(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); - | InconsistentBranches(u, i, Case(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) - | 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(DHExp.rule), - ) - : HoleInstanceInfo.t => - List.fold_right( - (DHExp.Rule(_, 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 67cd0438a9..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 (show({with_path: false}), sexp, yojson)] -type error = - | ClosureInsideClosure - | FixFOutsideClosureEnv - | UnevalOutsideClosure - | InvalidClosureBody - | PostprocessedNonHoleInClosure - | PostprocessedHoleOutsideClosure; - -[@deriving (show({with_path: false}), sexp, yojson)] -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/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 e699190314..916ac0586b 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/EvaluatorStep.re b/src/haz3lcore/dynamics/EvaluatorStep.re index 4545167b8d..f25f25603f 100644 --- a/src/haz3lcore/dynamics/EvaluatorStep.re +++ b/src/haz3lcore/dynamics/EvaluatorStep.re @@ -5,17 +5,11 @@ 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, }; -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 = { @@ -59,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; @@ -111,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, []) @@ -133,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 }; @@ -172,9 +179,13 @@ 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()) + | Step({expr, state_update, _}) => + state_update(); + Some(expr); | Constructor | Indet => None }; @@ -195,147 +206,7 @@ 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); - | Filter(flt, ctx) => - let d = compose(ctx, d); - Filter(flt, d); - | Sequence1(ctx, d2) => - let d1 = compose(ctx, d); - Sequence(d1, d2); - | Sequence2(d1, ctx) => - let d2 = compose(ctx, d); - Sequence(d1, d2); - | TypAp(ctx, typ) => - let d1 = compose(ctx, d); - TypAp(d1, typ); - | Ap1(ctx, d2) => - let d1 = compose(ctx, d); - Ap(d1, d2); - | Ap2(d1, ctx) => - let d2 = compose(ctx, d); - Ap(d1, d2); - | ApBuiltin(s, ctx) => - let d' = compose(ctx, d); - ApBuiltin(s, d'); - | IfThenElse1(c, ctx, d2, d3) => - let d' = compose(ctx, d); - IfThenElse(c, d', d2, d3); - | IfThenElse2(c, d1, ctx, d3) => - let d' = compose(ctx, d); - IfThenElse(c, d1, d', d3); - | IfThenElse3(c, d1, d2, ctx) => - let d' = compose(ctx, d); - IfThenElse(c, d1, d2, d'); - | Test(lit, ctx) => - let d1 = compose(ctx, d); - Test(lit, d1); - | BinBoolOp1(op, ctx, d2) => - let d1 = compose(ctx, d); - BinBoolOp(op, d1, d2); - | BinBoolOp2(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); - | Cons1(ctx, d2) => - let d1 = compose(ctx, d); - Cons(d1, d2); - | Cons2(d1, ctx) => - let d2 = compose(ctx, d); - Cons(d1, d2); - | ListConcat1(ctx, d2) => - let d1 = compose(ctx, d); - ListConcat(d1, d2); - | ListConcat2(d1, ctx) => - let d2 = compose(ctx, d); - ListConcat(d1, d2); - | Tuple(ctx, (ld, rd)) => - let d = compose(ctx, d); - Tuple(rev_concat(ld, [d, ...rd])); - | ListLit(m, i, t, ctx, (ld, rd)) => - let d = compose(ctx, d); - ListLit(m, i, t, rev_concat(ld, [d, ...rd])); - | Let1(dp, ctx, d2) => - let d = compose(ctx, d); - Let(dp, d, d2); - | Let2(dp, d1, ctx) => - let d = compose(ctx, d); - Let(dp, d1, d); - | Fun(dp, t, ctx, v) => - let d = compose(ctx, d); - Fun(dp, t, d, v); - | FixF(v, t, ctx) => - let d = compose(ctx, d); - FixF(v, t, d); - | Prj(ctx, n) => - let d = compose(ctx, d); - Prj(d, n); - | Cast(ctx, ty1, ty2) => - let d = compose(ctx, d); - Cast(d, ty1, ty2); - | FailedCast(ctx, ty1, ty2) => - let d = compose(ctx, d); - FailedCast(d, ty1, ty2); - | InvalidOperation(ctx, err) => - let d = compose(ctx, d); - InvalidOperation(d, err); - | NonEmptyHole(reason, u, i, ctx) => - let d = compose(ctx, d); - NonEmptyHole(reason, u, i, d); - | ConsistentCase(Case(ctx, rule, n)) => - let d = compose(ctx, d); - ConsistentCase(Case(d, rule, n)); - | ConsistentCaseRule(scr, p, ctx, (lr, rr), n) => - 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), - ); - } - ); -}; - -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); @@ -351,158 +222,165 @@ 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) = switch (ctx) { - | Filter(_, _) => (pact, pidx) + | Term({term: Filter(_, _), _}) => (pact, pidx) | _ => midx > pidx ? (mact, midx) : (pact, pidx) }; let map = ((a, i, c), f: EvalCtx.t => EvalCtx.t) => { (a, i, f(c)); }; let (let+) = map; - let (ract, ridx, rctx) = + let (ract, ridx, rctx) = { + let wrap_ids = (ids, ctx) => EvalCtx.Term({term: ctx, ids}); 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) = - if (idx > idx') { - matches(env, flt, ctx, exp, act, idx); + | Term({term, ids}) => + switch (term) { + | Closure(env, ctx) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Closure(env, ctx) |> wrap_ids(ids); + | Filter(Filter(flt'), ctx) => + let flt = flt |> FilterEnvironment.extends(flt'); + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Filter(Filter(flt'), ctx) |> wrap_ids(ids); + | Filter(Residue(idx', act'), ctx) => + let (ract, ridx, rctx) = + if (idx > idx') { + matches(env, flt, ctx, exp, act, idx); + } else { + matches(env, flt, ctx, exp, act', idx'); + }; + if (act' |> snd == All) { + ( + ract, + ridx, + Term({ + term: Filter(Residue(idx', act'), rctx), + ids: [Id.mk()], + }), + ); } else { - matches(env, flt, ctx, exp, act', idx'); + (ract, ridx, rctx); }; - if (act' |> snd == All) { - (ract, ridx, Filter(Residue(idx', act'), rctx)); - } else { - (ract, ridx, rctx); - }; - | Sequence1(ctx, d2) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Sequence1(ctx, d2); - | Sequence2(d1, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Sequence2(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, name) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Fun(dp, ty, ctx, name); - | FixF(name, ty, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - FixF(name, ty, ctx); - | Ap1(ctx, d2) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Ap1(ctx, d2); - | Ap2(d1, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Ap2(d1, ctx); - | IfThenElse1(c, ctx, d2, d3) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - IfThenElse1(c, ctx, d2, d3); - | IfThenElse2(c, d1, ctx, d3) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - IfThenElse2(c, d1, ctx, d3); - | IfThenElse3(c, d1, d2, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - IfThenElse3(c, d1, d2, ctx); - | BinBoolOp1(op, ctx, d1) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - BinBoolOp1(op, ctx, d1); - | BinBoolOp2(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); - | 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); - | ConsistentCase(Case(ctx, rs, i)) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - ConsistentCase(Case(ctx, rs, i)); - | ConsistentCaseRule(dexp, dpat, ctx, rs, i) => - 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); - | TypAp(ctx, ty) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - TypAp(ctx, ty); + | Seq1(ctx, d2) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Seq1(ctx, d2) |> wrap_ids(ids); + | Seq2(d1, ctx) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Seq2(d1, ctx) |> wrap_ids(ids); + | Let1(d1, ctx, d3) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Let1(d1, ctx, d3) |> wrap_ids(ids); + | Let2(d1, d2, ctx) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Let2(d1, d2, ctx) |> wrap_ids(ids); + | Fun(dp, ctx, env', name) => + let+ ctx = + matches( + env' |> Option.value(~default=env), + flt, + ctx, + exp, + act, + idx, + ); + Fun(dp, ctx, env', name) |> wrap_ids(ids); + | FixF(name, ctx, env') => + let+ ctx = + matches( + env' |> Option.value(~default=env), + flt, + ctx, + exp, + act, + idx, + ); + FixF(name, ctx, env') |> wrap_ids(ids); + | Ap1(dir, ctx, d2) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Ap1(dir, ctx, d2) |> wrap_ids(ids); + | Ap2(dir, d1, ctx) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Ap2(dir, d1, ctx) |> wrap_ids(ids); + | If1(ctx, d2, d3) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + If1(ctx, d2, d3) |> wrap_ids(ids); + | If2(d1, ctx, d3) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + If2(d1, ctx, d3) |> wrap_ids(ids); + | If3(d1, d2, ctx) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + If3(d1, d2, ctx) |> wrap_ids(ids); + | BinOp1(op, ctx, d1) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + BinOp1(op, ctx, d1) |> wrap_ids(ids); + | BinOp2(op, d1, ctx) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + BinOp2(op, d1, ctx) |> wrap_ids(ids); + | Test(ctx) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Test(ctx) |> wrap_ids(ids); + | ListLit(ctx, ds) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + ListLit(ctx, ds) |> wrap_ids(ids); + | Tuple(ctx, ds) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Tuple(ctx, ds) |> wrap_ids(ids); + | MultiHole(ctx, ds) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + MultiHole(ctx, ds) |> wrap_ids(ids); + | Cons1(ctx, d2) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Cons1(ctx, d2) |> wrap_ids(ids); + | Cons2(d1, ctx) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Cons2(d1, ctx) |> wrap_ids(ids); + | ListConcat1(ctx, d2) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + ListConcat1(ctx, d2) |> wrap_ids(ids); + | ListConcat2(d1, ctx) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + ListConcat2(d1, ctx) |> wrap_ids(ids); + | Cast(ctx, ty, ty') => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Cast(ctx, ty, ty') |> wrap_ids(ids); + | FailedCast(ctx, ty, ty') => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + FailedCast(ctx, ty, ty') |> wrap_ids(ids); + | DynamicErrorHole(ctx, error) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + DynamicErrorHole(ctx, error) |> wrap_ids(ids); + | MatchScrut(ctx, rs) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + MatchScrut(ctx, rs) |> wrap_ids(ids); + | MatchRule(dexp, dpat, ctx, rs) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + MatchRule(dexp, dpat, ctx, rs) |> wrap_ids(ids); + | TypAp(ctx, ty) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + TypAp(ctx, ty) |> wrap_ids(ids); + | DeferredAp1(ctx, ds) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + DeferredAp1(ctx, ds) |> wrap_ids(ids); + | DeferredAp2(d1, ctx, ds) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + DeferredAp2(d1, ctx, ds) |> wrap_ids(ids); + | UnOp(op, ctx) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + UnOp(op, ctx) |> wrap_ids(ids); + } }; + }; switch (ctx) { - | Filter(_) => (ract, ridx, rctx) + | Term({term: Filter(_), _}) => (ract, ridx, rctx) | _ when 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) }; @@ -533,19 +411,19 @@ let should_hide_step = (~settings, x: step): (FilterAction.action, step) => }; }; -let decompose = (~settings, d) => - d |> decompose |> List.map(should_hide_eval_obj(~settings)); +let decompose = (~settings, d, st) => + decompose(d, st) |> List.map(should_hide_eval_obj(~settings)); let evaluate_with_history = (~settings, d) => { let state = ref(EvaluatorState.init); let rec go = d => - switch (decompose(~settings, d)) { + switch (decompose(~settings, d, state^)) { | [] => [] | [(_, x), ..._] => 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/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/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 cddffd2311..fc70d83756 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -11,33 +11,45 @@ let rec matches_exp = if (d == f) { true; } else { - switch (d, f) { + switch (d |> DHExp.term_of, f |> DHExp.term_of) { + | (Parens(d), _) => matches_exp(d, f) + | (_, Parens(f)) => matches_exp(d, 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, dt, dc), FixF(fp, ft, fc)) => + | (FixF(dp, dc, _), FixF(fp, fc, _)) => dp == fp - && dt == ft && matches_exp( - ~denv=denv |> ClosureEnvironment.without_keys([dp]), + ~denv= + denv |> ClosureEnvironment.without_keys(dp |> DHPat.bound_vars), dc, - ~fenv=fenv |> ClosureEnvironment.without_keys([fp]), + ~fenv= + fenv |> ClosureEnvironment.without_keys(fp |> DHPat.bound_vars), fc, ) - | (FixF(dp, _, dc), f) => - matches_exp(~denv=denv |> ClosureEnvironment.without_keys([dp]), dc, f) - | (d, FixF(fp, _, fc)) => - matches_exp(d, ~fenv=fenv |> ClosureEnvironment.without_keys([fp]), fc) + | (FixF(dp, dc, _), _) => + matches_exp( + ~denv=denv |> ClosureEnvironment.without_keys(DHPat.bound_vars(dp)), + dc, + f, + ) + | (_, FixF(fp, fc, _)) => + matches_exp( + d, + ~fenv=fenv |> ClosureEnvironment.without_keys(DHPat.bound_vars(fp)), + fc, + ) | (_, Constructor("$v", _)) => - switch (ValueChecker.check_value(denv, d)) { + switch (ValueChecker.check_value((), denv, d)) { | Indet | Value => true | Expr => false } - | (_, EmptyHole(_)) + | (_, EmptyHole) | (_, Constructor("$e", _)) => true | (Cast(d, _, _), Cast(f, _, _)) => matches_exp(d, f) @@ -53,101 +65,115 @@ let rec matches_exp = | (FailedCast(d, _, _), _) => matches_exp(d, f) | (Filter(Residue(_), d), _) => matches_exp(d, f) - | (BoundVar(dx), BoundVar(fx)) - when String.starts_with(dx, ~prefix="__mutual__") => + | (Var(dx), Var(fx)) when String.starts_with(dx, ~prefix="__mutual__") => String.starts_with(fx, ~prefix="__mutual__") && dx == fx - | (BoundVar(dx), BoundVar(fx)) => + | (Var(dx), Var(fx)) => switch ( - ClosureEnvironment.lookup(denv, dx), - ClosureEnvironment.lookup(fenv, fx), + ClosureEnvironment.lookup(denv, dx) |> Option.map(DHExp.term_of), + ClosureEnvironment.lookup(fenv, fx) |> Option.map(DHExp.term_of), ) { | ( - Some(Fun(_, _, Closure(denv, _), Some(dname)) as d), - Some(Fun(_, _, Closure(fenv, _), Some(fname)) as f), + Some(Fun(_, _, Some(denv), Some(dname)) as d), + Some(Fun(_, _, Some(fenv), Some(fname)) as f), ) when - ClosureEnvironment.lookup(denv, dname) == Some(d) - && ClosureEnvironment.lookup(fenv, fname) == Some(f) => + ClosureEnvironment.lookup(denv, dname) + |> Option.map(DHExp.term_of) == Some(d) + && ClosureEnvironment.lookup(fenv, fname) + |> Option.map(DHExp.term_of) == Some(f) => matches_exp( ~denv=ClosureEnvironment.without_keys([dname], denv), - d, + d |> Exp.fresh, ~fenv=ClosureEnvironment.without_keys([fname], fenv), - f, + f |> Exp.fresh, ) | ( - Some(Fun(_, _, Closure(denv, _), Some(dname)) as d), + Some(Fun(_, _, Some(denv), Some(dname)) as d), Some(Fun(_, _, _, Some(fname)) as f), ) when - ClosureEnvironment.lookup(denv, dname) == Some(d) - && ClosureEnvironment.lookup(fenv, fname) == Some(f) => + ClosureEnvironment.lookup(denv, dname) + |> Option.map(DHExp.term_of) == Some(d) + && ClosureEnvironment.lookup(fenv, fname) + |> Option.map(DHExp.term_of) == Some(f) => matches_exp( ~denv=ClosureEnvironment.without_keys([dname], denv), - d, + d |> DHExp.fresh, ~fenv=ClosureEnvironment.without_keys([fname], fenv), - f, + f |> DHExp.fresh, ) | ( Some(Fun(_, _, _, Some(dname)) as d), Some(Fun(_, _, _, Some(fname)) as f), ) when - ClosureEnvironment.lookup(denv, dname) == Some(d) - && ClosureEnvironment.lookup(fenv, fname) == Some(f) => + ClosureEnvironment.lookup(denv, dname) + |> Option.map(DHExp.term_of) == Some(d) + && ClosureEnvironment.lookup(fenv, fname) + |> Option.map(DHExp.term_of) == Some(f) => matches_exp( ~denv=ClosureEnvironment.without_keys([dname], denv), - d, + d |> DHExp.fresh, ~fenv=ClosureEnvironment.without_keys([fname], fenv), - f, + f |> DHExp.fresh, ) | ( Some(Fun(_, _, _, Some(dname)) as d), Some(Fun(_, _, _, Some(fname)) as f), ) when - ClosureEnvironment.lookup(denv, dname) == Some(d) - && ClosureEnvironment.lookup(fenv, fname) == Some(f) => + ClosureEnvironment.lookup(denv, dname) + |> Option.map(DHExp.term_of) == Some(d) + && ClosureEnvironment.lookup(fenv, fname) + |> Option.map(DHExp.term_of) == Some(f) => matches_exp( ~denv=ClosureEnvironment.without_keys([dname], denv), - d, + d |> DHExp.fresh, ~fenv=ClosureEnvironment.without_keys([fname], denv), - f, + f |> DHExp.fresh, ) - | (Some(d), Some(f)) => matches_exp(d, f) + | (Some(d), Some(f)) => matches_exp(d |> Exp.fresh, f |> Exp.fresh) | (Some(_), None) => false | (None, Some(_)) => false | (None, None) => true } - | (BoundVar(dx), _) => + | (Var(dx), _) => switch (ClosureEnvironment.lookup(denv, dx)) { | Some(d) => matches_exp(d, f) | None => false } - | (_, BoundVar(fx)) => + | (_, Var(fx)) => switch (ClosureEnvironment.lookup(fenv, fx)) { | Some(f) => matches_exp(d, f) | None => false } - | (EmptyHole(_), _) => false + | (EmptyHole, _) => false + + | (Deferral(x), Deferral(y)) => x == y + | (Deferral(_), _) => false | (Filter(df, dd), Filter(ff, fd)) => - DH.DHFilter.fast_equal(df, ff) && matches_exp(dd, fd) + TermBase.StepperFilterKind.fast_equal(df, ff) && matches_exp(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(_), + Ap(_, {term: Constructor("~MVal", _), _}, {term: Tuple([]), _}), + ) => + true | (Constructor(dt, _), Constructor(ft, _)) => dt == ft | (Constructor(_), _) => false @@ -158,23 +184,16 @@ let rec matches_exp = s1 == s2 && matches_utpat(pat1, pat2) && matches_exp(d1, d2) | (TypFun(_), _) => false - | ( - Fun(dp1, _, Closure(denv, d1), _), - Fun(fp1, _, Closure(fenv, f1), _), - ) => + | (Fun(dp1, d1, Some(denv), _), Fun(fp1, f1, Some(fenv), _)) => matches_fun(~denv, dp1, d1, ~fenv, fp1, f1) - | (Fun(dp1, _, Closure(denv, d1), _), Fun(fp1, _, f1, _)) => + | (Fun(dp1, d1, Some(denv), _), Fun(fp1, f1, None, _)) => matches_fun(~denv, dp1, d1, ~fenv, fp1, f1) - | (Fun(dp1, _, d1, _), Fun(fp1, _, Closure(fenv, f1), _)) => + | (Fun(dp1, d1, None, _), Fun(fp1, f1, Some(fenv), _)) => matches_fun(~denv, dp1, d1, ~fenv, fp1, f1) - | (Fun(dp1, _, d1, _), Fun(fp1, _, f1, _)) => + | (Fun(dp1, d1, None, _), Fun(fp1, f1, None, _)) => matches_fun(~denv, dp1, d1, ~fenv, fp1, f1) | (Fun(_), _) => 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(d1, f1) && matches_exp(d2, f2) | (Let(_), _) => false @@ -183,76 +202,63 @@ let rec matches_exp = matches_exp(d1, d2) && matches_typ(t1, t2) | (TypAp(_), _) => 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(d1, f1) && matches_exp(d2, f2) | (Ap(_), _) => false - | (IfThenElse(dc, d1, d2, d3), IfThenElse(fc, f1, f2, f3)) => - dc == fc - && matches_exp(d1, f1) - && matches_exp(d2, f2) - && matches_exp(d3, f3) - | (IfThenElse(_), _) => false + | (DeferredAp(d1, d2), DeferredAp(f1, f2)) => + matches_exp(d1, f1) + && List.fold_left2( + (acc, d, f) => acc && matches_exp(d, f), + true, + d2, + f2, + ) + | (DeferredAp(_), _) => false - | (Sequence(d1, d2), Sequence(f1, f2)) => + | (If(d1, d2, d3), If(f1, f2, f3)) => + matches_exp(d1, f1) && matches_exp(d2, f2) && matches_exp(d3, f3) + | (If(_), _) => false + + | (Seq(d1, d2), Seq(f1, f2)) => matches_exp(d1, f1) && matches_exp(d2, f2) - | (Sequence(_), _) => false + | (Seq(_), _) => false - | (Test(id1, d2), Test(id2, f2)) => id1 == id2 && matches_exp(d2, f2) + | (Test(d2), Test(f2)) => matches_exp(d2, f2) | (Test(_), _) => false | (Cons(d1, d2), Cons(f1, f2)) => matches_exp(d1, f1) && matches_exp(d2, f2) | (Cons(_), _) => false - | (ListLit(_, _, dt, dv), ListLit(_, _, ft, fv)) => - dt == ft - && List.fold_left2( - (acc, d, f) => acc && matches_exp(d, f), - true, - dv, - fv, - ) + | (ListLit(dv), ListLit(fv)) => + List.fold_left2((acc, d, f) => acc && matches_exp(d, f), true, dv, fv) | (ListLit(_), _) => false | (Tuple(dv), Tuple(fv)) => List.fold_left2((acc, d, f) => acc && matches_exp(d, f), true, dv, fv) | (Tuple(_), _) => false - | (BinBoolOp(d_op_bin, d1, d2), BinBoolOp(f_op_bin, f1, f2)) => - d_op_bin == f_op_bin && matches_exp(d1, f1) && matches_exp(d2, f2) + | (UnOp(d_op, d1), UnOp(f_op, f1)) => + d_op == f_op && matches_exp(d1, f1) + | (UnOp(_), _) => false - | (BinBoolOp(_), _) => false - - | (BinIntOp(d_op_bin, d1, d2), BinIntOp(f_op_bin, f1, f2)) => - d_op_bin == f_op_bin && matches_exp(d1, f1) && matches_exp(d2, f2) - | (BinIntOp(_), _) => false - - | (BinFloatOp(d_op_bin, d1, d2), BinFloatOp(f_op_bin, f1, f2)) => - d_op_bin == f_op_bin && matches_exp(d1, f1) && matches_exp(d2, f2) - | (BinFloatOp(_), _) => false - - | (BinStringOp(d_op_bin, d1, d2), BinStringOp(f_op_bin, f1, f2)) => - d_op_bin == f_op_bin && matches_exp(d1, f1) && matches_exp(d2, f2) - | (BinStringOp(_), _) => false + | (BinOp(d_op, d1, d2), BinOp(f_op, f1, f2)) => + d_op == f_op && matches_exp(d1, f1) && matches_exp(d2, f2) + | (BinOp(_), _) => false + | (ListConcat(d1, d2), ListConcat(f1, f2)) => + matches_exp(d1, f1) && matches_exp(d2, f2) | (ListConcat(_), _) => false - | ( - ConsistentCase(Case(dscrut, drule, _)), - ConsistentCase(Case(fscrut, frule, _)), - ) - | ( - InconsistentBranches(_, _, Case(dscrut, drule, _)), - InconsistentBranches(_, _, Case(fscrut, frule, _)), - ) => + | (Match(dscrut, drule), Match(fscrut, frule)) => matches_exp(dscrut, fscrut) && ( switch ( - List.fold_left2( - (res, drule, frule) => - res && matches_rul(~denv, drule, ~fenv, frule), - true, + List.for_all2( + ((dk, dv), (fk, fv)) => + matches_pat(dk, fk) && matches_exp(dv, fv), drule, frule, ) @@ -261,24 +267,21 @@ let rec matches_exp = | res => res } ) - | (ConsistentCase(_), _) - | (InconsistentBranches(_), _) => false - - | (NonEmptyHole(_), _) => false - | (InvalidText(_), _) => false - | (InvalidOperation(_), _) => false + | (Match(_), _) => false + // TODO: should these not default to false? + | (MultiHole(_), _) => false + | (Invalid(_), _) => false + | (DynamicErrorHole(_), _) => false | (Undefined, _) => false - | (ApBuiltin(dname, darg), ApBuiltin(fname, farg)) => - dname == fname && matches_exp(darg, farg) - | (ApBuiltin(_), _) => false - - | (Prj(dv, di), Prj(fv, fi)) => matches_exp(dv, fv) && di == fi - | (Prj(_), _) => false + | (TyAlias(dtp, dut, dd), TyAlias(ftp, fut, fd)) => + dtp == ftp && dut == fut && matches_exp(dd, fd) + | (TyAlias(_), _) => false }; }; } + and matches_fun = ( ~denv: ClosureEnvironment.t, @@ -296,25 +299,33 @@ and matches_fun = f, ); } -and matches_pat = (d: DHPat.t, f: DHPat.t): bool => { - switch (d, f) { - | (_, EmptyHole(_)) => true + +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) + | (_, Parens(x)) => matches_pat(d, x) + | (Cast(x, _, _), _) => matches_pat(x, f) + | (_, Cast(x, _, _)) => matches_pat(d, x) + | (_, EmptyHole) => true + | (MultiHole(_), MultiHole(_)) => true + | (MultiHole(_), _) => false | (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 - | (ListLit(dty1, dl), ListLit(fty1, fl)) => + | (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(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 @@ -331,26 +342,17 @@ 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 - | (InvalidText(_), _) => false + | (EmptyHole, _) => false + | (Invalid(_), _) => false }; } and matches_typ = (d: Typ.t, f: Typ.t) => { Typ.eq(d, f); } -and matches_rul = (~denv, d: DHExp.rule, ~fenv, f: DHExp.rule) => { - switch (d, f) { - | (Rule(dp, d), Rule(fp, f)) => - matches_pat(dp, fp) && matches_exp(~denv, d, ~fenv, 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 @@ -362,7 +364,11 @@ and matches_utpat = (d: Term.UTPat.t, f: Term.UTPat.t): bool => { }; let matches = - (~env: ClosureEnvironment.t, ~exp: DHExp.t, ~flt: Filter.t) + ( + ~env: ClosureEnvironment.t, + ~exp: DHExp.t, + ~flt: TermBase.StepperFilterKind.filter, + ) : option(FilterAction.t) => if (matches_exp(~denv=env, exp, ~fenv=env, flt.pat)) { Some(flt.act); 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 4ad73c5b02..0000000000 --- a/src/haz3lcore/dynamics/HoleInstanceId.re +++ /dev/null @@ -1,4 +0,0 @@ -open Util; - -[@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 80f420e0c2..0000000000 --- a/src/haz3lcore/dynamics/HoleInstanceInfo.re +++ /dev/null @@ -1,38 +0,0 @@ -open Util; - -[@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 c82fe3ffcc..0000000000 --- a/src/haz3lcore/dynamics/HoleInstanceParents.re +++ /dev/null @@ -1,13 +0,0 @@ -open Util; - -[@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 b24ee0fbbd..0000000000 --- a/src/haz3lcore/dynamics/InstancePath.re +++ /dev/null @@ -1,4 +0,0 @@ -open Util; - -[@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/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 341513524a..0000000000 --- a/src/haz3lcore/dynamics/MetaVarInst.re +++ /dev/null @@ -1,7 +0,0 @@ -open Util; - -/** - * 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/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index e5aa4ff32b..329ca1efd8 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -1,510 +1,60 @@ -open Util; - -type match_result = - | Matches(Environment.t) - | DoesNotMatch - | IndetMatch; - -let const_unknown: 'a => Typ.t = _ => Unknown(Internal); - -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; +type match_result = Unboxing.unboxed(Environment.t); +let ( let* ) = Unboxing.( let* ); + +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)) }; -}; - -let rec matches = (dp: DHPat.t, d: DHExp.t): match_result => - switch (dp, d) { - | (_, BoundVar(_)) => DoesNotMatch - | (EmptyHole(_), _) - | (NonEmptyHole(_), _) => IndetMatch - | (Wild, _) => Matches(Environment.empty) - | (InvalidText(_), _) => IndetMatch - | (BadConstructor(_), _) => IndetMatch - | (Var(x), _) => - let env = Environment.extend(Environment.empty, (x, d)); - Matches(env); - | (_, EmptyHole(_)) => IndetMatch - | (_, NonEmptyHole(_)) => IndetMatch - | (_, Undefined) => IndetMatch - | (_, FailedCast(_)) => IndetMatch - | (_, InvalidOperation(_)) => IndetMatch - | (_, FreeVar(_)) => IndetMatch - | (_, InvalidText(_)) => IndetMatch - | (_, Let(_)) => IndetMatch - | (_, FixF(_)) => DoesNotMatch - | (_, Fun(_)) => DoesNotMatch - | (_, BinBoolOp(_)) => IndetMatch - | (_, BinIntOp(_)) => IndetMatch - | (_, BinFloatOp(_)) => IndetMatch - | (_, ConsistentCase(Case(_))) => IndetMatch - - /* Closure should match like underlying expression. */ - | (_, Closure(_, d')) - | (_, Filter(_, d')) => matches(dp, d') - - | (BoolLit(b1), BoolLit(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)) => - 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)) => - 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)) => - 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 - - | (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(Constructor(ctr, _), dp_opt), - Cast(d, Sum(sm1) | Rec(_, Sum(sm1)), Sum(sm2) | Rec(_, 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(_)))) => - matches(dp, d) - | (Ap(_, _), _) => DoesNotMatch - | (Constructor(ctr, _), Constructor(ctr', _)) => - ctr == ctr' ? Matches(Environment.empty) : DoesNotMatch - | ( - Constructor(ctr, _), - Cast(d, Sum(sm1) | Rec(_, Sum(sm1)), Sum(sm2) | Rec(_, 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(_))) => - matches(dp, d) - | (Constructor(_), Cast(d, Unknown(_), Sum(_) | Rec(_, Sum(_)))) => - matches(dp, d) - | (Constructor(_), _) => DoesNotMatch - - | (Tuple(dps), Tuple(ds)) => - if (List.length(dps) != List.length(ds)) { - DoesNotMatch; - } 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, Prod(tys), 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(_))) => - matches_cast_Tuple( - dps, - d, - List.map( - p => [p], - List.combine(tys, List.init(List.length(tys), const_unknown)), - ), - ) - | (Tuple(dps), Cast(d, Unknown(_), 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, List(ty1), 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(_, _), Cons(_, _)) - | (ListLit(_, _), Cons(_, _)) - | (Cons(_, _), ListLit(_)) - | (ListLit(_), ListLit(_)) => matches_cast_Cons(dp, d, []) - | (Cons(_) | ListLit(_), _) => DoesNotMatch - } -and matches_cast_Sum = - ( - ctr: string, - dp: option(DHPat.t), - d: DHExp.t, - castmaps: list(ConstructorMap.t((Typ.t, Typ.t))), - ) - : match_result => - switch (d) { - | Constructor(ctr', _) => - switch ( - dp, - castmaps |> List.map(ConstructorMap.find_opt(ctr')) |> OptUtil.sequence, - ) { - | (None, Some(_)) => - 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 - } - | Cast(d', Sum(sm1) | Rec(_, Sum(sm1)), Sum(sm2) | Rec(_, 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(_))) => - matches_cast_Sum(ctr, dp, d', castmaps) - | FreeVar(_) - | InvalidText(_) - | Let(_) - | TypAp(_) - | Ap(_) - | ApBuiltin(_) - | BinBoolOp(_) - | BinIntOp(_) - | BinFloatOp(_) - | BinStringOp(_) - | InconsistentBranches(_) - | EmptyHole(_) - | NonEmptyHole(_) - | FailedCast(_, _, _) - | Test(_) - | InvalidOperation(_) - | ConsistentCase(_) - | Prj(_) - | IfThenElse(_) - | Undefined - | BuiltinFun(_) => IndetMatch - | Cast(_) - | BoundVar(_) - | FixF(_) - | TypFun(_) - | Fun(_) - | BoolLit(_) - | IntLit(_) - | FloatLit(_) - | StringLit(_) - | ListLit(_) - | Tuple(_) - | Sequence(_, _) - | Closure(_) - | Filter(_) - | Cons(_) - | ListConcat(_) => DoesNotMatch - } -and matches_cast_Tuple = - ( - dps: list(DHPat.t), - d: DHExp.t, - elt_casts: list(list((Typ.t, Typ.t))), - ) - : match_result => - switch (d) { - | Tuple(ds) => - if (List.length(dps) != List.length(ds)) { - DoesNotMatch; +let rec matches = (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, xs, s') + |> List.fold_left(combine_result, Matches(Environment.empty)); } 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', Prod(tys), 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', Prod(tys), 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')) => - 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 - | BoundVar(_) => DoesNotMatch - | FreeVar(_) => IndetMatch - | InvalidText(_) => IndetMatch - | Let(_, _, _) => IndetMatch - | FixF(_, _, _) => DoesNotMatch - | TypFun(_, _, _) => DoesNotMatch - | Fun(_, _, _, _) => DoesNotMatch - | Closure(_, Fun(_)) => DoesNotMatch - | Closure(_, _) => IndetMatch - | TypAp(_, _) => IndetMatch - | Filter(_, _) => IndetMatch - | Ap(_, _) => IndetMatch - | ApBuiltin(_, _) => IndetMatch - | BinBoolOp(_, _, _) - | BinIntOp(_, _, _) - | BinFloatOp(_, _, _) - | BinStringOp(_) - | BoolLit(_) => DoesNotMatch - | IntLit(_) => DoesNotMatch - | Sequence(_) - | BuiltinFun(_) - | Test(_) => DoesNotMatch - | FloatLit(_) => DoesNotMatch - | StringLit(_) => DoesNotMatch - | ListLit(_) => DoesNotMatch - | Cons(_, _) => DoesNotMatch - | ListConcat(_) => DoesNotMatch - | Prj(_) => IndetMatch - | Constructor(_) => DoesNotMatch - | ConsistentCase(_) - | InconsistentBranches(_) => IndetMatch - | EmptyHole(_) => IndetMatch - | NonEmptyHole(_) => IndetMatch - | FailedCast(_, _, _) => IndetMatch - | InvalidOperation(_) => IndetMatch - | IfThenElse(_) => IndetMatch - | Undefined => IndetMatch - } -and matches_cast_Cons = - (dp: DHPat.t, d: DHExp.t, elt_casts: list((Typ.t, Typ.t))): match_result => - switch (d) { - | ListLit(_, _, _, []) => - switch (dp) { - | ListLit(_, []) => Matches(Environment.empty) - | _ => DoesNotMatch - } - | ListLit(u, i, ty, [dhd, ...dtl] as ds) => - switch (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.List(ty2)); - }, - elt_casts, - ); - let d2 = DHExp.ListLit(u, i, ty, dtl); - 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 (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.List(ty2)); - }, - 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(ty, [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.List(ty2)); - }, - elt_casts, - ); - let dp2 = DHPat.ListLit(ty, dptl); - 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', List(ty1), 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(_, _, _) => DoesNotMatch - | BoundVar(_) => DoesNotMatch - | FreeVar(_) => IndetMatch - | InvalidText(_) => IndetMatch - | Let(_, _, _) => IndetMatch - | FixF(_, _, _) => DoesNotMatch - | TypFun(_, _, _) => DoesNotMatch - | Fun(_, _, _, _) => DoesNotMatch - | Closure(_, d') => matches_cast_Cons(dp, d', elt_casts) - | TypAp(_, _) => IndetMatch - | Filter(_, d') => matches_cast_Cons(dp, d', elt_casts) - | Ap(_, _) => IndetMatch - | ApBuiltin(_, _) => IndetMatch - | BinBoolOp(_, _, _) - | BinIntOp(_, _, _) - | BinFloatOp(_, _, _) - | BinStringOp(_) - | ListConcat(_) - | BuiltinFun(_) => DoesNotMatch - | BoolLit(_) => DoesNotMatch - | IntLit(_) => DoesNotMatch - | Sequence(_) - | Test(_) => DoesNotMatch - | FloatLit(_) => DoesNotMatch - | StringLit(_) => DoesNotMatch - | Tuple(_) => DoesNotMatch - | Prj(_) => IndetMatch - | Constructor(_) => DoesNotMatch - | ConsistentCase(_) - | InconsistentBranches(_) => IndetMatch - | EmptyHole(_) => IndetMatch - | NonEmptyHole(_) => IndetMatch - | FailedCast(_, _, _) => IndetMatch - | InvalidOperation(_) => IndetMatch - | IfThenElse(_) => IndetMatch - | Undefined => IndetMatch + }; + | Cons(x, xs) => + let* (x', xs') = Unboxing.unbox(Cons, d); + 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(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, 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 |> Casts.transition_multiple) }; diff --git a/src/haz3lcore/dynamics/PatternMatch.rei b/src/haz3lcore/dynamics/PatternMatch.rei deleted file mode 100644 index 96cf6019fa..0000000000 --- a/src/haz3lcore/dynamics/PatternMatch.rei +++ /dev/null @@ -1,6 +0,0 @@ -type match_result = - | Matches(Environment.t) - | DoesNotMatch - | IndetMatch; - -let matches: (DHPat.t, DHExp.t) => match_result; diff --git a/src/haz3lcore/dynamics/Stepper.re b/src/haz3lcore/dynamics/Stepper.re index d59c095142..e922aacf52 100644 --- a/src/haz3lcore/dynamics/Stepper.re +++ b/src/haz3lcore/dynamics/Stepper.re @@ -1,30 +1,24 @@ -open Util; - 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(int) + | StepperReady + | StepperDone + | StepTimeout(EvalObj.t); [@deriving (show({with_path: false}), sexp, yojson)] -type current = - | StepperOK(DHExp.t, EvaluatorState.t) - | StepTimeout // Must have at least one in previous - | StepPending(DHExp.t, EvaluatorState.t, option(EvalObj.t)); // StepPending(_,Some(_)) cannot be saved +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((FilterAction.action, EvalObj.t)), + history, + next_options: list((FilterAction.action, EvalObj.t)), + stepper_state, }; let rec matches = @@ -37,158 +31,143 @@ 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) = switch (ctx) { - | Filter(_, _) => (pact, pidx) + | Term({term: Filter(_, _), _}) => (pact, pidx) | _ => midx > pidx ? (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) = - if (idx > idx') { - matches(env, flt, ctx, exp, act, idx); + | 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) = + if (idx > idx') { + matches(env, flt, ctx, exp, act, idx); + } else { + matches(env, flt, ctx, exp, act', idx'); + }; + if (act' |> snd == All) { + (ract, ridx, Filter(Residue(idx', act'), rctx) |> rewrap); } else { - matches(env, flt, ctx, exp, act', idx'); + (ract, ridx, rctx); }; - if (act' |> snd == All) { - (ract, ridx, Filter(Residue(idx', act'), rctx)); - } 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, ctx, env', name) => + let+ ctx = + 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, act, idx); + FixF(name, ctx, env') |> 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; + | TypAp(ctx, ty) => + 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) => + 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, act, idx); + If1(ctx, d2, d3) |> rewrap; + | If2(d1, ctx, d3) => + 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, act, idx); + If3(d1, d2, ctx) |> rewrap; + | UnOp(op, ctx) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + UnOp(op, 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; + | Test(ctx) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Test(ctx) |> rewrap; + | ListLit(ctx, ds) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + ListLit(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; + | MultiHole(ctx, (dl, dr)) => + 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, 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; + | DynamicErrorHole(ctx, error) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + DynamicErrorHole(ctx, error) |> rewrap; + | MatchScrut(ctx, rs) => + 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, act, idx); + MatchRule(scr, p, ctx, rs) |> rewrap; }; - | Sequence1(ctx, d2) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Sequence1(ctx, d2); - | Sequence2(d1, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Sequence2(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, name) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Fun(dp, ty, ctx, name); - | FixF(name, ty, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - FixF(name, ty, ctx); - | TypAp(ctx, ty) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - TypAp(ctx, ty); - | Ap1(ctx, d2) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Ap1(ctx, d2); - | Ap2(d1, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Ap2(d1, ctx); - | IfThenElse1(c, ctx, d2, d3) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - IfThenElse1(c, ctx, d2, d3); - | IfThenElse2(c, d1, ctx, d3) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - IfThenElse2(c, d1, ctx, d3); - | IfThenElse3(c, d1, d2, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - IfThenElse3(c, d1, d2, ctx); - | BinBoolOp1(op, ctx, d1) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - BinBoolOp1(op, ctx, d1); - | BinBoolOp2(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); - | 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); - | ConsistentCase(Case(ctx, rs, i)) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - ConsistentCase(Case(ctx, rs, i)); - | ConsistentCaseRule(dexp, dpat, ctx, rs, i) => - 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); }; switch (ctx) { - | Filter(_) => (ract, ridx, rctx) + | Term({term: Filter(_), _}) => (ract, ridx, rctx) | _ when 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) }; @@ -219,104 +198,81 @@ let should_hide_step = (~settings, x: step): (FilterAction.action, step) => }; }; -let get_elab = ({elab, _}: t) => elab; +let get_elab = ({history, _}: t): Elaborator.Elaboration.t => { + let (d, _) = Aba.last_a(history); + {d: d}; +}; -let get_next_steps = s => s.next; +let get_next_steps = s => s.next_options |> List.map(snd); -let current_expr = (s: t) => - switch (s.current, s.previous) { - | (StepperOK(d, _), _) - | (StepPending(d, _, _), _) => d - | (StepTimeout, [x, ..._]) => x.d - | (StepTimeout, []) => s.elab - }; +let current_expr = ({history, _}: t) => Aba.hd(history) |> fst; -let step_pending = (idx: int, {elab, previous, current, next}: t) => { - // TODO[Matt]: change to nth_opt after refactor - let eo = List.nth(next, idx) |> snd; - switch (current) { - | StepperOK(d, s) => { - elab, - previous, - current: StepPending(d, s, Some(eo)), - next, - } - | 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 current_state = ({history, _}: t) => Aba.hd(history) |> snd; + +let step_pending = (idx: int, stepper: t) => { + {...stepper, stepper_state: StepPending(idx)}; }; -let init = (~settings, elab: DHExp.t) => { +let init = (~settings, {d}: Elaborator.Elaboration.t) => { + let state = EvaluatorState.init; { - elab, - previous: [], - current: StepPending(elab, EvaluatorState.init, None), - next: decompose(~settings, elab), + history: Aba.singleton((d, state)), + next_options: decompose(~settings, d, state), + stepper_state: StepperReady, }; }; let rec evaluate_pending = (~settings, s: t) => { - switch (s.current) { - | StepperOK(_) - | StepTimeout => s - | StepPending(d, state, Some(eo)) => + switch (s.stepper_state) { + | StepperDone + | StepTimeout(_) => s + | StepperReady => + let next' = List.mapi((i, x) => (i, x), s.next_options); + 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(i) => + let (_, eo) = List.nth(s.next_options, i); + 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'); + ( + switch (take_step(state_ref, eo.env, eo.d_loc)) { + | Some(d) => d |> DHExp.repair_ids + | None => raise(Exception) + } + ) + |> DHExp.repair_ids; + let _ = print_endline(d_loc' |> DHExp.show); + let d' = EvalCtx.compose(eo.ctx, d_loc'); + let new_step = { + d, + d_loc: eo.d_loc, + d_loc', + ctx: eo.ctx, + knd: eo.knd, + state, + }; + let new_state = state_ref^; { - elab: s.elab, - previous: [ - {d, d_loc: eo.d_loc, ctx: eo.ctx, knd: eo.knd, state}, - ...s.previous, - ], - current: StepPending(d', state_ref^, None), - next: decompose(~settings, d'), + history: s.history |> Aba.cons((d', new_state), new_step), + stepper_state: StepperReady, + next_options: decompose(~settings, d', new_state), } |> evaluate_pending(~settings); - | StepPending(d, state, None) => - switch (List.find_opt(((act, _)) => act == FilterAction.Eval, s.next)) { - | Some((_, eo)) => - { - elab: s.elab, - previous: s.previous, - current: StepPending(d, state, Some(eo)), - next: s.next, - } - |> evaluate_pending(~settings) - | None => { - elab: s.elab, - previous: s.previous, - current: StepperOK(d, state), - next: s.next, - } - } }; }; let rec evaluate_full = (~settings, s: t) => { - switch (s.current) { - | StepTimeout => s - | StepperOK(_) when s.next == [] => s - | StepperOK(_) => s |> step_pending(0) |> evaluate_full(~settings) + switch (s.stepper_state) { + | StepTimeout(_) => s + | StepperDone when s.next_options == [] => s + | StepperDone => s |> step_pending(0) |> evaluate_full(~settings) + | StepperReady | StepPending(_) => evaluate_pending(~settings, s) |> evaluate_full(~settings) }; @@ -324,69 +280,48 @@ let rec evaluate_full = (~settings, s: t) => { 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, - next, + | {stepper_state: StepPending(idx), _} as s => { + ...s, + stepper_state: StepTimeout(List.nth(s.next_options, idx) |> snd), } - | {current: StepTimeout | StepperOK(_) | StepPending(_, _, None), _} as s => s; + | {stepper_state: 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(~settings, 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(~settings, Aba.hd(h') |> fst, Aba.hd(h') |> snd), + stepper_state: StepperDone, }; +}; + +let can_undo = (~settings, s: t) => { + truncate_history(~settings, s.history) |> Option.is_some; +}; let get_justification: step_kind => string = fun | LetBind => "substitution" - | Sequence => "sequence" + | Seq => "sequence" | FixUnwrap => "unroll fixpoint" | UpdateTest => "update test" | TypFunAp => "apply type function" | FunAp => "apply function" + | DeferredAp => "deferred application" | 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) @@ -395,12 +330,12 @@ 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" | 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" @@ -411,44 +346,84 @@ let get_justification: step_kind => string = | CompleteFilter => "complete filter" | CompleteClosure => "complete closure" | FunClosure => "function closure" - | Skip => "skipped steps"; + | RemoveTypeAlias => "define type" + | RemoveParens => "remove parentheses" + | UnOp(Meta(Unquote)) => failwith("INVALID STEP"); + +type step_info = { + 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) +}; 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 grouped_steps = + stepper.history + |> Aba.fold_right( + ((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 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 result = padded |> List.map(track_ids); + 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, +let hidden_steps_of_info = (info: step_info): list(step_info) => { + // note the previous_step field is fudged because it is currently usused.next_options + List.map( + ((hs: step, _)) => + { + d: hs.d, + chosen_step: Some(hs), + hidden_steps: [], + previous_step: None, + }, + info.hidden_steps, + ); }; +[@deriving (show({with_path: false}), sexp, yojson)] +type persistent = {history}; + +let (sexp_of_persistent, persistent_of_sexp) = + StructureShareSexp.structure_share_in( + sexp_of_persistent, + persistent_of_sexp, + ); + let (sexp_of_persistent, persistent_of_sexp) = StructureShareSexp.structure_share_in( sexp_of_persistent, @@ -456,16 +431,13 @@ let (sexp_of_persistent, persistent_of_sexp) = ); // 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 = (~settings, {elab, previous, current}) => { - let s = {elab, previous, current, next: []}; - {elab, previous, current, next: decompose(~settings, current_expr(s))}; +let from_persistent = (~settings, {history}) => { + { + history, + next_options: + decompose(~settings, Aba.hd(history) |> fst, Aba.hd(history) |> snd), + stepper_state: StepperDone, + }; }; diff --git a/src/haz3lcore/dynamics/Substitution.re b/src/haz3lcore/dynamics/Substitution.re index 1ffbc5a001..5d918e520b 100644 --- a/src/haz3lcore/dynamics/Substitution.re +++ b/src/haz3lcore/dynamics/Substitution.re @@ -1,139 +1,137 @@ /* closed substitution [d1/x]d2 */ -let rec subst_var = (d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => - switch (d2) { - | BoundVar(y) => +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)) { d1; } else { d2; } - | FreeVar(_) => d2 - | InvalidText(_) => d2 + | Invalid(_) => d2 | Undefined => d2 - | Sequence(d3, d4) => - let d3 = subst_var(d1, x, d3); - let d4 = subst_var(d1, x, d4); - Sequence(d3, d4); + | Seq(d3, 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); - Filter(filter, dbody); + 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); - | FixF(y, ty, d3) => + Let(dp, d3, d4) |> rewrap; + | FixF(y, d3, env) => + let env' = Option.map(subst_var_env(m, d1, x), env); let d3 = - if (Var.eq(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); - | Fun(dp, ty, d3, s) => - if (DHPat.binds_var(x, dp)) { - Fun(dp, ty, d3, s); + FixF(y, d3, env') |> 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, d3, env', s) |> rewrap; } else { - let d3 = subst_var(d1, x, d3); - Fun(dp, ty, d3, s); - } - | TypFun(tpat, d3, s) => TypFun(tpat, subst_var(d1, x, d3), s) + let d3 = subst_var(m, d1, x, d3); + Fun(dp, d3, env', s) |> rewrap; + }; + | 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) */ - let env' = subst_var_env(d1, x, env); - let d3' = subst_var(d1, x, d3); - Closure(env', d3'); - | Ap(d3, d4) => - let d3 = subst_var(d1, x, d3); - let d4 = subst_var(d1, x, d4); - Ap(d3, d4); - | TypAp(d3, ty) => TypAp(subst_var(d1, x, d3), ty) - | ApBuiltin(ident, args) => ApBuiltin(ident, subst_var(d1, x, args)) - | BuiltinFun(ident) => BuiltinFun(ident) - | Test(id, d3) => Test(id, subst_var(d1, x, d3)) - | BoolLit(_) - | IntLit(_) - | FloatLit(_) - | StringLit(_) + 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(m, d1, x, d3); + let d4 = subst_var(m, d1, x, d4); + Ap(dir, d3, d4) |> rewrap; + | BuiltinFun(_) => d2 + | Test(d3) => Test(subst_var(m, 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(ds) => ListLit(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); - Cons(d3, 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); - 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) => - 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); - | 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)); - | EmptyHole(u, i) => EmptyHole(u, i) - | NonEmptyHole(reason, u, i, d3) => - let d3' = subst_var(d1, x, d3); - NonEmptyHole(reason, u, i, d3'); + 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(m, d1, x), ds)) |> rewrap + | UnOp(op, d3) => + let d3 = subst_var(m, d1, x, d3); + UnOp(op, d3) |> rewrap; + | BinOp(op, d3, 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(m, d1, x, ds); + let rules = + List.map( + ((p, v)) => + if (DHPat.binds_var(m, x, p)) { + (p, v); + } else { + (p, subst_var(m, d1, x, v)); + }, + rules, + ); + Match(ds, rules) |> rewrap; + | EmptyHole => EmptyHole |> rewrap + // TODO: handle multihole + | MultiHole(_d2) => d2 //MultiHole(List.map(subst_var(m, d1, x), ds)) |> rewrap | Cast(d, ty1, ty2) => - let d' = subst_var(d1, x, d); - Cast(d', ty1, ty2); + let d' = subst_var(m, d1, x, d); + Cast(d', ty1, ty2) |> rewrap; | FailedCast(d, ty1, ty2) => - let d' = subst_var(d1, x, d); - FailedCast(d', ty1, ty2); - | InvalidOperation(d, err) => - let d' = subst_var(d1, x, d); - InvalidOperation(d', err); - | IfThenElse(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'); - } - -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)); - } - } - ) + let d' = subst_var(m, d1, x, d); + FailedCast(d', ty1, ty2) |> rewrap; + | DynamicErrorHole(d, err) => + let d' = subst_var(m, d1, x, d); + DynamicErrorHole(d', err) |> rewrap; + | If(d4, d5, 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(m, d1, x, d4); + TyAlias(tp, ut, d4') |> rewrap; + | 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; + | TypAp(d3, ut) => + let d3 = subst_var(m, d1, x, d3); + TypAp(d3, ut) |> 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 @@ -141,20 +139,20 @@ 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, + ((x'', d''), d) => subst_var(m, d'', x'', d), + d', ) - | 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, @@ -164,16 +162,17 @@ 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: TermBase.StepperFilterKind.t) + : TermBase.StepperFilterKind.t => { + flt |> TermBase.StepperFilterKind.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 6e683c2532..74a5f8f550 100644 --- a/src/haz3lcore/dynamics/TestMap.re +++ b/src/haz3lcore/dynamics/TestMap.re @@ -5,10 +5,10 @@ open Util; type instance_report = (DHExp.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)); +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 e5cc4cdcf7..a54c9d18d8 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -1,18 +1,17 @@ open Util; open PatternMatch; -open DH; /* Transition.re 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({expr: d2, state, kind: Seq, final: false}); Each step semantics starts with a `let. () = otherwise(...)` that defines how @@ -33,9 +32,9 @@ open DH; 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 @@ -47,7 +46,7 @@ open DH; type step_kind = | InvalidStep | VarLookup - | Sequence + | Seq | LetBind | FunClosure | FixUnwrap @@ -55,98 +54,26 @@ type step_kind = | UpdateTest | TypFunAp | FunAp + | DeferredAp | CastTypAp | CastAp | BuiltinWrap | BuiltinAp(string) - | 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 | ListConcat | CaseApply - | CaseNext | CompleteClosure | CompleteFilter | Cast - | Skip; - -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); - - let grounded_Arrow = - NotGroundOrHole(Arrow(Unknown(Internal), Unknown(Internal))); - // TODO: Maybe the Forall should allow a hole in the variable position? - let grounded_Forall = - NotGroundOrHole(Forall("grounded_forall", Unknown(Internal))); - let grounded_Prod = length => - NotGroundOrHole( - Prod(ListUtil.replicate(length, Typ.Unknown(Internal))), - ); - let grounded_Sum = (sm: Typ.sum_map): ground_cases => { - let sm' = sm |> ConstructorMap.map(Option.map(const_unknown)); - NotGroundOrHole(Sum(sm')); - }; - let grounded_List = NotGroundOrHole(List(Unknown(Internal))); - - 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(ty) => ground_cases_of(ty) == Ground; - switch (ty) { - | Unknown(_) => Hole - | Bool - | Int - | Float - | String - | Var(_) - | Rec(_) - | Forall(_, Unknown(_)) - | Arrow(Unknown(_), Unknown(_)) - | List(Unknown(_)) => Ground - | Prod(tys) => - if (List.for_all( - fun - | Typ.Unknown(_) => true - | _ => false, - tys, - )) { - Ground; - } else { - tys |> List.length |> grounded_Prod; - } - | Sum(sm) => - sm |> ConstructorMap.is_ground(is_ground_arg) - ? Ground : grounded_Sum(sm) - | Arrow(_, _) => grounded_Arrow - | Forall(_) => grounded_Forall - | List(_) => grounded_List - }; - }; -}; - -let rec unbox_list = (d: DHExp.t): DHExp.t => - switch (d) { - | Cast(d, List(t1), List(t2)) => - switch (unbox_list(d)) { - | ListLit(u, i, _, xs) => - ListLit(u, i, t2, List.map(x => DHExp.Cast(x, t1, t2), xs)) - | d => d - } - | d => d - }; - + | RemoveTypeAlias + | RemoveParens; let evaluate_extend_env = (new_bindings: Environment.t, to_extend: ClosureEnvironment.t) : ClosureEnvironment.t => { @@ -158,13 +85,21 @@ 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; +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; @@ -191,6 +126,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.): @@ -198,558 +136,676 @@ 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; }; module Transition = (EV: EV_MODE) => { open EV; open DHExp; - let (let.match) = ((env, match_result), r) => + + // Default state update + let state_update = () => (); + + let (let.match) = ((env, match_result: PatternMatch.match_result), r) => switch (match_result) { | IndetMatch | DoesNotMatch => Indet | Matches(env') => r(evaluate_extend_env(env', env)) }; - let transition = (req, state, env, d): 'a => - switch (d) { - | BoundVar(x) => - let. _ = otherwise(env, BoundVar(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}); + /* 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 => { + // 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); + switch (ClosureEnvironment.lookup(env, x)) { + | Some(d) => + Step({ + expr: d |> fast_copy(Id.mk()), + state_update, + kind: VarLookup, + is_value: false, + }) + | 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({expr: d2, state_update, kind: Seq, is_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); + 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), kind: LetBind, value: false}); + Step({ + expr: Closure(env', d2) |> fresh, + state_update, + kind: LetBind, + is_value: false, + }); | TypFun(_) - | Fun(_, _, Closure(_), _) => + | Fun(_, _, Some(_), _) => let. _ = otherwise(env, d); Constructor; - | Fun(p, t, d, v) => - let. _ = otherwise(env, Fun(p, t, d, v)); + | Fun(p, d1, None, v) => + let. _ = otherwise(env, d); Step({ - apply: () => Fun(p, t, Closure(env, d), v), + expr: Fun(p, d1, Some(env), v) |> rewrap, + state_update, kind: FunClosure, - value: true, + is_value: true, }); - | FixF(f, _, Closure(env, d1)) => - let. _ = otherwise(env, d); - let env' = evaluate_extend_env(Environment.singleton((f, d)), env); - Step({apply: () => Closure(env', d1), kind: FixUnwrap, value: false}); - | FixF(f, t, d1) => - let. _ = otherwise(env, FixF(f, t, d1)); + | FixF(dp, d1, None) => + let. _ = otherwise(env, FixF(dp, d1, None) |> rewrap); Step({ - apply: () => FixF(f, t, Closure(env, d1)), + expr: FixF(dp, d1, Some(env)) |> rewrap, + state_update, kind: FixClosure, - value: false, + is_value: false, }); - | Test(id, d) => - let. _ = otherwise(env, d => Test(id, d)) - and. d' = req_final(req(state, env), d => Test(id, d), d); + | FixF(dp, d1, Some(env)) => + switch (DHPat.get_var(dp)) { + // Simple Recursion case + | Some(f) => + let. _ = otherwise(env, d); + let env'' = + evaluate_extend_env( + Environment.singleton((f, FixF(dp, d1, Some(env)) |> rewrap)), + env, + ); + Step({ + expr: Closure(env'', d1) |> fresh, + state_update, + kind: FixUnwrap, + is_value: false, + }); + // Mutual Recursion case + | None => + let. _ = otherwise(env, d); + let bindings = DHPat.bound_vars(dp); + let substitutions = + List.map( + binding => + ( + binding, + Let( + dp, + FixF(dp, d1, Some(env)) |> rewrap, + Var(binding) |> fresh, + ) + |> fresh, + ), + bindings, + ); + let env'' = + evaluate_extend_env(Environment.of_list(substitutions), env); + Step({ + expr: Closure(env'', d1) |> fresh, + state_update, + kind: FixUnwrap, + is_value: false, + }); + } + | 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''); + 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 (d') { - | BoolLit(true) => - update_test(state, id, (d', Pass)); - Tuple([]); - | BoolLit(false) => - update_test(state, id, (d', Fail)); - Tuple([]); - /* Hack: assume if final and not Bool, then Indet; this won't catch errors in statics */ - | _ => - update_test(state, id, (d', Indet)); - Tuple([]); - }, + expr: Tuple([]) |> fresh, + state_update: () => + update_test(state, DHExp.rep_id(d), (d', result)), kind: UpdateTest, - value: true, + 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'))) }; - | Ap(d1, d2) => - let. _ = otherwise(env, (d1, d2) => Ap(d1, d2)) - 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') { + | 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' = + req_value(req(state, env), d1 => Ap1(dir, d1, d2) |> wrap_ctx, d1) + 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, _, Closure(env', d3), _) => + | Fun(dp, d3, Some(env'), _) => let.match env'' = (env', matches(dp, d2')); - Step({apply: () => Closure(env'', d3), kind: FunAp, value: false}); - | Cast(d3', Arrow(ty1, ty2), Arrow(ty1', ty2')) => Step({ - apply: () => Cast(Ap(d3', Cast(d2', ty1', ty1)), ty2, ty2'), + expr: Closure(env'', d3) |> fresh, + state_update, + kind: FunAp, + is_value: false, + }); + | Cast( + d3', + {term: Arrow(ty1, ty2), _}, + {term: Arrow(ty1', ty2'), _}, + ) => + Step({ + 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({ + expr: { + let builtin = + VarMap.lookup(Builtins.forms_init, ident) + |> OptUtil.get(() => { + /* 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), + is_value: false // Not necessarily a value because of InvalidOperations + }); + } 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: () => { - //HACK[Matt]: This step is just so we can check that d2' is not indet - ApBuiltin( - ident, - d2', - ); - }, - kind: BuiltinWrap, - value: false // Not necessarily a value because of InvalidOperations - }) + expr: Ap(Forward, d3, Tuple(new_args) |> fresh) |> fresh, + state_update, + kind: DeferredAp, + is_value: false, + }); + | Cast(_) + | FailedCast(_) => Indet + | FixF(_) => + print_endline(Exp.show(d1)); + print_endline(Exp.show(d1')); + print_endline("FIXF"); + failwith("FixF in Ap"); | _ => Step({ - apply: () => { + expr: { raise(EvaluatorError.Exception(InvalidBoxedFun(d1'))); }, + state_update, kind: InvalidStep, - value: true, + is_value: true, }) }; - | ApBuiltin(ident, arg) => - let. _ = otherwise(env, arg => ApBuiltin(ident, arg)) - and. arg' = - req_value(req(state, env), arg => ApBuiltin(ident, arg), 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 - }); - | BoolLit(_) - | IntLit(_) - | FloatLit(_) - | StringLit(_) + | Deferral(_) => + let. _ = otherwise(env, d); + Indet; + | 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(c, d1, d2) => + let. _ = otherwise(env, c => If(c, d1, d2) |> rewrap) and. c' = + req_value(req(state, env), c => If1(c, d1, d2) |> wrap_ctx, c); + 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; + | UnOp(Int(Minus), d1) => + let. _ = otherwise(env, d1 => UnOp(Int(Minus), d1) |> rewrap) + and. d1' = req_value( req(state, env), - c => IfThenElse1(consistent, c, d1, d2), - c, + c => UnOp(Int(Minus), c) |> wrap_ctx, + d1, ); - switch (consistent, c') { - | (ConsistentIf, BoolLit(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. - | (ConsistentIf, _) => - Step({ - apply: () => { - raise(EvaluatorError.Exception(InvalidBoxedBoolLit(c'))); - }, - kind: InvalidStep, - value: true, - }) - // Inconsistent branches should be Indet - | (InconsistentIf, _) => Indet - }; - | BinBoolOp(And, d1, d2) => - let. _ = otherwise(env, d1 => BinBoolOp(And, d1, d2)) + let-unbox n = (Int, d1'); + Step({ + expr: Int(- n) |> fresh, + state_update, + kind: UnOp(Int(Minus)), + is_value: true, + }); + | UnOp(Bool(Not), d1) => + let. _ = otherwise(env, d1 => UnOp(Bool(Not), d1) |> rewrap) and. d1' = - req_value(req(state, env), d1 => BinBoolOp1(And, d1, d2), d1); + req_value( + req(state, env), + c => UnOp(Bool(Not), c) |> wrap_ctx, + d1, + ); + let-unbox b = (Bool, d1'); Step({ - apply: () => - switch (d1') { - | BoolLit(true) => d2 - | BoolLit(false) => BoolLit(false) - | _ => raise(EvaluatorError.Exception(InvalidBoxedBoolLit(d1'))) - }, + expr: Bool(!b) |> fresh, + state_update, + kind: UnOp(Bool(Not)), + is_value: true, + }); + | 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) |> wrap_ctx, + d1, + ); + let-unbox b1 = (Bool, d1'); + Step({ + expr: b1 ? d2 : Bool(false) |> fresh, + state_update, kind: BinBoolOp(And), - value: false, + is_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) |> rewrap) and. d1' = - req_value(req(state, env), d1 => BinBoolOp1(Or, d1, d2), d1); + req_value( + req(state, env), + d1 => BinOp1(Bool(Or), d1, d2) |> wrap_ctx, + d1, + ); + let-unbox b1 = (Bool, d1'); Step({ - apply: () => - switch (d1') { - | BoolLit(true) => BoolLit(true) - | BoolLit(false) => d2 - | _ => raise(EvaluatorError.Exception(InvalidBoxedBoolLit(d2))) - }, + expr: b1 ? Bool(true) |> fresh : d2, + state_update, kind: BinBoolOp(Or), - value: false, + is_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) |> rewrap) + and. d1' = + req_value( + req(state, env), + d1 => BinOp1(Int(op), d1, d2) |> wrap_ctx, + 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) |> wrap_ctx, + d2, + ); + let-unbox n1 = (Int, d1'); + let-unbox n2 = (Int, d2'); Step({ - apply: () => - switch (d1', d2') { - | (IntLit(n1), IntLit(n2)) => + expr: + ( 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)), + DynamicErrorHole( + BinOp(Int(op), d1', d2') |> rewrap, 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)), + DynamicErrorHole( + BinOp(Int(op), d1', d2') |> rewrap, 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(_), _) => - raise(EvaluatorError.Exception(InvalidBoxedIntLit(d2'))) - | _ => raise(EvaluatorError.Exception(InvalidBoxedIntLit(d1'))) - }, + ) + |> fresh, + state_update, kind: BinIntOp(op), // False so that InvalidOperations are caught and made indet by the next step - value: false, + is_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) |> rewrap) and. d1' = - req_value(req(state, env), d1 => BinFloatOp1(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 => BinFloatOp2(op, d1, d2), d2); + req_value( + req(state, env), + d2 => BinOp2(Float(op), d1, d2) |> wrap_ctx, + d2, + ); + let-unbox n1 = (Float, d1'); + let-unbox n2 = (Float, d2'); Step({ - apply: () => - switch (d1', d2') { - | (FloatLit(n1), FloatLit(n2)) => + expr: + ( 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(_), _) => - raise(EvaluatorError.Exception(InvalidBoxedFloatLit(d2'))) - | _ => raise(EvaluatorError.Exception(InvalidBoxedFloatLit(d1'))) - }, + ) + |> fresh, + state_update, kind: BinFloatOp(op), - value: true, + is_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) |> rewrap) and. d1' = - req_value(req(state, env), d1 => BinStringOp1(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 => BinStringOp2(op, d1, d2), d2); + req_value( + req(state, env), + d2 => BinOp2(String(op), d1, d2) |> wrap_ctx, + d2, + ); + let-unbox s1 = (String, d1'); + let-unbox s2 = (String, d2'); Step({ - apply: () => - switch (d1', d2') { - | (StringLit(s1), StringLit(s2)) => - switch (op) { - | Concat => StringLit(s1 ++ s2) - | Equals => BoolLit(s1 == s2) - } - | (StringLit(_), _) => - raise(EvaluatorError.Exception(InvalidBoxedStringLit(d2'))) - | _ => raise(EvaluatorError.Exception(InvalidBoxedStringLit(d1'))) + 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)) + 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)) - and. d1' = req_final(req(state, env), d1 => Prj(d1, n), d1); + | 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 (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)) - | _ => raise(EvaluatorError.Exception(InvalidProjection(n))) - }, - kind: Projection, - value: false, + expr: ListLit([d1', ...ds]) |> fresh, + state_update, + kind: ListCons, + is_value: true, }); - | Cons(d1, d2) => - let. _ = otherwise(env, (d1, d2) => Cons(d1, d2)) - and. d1' = req_final(req(state, env), d1 => Cons1(d1, d2), d1) - and. d2' = req_final(req(state, env), d2 => Cons2(d1, d2), d2); - switch (unbox_list(d2')) { - | ListLit(u, i, ty, ds) => - Step({ - apply: () => ListLit(u, i, ty, [d1', ...ds]), - kind: ListCons, - value: true, - }) - | _ => Indet - }; | ListConcat(d1, d2) => - let. _ = otherwise(env, (d1, d2) => ListConcat(d1, d2)) - and. d1' = req_final(req(state, env), d1 => ListConcat1(d1, d2), d1) - and. d2' = req_final(req(state, env), d2 => ListConcat2(d1, d2), d2); - switch (unbox_list(d1'), unbox_list(d2')) { - | (ListLit(u1, i1, t1, ds1), ListLit(_, _, _, ds2)) => - Step({ - apply: () => ListLit(u1, i1, t1, ds1 @ ds2), - kind: ListConcat, - value: true, - }) - | _ => Indet - }; - | ListLit(u, i, ty, ds) => - let. _ = otherwise(env, ds => ListLit(u, i, ty, ds)) + let. _ = otherwise(env, (d1, d2) => ListConcat(d1, d2) |> rewrap) + 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, + ); + let-unbox ds1 = (List, d1'); + let-unbox ds2 = (List, d2'); + Step({ + expr: ListLit(ds1 @ ds2) |> fresh, + state_update, + kind: ListConcat, + is_value: true, + }); + | ListLit(ds) => + let. _ = otherwise(env, ds => ListLit(ds) |> rewrap) and. _ = req_all_final( req(state, env), - (d1, ds) => ListLit(u, i, ty, d1, ds), + (d1, ds) => ListLit(d1, ds) |> wrap_ctx, 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(d1, rules) => + let. _ = otherwise(env, d1 => Match(d1, rules) |> rewrap) + and. d1 = req_final( req(state, env), - d1 => ConsistentCase(Case(d1, rules, n)), + d1 => MatchScrut(d1, rules) |> wrap_ctx, 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({ + expr: Closure(evaluate_extend_env(env', env), d2) |> fresh, + state_update, + kind: CaseApply, + is_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 => + | Closure(env', d) => + let. _ = otherwise(env, d => Closure(env', d) |> rewrap) + and. d' = + req_final(req(state, env'), d1 => Closure(env', d1) |> wrap_ctx, d); + Step({expr: d', state_update, kind: CompleteClosure, is_value: true}); + | MultiHole(_) => let. _ = otherwise(env, d); + // and. _ = + // req_all_final( + // req(state, env), + // (d1, ds) => MultiHole(d1, ds) |> wrap_ctx, + // ds, + // ); Indet; - | Closure(env', d) => - let. _ = otherwise(env, d => Closure(env', d)) - and. d' = req_final(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)) + | EmptyHole + | Invalid(_) + | DynamicErrorHole(_) => + let. _ = otherwise(env, d); + Indet; + | 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) |> wrap_ctx, d); + switch (Casts.transition(Cast(d', t1, t2) |> rewrap)) { + | Some(d) => Step({expr: d, state_update, kind: Cast, is_value: false}) + | None => Constructor + }; + | FailedCast(d1, t1, t2) => + let. _ = otherwise(env, d1 => FailedCast(d1, t1, t2) |> rewrap) and. _ = req_final( req(state, env), - d1 => NonEmptyHole(reason, u, i, d1), + d1 => FailedCast(d1, t1, t2) |> wrap_ctx, d1, ); Indet; - | Undefined - | EmptyHole(_) - | FreeVar(_) - | InvalidText(_) - | InvalidOperation(_) => + | Undefined => let. _ = otherwise(env, d); Indet; - | Cast(d, t1, t2) => - open CastHelpers; /* Cast calculus */ - - let. _ = otherwise(env, d => Cast(d, t1, t2)) - and. d' = req_final(req(state, env), d => Cast(d, t1, t2), 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 (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), - kind: Cast, - value: false, - }); - } - | _ => Indet - } - | (Hole, NotGroundOrHole(t2_grounded)) => - /* ITExpand rule */ - Step({ - apply: () => - DHExp.Cast(Cast(d', t1, t2_grounded), t2_grounded, t2), - kind: Cast, - value: false, - }) - | (NotGroundOrHole(t1_grounded), Hole) => - /* ITGround rule */ - Step({ - apply: () => - DHExp.Cast(Cast(d', t1, t1_grounded), t1_grounded, t2), - 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; - } - }; - | FailedCast(d1, t1, t2) => - let. _ = otherwise(env, d1 => FailedCast(d1, t1, t2)) - and. _ = req_final(req(state, env), d1 => FailedCast(d1, t1, t2), d1); - Indet; - | Filter(Filter({pat: Closure(_), _}) as f1, d1) - | Filter(Residue(_) as f1, d1) => - let. _ = otherwise(env, d1 => Filter(f1, d1)) - and. d1 = req_final(req(state, env), d1 => Filter(f1, d1), d1); - Step({apply: () => d1, kind: CompleteFilter, value: true}); - | Filter(Filter({pat, act}) as f1, d1) => - let. _ = otherwise(env, Filter(f1, d1)); - Step({ - apply: () => Filter(Filter({pat: Closure(env, pat), act}), d1), - kind: CompleteFilter, - value: false, - }); + | Parens(d) => + let. _ = otherwise(env, d); + Step({expr: d, state_update, kind: RemoveParens, is_value: false}); + | TyAlias(_, _, d) => + let. _ = otherwise(env, d); + 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({expr: d1, state_update, kind: CompleteFilter, is_value: true}); }; + }; }; let should_hide_step_kind = (~settings: CoreSettings.Evaluation.t) => fun | LetBind - | Sequence + | Seq | UpdateTest | TypFunAp | FunAp + | DeferredAp | BuiltinAp(_) | BinBoolOp(_) | BinIntOp(_) | BinFloatOp(_) | BinStringOp(_) + | UnOp(_) | ListCons | 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 | CastTypAp | CastAp | Cast => !settings.show_casts | FixUnwrap => !settings.show_fixpoints - | CaseNext | CompleteClosure | CompleteFilter | BuiltinWrap | FunClosure - | FixClosure => true; + | FixClosure + | RemoveParens => true; diff --git a/src/haz3lcore/dynamics/TypeAssignment.re b/src/haz3lcore/dynamics/TypeAssignment.re index eb24d66990..f4979d94bf 100644 --- a/src/haz3lcore/dynamics/TypeAssignment.re +++ b/src/haz3lcore/dynamics/TypeAssignment.re @@ -1,290 +1,328 @@ open Util; open OptUtil.Syntax; -let equal_typ_list = (l: list(Typ.t)): option(Typ.t) => { - switch (l) { - | [] => None - | [ty, ..._] => - List.fold_left((acc, t) => {acc && Typ.eq(t, ty)}, true, l) - ? Some(ty) : None - }; -}; +// let equal_typ_list = (l: list(Typ.t)): option(Typ.t) => { +// switch (l) { +// | [] => None +// | [ty, ..._] => +// List.fold_left((acc, t) => {acc && Typ.eq(t, ty)}, true, l) +// ? Some(ty) : None +// }; +// }; -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 - | SynTypFun - | SynFun => Some(Unknown(Internal)) - | Ana(ana_ty) => Some(Typ.normalize(ctx, ana_ty)) - } - | _ => None - }; -}; +// 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 +// | SynTypFun +// | SynFun => Some(Unknown(Internal)) +// | Ana(ana_ty) => Some(Typ.normalize(ctx, ana_ty)) +// } +// | _ => None +// }; +// }; let ground = (ty: Typ.t): bool => { - switch (Transition.CastHelpers.ground_cases_of(ty)) { - | Ground => true + switch (Casts.ground_cases_of(ty)) { + | Casts.Ground => true | _ => false }; }; -let dhpat_extend_ctx = - (dhpat: DHPat.t, ty: Typ.t, m: Statics.Map.t, ctx: Ctx.t): option(Ctx.t) => { +let dhpat_extend_ctx = (dhpat: DHPat.t, ty: Typ.t, ctx: Ctx.t): option(Ctx.t) => { let rec dhpat_var_entry = (dhpat: DHPat.t, ty: Typ.t): option(list(Ctx.entry)) => { - switch (dhpat) { + switch (dhpat |> Pat.term_of) { | Var(name) => let entry = Ctx.VarEntry({name, id: Id.invalid, typ: ty}); Some([entry]); | Tuple(l1) => - switch (ty) { - | Prod(l2) when List.length(l1) == List.length(l2) => - let* l = - List.map2((dhp, typ) => {dhpat_var_entry(dhp, typ)}, l1, l2) - |> OptUtil.sequence; - Some(List.concat(l)); - | _ => None - } + let* ts = Typ.matched_prod_strict(ctx, List.length(l1), ty); + let* l = + List.map2((dhp, typ) => {dhpat_var_entry(dhp, typ)}, l1, ts) + |> OptUtil.sequence; + Some(List.concat(l)); | Cons(dhp1, dhp2) => - switch (ty) { - | List(typ) => - let* l1 = dhpat_var_entry(dhp1, typ); - let* l2 = dhpat_var_entry(dhp2, List(typ)); - Some(l1 @ l2); - | _ => None - } - | ListLit(typ1, l) => - switch (ty) { - | List(typ2) when Typ.eq(typ1, typ2) => - let* l = - List.map(dhp => {dhpat_var_entry(dhp, typ1)}, l) - |> OptUtil.sequence; - Some(List.concat(l)); - | _ => None - } - | Ap(Constructor(_, typ), dhp) => - let (ty1, ty2) = Typ.matched_arrow(ctx, typ); + let* t = Typ.matched_list_strict(ctx, ty); + let* l1 = dhpat_var_entry(dhp1, t); + let* l2 = dhpat_var_entry(dhp2, List(t) |> Typ.temp); + Some(l1 @ l2); + | ListLit(l) => + let* t = Typ.matched_list_strict(ctx, ty); + let* l = + List.map(dhp => {dhpat_var_entry(dhp, t)}, l) |> OptUtil.sequence; + Some(List.concat(l)); + | Ap({term: Constructor(name, _), _}, dhp) => + // TODO: make this stricter + let* ctrs = Typ.get_sum_constructors(ctx, ty); + let* typ = ConstructorMap.get_entry(name, ctrs); + let* (ty1, ty2) = Typ.matched_arrow_strict(ctx, typ); Typ.eq(ty2, ty) ? dhpat_var_entry(dhp, ty1) : None; - | EmptyHole(id, _) => - switch (delta_ty(id, m)) { - | None => None - | Some(_) => Some([]) - } - | NonEmptyHole(_, id, _, dhp) => - switch (delta_ty(id, m)) { - | None => None - | Some(_) => dhpat_var_entry(dhp, ty) - } - | Wild - | InvalidText(_) - | BadConstructor(_) => Some([]) | Ap(_) => None - | IntLit(_) => Typ.eq(ty, Int) ? Some([]) : None - | FloatLit(_) => Typ.eq(ty, Float) ? Some([]) : None - | BoolLit(_) => Typ.eq(ty, Bool) ? Some([]) : None - | StringLit(_) => Typ.eq(ty, String) ? Some([]) : None - | Constructor(_, typ) => Typ.eq(ty, typ) ? Some([]) : None + | EmptyHole + | Wild + | Invalid(_) + | MultiHole(_) => Some([]) + | Parens(dhp) => dhpat_var_entry(dhp, ty) + | Int(_) => Typ.eq(ty, Int |> Typ.temp) ? Some([]) : None + | Float(_) => Typ.eq(ty, Float |> Typ.temp) ? Some([]) : None + | Bool(_) => Typ.eq(ty, Bool |> Typ.temp) ? Some([]) : None + | String(_) => Typ.eq(ty, String |> Typ.temp) ? Some([]) : None + | Constructor(_) => Some([]) // TODO: make this stricter + | Cast(dhp, ty1, ty2) => + Typ.eq(ty, ty2) ? dhpat_var_entry(dhp, ty1) : None }; }; let+ l = dhpat_var_entry(dhpat, ty); List.fold_left((ctx, entry) => Ctx.extend(ctx, entry), ctx, l); }; -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) - } - | FreeVar(id, _, _) => delta_ty(id, m) - | InvalidText(_) => Some(Unknown(Internal)) - | InconsistentBranches(_, _, Case(d_scrut, d_rules, _)) => - let* ty' = typ_of_dhexp(ctx, m, d_scrut); - let* typ_cases = - d_rules - |> List.map((DHExp.Rule(dhp, de)) => { - let* ctx = dhpat_extend_ctx(dhp, ty', m, ctx); - typ_of_dhexp(ctx, m, de); - }) - |> OptUtil.sequence; +/* patterns in functions and fixpoints must have a synthesizable type */ +let rec dhpat_synthesize = (dhpat: DHPat.t, ctx: Ctx.t): option(Typ.t) => { + switch (dhpat |> Pat.term_of) { + | Var(_) + | Constructor(_) + | Ap(_) => None + | Tuple(dhs) => + let* l = List.map(dhpat_synthesize(_, ctx), dhs) |> OptUtil.sequence; + Some(Prod(l) |> Typ.temp); + | Cons(dhp1, _) => + let* t = dhpat_synthesize(dhp1, ctx); + Some(List(t) |> Typ.temp); + | ListLit([]) => Some(List(Unknown(Internal) |> Typ.temp) |> Typ.temp) + | ListLit([x, ..._]) => + let* t_x = dhpat_synthesize(x, ctx); + Some(List(t_x) |> Typ.temp); + | EmptyHole => Some(Unknown(Internal) |> Typ.temp) + | Wild => Some(Unknown(Internal) |> Typ.temp) + | Invalid(_) + | MultiHole(_) => Some(Unknown(Internal) |> Typ.temp) + | Parens(dhp) => dhpat_synthesize(dhp, ctx) + | Int(_) => Some(Int |> Typ.temp) + | Float(_) => Some(Float |> Typ.temp) + | Bool(_) => Some(Bool |> Typ.temp) + | String(_) => Some(String |> Typ.temp) + | Cast(_, _, ty) => Some(ty) + }; +}; - //Making sure that there at least one inconsistent branch - switch (equal_typ_list(typ_cases)) { - | None => Some(Typ.Unknown(Internal)) - | Some(_) => None - }; +let rec env_extend_ctx = + (env: ClosureEnvironment.t, m: Statics.Map.t, ctx: Ctx.t) + : option(Ctx.t) => { + let+ l = + env + |> ClosureEnvironment.to_list + |> List.map(((name, de)) => { + let+ ty = typ_of_dhexp(ctx, m, de); + Ctx.VarEntry({name, id: Id.invalid, typ: ty}); + }) + |> OptUtil.sequence; + List.fold_left((ctx, var_entry) => Ctx.extend(ctx, var_entry), ctx, l); +} + +and typ_of_dhexp = (ctx: Ctx.t, m: Statics.Map.t, dh: DHExp.t): option(Typ.t) => { + switch (dh |> DHExp.term_of) { + | Invalid(_) + | MultiHole(_) + | EmptyHole + | Deferral(_) + | Undefined => Some(Unknown(Internal) |> Typ.temp) + | DynamicErrorHole(e, _) => typ_of_dhexp(ctx, m, e) | Closure(env, d) => - let* l = - env - |> ClosureEnvironment.to_list - |> List.map(((name, de)) => { - let+ ty = typ_of_dhexp(ctx, m, de); - Ctx.VarEntry({name, id: Id.invalid, typ: ty}); - }) - |> OptUtil.sequence; - let ctx' = - List.fold_left( - (ctx, var_entry) => Ctx.extend(ctx, var_entry), - ctx, - l, - ); + let* ctx' = env_extend_ctx(env, m, ctx); typ_of_dhexp(ctx', m, d); | Filter(_, d) => typ_of_dhexp(ctx, m, d) - | BoundVar(name) => + | Var(name) => let* var = Ctx.lookup_var(ctx, name); Some(var.typ); - | Sequence(d1, d2) => + | Seq(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); - let* ctx = dhpat_extend_ctx(dhp, ty1, m, ctx); + let* ctx = dhpat_extend_ctx(dhp, ty1, ctx); typ_of_dhexp(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* ctx = dhpat_extend_ctx(dhp, ty1, m, ctx); + | FixF(dhp, d, env) => + let* ty_p = dhpat_synthesize(dhp, ctx); + let* ctx = + switch (env) { + | None => Some(ctx) + | Some(env) => env_extend_ctx(env, m, ctx) + }; + let* ctx = dhpat_extend_ctx(dhp, ty_p, ctx); + typ_of_dhexp(ctx, m, d); + | Fun(dhp, d, env, _) => + let* ty_p = dhpat_synthesize(dhp, ctx); + let* ctx = + switch (env) { + | None => Some(ctx) + | Some(env) => env_extend_ctx(env, m, ctx) + }; + let* ctx = dhpat_extend_ctx(dhp, ty_p, ctx); let* ty2 = typ_of_dhexp(ctx, m, d); - Some(Typ.Arrow(ty1, ty2)); + Some(Typ.Arrow(ty_p, ty2) |> Typ.temp); | TypFun({term: Var(name), _} as utpat, d, _) when !Ctx.shadows_typ(ctx, name) => let 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* ty = typ_of_dhexp(ctx, m, d); - Some(Typ.Forall(name, ty)); + Some(Typ.Forall(utpat, ty) |> Typ.temp); | TypFun(_, d, _) => let* ty = typ_of_dhexp(ctx, m, d); - Some(Typ.Forall("?", ty)); + Some(Typ.Forall(Var("?") |> TPat.fresh, ty) |> Typ.temp); | TypAp(d, ty1) => let* ty = typ_of_dhexp(ctx, m, d); - switch (ty) { - | Forall(name, ty2) => Some(Typ.subst(ty1, name, ty2)) - | _ => None + let* (name, ty2) = Typ.matched_forall_strict(ctx, ty); + switch (name) { + | Some(name) => Some(Typ.subst(ty1, name, ty2)) + | None => Some(ty2) }; - | Ap(d1, d2) => + | Ap(_, d1, d2) => let* ty1 = typ_of_dhexp(ctx, m, d1); let* ty2 = typ_of_dhexp(ctx, m, d2); - switch (ty1) { - | Arrow(tyl, tyr) when Typ.eq(tyl, ty2) => Some(tyr) - | _ => None - }; - | ApBuiltin(name, d) => - let* var = Ctx.lookup_var(ctx, name); - let* ty = typ_of_dhexp(ctx, m, d); - switch (var.typ) { - | Arrow(tyl, tyr) when Typ.eq(tyl, ty) => Some(tyr) - | _ => None + let* (tyl, tyr) = Typ.matched_arrow_strict(ctx, ty1); + Typ.eq(tyl, ty2) ? Some(tyr) : None; + | DeferredAp(d1, d2s) => + let* ty1 = typ_of_dhexp(ctx, m, d1); + let* tys = List.map(typ_of_dhexp(ctx, m), d2s) |> OptUtil.sequence; + let* (tyl, tyr) = Typ.matched_arrow_strict(ctx, ty1); + // TODO: make strict + let tyls = Typ.matched_args(ctx, List.length(tys), tyl); + let* combined = ListUtil.combine_opt(tyls, d2s); + let without_deferrals = + List.filter(((_, d)) => !DHExp.is_deferral(d), combined); + if (List.for_all( + ((t, d)) => { + let ty = typ_of_dhexp(ctx, m, d); + switch (ty) { + | Some(ty) => Typ.eq(t, ty) + | None => false + }; + }, + without_deferrals, + )) { + let with_deferrals = + List.filter(((_, d)) => DHExp.is_deferral(d), combined); + let* tys = + List.map(((_, d)) => typ_of_dhexp(ctx, m, d), with_deferrals) + |> OptUtil.sequence; + switch (tys) { + | [] => Some(tyr) + | [ty] => Some(Typ.Arrow(ty, tyr) |> Typ.temp) + | tys => Some(Typ.Arrow(Prod(tys) |> Typ.temp, tyr) |> Typ.temp) + }; + } else { + None; }; + | BuiltinFun(name) => let* var = Ctx.lookup_var(ctx, name); Some(var.typ); - | Test(_, dtest) => + | 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) => + Typ.eq(ty, Bool |> Typ.temp) ? Some(Typ.Prod([]) |> Typ.temp) : None; + | Bool(_) => Some(Bool |> Typ.temp) + | Int(_) => Some(Int |> Typ.temp) + | Float(_) => Some(Float |> Typ.temp) + | String(_) => Some(String |> Typ.temp) + | BinOp(Bool(_), 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) => + Typ.eq(ty1, Bool |> Typ.temp) && Typ.eq(ty2, Bool |> Typ.temp) + ? Some(Bool |> Typ.temp) : None; + | BinOp(Int(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)) { + if (Typ.eq(ty1, Int |> Typ.temp) && Typ.eq(ty2, Int |> Typ.temp)) { switch (op) { | Minus | Plus | Times | Power - | Divide => Some(Typ.Int) + | Divide => Some(Int |> Typ.temp) | LessThan | LessThanOrEqual | GreaterThan | GreaterThanOrEqual | Equals - | NotEquals => Some(Typ.Bool) + | NotEquals => Some(Bool |> Typ.temp) }; } else { None; }; - | BinFloatOp(op, d1, d2) => + | BinOp(Float(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)) { + if (Typ.eq(ty1, Float |> Typ.temp) && Typ.eq(ty2, Float |> Typ.temp)) { switch (op) { | Minus | Plus | Times | Power - | Divide => Some(Typ.Float) + | Divide => Some(Float |> Typ.temp) | LessThan | LessThanOrEqual | GreaterThan | GreaterThanOrEqual | Equals - | NotEquals => Some(Typ.Bool) + | NotEquals => Some(Bool |> Typ.temp) }; } else { None; }; - | BinStringOp(op, d1, d2) => + | BinOp(String(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)) { + if (Typ.eq(ty1, String |> Typ.temp) && Typ.eq(ty2, String |> Typ.temp)) { switch (op) { - | Concat => Some(Typ.String) - | Equals => Some(Typ.Bool) + | Concat => Some(String |> Typ.temp) + | Equals => Some(Bool |> Typ.temp) }; } else { None; }; - | ListLit(_, _, ty, _) => Some(List(ty)) + | UnOp(Int(Minus), d) => + let* ty = typ_of_dhexp(ctx, m, d); + Typ.eq(ty, Int |> Typ.temp) ? Some(Int |> Typ.temp) : None; + | UnOp(Bool(Not), d) => + let* ty = typ_of_dhexp(ctx, m, d); + Typ.eq(ty, Bool |> Typ.temp) ? Some(Bool |> Typ.temp) : None; + | UnOp(Meta(Unquote), d) => + let* ty = typ_of_dhexp(ctx, m, d); + Some(ty); + | ListLit([]) => Some(List(Unknown(Internal) |> Typ.temp) |> Typ.temp) + | ListLit([x, ...xs]) => + let* t_x = typ_of_dhexp(ctx, m, x); + let* t_xs = List.map(typ_of_dhexp(ctx, m), xs) |> OptUtil.sequence; + List.for_all(t => Typ.eq(t, t_x), t_xs) + ? Some(List(t_x) |> Typ.temp) : None; | Cons(d1, d2) => let* ty1 = typ_of_dhexp(ctx, m, d1); let* ty2 = typ_of_dhexp(ctx, m, d2); - switch (ty2) { - | List(ty3) when Typ.eq(ty3, ty1) => Some(ty2) - | _ => None - }; + let* ty3 = Typ.matched_list_strict(ctx, ty2); + Typ.eq(ty1, ty3) ? Some(ty2) : None; | ListConcat(d1, d2) => let* ty1 = typ_of_dhexp(ctx, m, d1); + let* ty1l = Typ.matched_list_strict(ctx, ty1); let* ty2 = typ_of_dhexp(ctx, m, d2); - switch (ty1, ty2) { - | (List(ty1), List(ty2)) when Typ.eq(ty1, ty2) => Some(Typ.List(ty1)) - | _ => None - }; + let* ty2l = Typ.matched_list_strict(ctx, ty2); + Typ.eq(ty1l, ty2l) ? Some(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) > i => Some(List.nth(l, i)) - | _ => None - }; - | Constructor(_, typ) => Some(typ) - | ConsistentCase(Case(d_scrut, d_rules, _)) => + Prod(typ_list) |> Typ.temp; + | Constructor(_) => None // Constructors should always be surrounded by casts + | Match(_, []) => Some(Unknown(Internal) |> Typ.temp) + | Match(d_scrut, [rule, ...rules]) => let* ty' = typ_of_dhexp(ctx, m, d_scrut); - let* typ_cases: list(Typ.t) = - d_rules - |> List.map((DHExp.Rule(dhp, de)) => { - let* ctx = dhpat_extend_ctx(dhp, ty', m, ctx); - typ_of_dhexp(ctx, m, de); - }) - |> OptUtil.sequence; - equal_typ_list(typ_cases); + let rule_to_ty = ((dhpat, dhexp): (Pat.t, Exp.t)) => { + let* ctx = dhpat_extend_ctx(dhpat, ty', ctx); + typ_of_dhexp(ctx, m, dhexp); + }; + let* rule_ty = rule_to_ty(rule); + let* rules_ty = List.map(rule_to_ty, rules) |> OptUtil.sequence; + List.for_all(Typ.eq(rule_ty, _), rules_ty) ? Some(rule_ty) : None; | Cast(d, ty1, ty2) => let* _ = Typ.join(~fix=true, ctx, ty1, ty2); let* tyd = typ_of_dhexp(ctx, m, d); @@ -296,26 +334,17 @@ let rec typ_of_dhexp = } else { None; } - | InvalidOperation(d, _) => typ_of_dhexp(ctx, m, d) - | 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); - equal_typ_list([ty1, ty2]); - } else { - None; - }; - | IfThenElse(InconsistentIf, d_scrut, d1, d2) => + | If(d_scrut, d1, d2) => let* ty = typ_of_dhexp(ctx, m, d_scrut); - if (Typ.eq(ty, Bool)) { + if (Typ.eq(ty, Bool |> Typ.temp)) { let* ty1 = typ_of_dhexp(ctx, m, d1); let* ty2 = typ_of_dhexp(ctx, m, d2); - Typ.eq(ty1, ty2) ? None : Some(Typ.Unknown(Internal)); + Typ.eq(ty1, ty2) ? Some(ty1) : None; } else { None; }; - | Undefined => Some(Typ.Unknown(Internal)) + | TyAlias(_, _, d) => typ_of_dhexp(ctx, m, d) + | Parens(d) => typ_of_dhexp(ctx, m, d) }; }; diff --git a/src/haz3lcore/dynamics/Unboxing.re b/src/haz3lcore/dynamics/Unboxing.re new file mode 100644 index 0000000000..400620026c --- /dev/null +++ b/src/haz3lcore/dynamics/Unboxing.re @@ -0,0 +1,198 @@ +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) => { + 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) + | (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) + || ConstructorMap.has_bad_entry(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(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 + + /* 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. */ + | ( + _, + Bool(_) | Int(_) | Float(_) | String(_) | Constructor(_) | + BuiltinFun(_) | + Deferral(_) | + DeferredAp(_) | + Fun(_, _, _, Some(_)) | + ListLit(_) | + Tuple(_) | + Cast(_) | + Ap(_, {term: Constructor(_), _}, _) | + TypFun(_) | + TypAp(_), + ) => + 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(_) | Undefined | EmptyHole | MultiHole(_) | DynamicErrorHole(_) | + Var(_) | + Let(_) | + Fun(_, _, _, None) | + FixF(_) | + TyAlias(_) | + Ap(_) | + If(_) | + Seq(_) | + Test(_) | + Filter(_) | + Closure(_) | + Parens(_) | + Cons(_) | + ListConcat(_) | + UnOp(_) | + BinOp(_) | + Match(_), + ) => + IndetMatch + }; + }; diff --git a/src/haz3lcore/dynamics/ValueChecker.re b/src/haz3lcore/dynamics/ValueChecker.re index 4bc7fea3d4..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 @@ -56,6 +55,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) => @@ -71,27 +77,20 @@ module ValueCheckerEVMode: { ((v1, v2), combine(r1, r2)); }; - let update_test = ((), _, _) => (); + let update_test = (_, _, _) => (); }; module CV = Transition(ValueCheckerEVMode); -let rec check_value = ((), env, d) => CV.transition(check_value, (), env, d); +let rec check_value = (state, env, d) => + CV.transition(check_value, state, env, d); -let check_value = check_value(); - -let rec check_value_mod_ctx = ((), env) => - fun - | BoundVar(x) => - check_value_mod_ctx( - (), - env, - ClosureEnvironment.lookup(env, x) - |> OptUtil.get(() => { - print_endline("FreeInvalidVar:" ++ x); - raise(EvaluatorError.Exception(FreeInvalidVar(x))); - }), - ) - | d => CV.transition(check_value_mod_ctx, (), env, d); - -let check_value_mod_ctx = check_value_mod_ctx(); +let rec check_value_mod_ctx = ((), env, d) => + switch (DHExp.term_of(d)) { + | Var(x) => + 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) + }; 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/lang/Form.re b/src/haz3lcore/lang/Form.re index 97719766a0..874ff98f2c 100644 --- a/src/haz3lcore/lang/Form.re +++ b/src/haz3lcore/lang/Form.re @@ -287,7 +287,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, []))), ("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, []))), @@ -315,6 +315,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]))), ("typfun", mk(ds, ["typfun", "->"], mk_pre(P.fun_, Exp, [TPat]))), ("forall", mk(ds, ["forall", "->"], mk_pre(P.fun_, Typ, [TPat]))), ("rec", mk(ds, ["rec", "->"], mk_pre(P.fun_, Typ, [TPat]))), 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/Precedence.re b/src/haz3lcore/lang/Precedence.re index df45604df2..7d72b66404 100644 --- a/src/haz3lcore/lang/Precedence.re +++ b/src/haz3lcore/lang/Precedence.re @@ -13,6 +13,7 @@ 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/haz3lcore/lang/term/Any.re b/src/haz3lcore/lang/term/Any.re new file mode 100644 index 0000000000..b759e67fc9 --- /dev/null +++ b/src/haz3lcore/lang/term/Any.re @@ -0,0 +1 @@ +include Term.Any; diff --git a/src/haz3lcore/lang/term/Cls.re b/src/haz3lcore/lang/term/Cls.re new file mode 100644 index 0000000000..e1acb702c8 --- /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(Typ.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) => 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/Exp.re b/src/haz3lcore/lang/term/Exp.re new file mode 100644 index 0000000000..ff620a0166 --- /dev/null +++ b/src/haz3lcore/lang/term/Exp.re @@ -0,0 +1 @@ +include Term.Exp; diff --git a/src/haz3lcore/lang/term/IdTagged.re b/src/haz3lcore/lang/term/IdTagged.re new file mode 100644 index 0000000000..084a252de4 --- /dev/null +++ b/src/haz3lcore/lang/term/IdTagged.re @@ -0,0 +1,27 @@ +open Util; + +[@deriving (show({with_path: false}), sexp, yojson)] +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. 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, +}; + +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 new_ids = + fun + | {ids: _, term, copied} => {ids: [Id.mk()], term, copied}; diff --git a/src/haz3lcore/lang/term/Pat.re b/src/haz3lcore/lang/term/Pat.re new file mode 100644 index 0000000000..b4bb875bdd --- /dev/null +++ b/src/haz3lcore/lang/term/Pat.re @@ -0,0 +1 @@ +include Term.Pat; diff --git a/src/haz3lcore/lang/term/Rul.re b/src/haz3lcore/lang/term/Rul.re new file mode 100644 index 0000000000..9a293a4270 --- /dev/null +++ b/src/haz3lcore/lang/term/Rul.re @@ -0,0 +1 @@ +include Term.Rul; diff --git a/src/haz3lcore/lang/term/TPat.re b/src/haz3lcore/lang/term/TPat.re new file mode 100644 index 0000000000..3dade36b54 --- /dev/null +++ b/src/haz3lcore/lang/term/TPat.re @@ -0,0 +1,31 @@ +[@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"; diff --git a/src/haz3lcore/lang/term/Typ.re b/src/haz3lcore/lang/term/Typ.re new file mode 100644 index 0000000000..3cb7f47b3c --- /dev/null +++ b/src/haz3lcore/lang/term/Typ.re @@ -0,0 +1,545 @@ +open Util; +open OptUtil.Syntax; + +[@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 + | Forall; + +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 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 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)) => + 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 + | Forall(_) => Forall; + +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" + | Forall => "Forall 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(_) + | 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 + }; +}; + +/* Functions below this point assume that types have been through the to_typ function above */ + +[@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 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 unroll = (ty: t): t => + switch (term_of(ty)) { + | Rec(tp, ty_body) => subst(ty, tp, ty_body) + | _ => 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 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 + 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)) |> temp) + | (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(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) |> temp, tp1, ty1) + | None => ty1 + }; + let+ ty_body = join(~resolve, ~fix, ctx, ty1', ty2); + 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) |> temp, x1, ty1) + | None => ty1 + }; + let+ ty_body = join(~resolve, ~fix, ctx, ty1', ty2); + 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 + 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(ty1) + | (Int, _) => None + | (Float, Float) => Some(ty1) + | (Float, _) => None + | (Bool, Bool) => Some(ty1) + | (Bool, _) => None + | (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) |> temp; + | (Arrow(_), _) => None + | (Prod(tys1), Prod(tys2)) => + let* tys = ListUtil.map2_opt(join', tys1, tys2); + let+ tys = OptUtil.sequence(tys); + Prod(tys) |> temp; + | (Prod(_), _) => None + | (Sum(sm1), Sum(sm2)) => + let+ sm' = ConstructorMap.join(eq, join(~resolve, ~fix, ctx), sm1, sm2); + Sum(sm') |> temp; + | (Sum(_), _) => None + | (List(ty1), List(ty2)) => + let+ ty = join'(ty1, ty2); + List(ty) |> temp; + | (List(_), _) => None + | (Ap(_), _) => failwith("Type join of ap") + }; +}; + +/* REQUIRES NORMALIZED TYPES + 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)) { + | (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(_), _) + | (Forall(_), _) => 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, eq, 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) => + 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) => Parens(normalize(ctx, t)) |> rewrap + | 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(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, tpat), ty)) |> rewrap + | Forall(name, ty) => + Forall(name, normalize(Ctx.extend_dummy_tvar(ctx, name), ty)) |> rewrap + }; +}; + +let rec matched_arrow_strict = (ctx, ty) => + switch (term_of(weak_head_normalize(ctx, ty))) { + | Parens(ty) => matched_arrow_strict(ctx, ty) + | Arrow(ty_in, ty_out) => Some((ty_in, ty_out)) + | Unknown(SynSwitch) => + Some((Unknown(SynSwitch) |> temp, Unknown(SynSwitch) |> temp)) + | _ => None + }; + +let matched_arrow = (ctx, ty) => + matched_arrow_strict(ctx, ty) + |> Option.value( + ~default=(Unknown(Internal) |> temp, Unknown(Internal) |> temp), + ); + +let rec matched_forall_strict = (ctx, ty) => + switch (term_of(weak_head_normalize(ctx, ty))) { + | Parens(ty) => matched_forall_strict(ctx, ty) + | Forall(t, ty) => Some((Some(t), ty)) + | Unknown(SynSwitch) => Some((None, Unknown(SynSwitch) |> temp)) + | _ => None // (None, Unknown(Internal) |> temp) + }; + +let matched_forall = (ctx, ty) => + matched_forall_strict(ctx, ty) + |> Option.value(~default=(None, Unknown(Internal) |> temp)); + +let rec matched_prod_strict = (ctx, length, ty) => + switch (term_of(weak_head_normalize(ctx, ty))) { + | Parens(ty) => matched_prod_strict(ctx, length, ty) + | Prod(tys) when List.length(tys) == length => Some(tys) + | Unknown(SynSwitch) => + Some(List.init(length, _ => Unknown(SynSwitch) |> temp)) + | _ => None + }; + +let matched_prod = (ctx, length, ty) => + matched_prod_strict(ctx, length, ty) + |> Option.value(~default=List.init(length, _ => Unknown(Internal) |> temp)); + +let rec matched_list_strict = (ctx, ty) => + switch (term_of(weak_head_normalize(ctx, ty))) { + | Parens(ty) => matched_list_strict(ctx, ty) + | List(ty) => Some(ty) + | Unknown(SynSwitch) => Some(Unknown(SynSwitch) |> temp) + | _ => None + }; + +let matched_list = (ctx, ty) => + matched_list_strict(ctx, ty) + |> Option.value(~default=Unknown(Internal) |> temp); + +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 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; + 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 rec is_unknown = (ty: t): bool => + switch (ty |> term_of) { + | Parens(x) => is_unknown(x) + | 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/prog/CachedStatics.re b/src/haz3lcore/prog/CachedStatics.re index f918dc73e5..f2bc13d113 100644 --- a/src/haz3lcore/prog/CachedStatics.re +++ b/src/haz3lcore/prog/CachedStatics.re @@ -2,13 +2,13 @@ open Util; [@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], term: Triv}, + term: UExp.{ids: [Id.invalid], copied: false, term: Tuple([])}, info_map: Id.Map.empty, error_ids: [], }; diff --git a/src/haz3lcore/prog/Interface.re b/src/haz3lcore/prog/Interface.re index 91d7237e06..d9f54f5692 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 => { @@ -32,7 +34,7 @@ module Statics = { core.statics ? mk_map_ctx(ctx, exp) : Id.Map.empty; }; -let dh_err = (error: string): DHExp.t => BoundVar(error); +let dh_err = (error: string): DHExp.t => Var(error) |> DHExp.fresh; let elaborate = Core.Memo.general(~cache_size_bound=1000, Elaborator.uexp_elab); @@ -54,9 +56,9 @@ let evaluate = (~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)); diff --git a/src/haz3lcore/prog/ModelResult.re b/src/haz3lcore/prog/ModelResult.re index 5965cd1c52..e8c8980a60 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 = (~settings, elab) => @@ -20,7 +20,7 @@ let update_elab = (~settings, elab) => Evaluation({elab, evaluation: ResultPending, previous: ResultPending}) | Evaluation({evaluation, _}) => Evaluation({elab, evaluation: ResultPending, previous: evaluation}) - | Stepper({elab: elab2, _}) as s when DHExp.fast_equal(elab, elab2) => s + | Stepper(s) as s' when DHExp.fast_equal(elab.d, Stepper.get_elab(s).d) => s' | Stepper(_) => Stepper(Stepper.init(~settings, elab)); let update_stepper = f => @@ -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) => @@ -59,8 +59,12 @@ let toggle_stepper = (~settings) => fun | NoElab => NoElab | Evaluation({elab, _}) => Stepper(Stepper.init(~settings, elab)) - | Stepper({elab, _}) => - Evaluation({elab, evaluation: ResultPending, previous: ResultPending}); + | Stepper(s) => + Evaluation({ + elab: Stepper.get_elab(s), + evaluation: ResultPending, + previous: ResultPending, + }); let test_results = (result: t) => switch (result) { diff --git a/src/haz3lcore/prog/ModelResults.re b/src/haz3lcore/prog/ModelResults.re index 900e9d8f29..a49d287d07 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 update_elabs = (~settings) => @@ -43,7 +43,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 @@ -64,7 +64,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 470d4b1821..58e2e9082e 100644 --- a/src/haz3lcore/prog/ProgramResult.re +++ b/src/haz3lcore/prog/ProgramResult.re @@ -7,7 +7,7 @@ open Util; */ [@deriving (show({with_path: false}), sexp, yojson)] type inner = { - result: EvaluatorResult.t, + result: Evaluator.Result.t, state: EvaluatorState.t, }; @@ -19,10 +19,10 @@ type error = [@deriving (show({with_path: false}), sexp, yojson)] type t = - | Off(DHExp.t) //elab + | Off(Elaborator.Elaboration.t) | ResultOk(inner) | 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/CoCtx.re b/src/haz3lcore/statics/CoCtx.re index 9ffc18645a..3088ef4a28 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/ConstructorMap.re b/src/haz3lcore/statics/ConstructorMap.re index b581c75c8d..bd4ac26195 100644 --- a/src/haz3lcore/statics/ConstructorMap.re +++ b/src/haz3lcore/statics/ConstructorMap.re @@ -2,107 +2,223 @@ open Util.OptUtil.Syntax; open Util; [@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); +// Invariant: Must not have duplicate constructors [@deriving (show({with_path: false}), sexp, yojson)] -type t('a) = list(binding('a)); - -let compare = compare; - -let empty: t('a) = []; - -let is_empty: t('a) => bool = - fun - | [] => 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; +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 { - [(ctr, value), ...tail]; - }; - } else { - [head, ...add(ctr, value, tail)]; - } + [Variant(ctr, ids, value), ...go(xs, List.cons(ctr, seen))]; + } + }; }; + go(with_duplicates, []); +}; -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 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 cardinal: t('a) => int = List.length; +let has_bad_entry = (x: t('a)): bool => + List.exists( + fun + | BadEntry(_) => true + | Variant(_) => false, + x, + ); -let ctrs_of = (m: list((Constructor.t, 'a))): list(Constructor.t) => - List.map(fst, m); +let has_good_entry = (x: t('a)): bool => + List.exists( + fun + | BadEntry(_) => false + | Variant(_) => true, + x, + ); -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 free_variables = (f, m) => + m + |> List.map( + fun + | Variant(_, _, Some(value)) => f(value) + | _ => [], + ) + |> List.flatten; -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 is_ground = is_hole => + fun + | [BadEntry(x)] when is_hole(x) => true + | _ => false; + +/* 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 for_all: (binding('a) => bool, t('a)) => bool = List.for_all; +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(_)) => Some(BadEntry(x)) + | _ => None + }; -let bindings: t('a) => list(binding('a)) = x => x; +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 find_opt = (ctr: Constructor.t, map: t('a)): option('a) => { - let+ binding = List.find_opt(((k, _)) => Constructor.equal(ctr, k), map); - snd(binding); +let match_synswitch = + ( + 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 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 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) + | (Variant(_, _, None), Variant(_, _, None)) => true + | (BadEntry(x), BadEntry(y)) => eq(x, y) + | _ => false + }, + inter, + ) + | _ => false + }; }; -/* sorts on ctrs only */ -let sort = (map: t('a)): t('a) => { - List.fast_sort(compare_bindings, map); +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; +let get_entry = (ctr, m) => + List.find_map( + fun + | Variant(ctr', _, value) when Constructor.equal(ctr, ctr') => value + | Variant(_) + | BadEntry(_) => None, + m, + ); -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 has_constructor_no_args = ctr => + List.exists( + fun + | Variant(ctr', _, None) when Constructor.equal(ctr, ctr') => true + | Variant(_) => false + | BadEntry(_) => false, + ); + +let get_constructors = + List.filter_map( + fun + | Variant(ctr, _, _) => Some(ctr) + | BadEntry(_) => None, + _, + ); let nth = (map: t('a), ctr: Constructor.t): option(int) => { // TODO: use List.find_index instead, which is available for OCaml 5.1 - let ctrs_sorted = map |> sort |> ctrs_of; + let ctrs_sorted = map |> get_constructors |> List.sort(String.compare); List.find_opt( nth => List.nth(ctrs_sorted, nth) == ctr, List.init(List.length(ctrs_sorted), Fun.id), diff --git a/src/haz3lcore/statics/Ctx.re b/src/haz3lcore/statics/Ctx.re index a7ddecd669..9791b6cd0f 100644 --- a/src/haz3lcore/statics/Ctx.re +++ b/src/haz3lcore/statics/Ctx.re @@ -1,4 +1,178 @@ -include TypBase.Ctx; +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, 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(kind) => + List.find_map( + fun + | TVarEntry(v) when v.name == name => Some(v.kind) + | _ => None, + ctx, + ); + +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 + | 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_tvar(ctx, name)) { + | Some(Singleton(_)) => true + | Some(Abstract) + | None => false + }; + +let is_abstract = (ctx: t, name: string): bool => + switch (lookup_tvar(ctx, name)) { + | 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 => + 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_tvar(ctx, name) != None; diff --git a/src/haz3lcore/statics/Info.re b/src/haz3lcore/statics/Info.re index 4c94c0b5d7..8aaaeaae3d 100644 --- a/src/haz3lcore/statics/Info.re +++ b/src/haz3lcore/statics/Info.re @@ -1,6 +1,5 @@ open Util; open OptUtil.Syntax; -open Term; /* INFO.re @@ -143,7 +142,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) @@ -154,7 +153,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)] @@ -177,14 +176,14 @@ type shadow_src = /* Type pattern term errors */ [@deriving (show({with_path: false}), sexp, yojson)] type error_tpat = - | ShadowsType(TypVar.t, shadow_src) + | ShadowsType(string, shadow_src) | 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 = @@ -199,7 +198,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 */ }; @@ -210,9 +209,10 @@ 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: Term.Cls.t, + cls: Cls.t, status: status_pat, ty: Typ.t, constraint_: Constraint.t, @@ -220,28 +220,27 @@ 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: 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 }; @@ -296,10 +295,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) => Typ.rep_id(i.term) + | InfoTPat(i) => TPat.rep_id(i.term) | Secondary(s) => s.id; let error_of: t => option(error) = @@ -326,13 +325,25 @@ 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.temp, Unknown(Internal) |> Typ.temp) + |> Typ.temp, + 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.temp) + |> Typ.temp, + ty, + ) + ) { | Some(_) => NotInHole(Syn(ty)) | None => InHole(Inconsistent(WithArrow(ty))) } @@ -359,9 +370,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.temp)) | (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.temp); switch (Typ.join_fix(ctx, ana, syn)) { | None => InHole(Inconsistent(Expectation({ana, syn}))) | Some(_) => @@ -441,14 +452,11 @@ let rec 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: TermBase.UTyp.t, ty: Typ.t) - : status_typ => - switch (term.term) { - | Invalid(token) => InHole(BadToken(token)) - | EmptyHole => NotInHole(Type(ty)) - | Var(name) - | Constructor(name) => +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) => switch (expects) { | VariantExpected(Unique, sum_ty) | ConstructorExpected(Unique, sum_ty) => @@ -461,20 +469,20 @@ 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.temp)) } | 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) | Constructor(name)) => - NotInHole(Variant(name, Arrow(ty_in, ty_variant))) - | _ => NotInHole(VariantIncomplete(Arrow(ty_in, ty_variant))) - }; + | (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) } @@ -486,7 +494,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) when Ctx.shadows_typ(ctx, name) => @@ -516,8 +524,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 } @@ -531,7 +539,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 @@ -539,6 +547,29 @@ 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.temp + | Inconsistent(Expectation({ana, _})) => ana + | Inconsistent(Internal(_)) => Unknown(Internal) |> Typ.temp // Should this be some sort of meet? + | Inconsistent(WithArrow(_)) => + Arrow(Unknown(Internal) |> Typ.temp, Unknown(Internal) |> Typ.temp) + |> Typ.temp; + +let fixed_typ_err: error_exp => Typ.t = + fun + | FreeVariable(_) => Unknown(Internal) |> Typ.temp + | UnusedDeferral => Unknown(Internal) |> Typ.temp + | BadPartialAp(_) => Unknown(Internal) |> Typ.temp + | InexhaustiveMatch(_) => 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.temp + | Redundant(_) => Unknown(Internal) |> Typ.temp + | Common(err) => fixed_typ_err_common(err); + let fixed_typ_pat = (ctx, mode: Mode.t, self: Self.pat): Typ.t => { // TODO: get rid of unwrapping (probably by changing the implementation of error_exp.Redundant) let self = @@ -547,7 +578,7 @@ let fixed_typ_pat = (ctx, mode: Mode.t, self: Self.pat): Typ.t => { | _ => self }; switch (status_pat(ctx, mode, self)) { - | InHole(_) => Unknown(Internal) + | InHole(err) => fixed_typ_err_pat(err) | NotInHole(ok) => fixed_typ_ok(ok) }; }; @@ -562,9 +593,9 @@ let fixed_constraint_pat = ) : Constraint.t => switch (upat.term) { - | TypeAnn(_) => constraint_ + | Cast(_) => constraint_ | _ => - switch (fixed_typ_pat(ctx, mode, self)) { + switch (fixed_typ_pat(ctx, mode, self) |> Typ.term_of) { | Unknown(_) => Constraint.Hole | _ => constraint_ } @@ -572,7 +603,7 @@ let fixed_constraint_pat = let fixed_typ_exp = (ctx, mode: Mode.t, self: Self.exp): Typ.t => switch (status_exp(ctx, mode, self)) { - | InHole(_) => Unknown(Internal) + | InHole(err) => fixed_typ_err(err) | NotInHole(AnaDeferralConsistent(ana)) => ana | NotInHole(Common(ok)) => fixed_typ_ok(ok) }; @@ -588,7 +619,16 @@ let derived_exp = /* Add derivable attributes for pattern terms */ let derived_pat = - (~upat: UPat.t, ~ctx, ~co_ctx, ~mode, ~ancestors, ~self, ~constraint_) + ( + ~upat: UPat.t, + ~ctx, + ~co_ctx, + ~prev_synswitch, + ~mode, + ~ancestors, + ~self, + ~constraint_, + ) : pat => { let cls = Cls.Pat(UPat.cls_of_term(upat.term)); let status = status_pat(ctx, mode, self); @@ -597,6 +637,7 @@ let derived_pat = { cls, self, + prev_synswitch, mode, ty, status, @@ -613,17 +654,17 @@ 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); - 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 */ -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}; }; @@ -635,13 +676,18 @@ let get_binding_site = (info: t): option(Id.t) => { | InfoExp({term: {term: Var(name), _}, ctx, _}) => let+ entry = Ctx.lookup_var(ctx, name); entry.id; - | InfoExp({term: {term: Constructor(name), _}, ctx, _}) - | InfoPat({term: {term: Constructor(name), _}, ctx, _}) => + | InfoExp({term: {term: Constructor(name, _), _}, ctx, _}) + | InfoPat({term: {term: Constructor(name, _), _}, ctx, _}) => 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 }; }; + +let typ_is_constructor_expected = t => + switch (t) { + | {expects: ConstructorExpected(_) | VariantExpected(_), _} => true + | _ => false + }; 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 2d75787dab..e0736b7da0 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 @@ -102,14 +102,22 @@ 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} => + | {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); -let rec go_s = (s: Sort.t, skel: Skel.t, seg: Segment.t): any => +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))) | TPat => TPat(tpat(unsorted(skel, seg))) @@ -138,18 +146,18 @@ 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, []); - 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) { // 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_wild(t) => ret(Deferral(OutsideAp)) | ([t], []) when Form.is_empty_list(t) => ret(ListLit([])) | ([t], []) when Form.is_bool(t) => ret(Bool(bool_of_string(t))) @@ -159,15 +167,16 @@ and exp_term: unsorted => (UExp.term, list(Id.t)) = { ret(String(Form.strip_quotes(t))) | ([t], []) when Form.is_float(t) => ret(Float(float_of_string(t))) | ([t], []) when Form.is_var(t) => ret(Var(t)) - | ([t], []) when Form.is_ctr(t) => ret(Constructor(t)) + | ([t], []) when Form.is_ctr(t) => + ret(Constructor(t, Unknown(Internal) |> Typ.temp)) | (["(", ")"], [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)) - | (["case", "end"], [Rul({ids, term: Rules(scrut, rules)})]) => ( + | (["case", "end"], [Rul({ids, term: Rules(scrut, rules), _})]) => ( Match(scrut, rules), ids, ) @@ -185,17 +194,18 @@ 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) - | (["typfun", "->"], [TPat(tpat)]) => TypFun(tpat, r) + | (["fun", "->"], [Pat(pat)]) => Fun(pat, r, None, None) + | (["fix", "->"], [Pat(pat)]) => FixF(pat, r, None) + | (["typfun", "->"], [TPat(tpat)]) => TypFun(tpat, 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)]) => @@ -210,10 +220,17 @@ and exp_term: unsorted => (UExp.term, list(Id.t)) = { | ([(_id, t)], []) => switch (t) { | (["()"], []) => - ret(Ap(l, {ids: [Id.nullary_ap_flag], term: Triv})) + ret( + Ap( + Forward, + l, + {ids: [Id.nullary_ap_flag], copied: false, term: Tuple([])}, + ), + ) | (["(", ")"], [Exp(arg)]) => let use_deferral = (arg: UExp.t): UExp.t => { ids: arg.ids, + copied: false, term: Deferral(InAp), }; switch (arg.term) { @@ -229,7 +246,7 @@ and exp_term: unsorted => (UExp.term, list(Id.t)) = { ), arg.ids, ) - | _ => ret(Ap(l, arg)) + | _ => ret(Ap(Forward, l, arg)) }; | (["@<", ">"], [Typ(ty)]) => ret(TypAp(l, ty)) | _ => ret(hole(tm)) @@ -272,7 +289,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, r, l) | (["@"], []) => ListConcat(l, r) | _ => hole(tm) }, @@ -285,18 +302,18 @@ 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, []); - 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) { | ([(_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)) @@ -307,7 +324,8 @@ and pat_term: unsorted => (UPat.term, list(Id.t)) = { String(s); | ([t], []) when Form.is_var(t) => Var(t) | ([t], []) when Form.is_wild(t) => Wild - | ([t], []) when Form.is_ctr(t) => Constructor(t) + | ([t], []) when Form.is_ctr(t) => + Constructor(t, Unknown(Internal) |> Typ.fresh) | ([t], []) when t != " " && !Form.is_explicit_hole(t) => Invalid(t) | (["(", ")"], [Pat(body)]) => Parens(body) @@ -335,7 +353,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 => @@ -352,18 +371,18 @@ 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, []); - 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) { | ([(_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 @@ -372,7 +391,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) }, ) @@ -390,7 +409,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) @@ -398,18 +417,24 @@ 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 => 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)) @@ -421,11 +446,11 @@ 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 => 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) { @@ -449,8 +474,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) { @@ -460,17 +485,18 @@ and rul = (unsorted: unsorted): URul.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} }; } 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/Mode.re b/src/haz3lcore/statics/Mode.re index 441d3964b6..5a85dbecd9 100644 --- a/src/haz3lcore/statics/Mode.re +++ b/src/haz3lcore/statics/Mode.re @@ -30,9 +30,13 @@ 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)) - | SynTypFun => Forall("syntypfun", Unknown(SynSwitch)); /* TODO: naming the type variable? */ + | Syn => Unknown(SynSwitch) |> Typ.temp + | SynFun => + Arrow(Unknown(SynSwitch) |> Typ.temp, Unknown(SynSwitch) |> Typ.temp) + |> Typ.temp + | SynTypFun => + 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) { @@ -42,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 @@ -51,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.temp, name_expected, item)) | _ => Ana(item) }; }; @@ -76,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)) - | Ana(ty) => Ana(List(Typ.matched_list(ctx, ty))) + | 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 => @@ -92,8 +96,8 @@ let of_list_concat = (ctx: Ctx.t, mode: t): t => switch (mode) { | Syn | SynFun - | SynTypFun => Ana(List(Unknown(SynSwitch))) - | Ana(ty) => Ana(List(Typ.matched_list(ctx, ty))) + | 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) => @@ -104,13 +108,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); + 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) + | Some(ty_in) => Arrow(ty_in, ty_ana) |> Typ.temp }; | _ => None }; @@ -118,14 +122,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.temp, ty_ana) |> Typ.temp)) | None => None }; @@ -148,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)) + ? ty_ins : List.init(length, _ => Typ.Unknown(Internal) |> Typ.temp) ) |> List.map(ty => Ana(ty)); diff --git a/src/haz3lcore/statics/Self.re b/src/haz3lcore/statics/Self.re index 6abd4c2672..cece7d2b0b 100644 --- a/src/haz3lcore/statics/Self.re +++ b/src/haz3lcore/statics/Self.re @@ -50,7 +50,7 @@ type error_partial_ap = type exp = | Free(Var.t) | InexhaustiveMatch(exp) - | IsDeferral(Term.UExp.deferral_position) + | IsDeferral(Exp.deferral_position) | IsBadPartialAp(error_partial_ap) | Common(t); @@ -62,7 +62,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 @@ -119,22 +119,24 @@ 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)); }; }; 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) }; @@ -142,11 +144,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 14b87eb4ab..e521e12167 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. @@ -68,7 +66,7 @@ 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 rec is_arrow_like = (t: Typ.t) => { - switch (t) { + switch (t |> Typ.term_of) { | Unknown(_) => true | Arrow(_) => true | Forall(_, t) => is_arrow_like(t) @@ -77,57 +75,69 @@ let rec is_arrow_like = (t: Typ.t) => { }; 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)) { + let norm = Typ.normalize(ctx, syn); + switch (norm |> Typ.term_of) { | Prod(syns) when List.length(syns) == num_vars => syns |> List.for_all(is_arrow_like) - | t when is_arrow_like(t) => num_vars == 1 + | _ when is_arrow_like(norm) => num_vars == 1 | _ => false - } + }; | _ => false }; }; -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 + | (Plus | Minus | Times | Power | Divide) as _op => Int |> Typ.temp | ( LessThan | GreaterThan | LessThanOrEqual | GreaterThanOrEqual | Equals | NotEquals ) as _op => - Bool; + Bool |> Typ.temp; -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 + | (Plus | Minus | Times | Power | Divide) as _op => Float |> Typ.temp | ( LessThan | GreaterThan | LessThanOrEqual | GreaterThanOrEqual | Equals | NotEquals ) as _op => - Bool; + Bool |> Typ.temp; -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; + | Concat => String |> Typ.temp + | Equals => Bool |> Typ.temp; -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)); + | 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.temp, + Float |> Typ.temp, + typ_exp_binop_bin_float(op), + ) + | String(op) => ( + String |> Typ.temp, + String |> Typ.temp, + 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); + | Meta(Unquote) => ( + Var("$Meta") |> Typ.temp, + Unknown(Internal) |> Typ.temp, + ) + | 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, 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) = @@ -172,14 +182,14 @@ 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) => { /* 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) => { @@ -211,26 +221,34 @@ 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); + | 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); | Invalid(token) => atomic(BadToken(token)) - | EmptyHole => atomic(Just(Unknown(Internal))) - | Triv => atomic(Just(Prod([]))) + | EmptyHole => atomic(Just(Unknown(Internal) |> Typ.temp)) | Deferral(position) => add'(~self=IsDeferral(position), ~co_ctx=CoCtx.empty, m) - | Undefined => atomic(Just(Unknown(TypeHole))) - | Bool(_) => atomic(Just(Bool)) - | Int(_) => atomic(Just(Int)) - | Float(_) => atomic(Just(Float)) - | String(_) => atomic(Just(String)) + | Undefined => atomic(Just(Unknown(Hole(EmptyHole)) |> Typ.temp)) + | 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); 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.temp, ctx, tys, ids), ~co_ctx=CoCtx.union(List.map(Info.exp_co_ctx, es)), m, ); @@ -238,13 +256,13 @@ 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.temp), ~co_ctx=CoCtx.union([hd.co_ctx, tl.co_ctx]), m, ); | ListConcat(e1, e2) => let mode = Mode.of_list_concat(ctx, mode); - let ids = List.map(Term.UExp.rep_id, [e1, e2]); + let ids = List.map(UExp.rep_id, [e1, e2]); let (e1, m) = go(~mode, e1, m); let (e2, m) = go(~mode, e2, m); add( @@ -258,21 +276,23 @@ and uexp_to_info_map = ~co_ctx=CoCtx.singleton(name, UExp.rep_id(uexp), Mode.ty_of(mode)), m, ) + | DynamicErrorHole(e, _) | Parens(e) => let (e, m) = go(~mode, e, m); add(~self=Just(e.ty), ~co_ctx=e.co_ctx, m); | 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") - | Var("v") => UExp.Constructor("$v") + | Var("e") => UExp.Constructor("$e", Unknown(Internal) |> Typ.temp) + | Var("v") => UExp.Constructor("$v", Unknown(Internal) |> Typ.temp) | _ => e.term }, }; - let ty_in = Typ.Var("$Meta"); - let ty_out = Typ.Unknown(Internal); + 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) => @@ -284,18 +304,24 @@ 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); add( - ~self=Just(Prod(List.map(Info.exp_ty, es))), + ~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), e, m); - add(~self=Just(Prod([])), ~co_ctx=e.co_ctx, m); - | Filter(_, cond, body) => + 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=Syn, cond, m, ~is_in_filter=true); let (body, m) = go(~mode, body, m); add( @@ -303,20 +329,22 @@ 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); 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) => + | Constructor(ctr, _) => atomic(Self.of_ctr(ctx, ctr)) + | 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); 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.temp) ? BadTrivAp(ty_in) : Just(ty_out); add(~self, ~co_ctx=CoCtx.union([fn.co_ctx, arg.co_ctx]), m); | TypAp(fn, utyp) => @@ -324,10 +352,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 = Term.UTyp.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) => @@ -341,7 +368,7 @@ and uexp_to_info_map = let (args, m) = map_m_go(m, modes, args); let arg_co_ctx = CoCtx.union(List.map(Info.exp_co_ctx, args)); 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); @@ -350,27 +377,33 @@ and uexp_to_info_map = let (p, m) = go_pat(~is_synswitch=false, ~co_ctx=e.co_ctx, ~mode=mode_pat, p, m); // TODO: factor out code - let unwrapped_self: Self.exp = Common(Just(Arrow(p.ty, e.ty))); + let unwrapped_self: Self.exp = + Common(Just(Arrow(p.ty, e.ty) |> Typ.temp)); let is_exhaustive = p |> Info.pat_constraint |> Incon.is_exhaustive; let self = is_exhaustive ? unwrapped_self : InexhaustiveMatch(unwrapped_self); add'(~self, ~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.temp), + ~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.temp), + ~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); @@ -403,16 +436,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.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); (def, def_ctx, m, ty_p_ana); @@ -438,9 +475,20 @@ 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); + 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( @@ -477,13 +525,13 @@ and uexp_to_info_map = let unwrapped_self: Self.exp = Common(Self.match(ctx, e_tys, branch_ids)); let constraint_ty = - switch (scrut.ty) { + switch (scrut.ty.term) { | Unknown(_) => map_m(go_pat(~is_synswitch=false, ~co_ctx=CoCtx.empty), ps, m) |> fst |> List.map(Info.pat_ty) - |> Typ.join_all(~empty=Unknown(Internal), ctx) - | ty => Some(ty) + |> Typ.join_all(~empty=Unknown(Internal) |> Typ.temp, ctx) + | _ => Some(scrut.ty) }; let (self, m) = switch (constraint_ty) { @@ -520,6 +568,7 @@ and uexp_to_info_map = ~co_ctx=p.co_ctx, ~mode=p.mode, ~ancestors=p.ancestors, + ~prev_synswitch=None, ~self, // Mark patterns as redundant at the top level // because redundancy doesn't make sense in a smaller context @@ -571,20 +620,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, name), 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(name, ty_pre); + let ty_rec = + Typ.Rec(TPat.Var(name) |> IdTagged.fresh, utyp) |> Typ.temp; 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)); - }; + | _ => ( + 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. */ @@ -598,6 +648,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)) { @@ -607,7 +658,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(_) @@ -628,13 +679,21 @@ 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) => { let add = (~self, ~ctx, ~constraint_, 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, @@ -648,7 +707,7 @@ and upat_to_info_map = let atomic = (self, constraint_) => add(~self, ~ctx, ~constraint_, m); let ancestors = [UPat.rep_id(upat)] @ ancestors; let go = upat_to_info_map(~is_synswitch, ~ancestors, ~co_ctx); - let unknown = Typ.Unknown(is_synswitch ? SynSwitch : Internal); + let unknown = Typ.Unknown(is_synswitch ? SynSwitch : Internal) |> Typ.temp; let ctx_fold = (ctx: Ctx.t, m) => List.fold_left2( ((ctx, tys, cons, m), e, mode) => @@ -670,17 +729,19 @@ and upat_to_info_map = add(~self=IsMulti, ~ctx, ~constraint_=Constraint.Hole, m); | Invalid(token) => hole(BadToken(token)) | EmptyHole => hole(Just(unknown)) - | Int(int) => atomic(Just(Int), Constraint.Int(int)) - | Float(float) => atomic(Just(Float), Constraint.Float(float)) - | Triv => atomic(Just(Prod([])), Constraint.Truth) + | Int(int) => atomic(Just(Int |> Typ.temp), Constraint.Int(int)) + | Float(float) => + atomic(Just(Float |> Typ.temp), Constraint.Float(float)) + | Tuple([]) => atomic(Just(Prod([]) |> Typ.temp), Constraint.Truth) | Bool(bool) => atomic( - Just(Bool), + Just(Bool |> Typ.temp), bool ? Constraint.InjL(Constraint.Truth) : Constraint.InjR(Constraint.Truth), ) - | String(string) => atomic(Just(String), Constraint.String(string)) + | String(string) => + atomic(Just(String |> Typ.temp), Constraint.String(string)) | ListLit(ps) => let ids = List.map(UPat.rep_id, ps); let modes = Mode.of_list_lit(ctx, List.length(ps), mode); @@ -702,7 +763,7 @@ and upat_to_info_map = let (tl, m) = go(~ctx=hd.ctx, ~mode=Mode.of_cons_tl(ctx, mode, hd.ty), tl, m); add( - ~self=Just(List(hd.ty)), + ~self=Just(List(hd.ty) |> Typ.temp), ~ctx=tl.ctx, ~constraint_= Constraint.InjR(Constraint.Pair(hd.constraint_, tl.constraint_)), @@ -714,7 +775,11 @@ and upat_to_info_map = 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.temp)), + ); let entry = Ctx.VarEntry({name, id: UPat.rep_id(upat), typ: ctx_typ}); add( ~self=Just(unknown), @@ -732,7 +797,7 @@ and upat_to_info_map = | [hd, ...tl] => Constraint.Pair(hd, cons_fold_tuple(tl)) }; add( - ~self=Just(Prod(tys)), + ~self=Just(Prod(tys) |> Typ.temp), ~ctx, ~constraint_=cons_fold_tuple(cons), m, @@ -740,7 +805,7 @@ and upat_to_info_map = | Parens(p) => let (p, m) = go(~ctx, ~mode, p, m); add(~self=Just(p.ty), ~ctx=p.ctx, ~constraint_=p.constraint_, m); - | Constructor(ctr) => + | Constructor(ctr, _) => let self = Self.of_ctr(ctx, ctr); atomic(self, Constraint.of_ctr(ctx, mode, ctr, self)); | Ap(fn, arg) => @@ -756,10 +821,10 @@ and upat_to_info_map = Constraint.of_ap(ctx, mode, ctr, arg.constraint_, Some(ty_out)), 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, ~constraint_=p.constraint_, m); + let (p, m) = go(~ctx, ~mode=Ana(ann.term), p, m); + add(~self=Just(ann.term), ~ctx=p.ctx, ~constraint_=p.constraint_, m); }; } and utyp_to_info_map = @@ -767,7 +832,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) => { @@ -780,17 +845,15 @@ 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 | String => add(m) - | Var(_) - | Constructor(_) => + | Var(_) => /* Names are resolved in Info.status_typ */ add(m) | List(t) @@ -799,35 +862,34 @@ 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) => - 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)) - | _ => ConstructorExpected(Unique, Arrow(ty_in, Unknown(Internal))) + ConstructorExpected(m, Arrow(t2, sum_ty) |> Typ.temp) + | _ => + ConstructorExpected( + Unique, + 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, ); 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, @@ -847,10 +909,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, @@ -871,13 +930,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); @@ -888,7 +947,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) => @@ -901,7 +966,7 @@ and variant_to_info_map = List.mem(ctr, ctrs) ? Duplicate : Unique, ty_sum, ), - {term: Constructor(ctr), ids}, + {term: Var(ctr), ids, copied: false}, m, ) |> snd; @@ -914,6 +979,40 @@ 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 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/Term.re b/src/haz3lcore/statics/Term.re index f967142a2d..0493150865 100644 --- a/src/haz3lcore/statics/Term.re +++ b/src/haz3lcore/statics/Term.re @@ -1,249 +1,4 @@ -/* 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 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 binding name" - | MultiHole => "Broken type binding" - | EmptyHole => "Empty type binding hole" - | Var => "Type binding"; - - let tyvar_of_utpat = ({ids: _, term}) => - switch (term) { - | Var(x) => Some(x) - | _ => None - }; -}; - -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 - | Forall - | Rec; - - 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 - | Forall(_) => Forall - | Rec(_) => Rec; - - 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" - | Forall => "Forall Type" - | Rec => "Recursive Type"; - - 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(_) - | Forall(_) - | Rec(_) => false - }; - }; - - let rec is_forall = (typ: t) => { - switch (typ.term) { - | Parens(typ) => is_forall(typ) - | Forall(_) => true - | Invalid(_) - | EmptyHole - | MultiHole(_) - | Int - | Float - | Bool - | String - | Arrow(_) - | List(_) - | Tuple(_) - | Var(_) - | Constructor(_) - | Ap(_) - | Sum(_) - | Rec(_) => 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) - | Forall({term: Var(name), _} as utpat, tbody) => - let ctx = - Ctx.extend_tvar( - ctx, - {name, id: UTPat.rep_id(utpat), kind: Abstract}, - ); - Forall(name, to_typ(ctx, tbody)); - // Rec is same as Forall - | Rec({term: Var(name), _} as utpat, tbody) => - let ctx = - Ctx.extend_tvar( - ctx, - {name, id: UTPat.rep_id(utpat), kind: Abstract}, - ); - Rec(name, to_typ(ctx, tbody)); - | Forall({term: Invalid(_), _}, tbody) - | Forall({term: EmptyHole, _}, tbody) - | Forall({term: MultiHole(_), _}, tbody) => - Forall("?", to_typ(ctx, tbody)) - | Rec({term: Invalid(_), _}, tbody) - | Rec({term: EmptyHole, _}, tbody) - | Rec({term: MultiHole(_), _}, tbody) => Rec("?", to_typ(ctx, tbody)) - /* 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 UPat = { +module Pat = { [@deriving (show({with_path: false}), sexp, yojson)] type cls = | Invalid @@ -254,7 +9,6 @@ module UPat = { | Float | Bool | String - | Triv | ListLit | Constructor | Cons @@ -262,16 +16,22 @@ module UPat = { | Tuple | Parens | Ap - | TypeAnn; + | Cast; - include TermBase.UPat; + include TermBase.Pat; let rep_id = ({ids, _}: t) => { assert(ids != []); List.hd(ids); }; - let hole = (tms: list(any)) => + let term_of: t => TermBase.Pat.term = IdTagged.term_of; + + let unwrap: t => (term, term => t) = IdTagged.unwrap; + + let fresh: term => t = IdTagged.fresh; + + let hole = (tms: list(TermBase.Any.t)) => switch (tms) { | [] => EmptyHole | [_, ..._] => MultiHole(tms) @@ -287,7 +47,6 @@ module UPat = { | Float(_) => Float | Bool(_) => Bool | String(_) => String - | Triv => Triv | ListLit(_) => ListLit | Constructor(_) => Constructor | Cons(_) => Cons @@ -295,7 +54,7 @@ module UPat = { | Tuple(_) => Tuple | Parens(_) => Parens | Ap(_) => Ap - | TypeAnn(_) => TypeAnn; + | Cast(_) => Cast; let show_cls: cls => string = fun @@ -307,7 +66,6 @@ module UPat = { | Float => "Float literal" | Bool => "Boolean literal" | String => "String literal" - | Triv => "Trivial literal" | ListLit => "List literal" | Constructor => "Constructor" | Cons => "Cons" @@ -315,12 +73,12 @@ module UPat = { | Tuple => "Tuple" | Parens => "Parenthesized pattern" | Ap => "Constructor application" - | TypeAnn => "Annotation"; + | Cast => "Annotation"; let rec is_var = (pat: t) => { switch (pat.term) { | Parens(pat) - | TypeAnn(pat, _) => is_var(pat) + | Cast(pat, _, _) => is_var(pat) | Var(_) => true | Invalid(_) | EmptyHole @@ -330,7 +88,6 @@ module UPat = { | Float(_) | Bool(_) | String(_) - | Triv | ListLit(_) | Cons(_, _) | Tuple(_) @@ -342,8 +99,8 @@ module UPat = { 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) || UTyp.is_forall(typ)) + | Cast(pat, typ, _) => + is_var(pat) && (UTyp.is_arrow(typ) || Typ.is_forall(typ)) | Invalid(_) | EmptyHole | MultiHole(_) @@ -352,7 +109,6 @@ module UPat = { | Float(_) | Bool(_) | String(_) - | Triv | ListLit(_) | Cons(_, _) | Var(_) @@ -376,11 +132,10 @@ module UPat = { | Float(_) | Bool(_) | String(_) - | Triv | ListLit(_) | Cons(_, _) | Var(_) - | TypeAnn(_) + | Cast(_) | Constructor(_) | Ap(_) => false } @@ -391,7 +146,7 @@ module UPat = { || ( switch (pat.term) { | Parens(pat) - | TypeAnn(pat, _) => is_tuple_of_vars(pat) + | Cast(pat, _, _) => is_tuple_of_vars(pat) | Tuple(pats) => pats |> List.for_all(is_var) | Invalid(_) | EmptyHole @@ -401,7 +156,6 @@ module UPat = { | Float(_) | Bool(_) | String(_) - | Triv | ListLit(_) | Cons(_, _) | Var(_) @@ -412,9 +166,9 @@ module UPat = { let rec get_var = (pat: t) => { switch (pat.term) { - | Parens(pat) - | TypeAnn(pat, _) => get_var(pat) + | Parens(pat) => get_var(pat) | Var(x) => Some(x) + | Cast(x, _, _) => get_var(x) | Invalid(_) | EmptyHole | MultiHole(_) @@ -423,7 +177,6 @@ module UPat = { | Float(_) | Bool(_) | String(_) - | Triv | ListLit(_) | Cons(_, _) | Tuple(_) @@ -435,8 +188,8 @@ module UPat = { let rec get_fun_var = (pat: t) => { switch (pat.term) { | Parens(pat) => get_fun_var(pat) - | TypeAnn(pat, typ) => - if (UTyp.is_arrow(typ) || UTyp.is_forall(typ)) { + | Cast(pat, t1, _) => + if (Typ.is_arrow(t1) || UTyp.is_forall(t1)) { get_var(pat) |> Option.map(var => var); } else { None; @@ -449,7 +202,6 @@ module UPat = { | Float(_) | Bool(_) | String(_) - | Triv | ListLit(_) | Cons(_, _) | Var(_) @@ -459,15 +211,20 @@ module UPat = { }; }; - let rec get_num_of_vars = (pat: t) => - if (is_var(pat)) { - Some(1); - } else { + let rec get_bindings = (pat: t) => + switch (get_var(pat)) { + | Some(x) => Some([x]) + | None => switch (pat.term) { | Parens(pat) - | TypeAnn(pat, _) => get_num_of_vars(pat) + | Cast(pat, _, _) => get_bindings(pat) | Tuple(pats) => - is_tuple_of_vars(pat) ? Some(List.length(pats)) : None + let vars = pats |> List.map(get_var); + if (List.exists(Option.is_none, vars)) { + None; + } else { + Some(List.map(Option.get, vars)); + }; | Invalid(_) | EmptyHole | MultiHole(_) @@ -476,29 +233,23 @@ module UPat = { | Float(_) | Bool(_) | String(_) - | Triv | ListLit(_) | Cons(_, _) | Var(_) | Constructor(_) | Ap(_) => None - }; + } }; - let rec get_bindings = (pat: t) => - switch (get_var(pat)) { - | Some(x) => Some([x]) - | None => + let rec get_num_of_vars = (pat: t) => + if (is_var(pat)) { + Some(1); + } else { switch (pat.term) { | Parens(pat) - | TypeAnn(pat, _) => get_bindings(pat) + | Cast(pat, _, _) => get_num_of_vars(pat) | Tuple(pats) => - let vars = pats |> List.map(get_var); - if (List.exists(Option.is_none, vars)) { - None; - } else { - Some(List.map(Option.get, vars)); - }; + is_tuple_of_vars(pat) ? Some(List.length(pats)) : None | Invalid(_) | EmptyHole | MultiHole(_) @@ -507,31 +258,32 @@ module UPat = { | Float(_) | Bool(_) | String(_) - | Triv | ListLit(_) | Cons(_, _) | Var(_) | Constructor(_) | Ap(_) => None - } + }; }; let ctr_name = (p: t): option(Constructor.t) => switch (p.term) { - | Constructor(name) => Some(name) + | Constructor(name, _) => Some(name) | _ => None }; }; -module UExp = { - include TermBase.UExp; +module Exp = { + include TermBase.Exp; [@deriving (show({with_path: false}), sexp, yojson)] type cls = | Invalid | EmptyHole | MultiHole - | Triv + | StaticErrorHole + | DynamicErrorHole + | FailedCast | Deferral | Undefined | Bool @@ -546,6 +298,7 @@ module UExp = { | Var | MetaVar | Let + | FixF | TyAlias | Ap | TypAp @@ -555,30 +308,33 @@ module UExp = { | Seq | Test | Filter + | Closure | Parens | Cons - | UnOp(op_un) - | BinOp(op_bin) + | UnOp(Operators.op_un) + | BinOp(Operators.op_bin) + | BuiltinFun | Match + | Cast | ListConcat; - let hole = (tms: list(any)): term => + let hole = (tms: list(TermBase.Any.t)): term => switch (tms) { | [] => EmptyHole | [_, ..._] => MultiHole(tms) }; - let rep_id = ({ids, _}) => { - assert(ids != []); - List.hd(ids); - }; + 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 | Invalid(_) => Invalid | EmptyHole => EmptyHole | MultiHole(_) => MultiHole - | Triv => Triv + | DynamicErrorHole(_) => DynamicErrorHole + | FailedCast(_) => FailedCast | Deferral(_) => Deferral | Undefined => Undefined | Bool(_) => Bool @@ -592,91 +348,33 @@ module UExp = { | Tuple(_) => Tuple | Var(_) => Var | Let(_) => Let + | FixF(_) => FixF | TyAlias(_) => TyAlias | Ap(_) => Ap | TypAp(_) => TypAp | DeferredAp(_) => DeferredAp - | Pipeline(_) => Pipeline | If(_) => If | Seq(_) => Seq | Test(_) => Test | Filter(_) => Filter + | Closure(_) => Closure | Parens(_) => Parens | Cons(_) => Cons | ListConcat(_) => ListConcat | UnOp(op, _) => UnOp(op) | BinOp(op, _, _) => BinOp(op) - | Match(_) => Match; - - 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); + | BuiltinFun(_) => BuiltinFun + | Match(_) => Match + | Cast(_) => Cast; let show_cls: cls => string = fun | Invalid => "Invalid expression" | MultiHole => "Broken expression" | EmptyHole => "Empty expression hole" - | Triv => "Trivial literal" + | StaticErrorHole => "Static error hole" + | DynamicErrorHole => "Dynamic error hole" + | FailedCast => "Failed cast" | Deferral => "Deferral" | Undefined => "Undefined expression" | Bool => "Boolean literal" @@ -691,6 +389,7 @@ module UExp = { | Var => "Variable reference" | MetaVar => "Meta variable reference" | Let => "Let expression" + | FixF => "Fixpoint operator" | TyAlias => "Type Alias definition" | Ap => "Application" | TypAp => "Type application" @@ -700,24 +399,30 @@ module UExp = { | 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) - | Match => "Case expression"; + | BinOp(op) => Operators.show_binop(op) + | UnOp(op) => Operators.show_unop(op) + | BuiltinFun => "Built-in Function" + | Match => "Case expression" + | Cast => "Cast expression"; // Typfun should be treated as a function here as this is only used to // determine when to allow for recursive definitions in a let binding. let rec is_fun = (e: t) => { switch (e.term) { | Parens(e) => is_fun(e) + | Cast(e, _, _) => is_fun(e) | TypFun(_) - | Fun(_) => true + | Fun(_) + | BuiltinFun(_) => true | Invalid(_) | EmptyHole | MultiHole(_) - | Triv + | DynamicErrorHole(_) + | FailedCast(_) | Deferral(_) | Undefined | Bool(_) @@ -728,17 +433,18 @@ module UExp = { | Tuple(_) | Var(_) | Let(_) + | FixF(_) | TyAlias(_) | Ap(_) | TypAp(_) | DeferredAp(_) - | Pipeline(_) | If(_) | Seq(_) | Test(_) | Filter(_) | Cons(_) | ListConcat(_) + | Closure(_) | UnOp(_) | BinOp(_) | Match(_) @@ -750,12 +456,14 @@ 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(_) | EmptyHole | MultiHole(_) - | Triv + | DynamicErrorHole(_) + | FailedCast(_) | Deferral(_) | Undefined | Bool(_) @@ -765,13 +473,15 @@ module UExp = { | ListLit(_) | Fun(_) | TypFun(_) + | Closure(_) + | BuiltinFun(_) | Var(_) | Let(_) + | FixF(_) | TyAlias(_) | Ap(_) | TypAp(_) | DeferredAp(_) - | Pipeline(_) | If(_) | Seq(_) | Test(_) @@ -787,7 +497,7 @@ module UExp = { let ctr_name = (e: t): option(Constructor.t) => switch (e.term) { - | Constructor(name) => Some(name) + | Constructor(name, _) => Some(name) | _ => None }; @@ -808,7 +518,12 @@ module UExp = { | Invalid(_) | EmptyHole | MultiHole(_) - | Triv + | DynamicErrorHole(_) + | FailedCast(_) + | FixF(_) + | Closure(_) + | BuiltinFun(_) + | Cast(_) | Deferral(_) | Undefined | Bool(_) @@ -825,7 +540,6 @@ module UExp = { | Ap(_) | TypAp(_) | DeferredAp(_) - | Pipeline(_) | If(_) | Seq(_) | Test(_) @@ -839,9 +553,8 @@ module UExp = { }; }; -// TODO(d): consider just folding this into UExp -module URul = { - include TermBase.URul; +module Rul = { + include TermBase.Rul; [@deriving (show({with_path: false}), sexp, yojson)] type cls = @@ -850,7 +563,7 @@ module URul = { // 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 | [] => @@ -863,59 +576,55 @@ module URul = { let rep_id = (~any_ids, tm) => switch (ids(~any_ids, tm)) { - | [] => raise(Invalid_argument("Term.UExp.rep_id")) + | [] => raise(Invalid_argument("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) - }; -}; +module Any = { + include TermBase.Any; -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")); + 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.Typ.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) => Typ.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/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index 0d8f57c77d..f0585955c6 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -1,139 +1,131 @@ open Util; -module rec Any: { - [@deriving (show({with_path: false}), sexp, yojson)] - type t = - | Exp(UExp.t) - | Pat(UPat.t) - | Typ(UTyp.t) - | TPat(UTPat.t) - | Rul(URul.t) - | Nul(unit) - | Any(unit); +let continue = x => x; +let stop = (_, x) => x; - 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) - | Nul(unit) - | Any(unit); +/* + 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... - 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; + Each module has: - [@deriving (show({with_path: false}), sexp, yojson)] - type op_un_meta = - | Unquote; + - A type definition for the term - [@deriving (show({with_path: false}), sexp, yojson)] - type op_un_int = - | Minus; + - A map_term function that allows you to apply a function to every term in + the data structure with the following type: - [@deriving (show({with_path: false}), sexp, yojson)] - type op_bin_bool = - | And - | Or; + 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; - [@deriving (show({with_path: false}), sexp, yojson)] - type op_bin_int = - | Plus - | Minus - | Times - | Power - | Divide - | LessThan - | LessThanOrEqual - | GreaterThan - | GreaterThanOrEqual - | Equals - | NotEquals; + 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. - [@deriving (show({with_path: false}), sexp, yojson)] - type op_bin_float = - | Plus - | Minus - | Times - | Power - | Divide - | LessThan - | LessThanOrEqual - | GreaterThan - | GreaterThanOrEqual - | Equals - | NotEquals; + - 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)] - type op_bin_string = - | Concat - | Equals; + type t = + | Exp(Exp.t) + | Pat(Pat.t) + | Typ(Typ.t) + | TPat(TPat.t) + | Rul(Rul.t) + | Nul(unit) + | Any(unit); - [@deriving (show({with_path: false}), sexp, yojson)] - type op_un = - | Meta(op_un_meta) - | Int(op_un_int) - | Bool(op_un_bool); + 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: (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; + let fast_equal: (t, t) => 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); + type t = + | Exp(Exp.t) + | Pat(Pat.t) + | Typ(Typ.t) + | TPat(TPat.t) + | Rul(Rul.t) + | Nul(unit) + | Any(unit); - [@deriving (show({with_path: false}), sexp, yojson)] - type cls = - | Invalid - | EmptyHole - | MultiHole - | Triv - | Undefined - | Bool - | Int - | Float - | String - | ListLit - | Constructor - | Fun - | TypFun - | Tuple - | Var - | Let - | TyAlias - | Ap - | TypAp - | If - | Seq - | Test - | Filter - | Parens - | Cons - | ListConcat - | UnOp(op_un) - | BinOp(op_bin) - | Match; + 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(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), + ) + | 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); + }; + 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)] type deferral_position = | InAp @@ -144,7 +136,8 @@ and UExp: { | Invalid(string) | EmptyHole | MultiHole(list(Any.t)) - | Triv + | DynamicErrorHole(t, InvalidOperationError.t) + | FailedCast(t, Typ.t, Typ.t) | Deferral(deferral_position) | Undefined | Bool(bool) @@ -152,133 +145,54 @@ and UExp: { | Float(float) | String(string) | ListLit(list(t)) - | Constructor(string) - | Fun(UPat.t, t) - | TypFun(UTPat.t, t) + | Constructor(string, Typ.t) // Typ.t field is only meaningful in dynamic expressions + | Fun( + Pat.t, + t, + [@show.opaque] option(ClosureEnvironment.t), + option(Var.t), + ) + | TypFun(TPat.t, t, option(Var.t)) | Tuple(list(t)) | Var(Var.t) - | Let(UPat.t, t, t) - | TyAlias(UTPat.t, UTyp.t, t) - | Ap(t, t) - | TypAp(t, UTyp.t) + | Let(Pat.t, t, t) + | FixF(Pat.t, t, option(ClosureEnvironment.t)) + | TyAlias(TPat.t, Typ.t, t) + | Ap(Operators.ap_direction, t, t) + | TypAp(t, Typ.t) | DeferredAp(t, list(t)) - | Pipeline(t, t) | 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) | ListConcat(t, t) - | UnOp(op_un, t) - | BinOp(op_bin, t, t) - | Match(t, list((UPat.t, t))) - and t = { - // invariant: nonempty - ids: list(Id.t), - 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); + | UnOp(Operators.op_un, t) + | 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. Both types should be normalized in + dynamics for the cast calculus to work right. */ + | Cast(t, Typ.t, Typ.t) // first Typ.t field is only meaningful in dynamic expressions + and t = IdTagged.t(term); - [@deriving (show({with_path: false}), sexp, yojson)] - type cls = - | Invalid - | EmptyHole - | MultiHole - | Triv - | Undefined - | Bool - | Int - | Float - | String - | ListLit - | Constructor - | Fun - | TypFun - | Tuple - | Var - | Let - | TyAlias - | Ap - | TypAp - | If - | Seq - | Test - | Filter - | Parens - | Cons - | ListConcat - | UnOp(op_un) - | BinOp(op_bin) - | Match; + 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: (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; + let fast_equal: (t, t) => bool; +} = { [@deriving (show({with_path: false}), sexp, yojson)] type deferral_position = | InAp @@ -289,7 +203,8 @@ and UExp: { | Invalid(string) | EmptyHole | MultiHole(list(Any.t)) - | Triv + | DynamicErrorHole(t, InvalidOperationError.t) + | FailedCast(t, Typ.t, Typ.t) | Deferral(deferral_position) | Undefined | Bool(bool) @@ -297,80 +212,241 @@ and UExp: { | Float(float) | String(string) | ListLit(list(t)) - | Constructor(string) - | Fun(UPat.t, t) - | TypFun(UTPat.t, t) + | Constructor(string, Typ.t) + | Fun( + Pat.t, + t, + [@show.opaque] option(ClosureEnvironment.t), + option(Var.t), + ) + | TypFun(TPat.t, t, option(string)) | Tuple(list(t)) | Var(Var.t) - | Let(UPat.t, t, t) - | TyAlias(UTPat.t, UTyp.t, t) - | Ap(t, t) - | TypAp(t, UTyp.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, Typ.t) | DeferredAp(t, list(t)) - | Pipeline(t, t) | If(t, t, t) | Seq(t, t) | Test(t) - | Filter(FilterAction.t, t, t) - | Parens(t) // ( + | Filter(StepperFilterKind.t, t) + | Closure([@show.opaque] ClosureEnvironment.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))) - and t = { - // invariant: nonempty - ids: list(Id.t), - term, - }; + | 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))) + | Cast(t, Typ.t, Typ.t) + and t = IdTagged.t(term); - let bool_op_to_string = (op: op_bin_bool): string => { - switch (op) { - | And => "&&" - | Or => "||" + 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 = + 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 = + 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: t) => { + ...exp, + term: + switch (term) { + | EmptyHole + | Invalid(_) + | Bool(_) + | Int(_) + | Float(_) + | Constructor(_) + | String(_) + | Deferral(_) + | Var(_) + | Undefined => term + | MultiHole(things) => MultiHole(List.map(any_map_term, things)) + | 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) + | 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)) + | 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)) + | 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) => + 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); }; - let int_op_to_string = (op: op_bin_int): string => { - switch (op) { - | Plus => "+" - | Minus => "-" - | Times => "*" - | Power => "**" - | Divide => "/" - | LessThan => "<" - | LessThanOrEqual => "<=" - | GreaterThan => ">" - | GreaterThanOrEqual => ">=" - | Equals => "==" - | NotEquals => "!=" + 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 + | (Undefined, Undefined) => 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, ty1), Constructor(c2, ty2)) => + c1 == c2 && Typ.fast_equal(ty1, ty2) + | (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, _) + | (Undefined, _) => false }; - }; - - 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: { +and Pat: { [@deriving (show({with_path: false}), sexp, yojson)] type term = | Invalid(string) @@ -381,19 +457,29 @@ and UPat: { | Float(float) | Bool(bool) | String(string) - | Triv | ListLit(list(t)) - | Constructor(string) + | Constructor(string, Typ.t) // Typ.t field is only meaningful in dynamic patterns | Cons(t, t) | Var(Var.t) | Tuple(list(t)) | Parens(t) | Ap(t, t) - | TypeAnn(t, UTyp.t) - and t = { - ids: list(Id.t), - term, - }; + | Cast(t, Typ.t, Typ.t) // The second Typ.t field is only meaningful in dynamic patterns + 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: (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; + + let fast_equal: (t, t) => bool; } = { [@deriving (show({with_path: false}), sexp, yojson)] type term = @@ -405,116 +491,681 @@ and UPat: { | Float(float) | Bool(bool) | String(string) - | Triv | ListLit(list(t)) - | Constructor(string) + | Constructor(string, Typ.t) | Cons(t, t) | Var(Var.t) | Tuple(list(t)) | Parens(t) | Ap(t, t) - | TypeAnn(t, UTyp.t) - and t = { - ids: list(Id.t), - term, + | Cast(t, Typ.t, Typ.t) // The second one is hidden from the user + and t = IdTagged.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 = + 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) => { + ...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)) + | Cast(e, t1, t2) => + Cast(pat_map_term(e), typ_map_term(t1), typ_map_term(t2)) + }, + }; + 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, t1), Constructor(c2, t2)) => + c1 == c2 && Typ.fast_equal(t1, t2) + | (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 UTyp: { +and Typ: { [@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 | String - | List(t) | Var(string) - | Constructor(string) + | List(t) | Arrow(t, t) - | Tuple(list(t)) + | Sum(ConstructorMap.t(t)) + | Prod(list(t)) | Parens(t) | Ap(t, t) - | Sum(list(variant)) - | Forall(UTPat.t, t) - | Rec(UTPat.t, t) - and variant = - | Variant(Constructor.t, list(Id.t), option(t)) - | BadEntry(t) - and t = { - ids: list(Id.t), - term, - }; + | Rec(TPat.t, t) + | Forall(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: (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; + + let subst: (t, TPat.t, t) => t; + + let fast_equal: (t, t) => bool; } = { [@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 | String - | List(t) | Var(string) - | Constructor(string) + | List(t) | Arrow(t, t) - | Tuple(list(t)) + | Sum(ConstructorMap.t(t)) + | Prod(list(t)) | Parens(t) | Ap(t, t) - | Sum(list(variant)) - | Forall(UTPat.t, t) - | Rec(UTPat.t, t) - and variant = - | Variant(Constructor.t, list(Id.t), option(t)) - | BadEntry(t) - and t = { - ids: list(Id.t), - term, + | Rec(TPat.t, t) + | Forall(TPat.t, t) + and t = IdTagged.t(term); + + type sum_map = ConstructorMap.t(t); + + 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 = + 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 = + TPat.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); + let rec_call = ({term, _} as exp: t) => { + ...exp, + term: + switch (term) { + | Unknown(Hole(EmptyHole)) + | Unknown(Hole(Invalid(_))) + | Unknown(SynSwitch) + | Unknown(Internal) + | Bool + | Int + | Float + | String + | Var(_) => term + | List(t) => List(typ_map_term(t)) + | 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)) + | Arrow(t1, t2) => Arrow(typ_map_term(t1), typ_map_term(t2)) + | Sum(variants) => + Sum( + List.map( + fun + | 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, + ), + ) + | 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); + }; + + 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 UTPat: { +and TPat: { [@deriving (show({with_path: false}), sexp, yojson)] type term = | Invalid(string) | EmptyHole | MultiHole(list(Any.t)) - | Var(TypVar.t) - and t = { - ids: list(Id.t), - term, - }; + | Var(string) + 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: (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; + + let tyvar_of_utpat: t => option(string); + + let fast_equal: (t, t) => bool; } = { [@deriving (show({with_path: false}), sexp, yojson)] type term = | Invalid(string) | EmptyHole | MultiHole(list(Any.t)) - | Var(TypVar.t) - and t = { - ids: list(Id.t), - term, + | Var(string) + and t = IdTagged.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: t) => { + ...exp, + term: + switch (term) { + | EmptyHole + | Invalid(_) + | Var(_) => term + | MultiHole(things) => MultiHole(List.map(any_map_term, things)) + }, + }; + 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 URul: { +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))) - and t = { - ids: list(Id.t), - term, - }; + | Rules(Exp.t, list((Pat.t, Exp.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: (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; + + let fast_equal: (t, t) => bool; } = { [@deriving (show({with_path: false}), sexp, yojson)] type term = | Invalid(string) | Hole(list(Any.t)) - | Rules(UExp.t, list((UPat.t, UExp.t))) - and t = { - ids: list(Id.t), - term, + | Rules(Exp.t, list((Pat.t, Exp.t))) + and t = IdTagged.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: t) => { + ...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); }; + + 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: { + include + (module type of VarBstMap.Ordered) with + type t_('a) = VarBstMap.Ordered.t_('a); + + [@deriving (show({with_path: false}), sexp, yojson)] + type t = t_(Exp.t); +} = { + include VarBstMap.Ordered; + + [@deriving (show({with_path: false}), sexp, yojson)] + type t = t_(Exp.t); +} + +and ClosureEnvironment: { + [@deriving (show({with_path: false}), sexp, yojson)] + type t; + + let wrap: (Id.t, Environment.t) => t; + + let id_of: t => Id.t; + let map_of: t => Environment.t; + + let to_list: t => list((Var.t, Exp.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(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, 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, 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; + + let placeholder: t; +} = { + module Inner: { + [@deriving (show({with_path: false}), sexp, yojson)] + type t; + + let wrap: (Id.t, Environment.t) => t; + + let id_of: t => Id.t; + let map_of: t => Environment.t; + } = { + [@deriving (show({with_path: false}), sexp, yojson)] + type t = (Id.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(Id.invalid, Environment.empty); + + let without_keys = keys => update(Environment.without_keys(keys)); +} +and StepperFilterKind: { + [@deriving (show({with_path: false}), sexp, yojson)] + type filter = { + pat: Exp.t, + act: FilterAction.t, + }; + + [@deriving (show({with_path: false}), sexp, yojson)] + type t = + | Filter(filter) + | Residue(int, FilterAction.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: (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; + + let map: (Exp.t => Exp.t, t) => t; + + let fast_equal: (t, t) => bool; +} = { + [@deriving (show({with_path: false}), sexp, yojson)] + type filter = { + pat: Exp.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) + }; + }; + + 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); + }; + + 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/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 f1d1067ecb..0000000000 --- a/src/haz3lcore/statics/TypBase.re +++ /dev/null @@ -1,746 +0,0 @@ -open Util; -open OptUtil.Syntax; - -let precedence_Prod = 1; -let precedence_Arrow = 2; -let precedence_Sum = 3; -let precedence_Const = 4; - -module rec Typ: { - /* 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 - | TypeHole - | Free(TypVar.t) - | Internal; - - /* TYP.T: Hazel types */ - [@deriving (show({with_path: false}), sexp, yojson)] - type t = - | Unknown(type_provenance) - | Int - | Float - | Bool - | String - | Var(TypVar.t) - | List(t) - | Arrow(t, t) - | Sum(sum_map) - | Prod(list(t)) - | Rec(TypVar.t, t) - | Forall(TypVar.t, t) - and sum_map = ConstructorMap.t(option(t)); - - [@deriving (show({with_path: false}), sexp, yojson)] - type sum_entry = ConstructorMap.binding(option(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 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_forall: (Ctx.t, t) => (option(string), t); - let matched_prod: (Ctx.t, int, t) => list(t); - let matched_list: (Ctx.t, t) => t; - let matched_args: (Ctx.t, int, t) => list(t); - let precedence: t => int; - let subst: (t, TypVar.t, 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; - let needs_parens: t => bool; - let pretty_print: t => string; -} = { - [@deriving (show({with_path: false}), sexp, yojson)] - type type_provenance = - | SynSwitch - | TypeHole - | Free(TypVar.t) - | Internal; - - /* TYP.T: Hazel types */ - [@deriving (show({with_path: false}), sexp, yojson)] - type t = - | Unknown(type_provenance) - | Int - | Float - | Bool - | String - | Var(TypVar.t) - | List(t) - | Arrow(t, t) - | Sum(sum_map) - | Prod(list(t)) - | Rec(TypVar.t, t) - | Forall(TypVar.t, t) - and sum_map = ConstructorMap.t(option(t)); - - [@deriving (show({with_path: false}), sexp, yojson)] - type sum_entry = ConstructorMap.binding(option(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) { - | (Free(tv1), Free(tv2)) when TypVar.eq(tv1, tv2) => Free(tv1) - | (TypeHole, TypeHole | SynSwitch) - | (SynSwitch, TypeHole) => TypeHole - | (SynSwitch, Internal) - | (Internal, SynSwitch) => SynSwitch - | (Internal | Free(_), _) - | (_, Internal | Free(_)) => Internal - | (SynSwitch, SynSwitch) => SynSwitch - }; - - let precedence = (ty: t): int => - switch (ty) { - | Int - | Float - | Bool - | String - | Unknown(_) - | Var(_) - | Rec(_) - | Forall(_) - | Sum(_) => precedence_Sum - | List(_) => precedence_Const - | Prod(_) => precedence_Prod - | Arrow(_, _) => precedence_Arrow - }; - - let rec free_vars = (~bound=[], ty: t): list(Var.t) => - switch (ty) { - | Unknown(_) - | Int - | Float - | Bool - | String => [] - | Var(v) => List.mem(v, bound) ? [] : [v] - | List(ty) => free_vars(~bound, ty) - | 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), - ) - | Prod(tys) => ListUtil.flat_map(free_vars(~bound), tys) - | Rec(x, ty) => free_vars(~bound=[x, ...bound], ty) - | Forall(x, ty) => free_vars(~bound=[x, ...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: TypVar.t, 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 TypVar.eq(x, y) => Rec(y, ty) - | Rec(y, ty) when List.mem(y, free_vars(s)) => - let fresh = fresh_var(y); - Rec(fresh, subst(s, x, subst(Var(fresh), y, ty))); - | Rec(y, ty) => Rec(y, subst(s, x, ty)) - | Forall(y, ty) when TypVar.eq(x, y) => Forall(y, ty) - | Forall(y, ty) when List.mem(y, free_vars(s)) => - let fresh = fresh_var(y); - Forall(fresh, subst(s, x, subst(Var(fresh), y, ty))); - | Forall(y, ty) => Forall(y, subst(s, x, ty)) - | List(ty) => List(subst(s, x, ty)) - | Var(y) => TypVar.eq(x, y) ? s : Var(y) - }; - }; - - let unroll = (ty: t): t => - switch (ty) { - | Rec(x, ty_body) => subst(ty, x, ty_body) - | _ => 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 (t1, t2) { - | (Rec(x1, t1), Rec(x2, t2)) - | (Forall(x1, t1), Forall(x2, t2)) => - eq_internal( - n + 1, - subst(Var("=" ++ string_of_int(n)), x1, t1), - subst(Var("=" ++ string_of_int(n)), 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 - | (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(Option.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); - - /* 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 (ty1, ty2) { - | (_, Unknown(TypeHole | Free(_)) as ty) when fix => - /* NOTE(andrew): This is load bearing - for ensuring that function literals get appropriate - casts. Documentation/Dynamics has regression tests */ - Some(ty) - | (Unknown(p1), Unknown(p2)) => - Some(Unknown(join_type_provenance(p1, p2))) - | (Unknown(_), ty) - | (ty, Unknown(_)) => Some(ty) - | (Var(n1), Var(n2)) => - if (n1 == n2) { - Some(Var(n1)); - } 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; - } - | (Var(name), ty) - | (ty, 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; - /* Note: Ordering of Unknown, Var, and Rec above is load-bearing! */ - | (Rec(x1, ty1), Rec(x2, ty2)) => - let ctx = Ctx.extend_dummy_tvar(ctx, x1); - let+ ty_body = - join(~resolve, ~fix, ctx, subst(Var(x2), x1, ty1), ty2); - Rec(x1, ty_body); - | (Forall(x1, ty1), Forall(x2, ty2)) => - let ctx = Ctx.extend_dummy_tvar(ctx, x1); - let+ ty_body = - join(~resolve, ~fix, ctx, subst(Var(x2), x1, ty1), ty2); - Forall(x1, ty_body); - /* 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. */ - | (Rec(_), _) => None - | (Forall(_), _) => None - | (Int, Int) => Some(Int) - | (Int, _) => None - | (Float, Float) => Some(Float) - | (Float, _) => None - | (Bool, Bool) => Some(Bool) - | (Bool, _) => None - | (String, String) => Some(String) - | (String, _) => None - | (Arrow(ty1, ty2), Arrow(ty1', ty2')) => - let* ty1 = join'(ty1, ty1'); - let+ ty2 = join'(ty2, ty2'); - Arrow(ty1, ty2); - | (Arrow(_), _) => None - | (Prod(tys1), Prod(tys2)) => - let* tys = ListUtil.map2_opt(join', tys1, tys2); - let+ tys = OptUtil.sequence(tys); - Prod(tys); - | (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); - | (Sum(_), _) => None - | (List(ty1), List(ty2)) => - let+ ty = join'(ty1, ty2); - List(ty); - | (List(_), _) => None - }; - } - 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); - - 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 (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 => { - switch (ty) { - | Var(x) => - switch (Ctx.lookup_alias(ctx, x)) { - | Some(ty) => normalize(ctx, ty) - | None => ty - } - | Unknown(_) - | Int - | Float - | Bool - | String => ty - | 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)) - | 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)) - | Forall(name, ty) => - Forall(name, normalize(Ctx.extend_dummy_tvar(ctx, name), ty)) - }; - }; - - let matched_arrow = (ctx, ty) => - switch (weak_head_normalize(ctx, ty)) { - | Arrow(ty_in, ty_out) => (ty_in, ty_out) - | Unknown(SynSwitch) => (Unknown(SynSwitch), Unknown(SynSwitch)) - | _ => (Unknown(Internal), Unknown(Internal)) - }; - - let matched_forall = (ctx, ty) => - switch (weak_head_normalize(ctx, ty)) { - | Forall(t, ty) => (Some(t), ty) - | Unknown(SynSwitch) => (None, Unknown(SynSwitch)) - | _ => (None, Unknown(Internal)) - }; - - let matched_prod = (ctx, length, ty) => - switch (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)) - }; - - let matched_list = (ctx, ty) => - switch (weak_head_normalize(ctx, ty)) { - | List(ty) => ty - | Unknown(SynSwitch) => Unknown(SynSwitch) - | _ => Unknown(Internal) - }; - - let matched_args = (ctx, default_arity, ty) => - switch (weak_head_normalize(ctx, ty)) { - | Prod([_, ..._] as tys) => tys - | Unknown(_) as ty_unknown => List.init(default_arity, _ => ty_unknown) - | _ as ty => [ty] - }; - - 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)) - | _ => None, - ctrs, - ); - - let get_sum_constructors = (ctx: Ctx.t, ty: t): option(sum_map) => { - let ty = weak_head_normalize(ctx, ty); - switch (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) { - | Rec(x, ty_body) => - switch (Ctx.lookup_alias(ctx, x)) { - | None => unroll(ty) - | Some(_) => ty_body - } - | _ => ty - }; - switch (ty) { - | Sum(sm) => Some(sm) - | _ => None - }; - | _ => None - }; - }; - - let is_unknown = (ty: t): bool => - switch (ty) { - | Unknown(_) => true - | _ => false - }; - - /* Does the type require parentheses when on the left of an arrow for printing? */ - let needs_parens = (ty: t): bool => - switch (ty) { - | 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) */ - }; - - /* Essentially recreates haz3lweb/view/Type.re's view_ty but with string output */ - let rec pretty_print = (ty: t): string => - switch (ty) { - | 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 " ++ tv ++ "->" ++ pretty_print(t) - | Forall(tv, t) => "forall " ++ tv ++ "->" ++ pretty_print(t) - } - and ctr_pretty_print = ((ctr, typ)) => - switch (typ) { - | None => ctr - | Some(typ) => ctr ++ "(" ++ pretty_print(typ) ++ ")" - } - and paren_pretty_print = typ => - if (needs_parens(typ)) { - "(" ++ pretty_print(typ) ++ ")"; - } else { - pretty_print(typ); - }; -} - -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: TypVar.t, - 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, 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 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 is_abstract: (t, TypVar.t) => bool; - let add_ctrs: (t, TypVar.t, 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; -} = { - [@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: TypVar.t, - 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: TypVar.t, id: Id.t, ty: Typ.t): t => - extend_tvar(ctx, {name, id, kind: Singleton(ty)}); - - let extend_dummy_tvar = (ctx: t, name: TypVar.t) => - extend_tvar(ctx, {kind: Abstract, name, id: Id.invalid}); - - let lookup_tvar = (ctx: t, name: TypVar.t): option(tvar_entry) => - List.find_map( - fun - | TVarEntry(v) when v.name == name => Some(v) - | _ => None, - ctx, - ); - - let lookup_alias = (ctx: t, t: TypVar.t): 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: TypVar.t): bool => - switch (lookup_alias(ctx, name)) { - | Some(_) => true - | None => false - }; - - let is_abstract = (ctx: t, name: TypVar.t): bool => - switch (lookup_tvar(ctx, name)) { - | Some({kind: Abstract, _}) => true - | _ => false - }; - - let add_ctrs = (ctx: t, name: TypVar.t, id: Id.t, ctrs: Typ.sum_map): t => - List.map( - ((ctr, typ)) => - ConstructorEntry({ - name: ctr, - id, - typ: - switch (typ) { - | None => Var(name) - | Some(typ) => Arrow(typ, Var(name)) - }, - }), - 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: TypVar.t): bool => - Form.is_base_typ(name) || is_alias(ctx, name) || is_abstract(ctx, name); -} -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/TypVar.re b/src/haz3lcore/statics/TypVar.re deleted file mode 100644 index f3870d5d05..0000000000 --- a/src/haz3lcore/statics/TypVar.re +++ /dev/null @@ -1,6 +0,0 @@ -open Util; - -[@deriving (show({with_path: false}), sexp, yojson)] -type t = string; - -let eq = String.equal; 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..7dcfba5350 --- /dev/null +++ b/src/haz3lcore/statics/uterm/UTyp.re @@ -0,0 +1 @@ +include Typ; diff --git a/src/haz3lcore/zipper/Editor.re b/src/haz3lcore/zipper/Editor.re index 9a340a2d78..73da0dbcc2 100644 --- a/src/haz3lcore/zipper/Editor.re +++ b/src/haz3lcore/zipper/Editor.re @@ -8,7 +8,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/haz3lcore/zipper/EditorUtil.re b/src/haz3lcore/zipper/EditorUtil.re index 31214c4378..6fd2eb8652 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: TermBase.UExp.t, e2: TermBase.UExp.t) => { - switch (e1.term) { - | EmptyHole - | Invalid(_) - | MultiHole(_) - | Triv - | Undefined - | Deferral(_) - | Bool(_) - | Int(_) - | Float(_) - | String(_) - | ListLit(_) - | Constructor(_) - | Fun(_) - | TypFun(_) - | Tuple(_) - | Var(_) - | Ap(_) - | TypAp(_) - | DeferredAp(_) - | Pipeline(_) - | If(_) - | Test(_) - | Parens(_) - | Cons(_) - | ListConcat(_) - | UnOp(_) - | BinOp(_) - | Match(_) => TermBase.UExp.{ids: [Id.mk()], term: Seq(e1, e2)} - | Seq(e11, e12) => - let e12' = append_exp(e12, e2); - TermBase.UExp.{ids: e1.ids, term: Seq(e11, e12')}; - | Filter(act, econd, ebody) => - let ebody' = append_exp(ebody, e2); - TermBase.UExp.{ids: e1.ids, 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')}; - | TyAlias(tp, tdef, ebody) => - let ebody' = append_exp(ebody, e2); - TermBase.UExp.{ids: e1.ids, term: TyAlias(tp, tdef, ebody')}; - }; +let rec append_exp = (e1: Exp.t, e2: Exp.t): Exp.t => { + Exp.( + switch (e1.term) { + | EmptyHole + | Invalid(_) + | MultiHole(_) + | DynamicErrorHole(_) + | FailedCast(_) + | Undefined + | 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/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 99eab647ad..91b4abf1d6 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, }; }; @@ -575,14 +575,21 @@ module F = (ExerciseEnv: ExerciseEnv) => { hidden_tests: 'a, }; - let wrap_filter = (act: FilterAction.action, term: Term.UExp.t): Term.UExp.t => - TermBase.UExp.{ + let wrap_filter = (act: FilterAction.action, term: UExp.t): UExp.t => + Exp.{ term: - TermBase.UExp.Filter( - FilterAction.(act, One), - {term: Constructor("$e"), ids: [Id.mk()]}, + Exp.Filter( + Filter({ + act: FilterAction.(act, One), + pat: { + term: Constructor("$e", Unknown(Internal) |> Typ.temp), + copied: false, + ids: [Id.mk()], + }, + }), term, ), + copied: false, ids: [Id.mk()], }; @@ -591,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( @@ -704,7 +710,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 +721,9 @@ 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), + }; [ (test_validation_key, elab(test_validation)), (user_impl_key, elab(user_impl)), @@ -752,13 +759,14 @@ module F = (ExerciseEnv: ExerciseEnv) => { module DynamicsItem = { type t = { - term: TermBase.UExp.t, + term: Exp.t, info_map: Statics.Map.t, result: ModelResult.t, }; let empty: t = { term: { term: Tuple([]), + copied: false, ids: [Id.mk()], }, info_map: Id.Map.empty, diff --git a/src/haz3lschool/Gradescope.re b/src/haz3lschool/Gradescope.re index 548e29f537..930bde1e64 100644 --- a/src/haz3lschool/Gradescope.re +++ b/src/haz3lschool/Gradescope.re @@ -70,7 +70,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/haz3lschool/SyntaxTest.re b/src/haz3lschool/SyntaxTest.re index 595092c66b..23dff72251 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) }; }; @@ -45,18 +44,13 @@ let rec find_var_upat = (name: string, upat: Term.UPat.t): bool => { if name="a", then l=[fun x -> x+1] */ 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) | (_, 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)) { @@ -72,8 +66,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(_) | @@ -88,24 +81,25 @@ let rec find_in_let = Find any function expressions in uexp that are bound to variable name */ 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) | ListLit(ul) | Tuple(ul) => List.fold_left((acc, u1) => {find_fn(name, u1, acc)}, l, ul) - | TypFun(_, body) - | Fun(_, body) => l |> find_fn(name, body) + | TypFun(_, body, _) + | FixF(_, body, _) + | Fun(_, body, _, _) => l |> find_fn(name, body) | TypAp(u1, _) | Parens(u1) + | Cast(u1, _, _) | UnOp(_, u1) | TyAlias(_, _, u1) | Test(u1) - | Filter(_, _, u1) => l |> find_fn(name, u1) - | Ap(u1, u2) - | Pipeline(u1, u2) + | Closure(_, u1) + | Filter(_, u1) => l |> find_fn(name, u1) + | Ap(_, u1, u2) | Seq(u1, u2) | Cons(u1, u2) | ListConcat(u1, u2) @@ -123,16 +117,18 @@ let rec find_fn = ul, ) | EmptyHole - | Triv | Deferral(_) | Invalid(_) | MultiHole(_) + | DynamicErrorHole(_) + | FailedCast(_) | Bool(_) | Int(_) | Float(_) | String(_) | Constructor(_) | Undefined + | BuiltinFun(_) | Var(_) => l }; }; @@ -140,12 +136,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(_) @@ -165,18 +160,17 @@ let rec var_mention_upat = (name: string, upat: Term.UPat.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) }; }; /* 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(_) @@ -186,7 +180,7 @@ let rec var_mention = (name: string, uexp: Term.UExp.t): bool => { | Constructor(_) | Undefined | Deferral(_) => false - | Fun(args, body) => + | Fun(args, body, _, _) => var_mention_upat(name, args) ? false : var_mention(name, body) | ListLit(l) | Tuple(l) => @@ -194,15 +188,21 @@ let rec var_mention = (name: string, uexp: Term.UExp.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) | UnOp(_, u) | TyAlias(_, _, u) - | Filter(_, _, u) => var_mention(name, u) - | Ap(u1, u2) - | Pipeline(u1, u2) + | Filter(_, 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) @@ -228,11 +228,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(_) @@ -242,7 +241,8 @@ let rec var_applied = (name: string, uexp: Term.UExp.t): bool => { | Constructor(_) | Undefined | 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) => @@ -250,18 +250,24 @@ let rec var_applied = (name: string, uexp: Term.UExp.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) | TyAlias(_, _, u) - | Filter(_, _, u) => var_applied(name, u) + | Filter(_, u) => var_applied(name, u) | TypAp(u, _) => switch (u.term) { | Var(x) => x == name ? true : false | _ => var_applied(name, u) } - | Ap(u1, u2) => + | 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) @@ -271,11 +277,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) @@ -298,7 +299,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; @@ -316,21 +317,24 @@ 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 - | Triv | Deferral(_) | Invalid(_) | MultiHole(_) + | DynamicErrorHole(_) + | FailedCast(_) | Bool(_) | Int(_) | Float(_) | String(_) | Constructor(_) | Undefined - | Var(_) => true - | Fun(args, body) => + | Var(_) + | BuiltinFun(_) => true + | FixF(args, body, _) + | Fun(args, body, _, _) => var_mention_upat(name, args) ? false : tail_check(name, body) | Let(p, def, body) => var_mention_upat(name, p) || var_mention(name, def) @@ -341,18 +345,16 @@ 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) - | Filter(_, _, u) - | TypFun(_, u) + | Cast(u, _, _) + | Filter(_, u) + | Closure(_, u) + | TypFun(_, u, _) | TypAp(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) | 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) @@ -376,7 +378,7 @@ let rec tail_check = (name: string, uexp: Term.UExp.t): bool => { /* Check whether all functions bound to variable name are tail recursive. */ -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; @@ -389,8 +391,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/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/Editors.re b/src/haz3lweb/Editors.re index 43e7479dc0..0af1a46ca3 100644 --- a/src/haz3lweb/Editors.re +++ b/src/haz3lweb/Editors.re @@ -97,20 +97,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: 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)]; + [(key, {d: d})]; | Exercises(_, _, exercise) => Exercise.spliced_elabs(settings.core, exercise) }; diff --git a/src/haz3lweb/Grading.re b/src/haz3lweb/Grading.re index bc1f14de95..e16827b918 100644 --- a/src/haz3lweb/Grading.re +++ b/src/haz3lweb/Grading.re @@ -215,7 +215,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/Example.re b/src/haz3lweb/explainthis/Example.re index aa52317ced..aa9e506cfc 100644 --- a/src/haz3lweb/explainthis/Example.re +++ b/src/haz3lweb/explainthis/Example.re @@ -118,6 +118,7 @@ let typeann = () => mk_monotile(Form.get("typeann")); let mk_typfun = mk_tile(Form.get("typfun")); let mk_fun = mk_tile(Form.get("fun_")); let mk_ap_exp_typ = mk_tile(Form.get("ap_exp_typ")); +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 ec085bf88b..a2291253e5 100644 --- a/src/haz3lweb/explainthis/ExplainThisForm.re +++ b/src/haz3lweb/explainthis/ExplainThisForm.re @@ -85,6 +85,8 @@ type example_id = | List(list_examples) | TypFun(typfun_examples) | Fun(fun_examples) + | Fix1 + | Fix2 | Tuple1 | Tuple2 | Let(let_examples) @@ -170,6 +172,7 @@ type form_id = | Tuple2Exp | Tuple3Exp | LetExp(pat_sub_form_id) + | FixExp(pat_sub_form_id) | TypFunApExp | FunApExp | ConApExp @@ -177,8 +180,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 @@ -263,14 +266,15 @@ type group_id = | Tuple3Exp | LetExp(pat_sub_form_id) | TypFunApExp + | FixExp(pat_sub_form_id) | FunApExp | ConApExp | DeferredApExp | 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/explainthis/data/FixFExp.re b/src/haz3lweb/explainthis/data/FixFExp.re new file mode 100644 index 0000000000..b106b6be8e --- /dev/null +++ b/src/haz3lweb/explainthis/data/FixFExp.re @@ -0,0 +1,54 @@ +open Haz3lcore; +open ExplainThisForm; +open Example; + +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/Cell.re b/src/haz3lweb/view/Cell.re index fae9110f3c..59fb27eb3e 100644 --- a/src/haz3lweb/view/Cell.re +++ b/src/haz3lweb/view/Cell.re @@ -174,7 +174,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( @@ -185,6 +185,7 @@ let live_eval = ~font_metrics, ~width=80, ~result_key, + ~infomap=Id.Map.empty, dhexp, ); let exn_view = @@ -240,6 +241,7 @@ let footer = ~settings=settings.core.evaluation, ~font_metrics, ~result_key, + ~read_only=false, s, ) }; @@ -393,12 +395,13 @@ let locked = statics.info_map, editor.state.meta.view_term, ) - : DHExp.BoolLit(true); + : DHExp.Bool(true) |> DHExp.fresh; + 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/CursorInspector.re b/src/haz3lweb/view/CursorInspector.re index c62c7e64bf..2102c68203 100644 --- a/src/haz3lweb/view/CursorInspector.re +++ b/src/haz3lweb/view/CursorInspector.re @@ -28,7 +28,7 @@ let explain_this_toggle = (~inject, ~show_explain_this: bool): Node.t => { let cls_view = (ci: Info.t): Node.t => div( ~attrs=[clss(["syntax-class"])], - [text(ci |> Info.cls_of |> Term.Cls.show)], + [text(ci |> Info.cls_of |> Cls.show)], ); let ctx_toggle = (~inject, context_inspector: bool): Node.t => @@ -59,7 +59,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) @@ -67,7 +67,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)) { @@ -78,7 +78,7 @@ let common_err_view = (cls: Term.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)) => [ @@ -98,7 +98,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"), @@ -138,17 +138,17 @@ 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), text("is a type")] | 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)), + Type.view(Var(name) |> Typ.fresh), text("is a sum type constuctor of type"), Type.view(sum_ty), ] @@ -160,7 +160,10 @@ let typ_ok_view = (cls: Term.Cls.t, ok: Info.ok_typ) => 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"), @@ -169,17 +172,17 @@ 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"), ] }; -let rec exp_view = (cls: Term.Cls.t, status: Info.status_exp) => +let rec exp_view = (cls: Cls.t, status: Info.status_exp) => switch (status) { | InHole(FreeVariable(name)) => div_err([code_err(name), text("not found")]) | InHole(InexhaustiveMatch(additional_err)) => - let cls_str = Term.Cls.show(cls); + let cls_str = Cls.show(cls); switch (additional_err) { | None => div_err([text(cls_str ++ " is inexhaustive")]) | Some(err) => @@ -211,7 +214,7 @@ let rec exp_view = (cls: Term.Cls.t, status: Info.status_exp) => | NotInHole(Common(ok)) => div_ok(common_ok_view(cls, ok)) }; -let rec pat_view = (cls: Term.Cls.t, status: Info.status_pat) => +let rec pat_view = (cls: Cls.t, status: Info.status_pat) => switch (status) { | InHole(ExpectedConstructor) => div_err([text("Expected a constructor")]) | InHole(Redundant(additional_err)) => @@ -224,13 +227,13 @@ let rec pat_view = (cls: Term.Cls.t, status: Info.status_pat) => | 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)]) @@ -238,18 +241,23 @@ let tpat_view = (_: Term.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), ]) }; -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 0f577762e5..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)) => @@ -138,7 +138,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. @@ -277,7 +277,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/ExplainThis.re b/src/haz3lweb/view/ExplainThis.re index c3cfd8cd4e..d8186758d2 100644 --- a/src/haz3lweb/view/ExplainThis.re +++ b/src/haz3lweb/view/ExplainThis.re @@ -397,29 +397,29 @@ 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) + | Cast(p, _, _) => bypass_parens_and_annot_pat(p) | _ => pat }; }; -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: Typ.t) => { switch (typ.term) { | Parens(t) => bypass_parens_typ(t) | _ => typ @@ -537,8 +537,13 @@ 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(_) + | FailedCast(_) + | Closure(_) + | Cast(_) + | 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) => @@ -559,7 +564,6 @@ let get_doc = TyAliasExp.tyalias_exps, ); | Undefined => get_message(UndefinedExp.undefined_exps) - | Triv => get_message(TerminalExp.triv_exps) | Deferral(_) => get_message(TerminalExp.deferral_exps) | Bool(b) => get_message(TerminalExp.bool_exps(b)) | Int(i) => get_message(TerminalExp.int_exps(i)) @@ -577,7 +581,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); @@ -601,7 +605,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); @@ -790,7 +794,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( @@ -1032,7 +1036,7 @@ let get_doc = } else { basic(FunctionExp.functions_ap); } - | Constructor(v) => + | Constructor(v, _) => if (FunctionExp.function_ctr_exp.id == get_specificity_level(FunctionExp.functions_ctr)) { let pat_id = List.nth(pat.ids, 0); @@ -1058,7 +1062,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 => @@ -1313,7 +1317,7 @@ let get_doc = LetExp.lets_str, ); } - | Triv => + | Tuple([]) => if (LetExp.let_triv_exp.id == get_specificity_level(LetExp.lets_triv)) { get_message( @@ -1540,7 +1544,7 @@ let get_doc = } else { basic(LetExp.lets_ap); } - | Constructor(v) => + | Constructor(v, _) => if (LetExp.let_ctr_exp.id == get_specificity_level(LetExp.lets_ctr)) { get_message( ~colorings= @@ -1564,13 +1568,20 @@ 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? }; - | Pipeline(arg, fn) => + | FixF(pat, body, _) => + message_single( + FixFExp.single( + ~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), ), ) | TypAp(f, typ) => @@ -1594,7 +1605,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) => { @@ -1605,7 +1616,7 @@ let get_doc = ); }; switch (x.term) { - | Constructor(v) => + | Constructor(v, _) => basic( AppExp.conaps, msg => @@ -1633,7 +1644,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) { @@ -1657,11 +1668,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, ); }; @@ -1704,34 +1715,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), + ~p_id=UExp.rep_id(pat), + ~body_id=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), + ~p_id=UExp.rep_id(pat), + ~body_id=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), + ~p_id=UExp.rep_id(pat), + ~body_id=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), + ~p_id=UExp.rep_id(pat), + ~body_id=UExp.rep_id(body), ), ) + | Filter(_) => simple("Internal expression") | Test(body) => let body_id = List.nth(body.ids, 0); get_message( @@ -1810,7 +1822,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; @@ -1887,7 +1899,7 @@ let get_doc = ), CaseExp.case, ); - | Constructor(v) => + | Constructor(v, _) => get_message( ~format= Some( @@ -1938,7 +1950,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); @@ -1973,7 +1985,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); @@ -2091,7 +2103,7 @@ let get_doc = ), AppPat.ap, ); - | Constructor(con) => + | Constructor(con, _) => get_message( ~format= Some( @@ -2099,7 +2111,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( @@ -2120,10 +2132,12 @@ 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) + | 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) @@ -2192,7 +2206,7 @@ let get_doc = doc, ); switch (result.term) { - | TermBase.UTyp.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); @@ -2220,7 +2234,7 @@ let get_doc = } | _ => basic(ArrowTyp.arrow) }; - | Tuple(elements) => + | Prod(elements) => let basic = group => get_message( ~format= @@ -2293,9 +2307,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( @@ -2306,9 +2318,9 @@ 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") + | Unknown(Hole(Invalid(_))) => simple("Not a type or type operator") | Ap(_) | Parens(_) => default // Shouldn't be hit? } @@ -2405,7 +2417,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/Kind.re b/src/haz3lweb/view/Kind.re index 148336e1c2..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.TypBase.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/StepperView.re b/src/haz3lweb/view/StepperView.re index 4dfde191ea..2558df5b01 100644 --- a/src/haz3lweb/view/StepperView.re +++ b/src/haz3lweb/view/StepperView.re @@ -91,22 +91,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_previous = (step_with_previous: Stepper.step_with_previous) => + let step_dh_code = + ( + ~next_steps, + {previous_step, hidden_steps, chosen_step, d}: Stepper.step_info, + ) => div( ~attrs=[Attr.classes(["result"])], [ @@ -116,120 +108,114 @@ let stepper_view = ~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, + ~previous_step, + ~chosen_step, + ~hidden_steps, ~result_key, - step_with_previous.step.d, + ~next_steps, + ~infomap=Id.Map.empty, + 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 rec previous_step = - (~hidden=false, step: Stepper.step_with_previous): list(Node.t) => { - [ + 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 button_hide_stepper = + Widgets.toggle(~tooltip="Show Stepper", "s", true, _ => + inject(UpdateAction.ToggleStepper(result_key)) + ); + let toggle_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( - ~attrs=[ - Attr.classes( - ["cell-item", "cell-result"] @ (hidden ? ["hidden"] : []), - ), - ], - [ - div(~attrs=[Attr.class_("equiv")], [Node.text("≡")]), - dh_code_previous(step), - div( - ~attrs=[Attr.classes(["stepper-justification"])], - [ - Node.text( - Stepper.get_justification(step.step.knd) - ++ (hidden ? " (hidden)" : ""), - ), - ], - ), - ], - ), - ] - @ ( - ( + ~attrs=[Attr.classes(["cell-item", "cell-result"])], + read_only + ? [ + div(~attrs=[Attr.class_("equiv")], [Node.text("≡")]), + step_dh_code(~next_steps=[], hd), + ] + : [ + div(~attrs=[Attr.class_("equiv")], [Node.text("≡")]), + 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, + toggle_show_history, + button_hide_stepper, + ], + ); + let dh_code_previous = step_dh_code; + let rec previous_step = + (~hidden: bool, step: Stepper.step_info): list(Node.t) => { + let hidden_steps = settings.show_hidden_steps - ? List.map( - step => - {step, previous: None, hidden: []} - |> previous_step(~hidden=true), - step.hidden, - ) - : [] - ) - |> List.flatten - ); - }; - let dh_code_current = d => - div( - ~attrs=[Attr.classes(["result"])], + ? Stepper.hidden_steps_of_info(step) + |> List.rev_map(previous_step(~hidden=true)) + |> List.flatten + : []; [ - DHCode.view( - ~inject, - ~settings, - ~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) |> List.map(snd), - ~hidden_steps=hidden, - ~result_key, - d, + div( + ~attrs=[ + Attr.classes( + ["cell-item", "cell-result"] @ (hidden ? ["hidden"] : []), + ), + ], + [ + div(~attrs=[Attr.class_("equiv")], [Node.text("≡")]), + dh_code_previous(~next_steps=[], step), + div( + ~attrs=[Attr.classes(["stepper-justification"])], + step.chosen_step + |> Option.map((chosen_step: EvaluatorStep.step) => + chosen_step.knd |> Stepper.get_justification |> Node.text + ) + |> Option.to_list, + ), + ], ), - ], - ); - - let current = + ] + @ hidden_steps; + }; ( ( - settings.show_hidden_steps - ? List.map( - step => - {step, previous: None, hidden: []} - |> previous_step(~hidden=true), - hidden, - ) + 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 + : [], + ) : [] ) - |> List.flatten - |> List.rev + @ [current] ) - @ [ - switch (stepper.current) { - | StepperOK(d, _) => - div( - ~attrs=[Attr.classes(["cell-item", "cell-result"])], - [ - div(~attrs=[Attr.class_("equiv")], [Node.text("≡")]), - dh_code_current(d), - button_back, - eval_settings, - show_history, - hide_stepper, - ], - ) - // TODO[Matt]: show errors and waiting - | StepTimeout - | StepPending(_, _, _) => div([]) - }, - ]; - let nodes_previous = List.map(previous_step, previous) |> List.flatten; - List.fold_left((x, y) => List.cons(y, x), current, nodes_previous) - @ (settings.show_settings ? settings_modal(~inject, settings) : []); + @ (settings.show_settings ? settings_modal(~inject, settings) : []); + }; }; diff --git a/src/haz3lweb/view/TestView.re b/src/haz3lweb/view/TestView.re index 7b62e1ad09..1b01158c56 100644 --- a/src/haz3lweb/view/TestView.re +++ b/src/haz3lweb/view/TestView.re @@ -8,7 +8,13 @@ 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, + ~infomap, + (d, status): TestMap.instance_report, + ) => div( ~attrs=[clss(["test-instance", TestStatus.to_string(status)])], [ @@ -19,6 +25,7 @@ let test_instance_view = ~font_metrics, ~width=40, ~result_key="", + ~infomap, d, ), ], @@ -36,6 +43,7 @@ let test_report_view = ~inject, ~font_metrics, ~description: option(string)=None, + ~infomap, i: int, (id, instance_reports): TestMap.report, ) => { @@ -55,7 +63,7 @@ let test_report_view = div( ~attrs=[Attr.class_("test-instances")], List.map( - test_instance_view(~settings, ~inject, ~font_metrics), + test_instance_view(~infomap, ~settings, ~inject, ~font_metrics), instance_reports, ), ), @@ -70,7 +78,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( ~attrs=[clss(["panel-body", "test-reports"])], switch (test_results) { @@ -82,6 +96,7 @@ let test_reports_view = ~settings, ~inject, ~font_metrics, + ~infomap, ~description=List.nth_opt(test_results.descriptions, i), i, r, @@ -159,6 +174,7 @@ let inspector_view = ~inject, ~font_metrics, ~test_map: TestMap.t, + ~infomap, id: Haz3lcore.Id.t, ) : option(t) => { @@ -171,7 +187,7 @@ let inspector_view = div( ~attrs=[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/Type.re b/src/haz3lweb/view/Type.re index 8e755b7749..4ee4f29af2 100644 --- a/src/haz3lweb/view/Type.re +++ b/src/haz3lweb/view/Type.re @@ -3,24 +3,20 @@ 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(~attrs=[clss(["typ-view", cls])], [text(s)]); let alias_view = (s: string): Node.t => div(~attrs=[clss(["typ-alias-view"])], [text(s)]); -let prov_view: Typ.type_provenance => Node.t = - fun - | Internal => div([]) - | Free(name) => - div(~attrs=[clss(["typ-mod", "free-type-var"])], [text(name)]) - | TypeHole => - div(~attrs=[clss(["typ-mod", "type-hole"])], [text("𝜏")]) - | SynSwitch => - div(~attrs=[clss(["typ-mod", "syn-switch"])], [text("⇒")]); - let rec view_ty = (~strip_outer_parens=false, ty: Haz3lcore.Typ.t): Node.t => - switch (ty) { + switch (Typ.term_of(ty)) { | Unknown(prov) => div( ~attrs=[ @@ -29,6 +25,7 @@ let rec view_ty = (~strip_outer_parens=false, 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") @@ -37,12 +34,12 @@ let rec view_ty = (~strip_outer_parens=false, ty: Haz3lcore.Typ.t): Node.t => | Rec(name, t) => div( ~attrs=[clss(["typ-view", "Rec"])], - [text("rec " ++ name ++ " -> "), view_ty(t)], + [text("Rec " ++ tpat_view(name) ++ ". "), view_ty(t)], ) | Forall(name, t) => div( ~attrs=[clss(["typ-view", "Forall"])], - [text("forall " ++ name ++ " -> "), view_ty(t)], + [text("forall " ++ tpat_view(name) ++ " -> "), view_ty(t)], ) | List(t) => div( @@ -97,16 +94,25 @@ let rec view_ty = (~strip_outer_parens=false, ty: Haz3lcore.Typ.t): Node.t => ctr_view(t0) @ ts_views; }, ) + | Ap(_) => + div( + ~attrs=[ + clss(["typ-view", "atom", "unknown"]), + Attr.title(Typ.show_type_provenance(Internal)), + ], + [text("?") /*, prov_view(prov)*/], + ) } -and ctr_view = ((ctr, typ)) => - switch (typ) { - | None => [text(ctr)] - | Some(typ) => [ +and ctr_view = + fun + | Variant(ctr, _, None) => [text(ctr)] + | Variant(ctr, _, Some(typ)) => [ text(ctr ++ "("), - view_ty(~strip_outer_parens=true, typ), + view_ty(typ), text(")"), ] - } + | BadEntry(typ) => [view_ty(typ)] + and paren_view = typ => if (Typ.needs_parens(typ)) { [text("("), view_ty(~strip_outer_parens=true, typ), text(")")]; diff --git a/src/haz3lweb/view/dhcode/DHCode.re b/src/haz3lweb/view/dhcode/DHCode.re index 4a8c14f5de..b28f9e18bf 100644 --- a/src/haz3lweb/view/dhcode/DHCode.re +++ b/src/haz3lweb/view/dhcode/DHCode.re @@ -96,12 +96,9 @@ let view_of_layout = ds, ) | VarHole(_) => ([with_cls("InVarHole", txt)], ds) - | Invalid((_, (-666))) => - /* Evaluation and Elaboration exceptions */ - ([with_cls("exception", txt)], ds) - | NonEmptyHole(_) + | NonEmptyHole | InconsistentBranches(_) - | Invalid(_) => + | Invalid => let offset = start.col - indent; let decoration = Decoration_common.container( @@ -128,15 +125,16 @@ let view = ~locked as _=false, // NOTE: When we add mouse events to this, ignore them if locked ~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, - ~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)=[], + ~next_steps: list((int, Id.t))=[], ~result_key: string, + ~infomap, d: DHExp.t, ) : Node.t => { @@ -149,6 +147,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 6884819d78..2b351315d3 100644 --- a/src/haz3lweb/view/dhcode/layout/DHAnnot.re +++ b/src/haz3lweb/view/dhcode/layout/DHAnnot.re @@ -8,11 +8,11 @@ type t = | Term | HoleLabel | Delim - | EmptyHole(bool, HoleInstance.t) - | NonEmptyHole(ErrStatus.HoleReason.t, HoleInstance.t) - | VarHole(VarErrStatus.HoleReason.t, HoleInstance.t) - | InconsistentBranches(HoleInstance.t) - | Invalid(HoleInstance.t) + | EmptyHole(bool, ClosureEnvironment.t) + | NonEmptyHole + | VarHole(VarErrStatus.HoleReason.t, Id.t) + | InconsistentBranches(Id.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 9edb84e014..34efdf0735 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,81 +37,83 @@ 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 }; let rec precedence = (~show_casts: bool, d: DHExp.t) => { let precedence' = precedence(~show_casts); - switch (d) { - | BoundVar(_) - | FreeVar(_) - | InvalidText(_) - | BoolLit(_) - | IntLit(_) - | Sequence(_) + switch (DHExp.term_of(d)) { + | Var(_) + | Invalid(_) + | Bool(_) + | Int(_) + | Seq(_) | Test(_) - | FloatLit(_) - | StringLit(_) + | Float(_) + | String(_) | ListLit(_) - | Prj(_) - | EmptyHole(_) + | EmptyHole | Constructor(_) | FailedCast(_) - | InvalidOperation(_) - | IfThenElse(_) + | DynamicErrorHole(_) + | If(_) + | Closure(_) | BuiltinFun(_) - | Filter(_) + | Deferral(_) | Undefined - | Closure(_) => DHDoc_common.precedence_const + | 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 - | ApBuiltin(_) => DHDoc_common.precedence_Ap | Cons(_) => DHDoc_common.precedence_Cons | ListConcat(_) => DHDoc_common.precedence_Plus | Tuple(_) => DHDoc_common.precedence_Comma | TypFun(_) | Fun(_) => DHDoc_common.precedence_max | Let(_) + | TyAlias(_) | FixF(_) - | 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) - - | NonEmptyHole(_, _, _, d) => precedence'(d) + | 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) + | BinOp(String(op), _, _) => precedence_bin_string_op(op) + | MultiHole(_) => DHDoc_common.precedence_max + | Parens(d) => precedence'(d) }; }; -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 = ( ~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), // 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 + ~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 => { @@ -121,34 +123,36 @@ 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, int)), recent_subst: list(Var.t), ) : DHDoc.t => { open Doc; 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) + | 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)) { + | Fun(p, _, _, _) => DHPat.bound_vars(p) + | _ => [] + } | (FunAp, _) => [] | (LetBind, Let(p, _, _)) => DHPat.bound_vars(p) | (LetBind, _) => [] - | (FixUnwrap, FixF(f, _, _)) => [f] + | (FixUnwrap, FixF(p, _, _)) => DHPat.bound_vars(p) | (FixUnwrap, _) => [] | (TypFunAp, _) // TODO: Could also do something here for type variable substitution like in FunAp? | (InvalidStep, _) | (VarLookup, _) - | (Sequence, _) + | (Seq, _) | (FunClosure, _) | (FixClosure, _) + | (DeferredAp, _) | (UpdateTest, _) | (CastTypAp, _) | (CastAp, _) | (BuiltinWrap, _) + | (UnOp(_), _) | (BuiltinAp(_), _) | (BinBoolOp(_), _) | (BinIntOp(_), _) @@ -158,57 +162,23 @@ let mk = | (ListCons, _) | (ListConcat, _) | (CaseApply, _) - | (CaseNext, _) | (CompleteClosure, _) | (CompleteFilter, _) | (Cast, _) | (Conditional(_), _) - | (Skip, _) => [] + | (RemoveParens, _) + | (RemoveTypeAlias, _) => [] // Maybe this last one could count as a substitution? } | _ => 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, - 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, - ); + go(d, env, enforce_inline, recent_subst); }; let parenthesize = (b, doc) => if (b) { @@ -220,29 +190,21 @@ 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 = ((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); hcats([ DHDoc_common.Delim.bar_Rule, - DHDoc_Pat.mk(dp) + DHDoc_Pat.mk(~infomap, ~show_casts=settings.show_casts, dp) |> DHDoc_common.pad_child( ~inline_padding=(space(), space()), ~enforce_inline=false, @@ -251,46 +213,45 @@ 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)]), hcats([ linebreak(), - indent_and_align(go'(~enforce_inline=false, dscrut, kind)), + 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(consistent)), + 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 (d) { - | Closure(env', d') => go'(d', Closure, ~env=env') + switch (DHExp.term_of(d)) { + | Parens(d') => go'(d') + | 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), @@ -301,170 +262,173 @@ 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') }; } /* 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)); - | NonEmptyHole(reason, u, i, d') => - go'(d', NonEmptyHole) - |> 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)) - | InconsistentBranches(u, i, Case(dscrut, drs, _)) => - go_case(dscrut, drs, false) - |> annot(DHAnnot.InconsistentBranches((u, i))) - | BoundVar(x) when settings.show_lookup_steps => text(x) - | BoundVar(x) => + | EmptyHole => + DHDoc_common.mk_EmptyHole( + ~selected=Some(DHExp.rep_id(d)) == selected_hole_instance, + env, + ) + | MultiHole(_ds) => + DHDoc_common.mk_EmptyHole( + ~selected=Some(DHExp.rep_id(d)) == selected_hole_instance, + env, + ) + | Invalid(t) => DHDoc_common.mk_InvalidText(t) + | 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, d) |> 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 { - go'(~env=ClosureEnvironment.empty, d', BoundVar); + go'(~env=ClosureEnvironment.empty, d'); } } | 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) | Undefined => DHDoc_common.mk_Undefined() - | Test(_, d) => DHDoc_common.mk_Test(go'(d, Test)) - | Sequence(d1, d2) => - let (doc1, doc2) = (go'(d1, Sequence1), go'(d2, Sequence2)); + | 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); - | ListLit(_, _, _, d_list) => - let ol = d_list |> List.mapi((i, d) => go'(d, ListLit(i))); + | 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, Ap1) + go_formattable(d1) |> parenthesize(precedence(d1) > DHDoc_common.precedence_Ap), - go'(d2, Ap2), + 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); | 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); - | ApBuiltin(ident, d) => + | 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); + | UnOp(Meta(Unquote), d) => DHDoc_common.mk_Ap( - text(ident), - go_formattable(d, ApBuiltin) + text("$"), + go_formattable(d) |> parenthesize(precedence(d) > DHDoc_common.precedence_Ap), ) - | BinIntOp(op, d1, d2) => + | 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) = - mk_left_associative_operands( - precedence_bin_int_op(op), - (d1, BinIntOp1), - (d2, BinIntOp2), - ); + mk_left_associative_operands(precedence_bin_int_op(op), d1, d2); 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), - ); + mk_left_associative_operands(precedence_bin_float_op(op), d1, d2); 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), - ); + 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); - | 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), - ); + 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) - | ConsistentCase(Case(dscrut, drs, _)) => go_case(dscrut, drs, true) - | Cast(d, _, ty) when settings.show_casts => + | 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, t1, t2) when settings.show_casts => // TODO[Matt]: Roll multiple casts into one cast - let doc = go'(d, Cast); + let doc = + go_formattable(d) + |> parenthesize(precedence(d) > DHDoc_common.precedence_Ap); Doc.( hcat( 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, + ]), ), ) ); | 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"), - DHDoc_Pat.mk(dp) + DHDoc_Pat.mk(~infomap, ~show_casts=settings.show_casts, dp) |> DHDoc_common.pad_child( ~inline_padding=(space(), space()), ~enforce_inline, @@ -481,14 +445,13 @@ 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, - Let2, ), ]); } - | FailedCast(Cast(d, ty1, ty2), ty2', ty3) when Typ.eq(ty2, ty2') => - let d_doc = go'(d, FailedCastCast); + | FailedCast(d1, ty1, ty3) => + let d_doc = go'(d1); let cast_decoration = hcats([ DHDoc_common.Delim.open_FailedCast, @@ -501,19 +464,16 @@ let mk = ]) |> annot(DHAnnot.FailedCastDecoration); hcats([d_doc, cast_decoration]); - | FailedCast(_d, _ty1, _ty2) => - failwith("unexpected FailedCast without inner cast") - | InvalidOperation(d, err) => - let d_doc = go'(d, InvalidOperation); + | DynamicErrorHole(d, err) => + let d_doc = go'(d); let decoration = Doc.text(InvalidOperationError.err_msg(err)) |> 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); + let d1_doc = go_formattable(d1); + let d2_doc = go_formattable(d2); hcats([ DHDoc_common.Delim.mk("("), DHDoc_common.Delim.mk("if"), @@ -536,68 +496,86 @@ let mk = ), DHDoc_common.Delim.mk(")"), ]); - | Fun(dp, ty, dbody, s) when settings.show_fn_bodies => - let bindings = DHPat.bound_vars(dp); - let body_doc = - switch (dbody) { - | Closure(env', dbody) => + | Fun(dp, d, Some(env'), s) => + if (settings.show_fn_bodies) { + let bindings = DHPat.bound_vars(dp); + let body_doc = go_formattable( - Closure(env', dbody), + Closure( + ClosureEnvironment.without_keys(Option.to_list(s), env'), + d, + ) + |> DHExp.fresh, ~env= ClosureEnvironment.without_keys( DHPat.bound_vars(dp) @ Option.to_list(s), env, ), ~recent_subst= - List.filter(x => !List.mem(x, bindings), next_recent_subst), - Fun, - ) - | _ => + List.filter(x => !List.mem(x, bindings), recent_subst), + ); + hcats( + [ + DHDoc_common.Delim.sym_Fun, + DHDoc_Pat.mk(~infomap, ~show_casts=settings.show_casts, dp) + |> DHDoc_common.pad_child( + ~inline_padding=(space(), space()), + ~enforce_inline, + ), + ] + @ [ + DHDoc_common.Delim.arrow_Fun, + space(), + body_doc |> DHDoc_common.pad_child(~enforce_inline=false), + ], + ); + } else { + 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) { + let bindings = DHPat.bound_vars(dp); + let body_doc = go_formattable( dbody, ~env=ClosureEnvironment.without_keys(bindings, env), ~recent_subst= - List.filter(x => !List.mem(x, bindings), next_recent_subst), - Fun, - ) - }; - hcats( - [ - DHDoc_common.Delim.sym_Fun, - DHDoc_Pat.mk(dp) - |> DHDoc_common.pad_child( - ~inline_padding=(space(), space()), - ~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(), - body_doc |> DHDoc_common.pad_child(~enforce_inline=false), - ], - ); - | Fun(_, _, _, s) => - let name = + List.filter(x => !List.mem(x, bindings), recent_subst), + ); + hcats( + [ + DHDoc_common.Delim.sym_Fun, + DHDoc_Pat.mk(~infomap, ~show_casts=settings.show_casts, dp) + |> DHDoc_common.pad_child( + ~inline_padding=(space(), space()), + ~enforce_inline, + ), + ] + @ [ + DHDoc_common.Delim.arrow_Fun, + space(), + body_doc |> DHDoc_common.pad_child(~enforce_inline), + ], + ); + } else { switch (s) { - | None => "anon fn" - | Some(name) - when - !settings.show_fixpoints - && String.ends_with(~suffix="+", name) => - String.sub(name, 0, String.length(name) - 1) - | Some(name) => name + | None => annot(DHAnnot.Collapsed, text("")) + | Some(name) => annot(DHAnnot.Collapsed, text("<" ++ name ++ ">")) }; - annot(DHAnnot.Collapsed, text("<" ++ name ++ ">")); + } | TypFun(_tpat, _dbody, s) => /* same display as with Fun but with anon typfn in the nameless case. */ let name = @@ -611,25 +589,24 @@ let mk = | Some(name) => name }; annot(DHAnnot.Collapsed, text("<" ++ name ++ ">")); - | FixF(x, ty, dbody) + | FixF(dp, dbody, _) when settings.show_fn_bodies && settings.show_fixpoints => let doc_body = go_formattable( dbody, - ~env=ClosureEnvironment.without_keys([x], env), - FixF, + ~env=ClosureEnvironment.without_keys(DHPat.bound_vars(dp), env), ); hcats( - [DHDoc_common.Delim.fix_FixF, space(), text(x)] - @ ( - settings.show_casts - ? [ - DHDoc_common.Delim.colon_Fun, - space(), - DHDoc_Typ.mk(~enforce_inline=true, ty), - ] - : [] - ) + [ + DHDoc_common.Delim.fix_FixF, + space(), + DHDoc_Pat.mk( + ~infomap, + dp, + ~show_casts=settings.show_casts, + ~enforce_inline=true, + ), + ] @ [ space(), DHDoc_common.Delim.arrow_FixF, @@ -637,20 +614,39 @@ let mk = doc_body |> DHDoc_common.pad_child(~enforce_inline), ], ); - | FixF(x, _, _) => annot(DHAnnot.Collapsed, text("<" ++ x ++ ">")) + | FixF(_, {term: Fun(_, _, _, Some(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("")) }; }; let steppable = - next_steps |> List.find_opt(((ctx, _)) => ctx == EvalCtx.Mark); + next_steps |> List.find_opt(((_, id)) => id == 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, id)) => + step.knd == VarLookup + // HACK[Matt]: to prevent substitutions hiding inside casts + && id == DHExp.rep_id(d) + ); let doc = switch (substitution) { - | Some({d_loc: BoundVar(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 = @@ -658,20 +654,11 @@ let mk = annot(DHAnnot.Stepped, doc); } else { switch (steppable) { - | Some((_, full)) => annot(DHAnnot.Steppable(full), doc) + | Some((i, _)) => annot(DHAnnot.Steppable(i), doc) | None => doc }; }; doc; }; - go( - d, - env, - enforce_inline, - previous_step, - hidden_steps, - chosen_step, - List.mapi((idx, x: EvalObj.t) => (x.ctx, idx), next_steps), - [], - ); + go(d, env, enforce_inline, []); }; diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re index 5c6be4a6e1..8996bd4b03 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re @@ -1,28 +1,36 @@ open Pretty; open Haz3lcore; -let precedence = (dp: DHPat.t) => - switch (dp) { - | EmptyHole(_) - | NonEmptyHole(_) +let precedence = (dp: Pat.t) => + switch (DHPat.term_of(dp)) { + | EmptyHole + | MultiHole(_) | Wild - | InvalidText(_) - | BadConstructor(_) + | Invalid(_) | Var(_) - | IntLit(_) - | FloatLit(_) - | BoolLit(_) - | StringLit(_) + | Int(_) + | Float(_) + | Bool(_) + | String(_) | ListLit(_) | Constructor(_) => DHDoc_common.precedence_const | Tuple(_) => DHDoc_common.precedence_Comma | Cons(_) => DHDoc_common.precedence_Cons | Ap(_) => DHDoc_common.precedence_Ap + | Parens(_) => DHDoc_common.precedence_const + | Cast(_) => DHDoc_common.precedence_Ap }; let rec mk = - (~parenthesize=false, ~enforce_inline: bool, dp: DHPat.t): DHDoc.t => { - let mk' = mk(~enforce_inline); + ( + ~infomap: Statics.Map.t, + ~parenthesize=false, + ~show_casts, + ~enforce_inline: bool, + dp: Pat.t, + ) + : DHDoc.t => { + 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), @@ -32,20 +40,18 @@ let rec mk = mk'(~parenthesize=precedence(dp2) > precedence_op, dp2), ); let doc = - switch (dp) { - | EmptyHole(u, i) => DHDoc_common.mk_EmptyHole((u, i)) - | NonEmptyHole(reason, u, i, dp) => - mk'(dp) |> Doc.annot(DHAnnot.NonEmptyHole(reason, (u, i))) - | InvalidText(u, i, t) => DHDoc_common.mk_InvalidText(t, (u, i)) - | BadConstructor(u, i, t) => DHDoc_common.mk_InvalidText(t, (u, i)) + switch (DHPat.term_of(dp)) { + | MultiHole(_) + | EmptyHole => DHDoc_common.mk_EmptyHole(ClosureEnvironment.empty) + | Invalid(t) => DHDoc_common.mk_InvalidText(t) | 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) - | ListLit(_, d_list) => + | 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); | Cons(dp1, dp2) => @@ -54,11 +60,34 @@ 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 + | Cast(dp, t1, t2) when show_casts => + Doc.hcats([ + mk'(dp), + 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, + ]), + ), + ]) + | 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); 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 deleted file mode 100644 index 33c37b6092..0000000000 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.rei +++ /dev/null @@ -1,5 +0,0 @@ -open Haz3lcore; - -let precedence: DHPat.t => int; - -let mk: (~parenthesize: bool=?, ~enforce_inline: bool, DHPat.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_Util.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Util.re index f127804400..9e9578d217 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_IntLit = n => Doc.text(string_of_int(n)); diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_common.re b/src/haz3lweb/view/dhcode/layout/DHDoc_common.re index 5a2dfda78d..2f35d5f0ab 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; @@ -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)]); "?"; @@ -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"); @@ -80,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); @@ -88,11 +87,10 @@ 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_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])); @@ -138,7 +136,6 @@ let mk_TypAp = (doc1, doc2) => let mk_Ap = (doc1, doc2) => Doc.(hcats([doc1, text("("), doc2, text(")")])); -let mk_Prj = (targ, n) => - Doc.hcats([targ, Delim.projection_dot, Doc.text(string_of_int(n))]); +let mk_rev_Ap = (doc1, doc2) => Doc.(hcats([doc1, text(" |> "), doc2])); let mk_Undefined = () => Doc.text("undefined"); diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_common.rei b/src/haz3lweb/view/dhcode/layout/DHDoc_common.rei index c801c4a8d9..aec422a020 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; @@ -29,7 +30,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; @@ -54,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); @@ -62,9 +64,9 @@ 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_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); @@ -92,6 +94,6 @@ let mk_TypAp: (Pretty.Doc.t('a), 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_Prj: (Pretty.Doc.t(DHAnnot.t), int) => Pretty.Doc.t(DHAnnot.t); +let mk_rev_Ap: (Pretty.Doc.t('a), Pretty.Doc.t('a)) => Pretty.Doc.t('a); let mk_Undefined: unit => Pretty.Doc.t('a); diff --git a/src/haz3lweb/view/dhcode/layout/HTypDoc.re b/src/haz3lweb/view/dhcode/layout/HTypDoc.re index c1ffa32652..996d01f607 100644 --- a/src/haz3lweb/view/dhcode/layout/HTypDoc.re +++ b/src/haz3lweb/view/dhcode/layout/HTypDoc.re @@ -6,6 +6,30 @@ 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(_) + | Forall(_) + | 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()), @@ -18,7 +42,7 @@ let pad_child = Doc.( hcats([ linebreak(), - indent_and_align(child(~enforce_inline=false)), + indent_and_align(child(~enforce_inline)), linebreak(), ]) ); @@ -33,15 +57,16 @@ 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) = - switch (ty) { + switch (Typ.term_of(ty)) { + | Parens(ty) => (mk(~parenthesize=true, ~enforce_inline, ty), false) | Unknown(_) => ( annot(HTypAnnot.Delim, annot(HTypAnnot.HoleLabel, text("?"))), parenthesize, @@ -65,7 +90,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(precedence_Arrow, ty1, ty2); ( hcats([ d1, @@ -83,20 +108,13 @@ let rec mk = (~parenthesize=false, ~enforce_inline: bool, ty: Typ.t): t => { [ annot( HTypAnnot.Step(0), - mk'( - ~parenthesize=Typ.precedence(head) <= TypBase.precedence_Prod, - head, - ), + mk'(~parenthesize=precedence(head) <= precedence_Prod, head), ), ...List.mapi( (i, ty) => annot( HTypAnnot.Step(i + 1), - mk'( - ~parenthesize= - Typ.precedence(ty) <= TypBase.precedence_Prod, - ty, - ), + mk'(~parenthesize=precedence(ty) <= precedence_Prod, ty), ), tail, ), @@ -108,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)) @@ -120,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)) @@ -133,15 +151,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( @@ -149,6 +173,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/util/Aba.re b/src/util/Aba.re index 56c1a171ce..4bd23b118a 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) { diff --git a/src/util/ListUtil.re b/src/util/ListUtil.re index 20195c8a84..52ffd1ac73 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); @@ -480,3 +487,30 @@ 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]) + }; + }; + +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") + }; + +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]); + }; +}; diff --git a/test/Test_Elaboration.re b/test/Test_Elaboration.re index d584492091..184aa2fc03 100644 --- a/test/Test_Elaboration.re +++ b/test/Test_Elaboration.re @@ -1,275 +1,181 @@ 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"), - 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, + None, + ) + |> Exp.fresh, + Int(55) |> Exp.fresh, + ) + |> Exp.fresh; + +let d9: Exp.t = + Let( + 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"), - ), - IntLit(55), - ); + ) + |> 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), + "Let expression for function which is not recursive", + d9, dhexp_of_uexp(u9), );