From 3cb13b1d100653ebe51f3647e81bca7eafda8e17 Mon Sep 17 00:00:00 2001 From: Alexander Bandukwala <7h3kk1d@gmail.com> Date: Tue, 13 Aug 2024 09:59:33 -0400 Subject: [PATCH 1/8] Make id a type param on tile --- src/haz3lcore/Measured.re | 53 ++-- src/haz3lcore/TermRanges.re | 6 +- src/haz3lcore/TileMap.re | 11 +- src/haz3lcore/assistant/TyDi.re | 4 +- src/haz3lcore/statics/MakeTerm.re | 18 +- src/haz3lcore/tiles/Base.re | 20 +- src/haz3lcore/tiles/Piece.re | 63 ++-- src/haz3lcore/tiles/Segment.re | 107 ++++--- src/haz3lcore/tiles/Skel.re | 15 +- src/haz3lcore/tiles/Tile.re | 53 ++-- src/haz3lcore/zipper/Ancestor.re | 17 +- src/haz3lcore/zipper/Ancestors.re | 10 +- src/haz3lcore/zipper/Backpack.re | 63 ++-- src/haz3lcore/zipper/Editor.re | 4 +- src/haz3lcore/zipper/Printer.re | 10 +- src/haz3lcore/zipper/Projector.re | 6 +- src/haz3lcore/zipper/ProjectorBase.re | 6 +- src/haz3lcore/zipper/Relatives.re | 14 +- src/haz3lcore/zipper/Selection.re | 11 +- src/haz3lcore/zipper/Siblings.re | 22 +- src/haz3lcore/zipper/Zipper.re | 11 +- src/haz3lcore/zipper/ZipperBase.re | 18 +- src/haz3lcore/zipper/action/Action.re | 2 +- src/haz3lcore/zipper/action/Indicated.re | 4 +- src/haz3lcore/zipper/action/Insert.re | 2 +- src/haz3lcore/zipper/action/Move.re | 2 +- .../zipper/action/ProjectorPerform.re | 19 +- .../zipper/projectors/CheckboxProj.re | 13 +- src/haz3lcore/zipper/projectors/InfoProj.re | 2 +- .../zipper/projectors/SliderFProj.re | 7 +- src/haz3lcore/zipper/projectors/SliderProj.re | 6 +- .../zipper/projectors/TextAreaProj.re | 8 +- src/haz3lweb/DebugConsole.re | 6 +- src/haz3lweb/exercises/Ex_OddlyRecursive.ml | 284 ++++++++--------- .../exercises/Ex_RecursiveFibonacci.ml | 294 +++++++++--------- src/haz3lweb/explainthis/Example.re | 19 +- src/haz3lweb/explainthis/ExplainThisForm.re | 21 +- src/haz3lweb/explainthis/ExplainThisModel.re | 4 +- src/haz3lweb/view/BackpackView.re | 10 +- src/haz3lweb/view/Cell.re | 2 +- src/haz3lweb/view/Code.re | 16 +- src/haz3lweb/view/Deco.re | 21 +- src/haz3lweb/view/ExplainThis.re | 4 +- src/haz3lweb/view/ProjectorView.re | 2 +- 44 files changed, 674 insertions(+), 616 deletions(-) diff --git a/src/haz3lcore/Measured.re b/src/haz3lcore/Measured.re index 61dad8a831..894f810943 100644 --- a/src/haz3lcore/Measured.re +++ b/src/haz3lcore/Measured.re @@ -85,12 +85,12 @@ let add_s = (id: Id.t, i: int, m, map) => { }; // assumes tile is single shard -let add_t = (t: Tile.t, m, map) => { +let add_t = (t: Tile.t(Id.t), m, map) => { ...map, tiles: map.tiles |> Id.Map.update( - t.id, + t.extra, fun | None => Some([(Tile.l_shard(t), m)]) | Some(ms) => Some([(Tile.l_shard(t), m), ...ms]), @@ -104,11 +104,11 @@ let add_w = (w: Secondary.t, m, map) => { ...map, secondary: map.secondary |> Id.Map.add(w.id, m), }; -let add_pr = (p: Base.projector, m, map) => { +let add_pr = (p: Base.projector(Id.t), m, map) => { ...map, - projectors: map.projectors |> Id.Map.add(p.id, m), + projectors: map.projectors |> Id.Map.add(p.extra, m), }; -let add_p = (p: Piece.t, m, map) => +let add_p = (p: Piece.t(Id.t), m, map) => p |> Piece.get( w => add_w(w, m, map), @@ -141,9 +141,10 @@ let singleton_g = (g, m) => empty |> add_g(g, m); let singleton_s = (id, shard, m) => empty |> add_s(id, shard, m); // TODO(d) rename -let find_opt_shards = (t: Tile.t, map) => Id.Map.find_opt(t.id, map.tiles); -let find_shards = (~msg="", t: Tile.t, map) => - try(Id.Map.find(t.id, map.tiles)) { +let find_opt_shards = (t: Tile.t(Id.t), map) => + Id.Map.find_opt(t.extra, map.tiles); +let find_shards = (~msg="", t: Tile.t(Id.t), map) => + try(Id.Map.find(t.extra, map.tiles)) { | _ => failwith("find_shards: " ++ msg) }; @@ -163,15 +164,15 @@ let find_g = (~msg="", g: Grout.t, map): measurement => try(Id.Map.find(g.id, map.grout)) { | _ => failwith("find_g: " ++ msg) }; -let find_pr = (~msg="", p: Base.projector, map): measurement => - try(Id.Map.find(p.id, map.projectors)) { +let find_pr = (~msg="", p: Base.projector(Id.t), map): measurement => + try(Id.Map.find(p.extra, map.projectors)) { | _ => failwith("find_g: " ++ msg) }; -let find_pr_opt = (p: Base.projector, map): option(measurement) => - Id.Map.find_opt(p.id, map.projectors); +let find_pr_opt = (p: Base.projector(Id.t), map): option(measurement) => + Id.Map.find_opt(p.extra, map.projectors); // returns the measurement spanning the whole tile -let find_t = (t: Tile.t, map): measurement => { - let shards = Id.Map.find(t.id, map.tiles); +let find_t = (t: Tile.t(Id.t), map): measurement => { + let shards = Id.Map.find(t.extra, map.tiles); let (first, last) = try({ let first = ListUtil.assoc_err(Tile.l_shard(t), shards, "find_t"); @@ -182,7 +183,7 @@ let find_t = (t: Tile.t, map): measurement => { }; {origin: first.origin, last: last.last}; }; -let find_p = (~msg="", p: Piece.t, map): measurement => +let find_p = (~msg="", p: Piece.t(Id.t), map): measurement => try( p |> Piece.get( @@ -228,7 +229,7 @@ let find_by_id = (id: Id.t, map: t): option(measurement) => { }; }; -let post_tile_indent = (t: Tile.t) => { +let post_tile_indent = (t: Tile.t(Id.t)) => { // hack for indent following fun/if tiles. // proper fix involves updating mold datatype // to specify whether a right-facing concave @@ -244,13 +245,13 @@ let post_tile_indent = (t: Tile.t) => { complete_fun || missing_right_extreme; }; -let missing_left_extreme = (t: Tile.t) => Tile.l_shard(t) > 0; +let missing_left_extreme = (t: Tile.t(Id.t)) => Tile.l_shard(t) > 0; -let is_indented_map = (seg: Segment.t) => { - let rec go = (~is_indented=false, ~map=Id.Map.empty, seg: Segment.t) => +let is_indented_map = (seg: Segment.t(Id.t)) => { + let rec go = (~is_indented=false, ~map=Id.Map.empty, seg: Segment.t(Id.t)) => seg |> List.fold_left( - ((is_indented, map), p: Piece.t) => + ((is_indented, map), p: Piece.t(Id.t)) => switch (p) { | Secondary(w) when Secondary.is_linebreak(w) => ( false, @@ -282,7 +283,7 @@ let last_of_token = (token: string, origin: Point.t): Point.t => row: origin.row + StringUtil.num_linebreaks(token), }; -let of_segment = (seg: Segment.t, info_map: Statics.Map.t): t => { +let of_segment = (seg: Segment.t(Id.t), info_map: Statics.Map.t): t => { let is_indented = is_indented_map(seg); // recursive across seg's bidelimited containers @@ -291,7 +292,7 @@ let of_segment = (seg: Segment.t, info_map: Statics.Map.t): t => { ~map, ~container_indent: abs_indent=0, ~origin=Point.zero, - seg: Segment.t, + seg: Segment.t(Id.t), ) : (Point.t, t) => { // recursive across seg's list structure @@ -300,7 +301,7 @@ let of_segment = (seg: Segment.t, info_map: Statics.Map.t): t => { ~map, ~contained_indent: rel_indent=0, ~origin: Point.t, - seg: Segment.t, + seg: Segment.t(Id.t), ) : (Point.t, t) => switch (seg) { @@ -354,7 +355,7 @@ let of_segment = (seg: Segment.t, info_map: Statics.Map.t): t => { (contained_indent, last, map); | Projector(p) => let token = - Projector.placeholder(p, Id.Map.find_opt(p.id, info_map)); + Projector.placeholder(p, Id.Map.find_opt(p.extra, info_map)); let last = last_of_token(token, origin); let map = extra_rows(token, origin, map); let map = add_pr(p, {origin, last}, map); @@ -364,7 +365,7 @@ let of_segment = (seg: Segment.t, info_map: Statics.Map.t): t => { let token = List.nth(t.label, shard); let map = extra_rows(token, origin, map); let last = last_of_token(token, origin); - let map = add_s(t.id, shard, {origin, last}, map); + let map = add_s(t.extra, shard, {origin, last}, map); (last, map); }; let (last, map) = @@ -392,7 +393,7 @@ let of_segment = (seg: Segment.t, info_map: Statics.Map.t): t => { snd(go_nested(~map=empty, seg)); }; -let length = (seg: Segment.t, map: t): int => +let length = (seg: Segment.t(Id.t), map: t): int => switch (seg) { | [] => 0 | [p] => diff --git a/src/haz3lcore/TermRanges.re b/src/haz3lcore/TermRanges.re index 6cbc1dfe75..890ddd55da 100644 --- a/src/haz3lcore/TermRanges.re +++ b/src/haz3lcore/TermRanges.re @@ -1,7 +1,7 @@ open Util; include Id.Map; -type range = (Piece.t, Piece.t); +type range = (Piece.t(Id.t), Piece.t(Id.t)); type nonrec t = t(range); let union = union((_, range, _) => Some(range)); @@ -11,7 +11,7 @@ let union = union((_, range, _) => Some(range)); * unmemoized traversal building a hashtbl avoiding unioning. TODO(andrew): Consider setting a limit for the hashtbl size */ -let range_hash: Hashtbl.t(Tile.segment, Id.Map.t(range)) = +let range_hash: Hashtbl.t(Tile.segment(Id.t), Id.Map.t(range)) = Hashtbl.create(1000); // NOTE: this calculation is out of sync with @@ -23,7 +23,7 @@ let range_hash: Hashtbl.t(Tile.segment, Id.Map.t(range)) = // TODO(d) fix or derive from other info // // tail-recursive in outer recursion -let rec mk' = (seg: Segment.t) => { +let rec mk' = (seg: Segment.t(Id.t)) => { let rec go = (skel: Skel.t): (range, t) => { let root = Skel.root(skel) |> Aba.map_a(List.nth(seg)); let root_l = Aba.first_a(root); diff --git a/src/haz3lcore/TileMap.re b/src/haz3lcore/TileMap.re index 8863f14393..73c47d39b2 100644 --- a/src/haz3lcore/TileMap.re +++ b/src/haz3lcore/TileMap.re @@ -1,13 +1,16 @@ include Id.Map; -type t = Id.Map.t(Tile.t); +type t = Id.Map.t(Tile.t(Id.t)); // tail-recursive -let rec mk = (~map=empty, seg: Segment.t): t => +let rec mk = (~map=empty, seg: Segment.t(Id.t)): t => Segment.tiles(seg) |> List.fold_left( - (map, t: Tile.t) => { + (map, t: Tile.t(Id.t)) => { t.children - |> List.fold_left((map, kid) => mk(~map, kid), add(t.id, t, map)) + |> List.fold_left( + (map, kid) => mk(~map, kid), + add(t.extra, t, map), + ) }, map, ); diff --git a/src/haz3lcore/assistant/TyDi.re b/src/haz3lcore/assistant/TyDi.re index 1118fc115f..ffadfc4d6a 100644 --- a/src/haz3lcore/assistant/TyDi.re +++ b/src/haz3lcore/assistant/TyDi.re @@ -50,9 +50,9 @@ let token_to_left = (z: Zipper.t): option(string) => * holds an unparsed string, which is parsed via the same mechanism as * Paste only when a suggestion is accepted. */ let mk_unparsed_buffer = - (~sort: Sort.t, sibs: Siblings.t, t: Token.t): Segment.t => { + (~sort: Sort.t, sibs: Siblings.t, t: Token.t): Segment.t(Id.t) => { let mold = Siblings.mold_fitting_between(sort, Precedence.max, sibs); - [Tile({id: Id.mk(), label: [t], shards: [0], children: [], mold})]; + [Tile({extra: Id.mk(), label: [t], shards: [0], children: [], mold})]; }; /* If 'current' is a proper prefix of 'candidate', return the diff --git a/src/haz3lcore/statics/MakeTerm.re b/src/haz3lcore/statics/MakeTerm.re index 673af0bb89..75e3a90a4e 100644 --- a/src/haz3lcore/statics/MakeTerm.re +++ b/src/haz3lcore/statics/MakeTerm.re @@ -18,7 +18,7 @@ let tokens = Piece.get( _ => [], _ => [" "], - (t: Tile.t) => t.shards |> List.map(List.nth(t.label)), + (t: Tile.t('a)) => t.shards |> List.map(List.nth(t.label)), _ => [], ); @@ -38,7 +38,7 @@ type unsorted = type t = { term: UExp.t, terms: TermMap.t, - projectors: Id.Map.t(Piece.projector), + projectors: Id.Map.t(Piece.projector(Id.t)), }; let is_nary = @@ -110,14 +110,14 @@ let return = (wrap, ids, tm) => { }; /* Map to collect projector ids */ -let projectors: ref(Id.Map.t(Piece.projector)) = ref(Id.Map.empty); +let projectors: ref(Id.Map.t(Piece.projector(Id.t))) = ref(Id.Map.empty); /* Strip a projector from a segment and log it in the map */ -let rm_and_log_projectors = (seg: Segment.t): Segment.t => +let rm_and_log_projectors = (seg: Segment.t(Id.t)): Segment.t(Id.t) => List.map( fun | Piece.Projector(pr) => { - projectors := Id.Map.add(pr.id, pr, projectors^); + projectors := Id.Map.add(pr.extra, pr, projectors^); pr.syntax; } | x => x, @@ -139,7 +139,7 @@ let mk_bad = (ctr, ids, value) => { }; }; -let rec go_s = (s: Sort.t, skel: Skel.t, seg: Segment.t): Term.Any.t => +let rec go_s = (s: Sort.t, skel: Skel.t, seg: Segment.t(Id.t)): Term.Any.t => switch (s) { | Pat => Pat(pat(unsorted(skel, seg))) | TPat => TPat(tpat(unsorted(skel, seg))) @@ -514,11 +514,11 @@ and rul = (unsorted: unsorted): Rul.t => { }; } -and unsorted = (skel: Skel.t, seg: Segment.t): unsorted => { +and unsorted = (skel: Skel.t, seg: Segment.t(Id.t)): unsorted => { /* Remove projectors. We do this here as opposed to removing * them in an external call to save a whole-syntax pass. */ let seg = rm_and_log_projectors(seg); - let tile_kids = (p: Piece.t): list(Term.Any.t) => + let tile_kids = (p: Piece.t(Id.t)): list(Term.Any.t) => switch (p) { | Secondary(_) | Grout(_) => [] @@ -531,7 +531,7 @@ and unsorted = (skel: Skel.t, seg: Segment.t): unsorted => { }) }; - let root: Aba.t(Piece.t, Skel.t) = + let root: Aba.t(Piece.t(Id.t), Skel.t) = Skel.root(skel) |> Aba.map_a(List.nth(seg)); // maintaining this alternating ordered structure diff --git a/src/haz3lcore/tiles/Base.re b/src/haz3lcore/tiles/Base.re index 8c127d83ba..c6995350ba 100644 --- a/src/haz3lcore/tiles/Base.re +++ b/src/haz3lcore/tiles/Base.re @@ -13,28 +13,28 @@ type kind = | TextArea; [@deriving (show({with_path: false}), sexp, yojson)] -type segment = list(piece) -and piece = - | Tile(tile) +type segment('a) = list(piece('a)) +and piece('a) = + | Tile(tile('a)) | Grout(Grout.t) | Secondary(Secondary.t) - | Projector(projector) -and tile = { + | Projector(projector('a)) +and tile('a) = { // invariants: // - length(mold.in_) + 1 == length(label) // - length(shards) <= length(label) // - length(shards) == length(children) + 1 // - sort(shards) == shards - id: Id.t, + extra: 'a, label: Label.t, mold: Mold.t, shards: list(int), - children: list(segment), + children: list(segment('a)), } -and projector = { - id: Id.t, +and projector('a) = { kind, - syntax: piece, + extra: 'a, + syntax: piece('a), model: string, }; diff --git a/src/haz3lcore/tiles/Piece.re b/src/haz3lcore/tiles/Piece.re index fd37cfa1d2..42acd7eb30 100644 --- a/src/haz3lcore/tiles/Piece.re +++ b/src/haz3lcore/tiles/Piece.re @@ -2,13 +2,13 @@ include Base; [@deriving (show({with_path: false}), sexp, yojson)] -type t = piece; +type t('a) = piece('a); let secondary = w => Secondary(w); let grout = g => Grout(g); let tile = t => Tile(t); -let get = (f_w, f_g, f_t: tile => _, f_p: projector => _, p: t) => +let get = (f_w, f_g, f_t: tile('a) => _, f_p: projector('a) => _, p: t('a)) => switch (p) { | Secondary(w) => f_w(w) | Grout(g) => f_g(g) @@ -16,10 +16,11 @@ let get = (f_w, f_g, f_t: tile => _, f_p: projector => _, p: t) => | Projector(p) => f_p(p) }; -let proj_id = projector => projector.id; -let id = get(Secondary.id, Grout.id, tile => tile.id, proj_id); +let proj_id = (projector: projector(Id.t)) => projector.extra; +let id = + get(Secondary.id, Grout.id, (tile: tile(Id.t)) => tile.extra, proj_id); -let sort = +let sort: t(Id.t) => (Sort.t, list(Sort.t)) = get( _ => (Sort.Any, []), _ => (Sort.Any, []), @@ -27,7 +28,7 @@ let sort = _ => (Sort.Any, []), ); -let nibs = +let nibs = x => get( _ => None, g => { @@ -39,9 +40,10 @@ let nibs = let (l, r) = ProjectorBase.shapes(p); Some(Nib.({shape: l, sort: Any}, {shape: r, sort: Any})); }, + x, ); -let nib_sorts = +let nib_sorts = x => get( _ => (Sort.Any, Sort.Any), _ => (Sort.Any, Sort.Any), @@ -50,9 +52,11 @@ let nib_sorts = (l.sort, r.sort); }, _ => (Sort.Any, Sort.Any), + x, ); -let sorted_children = get(_ => [], _ => [], Tile.sorted_children, _ => []); +let sorted_children = x => + get(_ => [], _ => [], Tile.sorted_children, _ => [], x); let children = p => sorted_children(p) |> List.split |> snd; // let is_balanced = @@ -62,14 +66,14 @@ let children = p => sorted_children(p) |> List.split |> snd; // | Grout(_) // | Tile(_) => true; -let pop_l = (p: t): (t, segment) => +let pop_l = (p: t('a)): (t('a), segment('a)) => switch (p) { | Tile(t) => Tile.pop_l(t) | Grout(_) | Secondary(_) | Projector(_) => (p, []) }; -let pop_r = (p: t): (segment, t) => +let pop_r = (p: t('a)): (segment('a), t('a)) => switch (p) { | Tile(t) => Tile.pop_r(t) | Grout(_) @@ -77,7 +81,7 @@ let pop_r = (p: t): (segment, t) => | Projector(_) => ([], p) }; -let disassemble = (p: t): segment => +let disassemble = (p: t('a)): segment('a) => switch (p) { | Grout(_) | Secondary(_) @@ -92,60 +96,61 @@ let disassemble = (p: t): segment => // | Tile(t) => List.map(tile, Tile.remold(t)) // }; -let shapes = +let shapes = x => get( _ => None, g => Some(Grout.shapes(g)), t => Some(Tile.shapes(t)), p => Some(ProjectorBase.shapes(p)), + x, ); -let is_convex = (p: t): bool => +let is_convex = (p: t('a)): bool => switch (shapes(p)) { | Some((Convex, Convex)) => true | _ => false }; -let is_grout: t => bool = +let is_grout: t('a) => bool = fun | Grout(_) => true | _ => false; -let is_secondary: t => bool = +let is_secondary: t('a) => bool = fun | Secondary(_) => true | _ => false; -let is_tile: t => option(Tile.t) = +let is_tile: t('a) => option(Tile.t('a)) = fun | Tile(t) => Some(t) | _ => None; -let is_projector: t => option(projector) = +let is_projector: t('a) => option(projector('a)) = fun | Projector(p) => Some(p) | _ => None; -let label: t => option(Label.t) = +let label: t('a) => option(Label.t) = fun | Tile({label, _}) => Some(label) | _ => None; -let monotile: t => option(Token.t) = +let monotile: t('a) => option(Token.t) = fun | Tile({label: [t], _}) => Some(t) | Secondary(w) when Secondary.is_comment(w) => Some(Secondary.get_string(w.content)) | _ => None; -let has_ends = get(_ => true, _ => true, Tile.has_ends); +let has_ends = x => get(_ => true, _ => true, Tile.has_ends, x); -let is_complete: t => bool = +let is_complete: t('a) => bool = fun | Tile(t) => Tile.is_complete(t) | _ => true; -let mold_of = (~shape=Nib.Shape.Convex, p: t) => +let mold_of = (~shape=Nib.Shape.Convex, p: t('a)) => // TODO(d) fix sorts switch (p) { | Tile(t) => t.mold @@ -154,28 +159,28 @@ let mold_of = (~shape=Nib.Shape.Convex, p: t) => | Projector(p) => ProjectorBase.mold_of(p, Any) }; -let replace_id = (id: Id.t, p: t): t => +let replace_id = (id: Id.t, p: t(Id.t)): t('a) => switch (p) { - | Tile(t) => Tile({...t, id}) + | Tile(t) => Tile({...t, extra: id}) | Grout(g) => Grout({...g, id}) | Secondary(w) => Secondary({...w, id}) - | Projector(p) => Projector({...p, id}) + | Projector(p) => Projector({...p, extra: id}) }; -let mk_tile: (Form.t, list(list(t))) => t = +let mk_tile: (Form.t, list(list(t('a)))) => t('a) = (form, children) => Tile({ - id: Id.mk(), + extra: Id.mk(), label: form.label, mold: form.mold, shards: List.mapi((i, _) => i, form.label), children, }); -let mk_mono = (sort: Sort.t, string: string): t => +let mk_mono = (sort: Sort.t, string: string): t('a) => string |> Form.mk_atomic(sort) |> mk_tile(_, []); -let of_mono = (syntax: t): option(string) => +let of_mono = (syntax: t('a)): option(string) => switch (syntax) { | Tile({label: [l], _}) => Some(l) | _ => None diff --git a/src/haz3lcore/tiles/Segment.re b/src/haz3lcore/tiles/Segment.re index fb438eab24..e70b985f5f 100644 --- a/src/haz3lcore/tiles/Segment.re +++ b/src/haz3lcore/tiles/Segment.re @@ -3,7 +3,7 @@ open Util; exception Empty_segment; [@deriving (show({with_path: false}), sexp, yojson)] -type t = Base.segment; +type t('a) = Base.segment('a); let empty = []; let cons = List.cons; @@ -26,31 +26,33 @@ let incomplete_tiles = | Piece.Tile(t) when !Tile.is_complete(t) => Some(t) | _ => None, ); -let tiles = +let tiles = x => List.filter_map( fun | Piece.Tile(t) => Some(t) | _ => None, + x, ); -let convex_grout = +let convex_grout = x => List.filter_map( fun | Piece.Grout(g) when g.shape == Convex => Some(g) | _ => None, + x, ); -let contains_matching = (t: Tile.t) => +let contains_matching = (t: Tile.t(Id.t)) => List.exists( fun - | Piece.Tile(t') => t'.id == t.id + | Piece.Tile(t': Piece.tile(Id.t)) => t'.extra == t.extra | _ => false, ); -let remove_matching = (t: Tile.t) => +let remove_matching = (t: Tile.t('a)) => List.filter_map( fun - | Piece.Tile(t') when t'.id == t.id => None + | Piece.Tile(t') when t'.extra == t.extra => None | p => Some(p), ); @@ -59,10 +61,10 @@ let snoc = (tiles, tile) => tiles @ [tile]; // let is_balanced = List.for_all(Piece.is_balanced); let shape_affix = - (d: Direction.t, affix: t, r: Nib.Shape.t) - : (Aba.t(list(Secondary.t), Grout.t), Nib.Shape.t, t) => { + (d: Direction.t, affix: t('a), r: Nib.Shape.t) + : (Aba.t(list(Secondary.t), Grout.t), Nib.Shape.t, t('a)) => { let empty_wgw = Aba.mk([[]], []); - let rec go = (affix: t, r: Nib.Shape.t) => + let rec go = (affix: t('a), r: Nib.Shape.t) => switch (affix) { | [] => (empty_wgw, r, []) | [p, ...tl] => @@ -85,7 +87,7 @@ let shape_affix = go((d == Left ? List.rev : Fun.id)(affix), r); }; -let rec remold = (~shape=Nib.Shape.concave(), seg: t, s: Sort.t) => +let rec remold = (~shape=Nib.Shape.concave(), seg: t('a), s: Sort.t) => switch (s) { | Any => seg | Typ => remold_typ(shape, seg) @@ -95,7 +97,7 @@ let rec remold = (~shape=Nib.Shape.concave(), seg: t, s: Sort.t) => | TPat => remold_tpat(shape, seg) | _ => failwith("remold unexpected") } -and remold_tile = (s: Sort.t, shape, t: Tile.t): option(Tile.t) => { +and remold_tile = (s: Sort.t, shape, t: Tile.t('a)): option(Tile.t('a)) => { open OptUtil.Syntax; let+ remolded = Molds.get(t.label) @@ -126,7 +128,7 @@ and remold_tile = (s: Sort.t, shape, t: Tile.t): option(Tile.t) => { ); {...remolded, children}; } -and remold_typ = (shape, seg: t): t => +and remold_typ = (shape, seg: t('a)): t('a) => switch (seg) { | [] => [] | [hd, ...tl] => @@ -141,7 +143,7 @@ and remold_typ = (shape, seg: t): t => } } } -and remold_typ_uni = (shape, seg: t): (t, Nib.Shape.t, t) => +and remold_typ_uni = (shape, seg: t('a)): (t('a), Nib.Shape.t, t('a)) => switch (seg) { | [] => ([], shape, []) | [hd, ...tl] => @@ -171,7 +173,7 @@ and remold_typ_uni = (shape, seg: t): (t, Nib.Shape.t, t) => } } } -and remold_pat_uni = (shape, seg: t): (t, Nib.Shape.t, t) => +and remold_pat_uni = (shape, seg: t('a)): (t('a), Nib.Shape.t, t('a)) => switch (seg) { | [] => ([], shape, []) | [hd, ...tl] => @@ -203,7 +205,7 @@ and remold_pat_uni = (shape, seg: t): (t, Nib.Shape.t, t) => } } } -and remold_pat = (shape, seg: t): t => +and remold_pat = (shape, seg: t('a)): t('a) => switch (seg) { | [] => [] | [hd, ...tl] => @@ -224,7 +226,7 @@ and remold_pat = (shape, seg: t): t => } } } -and remold_tpat_uni = (shape, seg: t): (t, Nib.Shape.t, t) => +and remold_tpat_uni = (shape, seg: t('a)): (t('a), Nib.Shape.t, t('a)) => switch (seg) { | [] => ([], shape, []) | [hd, ...tl] => @@ -252,7 +254,7 @@ and remold_tpat_uni = (shape, seg: t): (t, Nib.Shape.t, t) => } } } -and remold_tpat = (shape, seg: t): t => +and remold_tpat = (shape, seg: t('a)): t('a) => switch (seg) { | [] => [] | [hd, ...tl] => @@ -273,7 +275,7 @@ and remold_tpat = (shape, seg: t): t => } } } -and remold_exp_uni = (shape, seg: t): (t, Nib.Shape.t, t) => +and remold_exp_uni = (shape, seg: t('a)): (t('a), Nib.Shape.t, t('a)) => switch (seg) { | [] => ([], shape, []) | [hd, ...tl] => @@ -316,7 +318,7 @@ and remold_exp_uni = (shape, seg: t): (t, Nib.Shape.t, t) => } } } -and remold_rul = (shape, seg: t): t => +and remold_rul = (shape, seg: t('a)): t('a) => switch (seg) { | [] => [] | [hd, ...tl] => @@ -346,7 +348,7 @@ and remold_rul = (shape, seg: t): t => } } } -and remold_exp = (shape, seg: t): t => +and remold_exp = (shape, seg: t('a)): t('a) => switch (seg) { | [] => [] | [hd, ...tl] => @@ -383,11 +385,11 @@ let skel = |> Skel.mk ); -let sorted_children = List.concat_map(Piece.sorted_children); +let sorted_children = x => List.concat_map(Piece.sorted_children, x); let children = seg => List.map(snd, sorted_children(seg)); module Trim = { - type seg = t; + type seg = t(Id.t); type t = Aba.t(list(Secondary.t), Grout.t); let empty = Aba.mk([[]], []); @@ -511,10 +513,11 @@ let rec regrout = ((l, r), seg) => { Trim.to_seg(trim) @ tl; } and regrout_affix = - (d: Direction.t, affix: t, r: Nib.Shape.t): (Trim.t, Nib.Shape.t, t) => { + (d: Direction.t, affix: t('a), r: Nib.Shape.t) + : (Trim.t, Nib.Shape.t, t('a)) => { let (trim, s, affix) = fold_right( - (p: Piece.t, (trim, r, tl)) => { + (p: Piece.t('a), (trim, r, tl)) => { switch (p) { | Secondary(w) => (Trim.cons_w(w, trim), r, tl) | Grout(g) => (Trim.(merge(cons_g(g, trim))), r, tl) @@ -556,19 +559,20 @@ and regrout_affix = // | Tile(t) => Tile({...t, mold: Mold.flip_nibs(t.mold)}), // ); -let split_by_matching = (id: Id.t): (t => Aba.t(t, Tile.t)) => +let split_by_matching = + (id: Id.t): (t(Id.t) => Aba.t(t(Id.t), Tile.t(Id.t))) => Aba.split( fun - | Piece.Tile(t) when t.id == id => Either.R(t) + | Piece.Tile(t: Piece.tile(Id.t)) when t.extra == id => Either.R(t) | p => L(p), ); // module Match = Tile.Match.Make(Orientation.R); -let rec reassemble = (seg: t): t => +let rec reassemble = (seg: t(Id.t)): t(Id.t) => switch (incomplete_tiles(seg)) { | [] => seg | [t, ..._] => - switch (Aba.trim(split_by_matching(t.id, seg))) { + switch (Aba.trim(split_by_matching(t.extra, seg))) { | None => seg | Some((seg_l, match, seg_r)) => let t = Tile.reassemble(match); @@ -578,7 +582,9 @@ let rec reassemble = (seg: t): t => } }; -let trim_f: (list(Base.piece) => list(Base.piece), Direction.t, t) => t = +let trim_f: + (list(Base.piece('a)) => list(Base.piece('a)), Direction.t, t('a)) => + t('a) = (trim_l, d, ps) => { switch (d) { | Left => ps |> trim_l @@ -586,7 +592,7 @@ let trim_f: (list(Base.piece) => list(Base.piece), Direction.t, t) => t = }; }; -let trim_secondary: (Direction.t, t) => t = +let trim_secondary: (Direction.t, t(Id.t)) => t(Id.t) = (d, ps) => { /* Trims leading/trailing secondary */ let rec trim_l = xs => @@ -598,10 +604,10 @@ let trim_secondary: (Direction.t, t) => t = trim_f(trim_l, d, ps); }; -let trim_grout: (Direction.t, t) => t = +let trim_grout: (Direction.t, t(Id.t)) => t(Id.t) = (d, ps) => { /* Trims leading/trailing grout */ - let rec trim_l: list(Base.piece) => list(Base.piece) = + let rec trim_l: list(Base.piece(Id.t)) => list(Base.piece(Id.t)) = xs => switch (xs) { | [] => [] @@ -611,11 +617,11 @@ let trim_grout: (Direction.t, t) => t = trim_f(trim_l, d, ps); }; -let trim_secondary_and_grout: (Direction.t, t) => t = +let trim_secondary_and_grout: (Direction.t, t(Id.t)) => t(Id.t) = (d, ps) => { /* Trims leading/trailing secondary, continuing to trim around grout until first Tile is reached */ - let rec trim_l: list(Base.piece) => list(Base.piece) = + let rec trim_l: list(Base.piece(Id.t)) => list(Base.piece(Id.t)) = xs => switch (xs) { | [] => [] @@ -625,11 +631,11 @@ let trim_secondary_and_grout: (Direction.t, t) => t = trim_f(trim_l, d, ps); }; -let trim_grout_around_secondary: (Direction.t, t) => t = +let trim_grout_around_secondary: (Direction.t, t(Id.t)) => t(Id.t) = (d, ps) => { /* Trims leading/trailing grout, skipping over secondary, but not skipping over other pieces. */ - let rec trim_l: list(Base.piece) => list(Base.piece) = + let rec trim_l: list(Base.piece(Id.t)) => list(Base.piece(Id.t)) = xs => switch (xs) { | [] => [] @@ -640,7 +646,7 @@ let trim_grout_around_secondary: (Direction.t, t) => t = trim_f(trim_l, d, ps); }; -let edge_shape_of = (d: Direction.t, ps: t): option(Nib.Shape.t) => { +let edge_shape_of = (d: Direction.t, ps: t('a)): option(Nib.Shape.t) => { let trimmed = trim_secondary(d, ps); switch (d, ListUtil.hd_opt(trimmed), ListUtil.last_opt(trimmed)) { | (Right, _, Some(p)) => p |> Piece.shapes |> Option.map(snd) @@ -649,17 +655,18 @@ let edge_shape_of = (d: Direction.t, ps: t): option(Nib.Shape.t) => { }; }; -let edge_direction_of = (d: Direction.t, ps: t): option(Direction.t) => +let edge_direction_of = (d: Direction.t, ps: t('a)): option(Direction.t) => Option.map(Nib.Shape.absolute(d), edge_shape_of(d, ps)); -let sameline_secondary = +let sameline_secondary = x => List.for_all( fun | Piece.Secondary(w) => !Secondary.is_linebreak(w) | _ => false, + x, ); -let expected_sorts = (sort: Sort.t, seg: t): list((int, Sort.t)) => { +let expected_sorts = (sort: Sort.t, seg: t('a)): list((int, Sort.t)) => { let p = List.nth(seg); let rec go = (sort: Sort.t, skel: Skel.t): list((list(int), Sort.t)) => { let root = Skel.root(skel); @@ -688,7 +695,7 @@ let expected_sorts = (sort: Sort.t, seg: t): list((int, Sort.t)) => { |> List.concat_map(((ns, s)) => List.map(n => (n, s), ns)); }; -let rec holes = (segment: t): list(Grout.t) => +let rec holes = (segment: t('a)): list(Grout.t) => List.concat_map( fun | Piece.Secondary(_) @@ -698,41 +705,41 @@ let rec holes = (segment: t): list(Grout.t) => segment, ); -let get_childrens: t => list(t) = +let get_childrens: t('a) => list(t('a)) = List.concat_map( fun | Piece.Tile(t) => t.children | _ => [], ); -let rec get_incomplete_ids = (seg: t): list(Id.t) => +let rec get_incomplete_ids = (seg: t(Id.t)): list(Id.t) => List.concat_map( fun | Piece.Tile(t) => { let ids = List.concat_map(get_incomplete_ids, t.children); - Tile.is_complete(t) ? ids : [t.id, ...ids]; + Tile.is_complete(t) ? ids : [t.extra, ...ids]; } | _ => [], seg, ); -let ids_of_incomplete_tiles_in_bidelimiteds = (seg: t): list(Id.t) => +let ids_of_incomplete_tiles_in_bidelimiteds = (seg: t(Id.t)): list(Id.t) => get_childrens(seg) |> List.concat |> get_incomplete_ids; -let push_right = ((ls: t, rs: t)): (t, t) => +let push_right = ((ls: t('a), rs: t('a))): (t('a), t('a)) => switch (List.rev(ls)) { | [l, ...ls] => (List.rev(ls), [l, ...rs]) | [] => (ls, rs) }; -let push_left = ((ls: t, rs: t)): (t, t) => +let push_left = ((ls: t('a), rs: t('a))): (t('a), t('a)) => switch (rs) { | [r, ...rs] => (ls @ [r], rs) | [] => (ls, rs) }; -let rec ids = (s: t): list(Id.t) => List.concat_map(ids_of_piece, s) -and ids_of_piece = (p: Piece.t): list(Id.t) => +let rec ids = (s: t(Id.t)): list(Id.t) => List.concat_map(ids_of_piece, s) +and ids_of_piece = (p: Piece.t(Id.t)): list(Id.t) => switch (p) { | Tile(t) => [Piece.id(p), ...ids(List.concat(t.children))] | Grout(_) diff --git a/src/haz3lcore/tiles/Skel.re b/src/haz3lcore/tiles/Skel.re index 00a18786e1..dd9a4a3c55 100644 --- a/src/haz3lcore/tiles/Skel.re +++ b/src/haz3lcore/tiles/Skel.re @@ -57,14 +57,14 @@ exception Input_contains_secondary; exception Nonconvex_segment; [@deriving show({with_path: false})] -type ip = (int, Piece.t); +type ip('a) = (int, Piece.t('a)); type rel = | Lt | Eq | Gt; -let rel = (p1: Piece.t, p2: Piece.t): option(rel) => +let rel = (p1: Piece.t('a), p2: Piece.t('a)): option(rel) => switch (p1, p2) { | (Secondary(_), _) | (_, Secondary(_)) => None @@ -127,13 +127,14 @@ module Stacks = { [@deriving show({with_path: false})] type t = { output: list(skel), - shunted: list(ip), + shunted: list(ip(Id.t)), }; let empty = {output: [], shunted: []}; let rec pop_chain = - (~popped=[], shunted: list(ip)): (list(ip), list(ip)) => + (~popped=[], shunted: list(ip(Id.t))) + : (list(ip(Id.t)), list(ip(Id.t))) => switch (shunted) { | [] => (popped, shunted) | [hd, ...tl] => @@ -151,7 +152,7 @@ module Stacks = { Piece.shapes(p) |> OptUtil.get_or_raise(Input_contains_secondary); let shapes_of_chain = - (chain: list(ip)): option((Nib.Shape.t, Nib.Shape.t)) => + (chain: list(ip(Id.t))): option((Nib.Shape.t, Nib.Shape.t)) => switch (chain, ListUtil.split_last_opt(chain)) { | ([(_, first), ..._], Some((_, (_, last)))) => let (l, _) = shapes(first); @@ -200,7 +201,7 @@ module Stacks = { }; }; - let push_shunted = ((_, p) as ip: ip, stacks: t): t => { + let push_shunted = ((_, p) as ip: ip(Id.t), stacks: t): t => { let (l, _) = shapes(p); let stacks = switch (l) { @@ -213,7 +214,7 @@ module Stacks = { let finish = stacks => push_output(stacks); }; -let mk = (seg: list(ip)): t => { +let mk = (seg: list(ip(Id.t))): t => { let stacks = seg |> List.fold_left(Fun.flip(Stacks.push_shunted), Stacks.empty) diff --git a/src/haz3lcore/tiles/Tile.re b/src/haz3lcore/tiles/Tile.re index 10c7c41e42..e6b82bec5f 100644 --- a/src/haz3lcore/tiles/Tile.re +++ b/src/haz3lcore/tiles/Tile.re @@ -1,16 +1,14 @@ open Util; include Base; - exception Ambiguous_molds; exception Invalid_mold; exception Empty_tile; [@deriving (show({with_path: false}), sexp, yojson)] -type t = tile; - -let id = t => t.id; +type t('a) = tile('a); -let is_complete = (t: t) => List.length(t.label) == List.length(t.shards); +let is_complete = (t: t('a)) => + List.length(t.label) == List.length(t.shards); let l_shard = t => OptUtil.get_or_raise(Empty_tile, ListUtil.hd_opt(t.shards)); @@ -24,20 +22,20 @@ let has_end = (d: Direction.t, t) => }; let has_ends = t => has_end(Left, t) && has_end(Right, t); -let nibs = (t: t) => { +let nibs = (t: t('a)) => { let (l, _) = Mold.nibs(~index=l_shard(t), t.mold); let (_, r) = Mold.nibs(~index=r_shard(t), t.mold); (l, r); }; -let shapes = (t: t) => { +let shapes = (t: t('a)) => { let (l, r) = nibs(t); (l.shape, r.shape); }; let to_piece = t => Tile(t); -let sorted_children = ({mold, shards, children, _}: t) => +let sorted_children = ({mold, shards, children, _}: t('a)) => Aba.mk(shards, children) |> Aba.aba_triples |> List.map(((l, child, r)) => { @@ -46,7 +44,8 @@ let sorted_children = ({mold, shards, children, _}: t) => (l.sort == r.sort ? l.sort : Any, child); }); -let contained_children = (t: t): list((t, Base.segment, t)) => +let contained_children = + (t: t('a)): list((t('a), Base.segment('a), t('a))) => Aba.mk(t.shards, t.children) |> Aba.aba_triples |> List.map(((l, child, r)) => { @@ -55,25 +54,27 @@ let contained_children = (t: t): list((t, Base.segment, t)) => (l, child, r); }); -// let remold = (t: t): list(t) => +// let remold = (t:t('a)): list(t) => // Molds.get(t.label) |> List.map(mold => {...t, mold}); -let split_shards = (id, label, mold, shards) => - shards |> List.map(i => {id, label, mold, shards: [i], children: []}); +let split_shards = (extra, label, mold, shards) => + shards |> List.map(i => {extra, label, mold, shards: [i], children: []}); // postcond: output segment is nonempty -let disassemble = ({id, label, mold, shards, children}: t): segment => { - let shards = split_shards(id, label, mold, shards); +let disassemble = + ({extra, label, mold, shards, children}: t('a)): segment('a) => { + let shards = split_shards(extra, label, mold, shards); Aba.mk(shards, children) |> Aba.join(s => [to_piece(s)], Fun.id) |> List.concat; }; -let disintegrate = ({id, label, mold, shards, _}: t): list(tile) => { - split_shards(id, label, mold, shards); +let disintegrate = + ({extra, label, mold, shards, _}: t('a)): list(tile('a)) => { + split_shards(extra, label, mold, shards); }; -let reassemble = (match: Aba.t(t, segment)): t => { +let reassemble = (match: Aba.t(t('a), segment('a))): t('a) => { let t = Aba.hd(match); let (shards, children) = match @@ -86,7 +87,7 @@ let reassemble = (match: Aba.t(t, segment)): t => { let _ = Aba.mk(shards, children); assert(List.sort(Int.compare, shards) == shards); { - id: t.id, + extra: t.extra, label: t.label, // note: this throws away molds on tiles other than hd. // in cases where those molds differ, reassembled tile @@ -97,11 +98,11 @@ let reassemble = (match: Aba.t(t, segment)): t => { }; }; -let pop_l = (tile: t): (piece, segment) => +let pop_l = (tile: t('a)): (piece('a), segment('a)) => disassemble(tile) |> ListUtil.split_first_opt |> OptUtil.get_or_raise(Empty_tile); -let pop_r = (tile: t): (segment, piece) => +let pop_r = (tile: t('a)): (segment('a), piece('a)) => disassemble(tile) |> ListUtil.split_last_opt |> OptUtil.get_or_raise(Empty_tile); @@ -115,16 +116,16 @@ let pop_r = (tile: t): (segment, piece) => // [@deriving (show({with_path: false}), sexp, yojson)] // type t = Aba.t(Shard.t, segment); -// let id = (m: t) => Aba.hd(m).tile_id; +// let id = (m:t('a)) => Aba.hd(m).tile_id; -// let label = (m: t) => snd(Aba.hd(m).label); +// let label = (m:t('a)) => snd(Aba.hd(m).label); // let shards: t => list(Shard.t) = Aba.get_as; // // let children: t => list(segment) = Aba.get_bs; -// let length = (m: t) => List.length(shards(m)); +// let length = (m:t('a)) => List.length(shards(m)); -// let mold = (m: t) => { +// let mold = (m:t('a)) => { // let molds = // switch (Shard.consistent_molds(shards(m))) { // | [] => @@ -140,10 +141,10 @@ let pop_r = (tile: t): (segment, piece) => // let children = m => // List.map(ListUtil.rev_if(O.d == Left), Aba.get_bs(m)); -// let join = (m: t): segment => +// let join = (m:t('a)): segment => // m |> Aba.join(s => [Shard.to_piece(s)], Fun.id) |> List.flatten; -// let complete = (m: t): option(tile) => { +// let complete = (m:t('a)): option(tile) => { // let id = id(m); // let label = label(m); // let mold = mold(m); diff --git a/src/haz3lcore/zipper/Ancestor.re b/src/haz3lcore/zipper/Ancestor.re index 7d18c088fb..f94f4bcd35 100644 --- a/src/haz3lcore/zipper/Ancestor.re +++ b/src/haz3lcore/zipper/Ancestor.re @@ -11,7 +11,7 @@ type t = { label: Label.t, mold: Mold.t, shards: (list(int), list(int)), - children: (list(Segment.t), list(Segment.t)), + children: (list(Segment.t(Id.t)), list(Segment.t(Id.t))), }; // TODO(d) revisit naming w.r.t. outer vs inner shards @@ -31,8 +31,10 @@ let shapes = a => { (l.shape, r.shape); }; -let zip = (child: Segment.t, {id, label, mold, shards, children}: t): Tile.t => { - id, +let zip = + (child: Segment.t(Id.t), {id, label, mold, shards, children}: t) + : Tile.t(Id.t) => { + extra: id, label, mold, shards: fst(shards) @ snd(shards), @@ -81,7 +83,7 @@ let disassemble = (flatten(shards_l, kids_l), flatten(shards_r, kids_r)); }; -let container_shards = (a: t): (Piece.t, Piece.t) => { +let container_shards = (a: t): (Piece.t(Id.t), Piece.t(Id.t)) => { let (shards_l, shards_r) = a.shards |> TupleUtil.map2(Tile.split_shards(a.id, a.label, a.mold)) @@ -93,13 +95,14 @@ let container_shards = (a: t): (Piece.t, Piece.t) => { (l, r); }; -let reassemble = (match_l: Aba.t(Tile.t, Segment.t) as 'm, match_r: 'm): t => { +let reassemble = + (match_l: Aba.t(Tile.t(Id.t), Segment.t(Id.t)) as 'm, match_r: 'm): t => { // TODO(d) bit hacky, need to do a flip/orientation pass // let match_l = Aba.map_b(Segment.rev, match_l); let (t_l, t_r) = Tile.(reassemble(match_l), reassemble(match_r)); - assert(t_l.id == t_r.id); + assert(t_l.extra == t_r.extra); { - id: t_l.id, + id: t_l.extra, label: t_l.label, mold: t_l.mold, shards: (t_l.shards, t_r.shards), diff --git a/src/haz3lcore/zipper/Ancestors.re b/src/haz3lcore/zipper/Ancestors.re index 467bbd17eb..f8840d8d37 100644 --- a/src/haz3lcore/zipper/Ancestors.re +++ b/src/haz3lcore/zipper/Ancestors.re @@ -18,9 +18,11 @@ let sort = | [] => Sort.root | [(a, _), ..._] => Ancestor.sort(a); -let zip_gen = (seg: Segment.t, (a, (pre, suf)): generation): Segment.t => +let zip_gen = + (seg: Segment.t(Id.t), (a, (pre, suf)): generation): Segment.t(Id.t) => pre @ [Piece.Tile(Ancestor.zip(seg, a)), ...suf]; -let zip = (seg: Segment.t, ancs: t) => ancs |> List.fold_left(zip_gen, seg); +let zip = (seg: Segment.t(Id.t), ancs: t) => + ancs |> List.fold_left(zip_gen, seg); let disassemble = ancs => ancs @@ -87,8 +89,8 @@ let regrout = (ancs: t) => empty, ); -let parent_matches = (t: Tile.t, ancs: t) => +let parent_matches = (t: Tile.t(Id.t), ancs: t) => switch (ancs) { | [] => false - | [(a, _), ..._] => a.id == t.id + | [(a, _), ..._] => a.id == t.extra }; diff --git a/src/haz3lcore/zipper/Backpack.re b/src/haz3lcore/zipper/Backpack.re index b704e36721..d557dd325b 100644 --- a/src/haz3lcore/zipper/Backpack.re +++ b/src/haz3lcore/zipper/Backpack.re @@ -11,18 +11,18 @@ module ShardInfo = { let n = 20; let init = () => create(n); - let lt = (l: Tile.t, r: Tile.t, ord: t): bool => { + let lt = (l: Tile.t(Id.t), r: Tile.t(Id.t), ord: t): bool => { let (i_l, i_r) = Tile.(r_shard(l), l_shard(r)); - switch (find_opt(ord, (l.id, i_l))) { + switch (find_opt(ord, (l.extra, i_l))) { | None => false - | Some(row) => Option.is_some(find_opt(row, (r.id, i_r))) + | Some(row) => Option.is_some(find_opt(row, (r.extra, i_r))) }; }; let gt = (l, r, ord) => lt(r, l, ord); let un = (l, r, ord) => !lt(l, r, ord) && !gt(l, r, ord); - let disordered = (t: Tile.t, t': Tile.t): bool => - t.id == t'.id + let disordered = (t: Tile.t(Id.t), t': Tile.t(Id.t)): bool => + t.extra == t'.extra && { let (l, r) = Tile.(l_shard(t), r_shard(t)); let (l', r') = Tile.(l_shard(t'), r_shard(t')); @@ -98,9 +98,9 @@ module ShardInfo = { counts: Id.Map.t(int), }; - let of_tile = (t: Tile.t) => { - labels: Id.Map.singleton(t.id, t.label), - counts: Id.Map.singleton(t.id, List.length(t.shards)), + let of_tile = (t: Tile.t(Id.t)) => { + labels: Id.Map.singleton(t.extra, t.label), + counts: Id.Map.singleton(t.extra, List.length(t.shards)), }; let merge = (m: t, m': t) => { @@ -110,8 +110,8 @@ module ShardInfo = { let mem = (id, m) => Id.Map.mem(id, m.labels); - let exists_mem = (ts: list(Tile.t), m) => - List.exists((t: Tile.t) => mem(t.id, m), ts); + let exists_mem = (ts: list(Tile.t(Id.t)), m) => + List.exists((t: Tile.t(Id.t)) => mem(t.extra, m), ts); let is_complete = (m: t) => m.counts @@ -124,20 +124,20 @@ module ShardInfo = { type t = Id.Uf.store(Count.t); include Id.Uf; let merge = merge(Count.merge); - let add_tile = (t: Tile.t, cs: t): unit => - switch (get_opt(t.id, cs)) { - | None => add(t.id, Count.of_tile(t), cs) + let add_tile = (t: Tile.t(Id.t), cs: t): unit => + switch (get_opt(t.extra, cs)) { + | None => add(t.extra, Count.of_tile(t), cs) | Some(c) => let c = { ...c, counts: Id.Map.update( - t.id, + t.extra, Option.map((+)(List.length(t.shards))), c.counts, ), }; - set(t.id, c, cs); + set(t.extra, c, cs); }; }; @@ -160,18 +160,18 @@ module ShardInfo = { let ts = Segment.incomplete_tiles(sel.content); // initialize ts - |> List.iter((t: Tile.t) => { + |> List.iter((t: Tile.t(Id.t)) => { Counts.add_tile(t, counts); - Order.add_tile(t.id, t.label, order); + Order.add_tile(t.extra, t.label, order); }); // merge counts ignore( ts |> List.fold_left( - (prev: option(Tile.t), curr: Tile.t) => { + (prev: option(Tile.t(Id.t)), curr: Tile.t(Id.t)) => { switch (prev) { | None => () - | Some(prev) => Counts.merge(prev.id, curr.id, counts) + | Some(prev) => Counts.merge(prev.extra, curr.extra, counts) }; Some(curr); }, @@ -180,22 +180,22 @@ module ShardInfo = { ); // propagate well-nested ordering constraints ListUtil.ordered_pairs(ts) - |> List.iter(((l: Tile.t, r: Tile.t)) => { + |> List.iter(((l: Tile.t(Id.t), r: Tile.t(Id.t))) => { let (n_l, n_r) = List.(length(l.label), length(r.label)); let (i_l, i_r) = Tile.(r_shard(l), l_shard(r)); - Order.set((l.id, i_l), (r.id, i_r), order); + Order.set((l.extra, i_l), (r.extra, i_r), order); if (i_l == n_l - 1 && i_r != 0) { // l must be nested within r Order.set( - (r.id, i_r - 1), - (l.id, 0), + (r.extra, i_r - 1), + (l.extra, 0), order, ); } else if (i_l != n_l - 1 && i_r == 0) { // r must be nested within l Order.set( - (r.id, n_r - 1), - (l.id, i_l + 1), + (r.extra, n_r - 1), + (l.extra, i_l + 1), order, ); }; @@ -226,7 +226,7 @@ let push = sel => Selection.is_empty(sel) ? Fun.id : List.cons(sel); let push_s: (list(Selection.t), t) => t = List.fold_right(push); let pop = - ((pre, suf): (list(Tile.t), list(Tile.t)), bp: t) + ((pre, suf): (list(Tile.t(Id.t)), list(Tile.t(Id.t))), bp: t) : option((bool, Selection.t, t)) => { open OptUtil.Syntax; let* (hd, tl) = ListUtil.split_first_opt(bp); @@ -235,7 +235,7 @@ let pop = | [t, ..._] as ts => open ShardInfo; let {counts, order} = shard_info(bp); - let count = Counts.get(t.id, counts); + let count = Counts.get(t.extra, counts); let first = Count.is_complete(count); first || (Count.exists_mem(pre, count) || Count.exists_mem(suf, count)) @@ -254,13 +254,13 @@ let restricted = (bp: t): bool => | [t, ..._] => open ShardInfo; let info = shard_info(bp); - !Count.is_complete(Counts.get(t.id, info.counts)); + !Count.is_complete(Counts.get(t.extra, info.counts)); } }; -let remove_matching = (ts: list(Tile.t), bp: t) => +let remove_matching = (ts: list(Tile.t(Id.t)), bp: t) => List.fold_left( - (bp, t: Tile.t) => + (bp, t: Tile.t(Id.t)) => bp |> List.map(Selection.map(Segment.remove_matching(t))) |> List.filter_map( @@ -294,7 +294,8 @@ let remove_uni_tiles_with_deep_matches = (bp: t, sel: Selection.t): t => { let ids = Segment.ids_of_incomplete_tiles_in_bidelimiteds(sel.content); List.filter_map( fun - | Selection.{content: [Piece.Tile({id, _})], _} when List.mem(id, ids) => + | Selection.{content: [Piece.Tile({extra: id, _})], _} + when List.mem(id, ids) => None | x => Some(x), bp, diff --git a/src/haz3lcore/zipper/Editor.re b/src/haz3lcore/zipper/Editor.re index cd05476fd9..427a833f79 100644 --- a/src/haz3lcore/zipper/Editor.re +++ b/src/haz3lcore/zipper/Editor.re @@ -38,7 +38,7 @@ module CachedStatics = { module CachedSyntax = { type t = { - segment: Segment.t, + segment: Segment.t(Id.t), measured: Measured.t, tiles: TileMap.t, holes: list(Grout.t), @@ -59,7 +59,7 @@ module CachedSyntax = { * certain ids to be present/non-present unexpectedly. */ term_ranges: TermRanges.t, terms: TermMap.t, - projectors: Id.Map.t(Base.projector), + projectors: Id.Map.t(Base.projector(Id.t)), }; let init = (z, info_map): t => { diff --git a/src/haz3lcore/zipper/Printer.re b/src/haz3lcore/zipper/Printer.re index ed19ee3846..2821b7b7d4 100644 --- a/src/haz3lcore/zipper/Printer.re +++ b/src/haz3lcore/zipper/Printer.re @@ -10,9 +10,9 @@ type t = { let seg_of_zip = Zipper.seg_without_buffer; -let rec of_segment = (~holes, seg: Segment.t): string => +let rec of_segment = (~holes, seg: Segment.t('a)): string => seg |> List.map(of_piece(~holes)) |> String.concat("") -and of_piece = (~holes, p: Piece.t): string => +and of_piece = (~holes, p: Piece.t('a)): string => switch (p) { | Tile(t) => of_tile(~holes, t) | Grout({shape: Concave, _}) => " " @@ -22,11 +22,11 @@ and of_piece = (~holes, p: Piece.t): string => Secondary.is_linebreak(w) ? "\n" : Secondary.get_string(w.content) | Projector(p) => of_piece(~holes, p.syntax) } -and of_tile = (~holes, t: Tile.t): string => +and of_tile = (~holes, t: Tile.t('a)): string => Aba.mk(t.shards, t.children) |> Aba.join(of_delim(t), of_segment(~holes)) |> String.concat("") -and of_delim = (t: Piece.tile, i: int): string => List.nth(t.label, i); +and of_delim = (t: Piece.tile('a), i: int): string => List.nth(t.label, i); let to_string_basic = (z: Zipper.t): string => { z |> seg_of_zip |> of_segment(~holes=None); @@ -42,7 +42,7 @@ let to_rows = ~measured: Measured.t, ~caret: option(Point.t), ~indent: string, - ~segment: Segment.t, + ~segment: Segment.t('a), ) : list(string) => { let indent_of = i => Measured.Rows.find(i, measured.rows).indent; diff --git a/src/haz3lcore/zipper/Projector.re b/src/haz3lcore/zipper/Projector.re index 82b036b821..1f9728dbeb 100644 --- a/src/haz3lcore/zipper/Projector.re +++ b/src/haz3lcore/zipper/Projector.re @@ -14,7 +14,7 @@ let to_module = (kind: Base.kind): (module Cooked) => | TextArea => (module Cook(TextAreaProj.M)) }; -let shape = (p: Base.projector, info: info): shape => { +let shape = (p: Base.projector('a), info: info): shape => { let (module P) = to_module(p.kind); P.placeholder(p.model, info); }; @@ -25,8 +25,8 @@ let shape = (p: Base.projector, info: info): shape => { * in the zipper; a tile consisting of any number of whitespaces * is considered a placeholder. This could be made more principled. * Note that a placeholder retains the UUID of the underlying. */ -let placeholder = (p: Base.projector, ci: option(Info.t)): string => - switch (shape(p, {id: p.id, syntax: p.syntax, ci})) { +let placeholder = (p: Base.projector('a), ci: option(Info.t)): string => + switch (shape(p, {id: p.extra, syntax: p.syntax, ci})) { | Inline(width) => String.make(width, ' ') | Block({row, col}) => String.make(row - 1, '\n') ++ String.make(col, ' ') }; diff --git a/src/haz3lcore/zipper/ProjectorBase.re b/src/haz3lcore/zipper/ProjectorBase.re index 5abe811d76..fe9812e2f5 100644 --- a/src/haz3lcore/zipper/ProjectorBase.re +++ b/src/haz3lcore/zipper/ProjectorBase.re @@ -16,7 +16,7 @@ type shape = /* The type of syntax which a projector can replace. * Right now projectors can replace a single piece */ [@deriving (show({with_path: false}), sexp, yojson)] -type syntax = Base.piece; +type syntax = Base.piece(Id.t); /* Global actions available to handlers in all projectors */ type external_action = @@ -65,7 +65,7 @@ module type Projector = { * syntax (currently limited to convex pieces) is * supported by this projector. This is used to gate * adding the projector */ - let can_project: Base.piece => bool; + let can_project: Base.piece(Id.t) => bool; /* Does this projector have internal position states, * overriding the editor caret & keyboard handlers? * If yes, the focus method will be called when this @@ -138,7 +138,7 @@ module Cook = (C: Projector) : Cooked => { }; /* Projectors currently are all convex */ -let shapes = (_: Base.projector) => Nib.Shape.(Convex, Convex); +let shapes = (_: Base.projector('a)) => Nib.Shape.(Convex, Convex); /* Projectors currently have a unique molding */ let mold_of = (p, sort: Sort.t): Mold.t => { diff --git a/src/haz3lcore/zipper/Relatives.re b/src/haz3lcore/zipper/Relatives.re index 04a9740130..0eba98f99a 100644 --- a/src/haz3lcore/zipper/Relatives.re +++ b/src/haz3lcore/zipper/Relatives.re @@ -8,17 +8,17 @@ type t = { let empty = {siblings: Siblings.empty, ancestors: Ancestors.empty}; -let push = (d: Direction.t, p: Piece.t, rs: t): t => { +let push = (d: Direction.t, p: Piece.t(Id.t), rs: t): t => { ...rs, siblings: Siblings.push(d, p, rs.siblings), }; -let prepend = (d: Direction.t, seg: Segment.t, rs: t): t => { +let prepend = (d: Direction.t, seg: Segment.t(Id.t), rs: t): t => { let siblings = Siblings.prepend(d, seg, rs.siblings); {...rs, siblings}; }; -let pop = (d: Direction.t, rs: t): option((Piece.t, t)) => +let pop = (d: Direction.t, rs: t): option((Piece.t(Id.t), t)) => switch (Siblings.pop(d, rs.siblings)) { | Some((p, siblings)) => Some((p, {...rs, siblings})) | None => @@ -49,7 +49,7 @@ let local_incomplete_tiles = ({siblings: (pre, suf), ancestors}: t) => { let parent = (~sel=Segment.empty, {siblings: (l_sibs, r_sibs), ancestors}: t) - : option(Piece.t) => + : option(Piece.t(Id.t)) => ancestors |> Ancestors.parent |> Option.map(p => Base.Tile(Ancestor.zip(l_sibs @ sel @ r_sibs, p))); @@ -148,9 +148,9 @@ let reassemble_parent = (rs: t): t => |> TupleUtil.map2(Aba.trim); let flatten_match = Aba.fold_right( - (t: Tile.t, kid, (shards, kids)) => + (t: Tile.t(Id.t), kid, (shards, kids)) => Aba.mk(t.shards @ shards, t.children @ [kid, ...kids]), - (t: Tile.t) => Aba.mk(t.shards, t.children), + (t: Tile.t(Id.t)) => Aba.mk(t.shards, t.children), ); let (a, l) = switch (l) { @@ -195,7 +195,7 @@ let reassemble = (rs: t): t => { | [t, ..._] => switch ( rs.siblings - |> Siblings.split_by_matching(t.id) + |> Siblings.split_by_matching(t.extra) |> TupleUtil.map2(Aba.trim) ) { | (_, None) => failwith("impossible") diff --git a/src/haz3lcore/zipper/Selection.re b/src/haz3lcore/zipper/Selection.re index 826dd64873..41ac681572 100644 --- a/src/haz3lcore/zipper/Selection.re +++ b/src/haz3lcore/zipper/Selection.re @@ -13,12 +13,12 @@ type mode = [@deriving (show({with_path: false}), sexp, yojson)] type t = { focus: Direction.t, - content: Segment.t, + content: Segment.t(Id.t), mode, }; /* NOTE: backpack no longer uses selection focus */ -let mk = (~mode=Normal, ~focus=Direction.Left, content: Segment.t) => { +let mk = (~mode=Normal, ~focus=Direction.Left, content: Segment.t(Id.t)) => { focus, content, mode, @@ -44,7 +44,7 @@ let toggle_focus = selection => { let is_empty = (selection: t) => selection.content == Segment.empty; -let push = (p: Piece.t, {focus, content, mode}: t): t => { +let push = (p: Piece.t(Id.t), {focus, content, mode}: t): t => { let content = Segment.reassemble( switch (focus) { @@ -55,7 +55,7 @@ let push = (p: Piece.t, {focus, content, mode}: t): t => { {focus, content, mode}; }; -let pop = (sel: t): option((Piece.t, t)) => +let pop = (sel: t): option((Piece.t(Id.t), t)) => switch (sel.focus, sel.content, ListUtil.split_last_opt(sel.content)) { | (_, [], _) | (_, _, None) => None @@ -67,4 +67,5 @@ let pop = (sel: t): option((Piece.t, t)) => Some((p, {...sel, content: content @ rest})); }; -let split_piece = _: option((Piece.t, t)) => failwith("todo split_piece"); +let split_piece = _: option((Piece.t(Id.t), t)) => + failwith("todo split_piece"); diff --git a/src/haz3lcore/zipper/Siblings.re b/src/haz3lcore/zipper/Siblings.re index 96d254e31e..0fd15c52d4 100644 --- a/src/haz3lcore/zipper/Siblings.re +++ b/src/haz3lcore/zipper/Siblings.re @@ -4,17 +4,17 @@ open Util; // module Suffix = Affix.Make(Orientation.R); [@deriving (show({with_path: false}), sexp, yojson)] -type t = (Segment.t, Segment.t); +type t = (Segment.t(Id.t), Segment.t(Id.t)); let empty = Segment.(empty, empty); let no_siblings: t => bool = s => s == empty; -let unzip: (int, Segment.t) => t = ListUtil.split_n; +let unzip: (int, Segment.t(Id.t)) => t = ListUtil.split_n; let zip = (~sel=Segment.empty, (pre, suf): t) => Segment.concat([pre, sel, suf]); -let prepend = (d: Direction.t, seg: Segment.t, (l, r): t): t => +let prepend = (d: Direction.t, seg: Segment.t(Id.t), (l, r): t): t => switch (d) { | Left => (l @ seg, r) | Right => (l, seg @ r) @@ -53,16 +53,16 @@ let is_mismatch = ((l, r): t): bool => { }; }; -let contains_matching = (t: Tile.t, (pre, suf): t) => +let contains_matching = (t: Tile.t(Id.t), (pre, suf): t) => Segment.(contains_matching(t, pre) || contains_matching(t, suf)); -let push = (onto: Direction.t, p: Piece.t, (pre, suf): t): t => +let push = (onto: Direction.t, p: Piece.t(Id.t), (pre, suf): t): t => switch (onto) { | Left => (pre @ [p], suf) | Right => (pre, [p, ...suf]) }; -let pop = (from: Direction.t, (pre, suf): t): option((Piece.t, t)) => +let pop = (from: Direction.t, (pre, suf): t): option((Piece.t(Id.t), t)) => switch (from) { | Left => ListUtil.split_last_opt(pre) @@ -91,11 +91,13 @@ let regrout = ((pre, suf): t) => { ((pre, s_l, trim_l), suf); }; -let left_neighbor: t => option(Piece.t) = ((l, _)) => ListUtil.last_opt(l); +let left_neighbor: t => option(Piece.t(Id.t)) = + ((l, _)) => ListUtil.last_opt(l); -let right_neighbor: t => option(Piece.t) = ((_, r)) => ListUtil.hd_opt(r); +let right_neighbor: t => option(Piece.t(Id.t)) = + ((_, r)) => ListUtil.hd_opt(r); -let neighbors: t => (option(Piece.t), option(Piece.t)) = +let neighbors: t => (option(Piece.t(Id.t)), option(Piece.t(Id.t))) = n => (left_neighbor(n), right_neighbor(n)); let trim_secondary = ((l_sibs, r_sibs): t) => ( @@ -126,4 +128,4 @@ let mold_fitting_between = (sort: Sort.t, p: Precedence.t, sibs: t): Mold.t => | None => Mold.mk_op(sort, []) }; -let sorted_children = TupleUtil.map2(Segment.sorted_children); +let sorted_children = x => TupleUtil.map2(Segment.sorted_children, x); diff --git a/src/haz3lcore/zipper/Zipper.re b/src/haz3lcore/zipper/Zipper.re index 18ce31dffc..be59349ca6 100644 --- a/src/haz3lcore/zipper/Zipper.re +++ b/src/haz3lcore/zipper/Zipper.re @@ -46,10 +46,10 @@ let delete_parent = (z: t): t => { relatives: Relatives.delete_parent(z.relatives), }; -let zip = (z: t): Segment.t => +let zip = (z: t): Segment.t(Id.t) => Relatives.zip(~sel=z.selection.content, z.relatives); -let unzip = (seg: Segment.t): t => { +let unzip = (seg: Segment.t(Id.t)): t => { selection: Selection.mk([]), backpack: [], relatives: { @@ -103,7 +103,7 @@ let unselect = (~erase_buffer=false, z: t): t => { let selection = Selection.empty; {...z, selection, relatives}; }; -let unselect_and_zip = (~erase_buffer=false, z: t): Segment.t => +let unselect_and_zip = (~erase_buffer=false, z: t): Segment.t(Id.t) => z |> unselect(~erase_buffer) |> zip; let update_selection = (selection: Selection.t, z: t): (Selection.t, t) => { @@ -260,7 +260,7 @@ let replace = let replace_mono = (d: Direction.t, t: Token.t, z: t): option(t) => replace(~caret=d, ~backpack=Left, [t], z); -let representative_piece = (z: t): option((Piece.t, Direction.t)) => { +let representative_piece = (z: t): option((Piece.t(Id.t), Direction.t)) => { /* The piece to the left of the caret, or if none exists, the piece to the right */ switch (Siblings.neighbors(sibs_with_sel(z))) { | (Some(l), _) => Some((l, Left)) @@ -317,7 +317,8 @@ let can_put_down = z => | None => false }; -let set_buffer = (z: t, ~mode: Selection.buffer, ~content: Segment.t): t => { +let set_buffer = + (z: t, ~mode: Selection.buffer, ~content: Segment.t(Id.t)): t => { ...z, selection: Selection.mk_buffer(mode, content), }; diff --git a/src/haz3lcore/zipper/ZipperBase.re b/src/haz3lcore/zipper/ZipperBase.re index cb6311a4b8..7ad4c3038d 100644 --- a/src/haz3lcore/zipper/ZipperBase.re +++ b/src/haz3lcore/zipper/ZipperBase.re @@ -37,7 +37,7 @@ let update_siblings: (Siblings.t => Siblings.t, t) => t = let put_siblings = (siblings, z: t): t => update_siblings(_ => siblings, z); -let put_selection_content = (content: Segment.t, z): t => { +let put_selection_content = (content: Segment.t(Id.t), z): t => { ...z, selection: { ...z.selection, @@ -45,7 +45,7 @@ let put_selection_content = (content: Segment.t, z): t => { }, }; -let parent = (z: t): option(Piece.t) => +let parent = (z: t): option(Piece.t(Id.t)) => Relatives.parent(~sel=z.selection.content, z.relatives); let sibs_with_sel = @@ -63,12 +63,12 @@ let sibs_with_sel = }; module MapPiece = { - type updater = Piece.t => Piece.t; + type updater = Piece.t(Id.t) => Piece.t(Id.t); - let rec of_segment = (f: updater, seg: Segment.t): Segment.t => { + let rec of_segment = (f: updater, seg: Segment.t(Id.t)): Segment.t(Id.t) => { seg |> List.map(p => f(p)) |> List.map(of_piece(f)); } - and of_piece = (f: updater, piece: Piece.t): Piece.t => { + and of_piece = (f: updater, piece: Piece.t(Id.t)): Piece.t(Id.t) => { switch (piece) { | Tile(t) => Tile(of_tile(f, t)) | Grout(_) @@ -76,7 +76,7 @@ module MapPiece = { | Secondary(_) => piece }; } - and of_tile = (f: updater, t: Tile.t): Tile.t => { + and of_tile = (f: updater, t: Tile.t(Id.t)): Tile.t(Id.t) => { {...t, children: List.map(of_segment(f), t.children)}; }; @@ -130,13 +130,13 @@ module MapPiece = { let right_sib_has_id = sib_has_id(Siblings.right_neighbor); - let update_left_sib = (f: Piece.t => Piece.t, z: t) => { + let update_left_sib = (f: Piece.t(Id.t) => Piece.t(Id.t), z: t) => { let (l, r) = z.relatives.siblings; let sibs = (List.map(f, l), List.map(f, r)); put_siblings(sibs, z); }; - let update_right_sib = (f: Piece.t => Piece.t, z: t) => { + let update_right_sib = (f: Piece.t(Id.t) => Piece.t(Id.t), z: t) => { let sibs = switch (z.relatives.siblings) { | (l, [hd, ...tl]) => (l, [f(hd), ...tl]) @@ -145,7 +145,7 @@ module MapPiece = { put_siblings(sibs, z); }; - let fast_local = (f: Piece.t => Piece.t, id: Id.t, z: t): t => + let fast_local = (f: Piece.t(Id.t) => Piece.t(Id.t), id: Id.t, z: t): t => /* This applies the function to the piece in the zipper having id id, and * then replaces the id of the resulting piece with the idea of the old * piece, ensuring that the root id remains stable. This function assumes diff --git a/src/haz3lcore/zipper/action/Action.re b/src/haz3lcore/zipper/action/Action.re index 71c426a53f..e87a27fd77 100644 --- a/src/haz3lcore/zipper/action/Action.re +++ b/src/haz3lcore/zipper/action/Action.re @@ -52,7 +52,7 @@ type project = | SetIndicated(Base.kind) /* Project syntax at caret */ | ToggleIndicated(Base.kind) /* Un/Project syntax at caret */ | Remove(Id.t) /* Remove projector at Id */ - | SetSyntax(Id.t, Piece.t) /* Set underlying syntax */ + | SetSyntax(Id.t, Piece.t(Id.t)) /* Set underlying syntax */ | SetModel(Id.t, string) /* Set serialized projector model */ | Focus(Id.t, option(Util.Direction.t)) /* Pass control to projector */ | Escape(Id.t, Direction.t); /* Pass control to parent editor */ diff --git a/src/haz3lcore/zipper/action/Indicated.re b/src/haz3lcore/zipper/action/Indicated.re index 7107abbcbf..3961901c60 100644 --- a/src/haz3lcore/zipper/action/Indicated.re +++ b/src/haz3lcore/zipper/action/Indicated.re @@ -6,8 +6,8 @@ type relation = | Sibling; let piece' = - (~no_ws: bool, ~ign: Piece.t => bool, z: ZipperBase.t) - : option((Piece.t, Direction.t, relation)) => { + (~no_ws: bool, ~ign: Piece.t(Id.t) => bool, z: ZipperBase.t) + : option((Piece.t(Id.t), Direction.t, relation)) => { /* Returns the piece currently indicated (if any) and which side of that piece the caret is on. We favor indicating the piece to the (R)ight, but may end up indicating the (P)arent or the (L)eft. diff --git a/src/haz3lcore/zipper/action/Insert.re b/src/haz3lcore/zipper/action/Insert.re index d1cbca001f..a28c96399b 100644 --- a/src/haz3lcore/zipper/action/Insert.re +++ b/src/haz3lcore/zipper/action/Insert.re @@ -38,7 +38,7 @@ let expand_or_barf_right_neighbor = (z as s: t): option(t) => | _ => Some(s) }; -let get_duo_shard = ({label, shards, _}: Tile.t) => +let get_duo_shard = ({label, shards, _}: Tile.t('a)) => if (List.length(label) == 2 && List.length(shards) == 1) { List.nth_opt(label, List.hd(shards)); } else { diff --git a/src/haz3lcore/zipper/action/Move.re b/src/haz3lcore/zipper/action/Move.re index 8f38ebc8ba..11c43bb603 100644 --- a/src/haz3lcore/zipper/action/Move.re +++ b/src/haz3lcore/zipper/action/Move.re @@ -222,7 +222,7 @@ module Make = (M: Editor.Meta.S) => { ( ~move_first=true, move_action: t => option(t), - piece_p: Piece.t => bool, + piece_p: Piece.t(Id.t) => bool, z: t, ) : option(t) => { diff --git a/src/haz3lcore/zipper/action/ProjectorPerform.re b/src/haz3lcore/zipper/action/ProjectorPerform.re index a0996437bd..b1efb90dff 100644 --- a/src/haz3lcore/zipper/action/ProjectorPerform.re +++ b/src/haz3lcore/zipper/action/ProjectorPerform.re @@ -4,9 +4,13 @@ open ProjectorBase; /* Updates the underlying piece of syntax for a projector */ module Update = { let update_piece = - (f: Base.projector => Base.projector, id: Id.t, syntax: syntax) => + ( + f: Base.projector(Id.t) => Base.projector(Id.t), + id: Id.t, + syntax: syntax, + ) => switch (syntax) { - | Projector(pr) when pr.id == id => Base.Projector(f(pr)) + | Projector(pr) when pr.extra == id => Base.Projector(f(pr)) | x => x }; @@ -17,7 +21,8 @@ module Update = { let (module P) = to_module(kind); switch (P.can_project(syntax) && minimum_projection_condition(syntax)) { | false => syntax - | true => Projector({id: Piece.id(syntax), kind, model: P.init, syntax}) + | true => + Projector({extra: Piece.id(syntax), kind, model: P.init, syntax}) }; }; @@ -30,7 +35,7 @@ module Update = { let remove_projector = (id: Id.t, syntax: syntax) => switch (syntax) { - | Projector(pr) when pr.id == id => pr.syntax + | Projector(pr) when pr.extra == id => pr.syntax | x => x }; @@ -48,7 +53,11 @@ module Update = { }; let update = - (f: Base.projector => Base.projector, id: Id.t, z: ZipperBase.t) + ( + f: Base.projector(Id.t) => Base.projector(Id.t), + id: Id.t, + z: ZipperBase.t, + ) : ZipperBase.t => ZipperBase.MapPiece.fast_local(update_piece(f, id), id, z); diff --git a/src/haz3lcore/zipper/projectors/CheckboxProj.re b/src/haz3lcore/zipper/projectors/CheckboxProj.re index b1d734a8cf..aca1f1b17a 100644 --- a/src/haz3lcore/zipper/projectors/CheckboxProj.re +++ b/src/haz3lcore/zipper/projectors/CheckboxProj.re @@ -2,27 +2,28 @@ open Util; open ProjectorBase; open Virtual_dom.Vdom; -let of_mono = (syntax: Piece.t): option(string) => +let of_mono = (syntax: Piece.t('a)): option(string) => switch (syntax) { | Tile({label: [l], _}) => Some(l) | _ => None }; -let mk_mono = (sort: Sort.t, string: string): Piece.t => +let mk_mono = (sort: Sort.t, string: string): Piece.t('a) => string |> Form.mk_atomic(sort) |> Piece.mk_tile(_, []); -let state_of = (piece: Piece.t): option(bool) => +let state_of = (piece: Piece.t('a)): option(bool) => piece |> of_mono |> Option.map(bool_of_string); -let get = (piece: Piece.t): bool => +let get = (piece: Piece.t('a)): bool => switch (piece |> of_mono |> Util.OptUtil.and_then(bool_of_string_opt)) { | None => failwith("Checkbox: not boolean literal") | Some(s) => s }; -let put = (bool: bool): Piece.t => bool |> string_of_bool |> mk_mono(Exp); +let put = (bool: bool): Piece.t('a) => + bool |> string_of_bool |> mk_mono(Exp); -let toggle = (piece: Piece.t) => put(!get(piece)); +let toggle = (piece: Piece.t('a)) => put(!get(piece)); let view = (_, ~info, ~local as _, ~parent: external_action => Ui_effect.t(unit)) => diff --git a/src/haz3lcore/zipper/projectors/InfoProj.re b/src/haz3lcore/zipper/projectors/InfoProj.re index a78e0ae6e3..6102d7f689 100644 --- a/src/haz3lcore/zipper/projectors/InfoProj.re +++ b/src/haz3lcore/zipper/projectors/InfoProj.re @@ -40,7 +40,7 @@ module M: Projector = { let init = Expected; - let can_project = (p: Piece.t): bool => { + let can_project = (p: Piece.t(Id.t)): bool => { switch (Piece.sort(p)) { | (Exp | Pat, _) => true | _ when Piece.is_grout(p) => true /* Grout don't have sorts rn */ diff --git a/src/haz3lcore/zipper/projectors/SliderFProj.re b/src/haz3lcore/zipper/projectors/SliderFProj.re index 4ad36621ad..8c83c9c5d0 100644 --- a/src/haz3lcore/zipper/projectors/SliderFProj.re +++ b/src/haz3lcore/zipper/projectors/SliderFProj.re @@ -5,12 +5,13 @@ open ProjectorBase; /* Some decimal places necessary to avoid becoming an int */ let float_of_float = s => s |> float_of_string |> Printf.sprintf("%.2f"); -let put = (s: string): Piece.t => s |> float_of_float |> Piece.mk_mono(Exp); +let put = (s: string): Piece.t(Id.t) => + s |> float_of_float |> Piece.mk_mono(Exp); -let get_opt = (piece: Piece.t): option(float) => +let get_opt = (piece: Piece.t(Id.t)): option(float) => piece |> Piece.of_mono |> Util.OptUtil.and_then(float_of_string_opt); -let get = (piece: Piece.t): float => +let get = (piece: Piece.t(Id.t)): float => switch (get_opt(piece)) { | None => failwith("ERROR: Slider: not float literal") | Some(s) => s diff --git a/src/haz3lcore/zipper/projectors/SliderProj.re b/src/haz3lcore/zipper/projectors/SliderProj.re index 2a73c6d012..cadfa43c2f 100644 --- a/src/haz3lcore/zipper/projectors/SliderProj.re +++ b/src/haz3lcore/zipper/projectors/SliderProj.re @@ -2,12 +2,12 @@ open Util; open Virtual_dom.Vdom; open ProjectorBase; -let put: string => Piece.t = Piece.mk_mono(Exp); +let put: string => Piece.t(Id.t) = Piece.mk_mono(Exp); -let get_opt = (piece: Piece.t): option(int) => +let get_opt = (piece: Piece.t(Id.t)): option(int) => piece |> Piece.of_mono |> Util.OptUtil.and_then(int_of_string_opt); -let get = (piece: Piece.t): string => +let get = (piece: Piece.t(Id.t)): string => switch (get_opt(piece)) { | None => failwith("ERROR: Slider: not integer literal") | Some(s) => string_of_int(s) diff --git a/src/haz3lcore/zipper/projectors/TextAreaProj.re b/src/haz3lcore/zipper/projectors/TextAreaProj.re index ce93f38324..a680fbfb42 100644 --- a/src/haz3lcore/zipper/projectors/TextAreaProj.re +++ b/src/haz3lcore/zipper/projectors/TextAreaProj.re @@ -5,25 +5,25 @@ open ProjectorBase; let of_id = (id: Id.t) => "id" ++ (id |> Id.to_string |> String.sub(_, 0, 8)); -let of_mono = (syntax: Piece.t): option(string) => +let of_mono = (syntax: Piece.t('a)): option(string) => switch (syntax) { | Tile({label: [l], _}) => Some(StringUtil.unescape_linebreaks(l)) | _ => None }; -let mk_mono = (sort: Sort.t, string: string): Piece.t => +let mk_mono = (sort: Sort.t, string: string): Piece.t(Id.t) => string |> StringUtil.escape_linebreaks |> Form.mk_atomic(sort) |> Piece.mk_tile(_, []); -let get = (piece: Piece.t): string => +let get = (piece: Piece.t('a)): string => switch (piece |> of_mono) { | None => failwith("TextArea: not string literal") | Some(s) => s }; -let put = (s: string): Piece.t => s |> mk_mono(Exp); +let put = (s: string): Piece.t(Id.t) => s |> mk_mono(Exp); let put = (str: string): external_action => SetSyntax(str |> Form.string_quote |> put); diff --git a/src/haz3lweb/DebugConsole.re b/src/haz3lweb/DebugConsole.re index a7f6d8ee33..4ef2c3a288 100644 --- a/src/haz3lweb/DebugConsole.re +++ b/src/haz3lweb/DebugConsole.re @@ -11,7 +11,11 @@ let print = ({settings, editors, _}: Model.t, key: string): unit => { let print = print_endline; switch (key) { | "F1" => zipper |> Zipper.show |> print - | "F2" => zipper |> Zipper.unselect_and_zip |> Segment.show |> print + | "F2" => + zipper + |> Zipper.unselect_and_zip + |> ((seg: Segment.t(Uuidm.t)) => [%derive.show: Segment.t(Id.t)](seg)) + |> print | "F3" => term |> UExp.show |> print | "F4" => map |> Statics.Map.show |> print | "F5" => diff --git a/src/haz3lweb/exercises/Ex_OddlyRecursive.ml b/src/haz3lweb/exercises/Ex_OddlyRecursive.ml index ab0a0b5ee7..968bd10241 100644 --- a/src/haz3lweb/exercises/Ex_OddlyRecursive.ml +++ b/src/haz3lweb/exercises/Ex_OddlyRecursive.ml @@ -22,7 +22,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace "\226\143\142" }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "fun"; "->" ]; mold = { @@ -40,7 +40,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "x" ]; mold = { @@ -62,7 +62,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace "\226\143\142" }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "if"; "then"; "else" ]; mold = { @@ -80,7 +80,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "x" ]; mold = { @@ -101,7 +101,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "false" ]; mold = { @@ -122,7 +122,7 @@ let exercise : Exercise.spec = Secondary { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "true" ]; mold = { @@ -160,7 +160,7 @@ let exercise : Exercise.spec = Secondary { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "not" ]; mold = { @@ -177,7 +177,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ ":" ]; mold = { @@ -194,7 +194,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "Bool" ]; mold = { @@ -211,7 +211,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "->" ]; mold = { @@ -228,7 +228,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "Bool" ]; mold = { @@ -268,7 +268,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace "\226\143\142" }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "fun"; "->" ]; mold = { @@ -286,7 +286,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "x" ]; mold = { @@ -308,7 +308,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace "\226\143\142" }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "if"; "then"; "else" ]; mold = { @@ -326,7 +326,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "x" ]; mold = { @@ -343,7 +343,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "<" ]; mold = { @@ -360,7 +360,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "0" ]; mold = { @@ -386,7 +386,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "odd" ]; mold = { @@ -401,7 +401,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "("; ")" ]; mold = { @@ -417,7 +417,7 @@ let exercise : Exercise.spec = [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "-" ]; mold = { @@ -435,7 +435,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "x" ]; mold = { @@ -465,7 +465,7 @@ let exercise : Exercise.spec = Secondary { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "if"; "then"; "else" ]; mold = { @@ -483,7 +483,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "x" ]; mold = { @@ -500,7 +500,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "==" ]; mold = { @@ -517,7 +517,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "0" ]; mold = { @@ -538,7 +538,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "false" ]; mold = { @@ -564,7 +564,7 @@ let exercise : Exercise.spec = Secondary { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "not" ]; mold = { @@ -579,7 +579,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "("; ")" ]; mold = { @@ -595,7 +595,7 @@ let exercise : Exercise.spec = [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "odd" ]; mold = { @@ -610,7 +610,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "("; ")" ]; mold = { @@ -626,7 +626,7 @@ let exercise : Exercise.spec = [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "x" ]; mold = { @@ -642,7 +642,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "-" ]; mold = { @@ -663,7 +663,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "1" ]; mold = { @@ -708,7 +708,7 @@ let exercise : Exercise.spec = Secondary { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "odd" ]; mold = { @@ -723,7 +723,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ ":" ]; mold = { @@ -738,7 +738,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "Int" ]; mold = { @@ -753,7 +753,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "->" ]; mold = { @@ -768,7 +768,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "Bool" ]; mold = { @@ -808,7 +808,7 @@ let exercise : Exercise.spec = ( [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "test"; "end" ]; mold = { @@ -826,7 +826,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "not" ]; mold = { @@ -841,7 +841,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "("; ")" ]; mold = { @@ -857,7 +857,7 @@ let exercise : Exercise.spec = [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "false" ]; mold = { @@ -886,7 +886,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ ";" ]; mold = { @@ -903,7 +903,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace "\226\143\142" }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "test"; "end" ]; mold = { @@ -921,7 +921,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "not" ]; mold = { @@ -936,7 +936,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "("; ")" ]; mold = { @@ -952,7 +952,7 @@ let exercise : Exercise.spec = [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "not" ]; mold = { @@ -973,7 +973,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "("; ")" ]; mold = { @@ -995,7 +995,7 @@ let exercise : Exercise.spec = [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "true" ]; mold = { @@ -1027,7 +1027,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ ";" ]; mold = { @@ -1062,7 +1062,7 @@ let exercise : Exercise.spec = ( [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "let"; "="; "in" ]; mold = { @@ -1080,7 +1080,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "odd" ]; mold = { @@ -1095,7 +1095,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ ":" ]; mold = { @@ -1112,7 +1112,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "Int" ]; mold = { @@ -1129,7 +1129,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "->" ]; mold = { @@ -1146,7 +1146,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "Bool" ]; mold = { @@ -1170,7 +1170,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "fun"; "->" ]; mold = { @@ -1191,7 +1191,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "n" ]; mold = { @@ -1246,7 +1246,7 @@ let exercise : Exercise.spec = ( [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "let"; "="; "in" ]; mold = { @@ -1264,7 +1264,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "odd" ]; mold = { @@ -1279,7 +1279,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ ":" ]; mold = { @@ -1297,7 +1297,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "Int" ]; mold = { @@ -1314,7 +1314,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "->" ]; mold = { @@ -1332,7 +1332,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "Bool" ]; mold = { @@ -1356,7 +1356,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "fun"; "->" ]; mold = { @@ -1378,7 +1378,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "x" ]; mold = { @@ -1409,7 +1409,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "false" ]; mold = { @@ -1452,7 +1452,7 @@ let exercise : Exercise.spec = ( [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "let"; "="; "in" ]; mold = { @@ -1470,7 +1470,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "odd" ]; mold = { @@ -1485,7 +1485,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ ":" ]; mold = { @@ -1503,7 +1503,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "Int" ]; mold = { @@ -1520,7 +1520,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "->" ]; mold = { @@ -1538,7 +1538,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "Bool" ]; mold = { @@ -1562,7 +1562,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "fun"; "->" ]; mold = { @@ -1584,7 +1584,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "x" ]; mold = { @@ -1615,7 +1615,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "true" ]; mold = { @@ -1658,7 +1658,7 @@ let exercise : Exercise.spec = ( [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "let"; "="; "in" ]; mold = { @@ -1676,7 +1676,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "odd" ]; mold = { @@ -1691,7 +1691,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ ":" ]; mold = { @@ -1709,7 +1709,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "Int" ]; mold = { @@ -1726,7 +1726,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "->" ]; mold = { @@ -1744,7 +1744,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "Bool" ]; mold = { @@ -1768,7 +1768,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "fun"; "->" ]; mold = { @@ -1790,7 +1790,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "x" ]; mold = { @@ -1821,7 +1821,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "if"; "then"; "else" ]; mold = { @@ -1843,7 +1843,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "x" ]; mold = { @@ -1869,7 +1869,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "<" ]; mold = { @@ -1895,7 +1895,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "0" ]; mold = { @@ -1928,7 +1928,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "odd" ]; mold = { @@ -1949,7 +1949,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "("; ")" ]; mold = { @@ -1971,7 +1971,7 @@ let exercise : Exercise.spec = [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "-" ]; mold = { @@ -1994,7 +1994,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "x" ]; mold = { @@ -2036,7 +2036,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "if"; "then"; "else" ]; mold = { @@ -2058,7 +2058,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "x" ]; mold = { @@ -2084,7 +2084,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "==" ]; mold = { @@ -2110,7 +2110,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "0" ]; mold = { @@ -2143,7 +2143,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "true" ]; mold = { @@ -2180,7 +2180,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "if"; "then"; "else" ]; mold = { @@ -2202,7 +2202,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "x" ]; mold = { @@ -2228,7 +2228,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "==" ]; mold = { @@ -2254,7 +2254,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "1" ]; mold = { @@ -2287,7 +2287,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "true" ]; mold = { @@ -2324,7 +2324,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "odd" ]; mold = { @@ -2339,7 +2339,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "("; ")" ]; mold = { @@ -2355,7 +2355,7 @@ let exercise : Exercise.spec = [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "x" ]; mold = { @@ -2381,7 +2381,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "-" ]; mold = { @@ -2407,7 +2407,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "1" ]; mold = { @@ -2457,7 +2457,7 @@ let exercise : Exercise.spec = ( [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "test"; "end" ]; mold = { @@ -2475,7 +2475,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "not" ]; mold = { @@ -2490,7 +2490,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "("; ")" ]; mold = { @@ -2506,7 +2506,7 @@ let exercise : Exercise.spec = [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "odd" ]; mold = { @@ -2527,7 +2527,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "("; ")" ]; mold = { @@ -2549,7 +2549,7 @@ let exercise : Exercise.spec = [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "0" ]; mold = { @@ -2581,7 +2581,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ ";" ]; mold = { @@ -2598,7 +2598,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace "\226\143\142" }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "test"; "end" ]; mold = { @@ -2616,7 +2616,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "odd" ]; mold = { @@ -2631,7 +2631,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "("; ")" ]; mold = { @@ -2647,7 +2647,7 @@ let exercise : Exercise.spec = [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "1" ]; mold = { @@ -2676,7 +2676,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ ";" ]; mold = { @@ -2693,7 +2693,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace "\226\143\142" }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "test"; "end" ]; mold = { @@ -2711,7 +2711,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "not" ]; mold = { @@ -2726,7 +2726,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "("; ")" ]; mold = { @@ -2742,7 +2742,7 @@ let exercise : Exercise.spec = [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "odd" ]; mold = { @@ -2763,7 +2763,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "("; ")" ]; mold = { @@ -2785,7 +2785,7 @@ let exercise : Exercise.spec = [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "2" ]; mold = { @@ -2817,7 +2817,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ ";" ]; mold = { @@ -2834,7 +2834,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace "\226\143\142" }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "test"; "end" ]; mold = { @@ -2852,7 +2852,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "odd" ]; mold = { @@ -2867,7 +2867,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "("; ")" ]; mold = { @@ -2883,7 +2883,7 @@ let exercise : Exercise.spec = [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "3" ]; mold = { @@ -2912,7 +2912,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ ";" ]; mold = { @@ -2929,7 +2929,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace "\226\143\142" }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "test"; "end" ]; mold = { @@ -2947,7 +2947,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "not" ]; mold = { @@ -2962,7 +2962,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "("; ")" ]; mold = { @@ -2978,7 +2978,7 @@ let exercise : Exercise.spec = [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "odd" ]; mold = { @@ -2999,7 +2999,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "("; ")" ]; mold = { @@ -3021,7 +3021,7 @@ let exercise : Exercise.spec = [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "42" ]; mold = { @@ -3053,7 +3053,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ ";" ]; mold = { @@ -3071,7 +3071,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace "\226\143\142" }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "test"; "end" ]; mold = { @@ -3089,7 +3089,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "odd" ]; mold = { @@ -3104,7 +3104,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "("; ")" ]; mold = { @@ -3120,7 +3120,7 @@ let exercise : Exercise.spec = [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "27" ]; mold = { diff --git a/src/haz3lweb/exercises/Ex_RecursiveFibonacci.ml b/src/haz3lweb/exercises/Ex_RecursiveFibonacci.ml index 1e95c4719d..c7509197b6 100644 --- a/src/haz3lweb/exercises/Ex_RecursiveFibonacci.ml +++ b/src/haz3lweb/exercises/Ex_RecursiveFibonacci.ml @@ -34,7 +34,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace "\226\143\142" }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "fun"; "->" ]; mold = { @@ -52,7 +52,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "x" ]; mold = { @@ -75,7 +75,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace "\226\143\142" }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "if"; "then"; "else" ]; mold = { @@ -93,7 +93,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "x" ]; mold = { @@ -110,7 +110,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "<" ]; mold = { @@ -127,7 +127,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "2" ]; mold = { @@ -148,7 +148,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "1" ]; mold = { @@ -174,7 +174,7 @@ let exercise : Exercise.spec = Secondary { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "fib" ]; mold = { @@ -189,7 +189,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "("; ")" ]; mold = { @@ -205,7 +205,7 @@ let exercise : Exercise.spec = [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "x" ]; mold = { @@ -222,7 +222,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "-" ]; mold = { @@ -239,7 +239,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "1" ]; mold = { @@ -258,7 +258,7 @@ let exercise : Exercise.spec = Secondary { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "+" ]; mold = { @@ -274,7 +274,7 @@ let exercise : Exercise.spec = Secondary { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "fib" ]; mold = { @@ -289,7 +289,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "("; ")" ]; mold = { @@ -305,7 +305,7 @@ let exercise : Exercise.spec = [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "x" ]; mold = { @@ -322,7 +322,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "-" ]; mold = { @@ -339,7 +339,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "2" ]; mold = { @@ -381,7 +381,7 @@ let exercise : Exercise.spec = Secondary { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "fib" ]; mold = { @@ -396,7 +396,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ ":" ]; mold = { @@ -413,7 +413,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "Int" ]; mold = { @@ -430,7 +430,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "->" ]; mold = { @@ -447,7 +447,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "Int" ]; mold = { @@ -501,7 +501,7 @@ let exercise : Exercise.spec = ( [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "let"; "="; "in" ]; mold = { @@ -519,7 +519,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "fib" ]; mold = { @@ -536,7 +536,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ ":" ]; mold = { @@ -553,7 +553,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "Int" ]; mold = { @@ -570,7 +570,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "->" ]; mold = { @@ -587,7 +587,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "Int" ]; mold = { @@ -613,7 +613,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "fun"; "->" ]; mold = { @@ -634,7 +634,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "n" ]; mold = { @@ -688,7 +688,7 @@ let exercise : Exercise.spec = ( [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "let"; "="; "in" ]; mold = { @@ -706,7 +706,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "fib" ]; mold = { @@ -721,7 +721,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ ":" ]; mold = { @@ -739,7 +739,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "Int" ]; mold = { @@ -756,7 +756,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "->" ]; mold = { @@ -774,7 +774,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "Int" ]; mold = { @@ -800,7 +800,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "fun"; "->" ]; mold = { @@ -822,7 +822,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "x" ]; mold = { @@ -858,7 +858,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "if"; "then"; "else" ]; mold = { @@ -880,7 +880,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "x" ]; mold = { @@ -906,7 +906,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "<" ]; mold = { @@ -932,7 +932,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "1" ]; mold = { @@ -965,7 +965,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "0" ]; mold = { @@ -1002,7 +1002,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "if"; "then"; "else" ]; mold = { @@ -1024,7 +1024,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "x" ]; mold = { @@ -1050,7 +1050,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "<" ]; mold = { @@ -1076,7 +1076,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "2" ]; mold = { @@ -1109,7 +1109,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "1" ]; mold = { @@ -1146,7 +1146,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "fib" ]; mold = { @@ -1161,7 +1161,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "("; ")" ]; mold = { @@ -1177,7 +1177,7 @@ let exercise : Exercise.spec = [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "x" ]; mold = { @@ -1203,7 +1203,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "-" ]; mold = { @@ -1229,7 +1229,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "1" ]; mold = { @@ -1255,7 +1255,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "+" ]; mold = { @@ -1273,7 +1273,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "fib" ]; mold = { @@ -1288,7 +1288,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "("; ")" ]; mold = { @@ -1304,7 +1304,7 @@ let exercise : Exercise.spec = [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "x" ]; mold = { @@ -1330,7 +1330,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "-" ]; mold = { @@ -1356,7 +1356,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "2" ]; mold = { @@ -1410,7 +1410,7 @@ let exercise : Exercise.spec = ( [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "let"; "="; "in" ]; mold = { @@ -1428,7 +1428,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "fib" ]; mold = { @@ -1443,7 +1443,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ ":" ]; mold = { @@ -1461,7 +1461,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "Int" ]; mold = { @@ -1478,7 +1478,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "->" ]; mold = { @@ -1496,7 +1496,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "Int" ]; mold = { @@ -1522,7 +1522,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "fun"; "->" ]; mold = { @@ -1544,7 +1544,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "x" ]; mold = { @@ -1580,7 +1580,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "if"; "then"; "else" ]; mold = { @@ -1602,7 +1602,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "x" ]; mold = { @@ -1628,7 +1628,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "<" ]; mold = { @@ -1654,7 +1654,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "2" ]; mold = { @@ -1687,7 +1687,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "1" ]; mold = { @@ -1729,7 +1729,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "fib" ]; mold = { @@ -1744,7 +1744,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "("; ")" ]; mold = { @@ -1760,7 +1760,7 @@ let exercise : Exercise.spec = [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "x" ]; mold = { @@ -1786,7 +1786,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "-" ]; mold = { @@ -1812,7 +1812,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "2" ]; mold = { @@ -1838,7 +1838,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "+" ]; mold = { @@ -1856,7 +1856,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "fib" ]; mold = { @@ -1871,7 +1871,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "("; ")" ]; mold = { @@ -1887,7 +1887,7 @@ let exercise : Exercise.spec = [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "x" ]; mold = { @@ -1913,7 +1913,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "-" ]; mold = { @@ -1939,7 +1939,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "2" ]; mold = { @@ -1993,7 +1993,7 @@ let exercise : Exercise.spec = ( [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "test"; "end" ]; mold = { @@ -2011,7 +2011,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "fib" ]; mold = { @@ -2026,7 +2026,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "("; ")" ]; mold = { @@ -2042,7 +2042,7 @@ let exercise : Exercise.spec = [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "0" ]; mold = { @@ -2068,7 +2068,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "==" ]; mold = { @@ -2085,7 +2085,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "1" ]; mold = { @@ -2105,7 +2105,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ ";" ]; mold = { @@ -2122,7 +2122,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace "\226\143\142" }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "test"; "end" ]; mold = { @@ -2140,7 +2140,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "fib" ]; mold = { @@ -2155,7 +2155,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "("; ")" ]; mold = { @@ -2171,7 +2171,7 @@ let exercise : Exercise.spec = [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "1" ]; mold = { @@ -2197,7 +2197,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "==" ]; mold = { @@ -2214,7 +2214,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "1" ]; mold = { @@ -2234,7 +2234,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ ";" ]; mold = { @@ -2251,7 +2251,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace "\226\143\142" }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "test"; "end" ]; mold = { @@ -2269,7 +2269,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "fib" ]; mold = { @@ -2284,7 +2284,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "("; ")" ]; mold = { @@ -2300,7 +2300,7 @@ let exercise : Exercise.spec = [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "2" ]; mold = { @@ -2326,7 +2326,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "==" ]; mold = { @@ -2343,7 +2343,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "2" ]; mold = { @@ -2363,7 +2363,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ ";" ]; mold = { @@ -2380,7 +2380,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace "\226\143\142" }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "test"; "end" ]; mold = { @@ -2398,7 +2398,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "fib" ]; mold = { @@ -2413,7 +2413,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "("; ")" ]; mold = { @@ -2429,7 +2429,7 @@ let exercise : Exercise.spec = [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "3" ]; mold = { @@ -2455,7 +2455,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "==" ]; mold = { @@ -2472,7 +2472,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "3" ]; mold = { @@ -2492,7 +2492,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ ";" ]; mold = { @@ -2509,7 +2509,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace "\226\143\142" }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "test"; "end" ]; mold = { @@ -2527,7 +2527,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "fib" ]; mold = { @@ -2542,7 +2542,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "("; ")" ]; mold = { @@ -2558,7 +2558,7 @@ let exercise : Exercise.spec = [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "4" ]; mold = { @@ -2584,7 +2584,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "==" ]; mold = { @@ -2601,7 +2601,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "5" ]; mold = { @@ -2621,7 +2621,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ ";" ]; mold = { @@ -2638,7 +2638,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace "\226\143\142" }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "test"; "end" ]; mold = { @@ -2656,7 +2656,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "fib" ]; mold = { @@ -2671,7 +2671,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "("; ")" ]; mold = { @@ -2687,7 +2687,7 @@ let exercise : Exercise.spec = [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "5" ]; mold = { @@ -2713,7 +2713,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "==" ]; mold = { @@ -2730,7 +2730,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "8" ]; mold = { @@ -2750,7 +2750,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ ";" ]; mold = { @@ -2767,7 +2767,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace "\226\143\142" }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "test"; "end" ]; mold = { @@ -2785,7 +2785,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "fib" ]; mold = { @@ -2800,7 +2800,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "("; ")" ]; mold = { @@ -2816,7 +2816,7 @@ let exercise : Exercise.spec = [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "6" ]; mold = { @@ -2842,7 +2842,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "==" ]; mold = { @@ -2859,7 +2859,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "13" ]; mold = { @@ -2879,7 +2879,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ ";" ]; mold = { @@ -2896,7 +2896,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace "\226\143\142" }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "test"; "end" ]; mold = { @@ -2914,7 +2914,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "fib" ]; mold = { @@ -2929,7 +2929,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "("; ")" ]; mold = { @@ -2945,7 +2945,7 @@ let exercise : Exercise.spec = [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "7" ]; mold = { @@ -2971,7 +2971,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "==" ]; mold = { @@ -2988,7 +2988,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "21" ]; mold = { @@ -3008,7 +3008,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ ";" ]; mold = { @@ -3025,7 +3025,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace "\226\143\142" }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "test"; "end" ]; mold = { @@ -3043,7 +3043,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "fib" ]; mold = { @@ -3058,7 +3058,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "("; ")" ]; mold = { @@ -3074,7 +3074,7 @@ let exercise : Exercise.spec = [ Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "8" ]; mold = { @@ -3100,7 +3100,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "==" ]; mold = { @@ -3117,7 +3117,7 @@ let exercise : Exercise.spec = { id = Id.mk (); content = Whitespace " " }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ "34" ]; mold = { @@ -3137,7 +3137,7 @@ let exercise : Exercise.spec = }; Tile { - id = Id.mk (); + extra = Id.mk (); label = [ ";" ]; mold = { diff --git a/src/haz3lweb/explainthis/Example.re b/src/haz3lweb/explainthis/Example.re index 9408167cf6..05ecd2f14d 100644 --- a/src/haz3lweb/explainthis/Example.re +++ b/src/haz3lweb/explainthis/Example.re @@ -1,11 +1,12 @@ open Haz3lcore; -let mk_secondary: string => Piece.t = +let mk_secondary: string => Piece.t(Id.t) = content => Secondary({id: Id.mk(), content: Whitespace(content)}); let mk_tile = Piece.mk_tile; -let mk_ancestor: (Form.t, (list(Segment.t), list(Segment.t))) => Ancestor.t = +let mk_ancestor: + (Form.t, (list(Segment.t(Id.t)), list(Segment.t(Id.t)))) => Ancestor.t = //TODO: asserts (form, (l, _) as children) => { id: Id.mk(), @@ -28,10 +29,18 @@ let mk_parens_ancestor = mk_ancestor(Form.get("parens_exp")); let mk_let_ancestor = mk_ancestor(Form.get("let_")); let plus = mk_monotile(Form.get("plus")); -let l_sibling: Segment.t = [plus, Grout({id: Id.mk(), shape: Convex})]; -let r_sibling: Segment.t = [mk_parens_exp([[int("1"), plus, int("2")]])]; +let l_sibling: Segment.t(Id.t) = [ + plus, + Grout({id: Id.mk(), shape: Convex}), +]; +let r_sibling: Segment.t(Id.t) = [ + mk_parens_exp([[int("1"), plus, int("2")]]), +]; -let content: Segment.t = [exp("foo"), Grout({id: Id.mk(), shape: Concave})]; +let content: Segment.t(Id.t) = [ + exp("foo"), + Grout({id: Id.mk(), shape: Concave}), +]; let ancestors: Ancestors.t = [ (mk_parens_ancestor(([], [])), ([mk_fun([[pat("bar")]])], [])), diff --git a/src/haz3lweb/explainthis/ExplainThisForm.re b/src/haz3lweb/explainthis/ExplainThisForm.re index a2291253e5..2acd963d2d 100644 --- a/src/haz3lweb/explainthis/ExplainThisForm.re +++ b/src/haz3lweb/explainthis/ExplainThisForm.re @@ -125,7 +125,7 @@ type example_id = [@deriving (show({with_path: false}), sexp, yojson)] type example = { sub_id: example_id, - term: Segment.t, + term: Segment.t(Id.t), message: string, }; @@ -235,8 +235,8 @@ type form_id = [@deriving (show({with_path: false}), sexp, yojson)] type form = { id: form_id, - syntactic_form: Segment.t, - expandable_id: option((Id.t, Segment.t)), + syntactic_form: Segment.t(Id.t), + expandable_id: option((Id.t, Segment.t(Id.t))), explanation: string, examples: list(example), }; @@ -336,7 +336,7 @@ module Simple = { type t = { group_id, form_id, - abstract: (Segment.t, list((Id.t, Id.t))), + abstract: (Segment.t(Id.t), list((Id.t, Id.t))), explanation: string, examples: list(example), }; @@ -368,8 +368,8 @@ module Simple = { ); let mk_1 = - ((n: string, id: Id.t), mk_form: Piece.t => Segment.t) - : (Segment.t, list((Id.t, Id.t))) => { + ((n: string, id: Id.t), mk_form: Piece.t(Id.t) => Segment.t(Id.t)) + : (Segment.t(Id.t), list((Id.t, Id.t))) => { let p = Example.exp(n); (mk_form(p), [(Piece.id(p), id)]); }; @@ -378,9 +378,9 @@ module Simple = { ( (n1: string, id_1: Id.t), (n2: string, id_2: Id.t), - mk_form: (Piece.t, Piece.t) => Segment.t, + mk_form: (Piece.t(Id.t), Piece.t(Id.t)) => Segment.t(Id.t), ) - : (Segment.t, list((Id.t, Id.t))) => { + : (Segment.t(Id.t), list((Id.t, Id.t))) => { let (p1, p2) = (Example.exp(n1), Example.exp(n2)); (mk_form(p1, p2), [(Piece.id(p1), id_1), (Piece.id(p2), id_2)]); }; @@ -390,9 +390,10 @@ module Simple = { (n1: string, id_1: Id.t), (n2: string, id_2: Id.t), (n3: string, id_3: Id.t), - mk_form: (Piece.t, Piece.t, Piece.t) => Segment.t, + mk_form: + (Piece.t(Id.t), Piece.t(Id.t), Piece.t(Id.t)) => Segment.t(Id.t), ) - : (Segment.t, list((Id.t, Id.t))) => { + : (Segment.t(Id.t), list((Id.t, Id.t))) => { let (p1, p2, p3) = ( Example.exp(n1), Example.exp(n2), diff --git a/src/haz3lweb/explainthis/ExplainThisModel.re b/src/haz3lweb/explainthis/ExplainThisModel.re index 92ab95a342..5308311c83 100644 --- a/src/haz3lweb/explainthis/ExplainThisModel.re +++ b/src/haz3lweb/explainthis/ExplainThisModel.re @@ -177,7 +177,7 @@ let get_selected_option = (group: group, model: t): form => { }; }; -let get_options = (group: group): list((form_id, Segment.t)) => +let get_options = (group: group): list((form_id, Segment.t(Id.t))) => if (List.length(group.forms) < 2) { []; } else { @@ -201,6 +201,6 @@ let get_options = (group: group): list((form_id, Segment.t)) => }; let get_form_and_options = - (group: group, model: t): (form, list((form_id, Segment.t))) => { + (group: group, model: t): (form, list((form_id, Segment.t(Id.t)))) => { (get_selected_option(group, model), get_options(group)); }; diff --git a/src/haz3lweb/view/BackpackView.re b/src/haz3lweb/view/BackpackView.re index d422458d7d..b1f8f4f1c9 100644 --- a/src/haz3lweb/view/BackpackView.re +++ b/src/haz3lweb/view/BackpackView.re @@ -6,7 +6,7 @@ open Util; /* Assume this doesn't contain projectors */ let measured_of = seg => Measured.of_segment(seg, Id.Map.empty); -let text_view = (seg: Segment.t): list(Node.t) => { +let text_view = (seg: Segment.t(Id.t)): list(Node.t) => { module Text = Code.Text({ let map = measured_of(seg); @@ -16,25 +16,25 @@ let text_view = (seg: Segment.t): list(Node.t) => { Text.of_segment([], true, Any, seg); }; -let segment_origin = (seg: Segment.t): option(Point.t) => +let segment_origin = (seg: Segment.t(Id.t)): option(Point.t) => Option.map( first => Measured.find_p(first, measured_of(seg)).origin, ListUtil.hd_opt(seg), ); -let segment_last = (seg: Segment.t): option(Point.t) => +let segment_last = (seg: Segment.t(Id.t)): option(Point.t) => Option.map( last => Measured.find_p(last, measured_of(seg)).last, ListUtil.last_opt(seg), ); -let segment_height = (seg: Segment.t) => +let segment_height = (seg: Segment.t(Id.t)) => switch (segment_last(seg), segment_origin(seg)) { | (Some(last), Some(first)) => 1 + last.row - first.row | _ => 0 }; -let segment_width = (seg: Segment.t): int => +let segment_width = (seg: Segment.t(Id.t)): int => IntMap.fold( (_, {max_col, _}: Measured.Rows.shape, acc) => max(max_col, acc), measured_of(seg).rows, diff --git a/src/haz3lweb/view/Cell.re b/src/haz3lweb/view/Cell.re index e006b7e30d..b239c0c639 100644 --- a/src/haz3lweb/view/Cell.re +++ b/src/haz3lweb/view/Cell.re @@ -388,7 +388,7 @@ let locked = ~settings: Settings.t, ~inject, ~target_id, - ~segment: Segment.t, + ~segment: Segment.t(Id.t), ) => { let editor = segment diff --git a/src/haz3lweb/view/Code.re b/src/haz3lweb/view/Code.re index 9cc249acfe..a11df92a34 100644 --- a/src/haz3lweb/view/Code.re +++ b/src/haz3lweb/view/Code.re @@ -35,7 +35,7 @@ let of_delim' = }, ); let of_delim = - (is_in_buffer, is_consistent, indent, t: Piece.tile, i: int) + (is_in_buffer, is_consistent, indent, t: Piece.tile('a), i: int) : list(Node.t) => of_delim'(( t.label, @@ -71,7 +71,7 @@ let of_secondary = let of_projector = (p, expected_sort, indent, info_map) => of_delim'(( - [Projector.placeholder(p, Id.Map.find_opt(p.id, info_map))], + [Projector.placeholder(p, Id.Map.find_opt(p.extra, info_map))], false, expected_sort, true, @@ -90,7 +90,7 @@ module Text = ) => { let m = p => Measured.find_p(~msg="Text", p, M.map); let rec of_segment = - (buffer_ids, no_sorts, sort, seg: Segment.t): list(Node.t) => { + (buffer_ids, no_sorts, sort, seg: Segment.t(Id.t)): list(Node.t) => { /* note: no_sorts flag is used for backpack view; otherwise Segment.expected_sorts call crashes for some reason */ let expected_sorts = @@ -109,7 +109,7 @@ module Text = ); } and of_piece = - (buffer_ids, expected_sort: Sort.t, p: Piece.t): list(Node.t) => { + (buffer_ids, expected_sort: Sort.t, p: Piece.t(Id.t)): list(Node.t) => { switch (p) { | Tile(t) => of_tile(buffer_ids, expected_sort, t) | Grout(_) => of_grout @@ -119,7 +119,8 @@ module Text = of_projector(p, expected_sort, m(Projector(p)).origin.col, M.info_map) }; } - and of_tile = (buffer_ids, expected_sort: Sort.t, t: Tile.t): list(Node.t) => { + and of_tile = + (buffer_ids, expected_sort: Sort.t, t: Tile.t(Id.t)): list(Node.t) => { let children_and_sorts = List.mapi( (i, (l, child, r)) => @@ -128,7 +129,7 @@ module Text = Aba.aba_triples(Aba.mk(t.shards, t.children)), ); let is_consistent = Sort.consistent(t.mold.out, expected_sort); - let is_in_buffer = List.mem(t.id, buffer_ids); + let is_in_buffer = List.mem(t.extra, buffer_ids); Aba.mk(t.shards, children_and_sorts) |> Aba.join( of_delim(is_in_buffer, is_consistent, m(Tile(t)).origin.col, t), @@ -140,7 +141,8 @@ module Text = }; let rec holes = - (~font_metrics, ~map: Measured.t, seg: Segment.t): list(Node.t) => + (~font_metrics, ~map: Measured.t, seg: Segment.t(Id.t)) + : list(Node.t) => seg |> List.concat_map( fun diff --git a/src/haz3lweb/view/Deco.re b/src/haz3lweb/view/Deco.re index 8c296ca6c4..604a0cc646 100644 --- a/src/haz3lweb/view/Deco.re +++ b/src/haz3lweb/view/Deco.re @@ -22,7 +22,7 @@ module HighlightSegment = let find_g = Measured.find_g(~msg="Highlight.of_piece", _, M.measured); let find_w = Measured.find_w(~msg="Highlight.of_piece", _, M.measured); let rec of_piece = - (start_shape: Nib.Shape.t, p: Piece.t) + (start_shape: Nib.Shape.t, p: Piece.t(Id.t)) : (Nib.Shape.t, list(option(shard_data))) => { let shard_data = switch (p) { @@ -39,7 +39,7 @@ module HighlightSegment = }; (start_shape, shard_data); } - and of_tile = (~start_shape, t: Tile.t): list(option(shard_data)) => { + and of_tile = (~start_shape, t: Tile.t(Id.t)): list(option(shard_data)) => { let tile_shards = Measured.find_shards(~msg="sel_of_tile", t, M.measured) |> List.filter(((i, _)) => List.mem(i, t.shards)) @@ -59,14 +59,14 @@ module HighlightSegment = ListUtil.interleave(tile_shards, children_shards) |> List.flatten; } and of_projector = - (~start_shape, p: Base.projector): list(option(shard_data)) => { + (~start_shape, p: Base.projector(Id.t)): list(option(shard_data)) => { let m = switch (Measured.find_pr_opt(p, M.measured)) { | None => failwith("TODO(andrew): Deco.sel_of_projector: missing measurement") | Some(m) => m }; - let ci = Id.Map.find_opt(p.id, M.info_map); + let ci = Id.Map.find_opt(p.extra, M.info_map); let token = Projector.placeholder(p, ci); switch (StringUtil.num_linebreaks(token)) { | 0 => [Some(sel_shard_svg(~start_shape, ~index=0, m, Projector(p)))] @@ -77,13 +77,14 @@ module HighlightSegment = }; } and of_segment = - (start_shape: Nib.Shape.t, seg: Segment.t): list(option(shard_data)) => { + (start_shape: Nib.Shape.t, seg: Segment.t(Id.t)) + : list(option(shard_data)) => { seg |> ListUtil.fold_left_map(of_piece, start_shape) |> snd |> List.flatten; } - and go = (segment: Segment.t, shape_init, classes): list(Node.t) => + and go = (segment: Segment.t(Id.t), shape_init, classes): list(Node.t) => /* We draw a single deco per row by dividing partionining the shards * into linebreak-seperated segments, then combining the measurements * and shapes of the first and last shard of each segment. Ideally we @@ -152,7 +153,8 @@ module Deco = }; }; - let all_tiles = (p: Piece.t): list((Uuidm.t, Mold.t, Measured.Shards.t)) => + let all_tiles = + (p: Piece.t(Id.t)): list((Uuidm.t, Mold.t, Measured.Shards.t)) => Id.Map.find(Piece.id(p), M.meta.syntax.terms) |> Any.ids |> List.map(id => { @@ -196,7 +198,8 @@ module Deco = }; }; - let rec targets = (~container_shards=?, bp: Backpack.t, seg: Segment.t) => { + let rec targets = + (~container_shards=?, bp: Backpack.t, seg: Segment.t(Id.t)) => { let with_container_shards = ((pre, suf) as sibs) => switch (container_shards) { | None => sibs @@ -246,7 +249,7 @@ module Deco = | Piece.Tile(t) => Some(t) | _ => None, ) - |> List.concat_map((t: Tile.t) => { + |> List.concat_map((t: Tile.t(Id.t)) => { // TODO(d): unify with Relatives.local_incomplete_tiles Tile.contained_children(t) |> List.concat_map(((l, seg, r)) => diff --git a/src/haz3lweb/view/ExplainThis.re b/src/haz3lweb/view/ExplainThis.re index 0fb1efae04..cfca701ebb 100644 --- a/src/haz3lweb/view/ExplainThis.re +++ b/src/haz3lweb/view/ExplainThis.re @@ -233,7 +233,7 @@ let expander_deco = ~settings: Settings.t, ~inject, ~ui_state: Model.ui_state, - ~options: list((ExplainThisForm.form_id, Segment.t)), + ~options: list((ExplainThisForm.form_id, Segment.t(Id.t))), ~group: ExplainThisForm.group, ~doc: ExplainThisForm.form, ) => { @@ -283,7 +283,7 @@ let expander_deco = specificity_style, ], List.map( - ((id: ExplainThisForm.form_id, segment: Segment.t)): Node.t => { + ((id: ExplainThisForm.form_id, segment: Segment.t(Id.t))): Node.t => { let code_view = Code.simple_view(~font_metrics, ~segment, ~settings); let classes = diff --git a/src/haz3lweb/view/ProjectorView.re b/src/haz3lweb/view/ProjectorView.re index 27f2e5d4ae..d9a6f1509d 100644 --- a/src/haz3lweb/view/ProjectorView.re +++ b/src/haz3lweb/view/ProjectorView.re @@ -83,7 +83,7 @@ let view_wrapper = ~info: info, ~indication: option(Direction.t), ~selected: bool, - p: Base.projector, + p: Base.projector(Id.t), view: Node.t, ) => { let shape = Projector.shape(p, info); From a5a49573f2421685062fd6601924dca714ac3d86 Mon Sep 17 00:00:00 2001 From: Alexander Bandukwala <7h3kk1d@gmail.com> Date: Tue, 13 Aug 2024 17:05:49 -0400 Subject: [PATCH 2/8] pain and regret --- src/haz3lcore/dynamics/Builtins.re | 45 +++- src/haz3lcore/dynamics/Casts.re | 11 +- src/haz3lcore/dynamics/DHExp.re | 8 +- src/haz3lcore/dynamics/Elaborator.re | 20 +- src/haz3lcore/dynamics/EvalCtx.re | 53 +++-- src/haz3lcore/dynamics/Evaluator.re | 11 +- src/haz3lcore/dynamics/EvaluatorError.re | 22 +- src/haz3lcore/dynamics/EvaluatorStep.re | 25 +- src/haz3lcore/dynamics/FilterMatcher.re | 17 +- src/haz3lcore/dynamics/PatternMatch.re | 2 +- src/haz3lcore/dynamics/Stepper.re | 10 +- src/haz3lcore/dynamics/Substitution.re | 20 +- src/haz3lcore/dynamics/Substitution.rei | 8 +- src/haz3lcore/dynamics/TestMap.re | 2 +- src/haz3lcore/dynamics/Transition.re | 60 +++-- src/haz3lcore/dynamics/TypeAssignment.re | 8 +- src/haz3lcore/dynamics/Unboxing.re | 11 +- src/haz3lcore/lang/term/IdTagged.re | 4 +- src/haz3lcore/prog/CachedStatics.re | 2 +- src/haz3lcore/prog/Interface.re | 11 +- src/haz3lcore/statics/Info.re | 5 +- src/haz3lcore/statics/MakeTerm.re | 11 +- src/haz3lcore/statics/Statics.re | 6 +- src/haz3lcore/statics/Term.re | 24 +- src/haz3lcore/statics/TermBase.re | 227 +++++++++++-------- src/haz3lcore/zipper/Editor.re | 4 +- src/haz3lcore/zipper/EditorUtil.re | 4 +- src/haz3lschool/Exercise.re | 16 +- src/haz3lschool/SyntaxTest.re | 33 ++- src/haz3lweb/DebugConsole.re | 2 +- src/haz3lweb/view/ExplainThis.re | 6 +- src/haz3lweb/view/dhcode/DHCode.re | 2 +- src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 6 +- 33 files changed, 426 insertions(+), 270 deletions(-) diff --git a/src/haz3lcore/dynamics/Builtins.re b/src/haz3lcore/dynamics/Builtins.re index 4479989fd5..a16d0db583 100644 --- a/src/haz3lcore/dynamics/Builtins.re +++ b/src/haz3lcore/dynamics/Builtins.re @@ -1,4 +1,5 @@ open DHExp; +open Sexplib.Conv; /* Built-in functions for Hazel. @@ -8,28 +9,30 @@ open DHExp; See the existing ones for reference. */ - +[@deriving (show({with_path: false}), sexp)] +type foo = DHExp.t(list(Id.t)); [@deriving (show({with_path: false}), sexp)] type builtin = - | Const(Typ.t, DHExp.t) - | Fn(Typ.t, Typ.t, DHExp.t => DHExp.t); + | Const(Typ.t, foo) + | Fn(Typ.t, Typ.t, DHExp.t(list(Id.t)) => DHExp.t(list(Id.t))); [@deriving (show({with_path: false}), sexp)] type t = VarMap.t_(builtin); [@deriving (show({with_path: false}), sexp)] -type forms = VarMap.t_(DHExp.t => DHExp.t); +type forms = VarMap.t_(DHExp.t(list(Id.t)) => DHExp.t(list(Id.t))); -type result = Result.t(DHExp.t, EvaluatorError.t); +type result = Result.t(DHExp.t(list(Id.t)), EvaluatorError.t); -let const = (name: Var.t, typ: Typ.term, v: DHExp.t, builtins: t): t => +let const = + (name: Var.t, typ: Typ.term, v: DHExp.t(list(Id.t)), builtins: t): t => VarMap.extend(builtins, (name, Const(typ |> Typ.fresh, v))); let fn = ( name: Var.t, t1: Typ.term, t2: Typ.term, - impl: DHExp.t => DHExp.t, + impl: DHExp.t(list(Id.t)) => DHExp.t(list(Id.t)), builtins: t, ) : t => @@ -49,14 +52,18 @@ module Pervasives = { let max_int = DHExp.Int(Int.max_int) |> fresh; let min_int = DHExp.Int(Int.min_int) |> fresh; - let unary = (f: DHExp.t => result, d: DHExp.t) => { + let unary = (f: DHExp.t(list(Id.t)) => result, d: DHExp.t(list(Id.t))) => { switch (f(d)) { | Ok(r') => r' | Error(e) => EvaluatorError.Exception(e) |> raise }; }; - let binary = (f: (DHExp.t, DHExp.t) => result, d: DHExp.t) => { + let binary = + ( + f: (DHExp.t(list(Id.t)), DHExp.t(list(Id.t))) => result, + d: DHExp.t(list(Id.t)), + ) => { switch (term_of(d)) { | Tuple([d1, d2]) => switch (f(d1, d2)) { @@ -67,7 +74,17 @@ module Pervasives = { }; }; - let ternary = (f: (DHExp.t, DHExp.t, DHExp.t) => result, d: DHExp.t) => { + let ternary = + ( + f: + ( + DHExp.t(list(Id.t)), + DHExp.t(list(Id.t)), + DHExp.t(list(Id.t)) + ) => + result, + d: DHExp.t(list(Id.t)), + ) => { switch (term_of(d)) { | Tuple([d1, d2, d3]) => switch (f(d1, d2, d3)) { @@ -173,7 +190,11 @@ module Pervasives = { let atan = float_op(atan); let of_string = - (convert: string => option('a), wrap: 'a => DHExp.t, name: string) => + ( + convert: string => option('a), + wrap: 'a => DHExp.t(list(Id.t)), + name: string, + ) => unary(d => switch (term_of(d)) { | String(s) => @@ -245,7 +266,7 @@ module Pervasives = { } ); - let string_of: DHExp.t => option(string) = + let string_of: DHExp.t(list(Id.t)) => option(string) = d => switch (term_of(d)) { | String(s) => Some(s) diff --git a/src/haz3lcore/dynamics/Casts.re b/src/haz3lcore/dynamics/Casts.re index 170d057e76..566c966cba 100644 --- a/src/haz3lcore/dynamics/Casts.re +++ b/src/haz3lcore/dynamics/Casts.re @@ -90,7 +90,9 @@ let rec ground_cases_of = (ty: Typ.t): ground_cases => { /* 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) => { +let rec transition = + (~recursive=false, d: DHExp.t(list(Id.t))) + : option(DHExp.t(list(Id.t))) => { switch (DHExp.term_of(d)) { | Cast(d1, t1, t2) => let d1 = @@ -168,7 +170,8 @@ let rec transition = (~recursive=false, d: DHExp.t): option(DHExp.t) => { }; }; -let rec transition_multiple = (d: DHExp.t): DHExp.t => { +let rec transition_multiple = + (d: DHExp.t(list(Id.t))): DHExp.t(list(Id.t)) => { switch (transition(~recursive=true, d)) { | Some(d'') => transition_multiple(d'') | None => d @@ -181,7 +184,7 @@ 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) => { + let rec unwrap_casts = (p: DHPat.t): (DHPat.t, DHExp.t(list(Id.t))) => { switch (DHPat.term_of(p)) { | Cast(p1, t1, t2) => let (p1, d1) = unwrap_casts(p1); @@ -193,7 +196,7 @@ let pattern_fixup = (p: DHPat.t): DHPat.t => { | _ => (p, hole) }; }; - let rec rewrap_casts = ((p: DHPat.t, d: DHExp.t)): DHPat.t => { + let rec rewrap_casts = ((p: DHPat.t, d: DHExp.t(list(Id.t)))): DHPat.t => { switch (DHExp.term_of(d)) { | EmptyHole => p | Cast(d1, t1, t2) => diff --git a/src/haz3lcore/dynamics/DHExp.re b/src/haz3lcore/dynamics/DHExp.re index f7651ba963..e1834ded7e 100644 --- a/src/haz3lcore/dynamics/DHExp.re +++ b/src/haz3lcore/dynamics/DHExp.re @@ -7,10 +7,10 @@ include Exp; -let term_of: t => term = IdTagged.term_of; -let fast_copy: (Id.t, t) => t = IdTagged.fast_copy; +let term_of: t(list(Id.t)) => term(list(Id.t)) = IdTagged.term_of; +let fast_copy: (Id.t, t(list(Id.t))) => t(list(Id.t)) = IdTagged.fast_copy; -let mk = (ids, term): t => { +let mk = (ids, term): t(list(Id.t)) => { {ids, copied: true, term}; }; @@ -95,7 +95,7 @@ let assign_name_if_none = (t, name) => { }; }; -let ty_subst = (s: Typ.t, tpat: TPat.t, exp: t): t => { +let ty_subst = (s: Typ.t, tpat: TPat.t, exp: t(list(Id.t))): t(list(Id.t)) => { switch (TPat.tyvar_of_utpat(tpat)) { | None => exp | Some(x) => diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index c1f3aa12d7..482bc71ff9 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -8,17 +8,18 @@ exception MissingTypeInfo; module Elaboration = { [@deriving (show({with_path: false}), sexp, yojson)] - type t = {d: DHExp.t}; + type t = {d: DHExp.t(list(Id.t))}; }; module ElaborationResult = { [@deriving sexp] type t = - | Elaborates(DHExp.t, Typ.t, Delta.t) + | Elaborates(DHExp.t(list(Id.t)), Typ.t, Delta.t) | DoesNotElaborate; }; -let fresh_cast = (d: DHExp.t, t1: Typ.t, t2: Typ.t): DHExp.t => { +let fresh_cast = + (d: DHExp.t(list(Id.t)), t1: Typ.t, t2: Typ.t): DHExp.t(list(Id.t)) => { Typ.eq(t1, t2) ? d : { @@ -47,7 +48,8 @@ let fresh_pat_cast = (p: DHPat.t, t1: Typ.t, t2: Typ.t): DHPat.t => { }; }; -let elaborated_type = (m: Statics.Map.t, uexp: UExp.t): (Typ.t, Ctx.t, 'a) => { +let elaborated_type = + (m: Statics.Map.t, uexp: UExp.t(list(Id.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, _})) => ( @@ -205,7 +207,9 @@ let rec elaborate_pattern = [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 rec elaborate = + (m: Statics.Map.t, uexp: UExp.t(list(Id.t))) + : (DHExp.t(list(Id.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); @@ -285,7 +289,8 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { |> Option.value(~default=Typ.temp(Typ.Unknown(Internal))), ) | Let(p, def, body) => - let add_name: (option(string), DHExp.t) => DHExp.t = ( + let add_name: + (option(string), DHExp.t(list(Id.t))) => DHExp.t(list(Id.t)) = ( (name, exp) => { let (term, rewrap) = DHExp.unwrap(exp); switch (term) { @@ -568,7 +573,8 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { 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 => +let uexp_elab = + (m: Statics.Map.t, uexp: UExp.t(list(Id.t))): ElaborationResult.t => switch (elaborate(m, uexp)) { | exception MissingTypeInfo => DoesNotElaborate | (d, ty) => Elaborates(d, ty, Delta.empty) diff --git a/src/haz3lcore/dynamics/EvalCtx.re b/src/haz3lcore/dynamics/EvalCtx.re index bed931c8d3..23227822f9 100644 --- a/src/haz3lcore/dynamics/EvalCtx.re +++ b/src/haz3lcore/dynamics/EvalCtx.re @@ -4,40 +4,47 @@ open Util; type term = | Closure([@show.opaque] ClosureEnvironment.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) + | Seq1(t, DHExp.t(list(Id.t))) + | Seq2(DHExp.t(list(Id.t)), t) + | Let1(Pat.t, t, DHExp.t(list(Id.t))) + | Let2(Pat.t, DHExp.t(list(Id.t)), t) | Fun(Pat.t, t, option(ClosureEnvironment.t), option(Var.t)) | FixF(Pat.t, t, option(ClosureEnvironment.t)) | TypAp(t, Typ.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) + | Ap1(Operators.ap_direction, t, DHExp.t(list(Id.t))) + | Ap2(Operators.ap_direction, DHExp.t(list(Id.t)), t) + | DeferredAp1(t, list(DHExp.t(list(Id.t)))) + | DeferredAp2( + DHExp.t(list(Id.t)), + t, + (list(DHExp.t(list(Id.t))), list(DHExp.t(list(Id.t)))), + ) + | If1(t, DHExp.t(list(Id.t)), DHExp.t(list(Id.t))) + | If2(DHExp.t(list(Id.t)), t, DHExp.t(list(Id.t))) + | If3(DHExp.t(list(Id.t)), DHExp.t(list(Id.t)), t) | UnOp(Operators.op_un, t) - | BinOp1(Operators.op_bin, t, DHExp.t) - | BinOp2(Operators.op_bin, DHExp.t, t) - | Tuple(t, (list(DHExp.t), list(DHExp.t))) + | BinOp1(Operators.op_bin, t, DHExp.t(list(Id.t))) + | BinOp2(Operators.op_bin, DHExp.t(list(Id.t)), t) + | Tuple(t, (list(DHExp.t(list(Id.t))), list(DHExp.t(list(Id.t))))) | Test(t) - | ListLit(t, (list(DHExp.t), list(DHExp.t))) + | ListLit(t, (list(DHExp.t(list(Id.t))), list(DHExp.t(list(Id.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) + | Cons1(t, DHExp.t(list(Id.t))) + | Cons2(DHExp.t(list(Id.t)), t) + | ListConcat1(t, DHExp.t(list(Id.t))) + | ListConcat2(DHExp.t(list(Id.t)), t) | Cast(t, Typ.t, Typ.t) | FailedCast(t, Typ.t, Typ.t) | DynamicErrorHole(t, InvalidOperationError.t) - | MatchScrut(t, list((UPat.t, DHExp.t))) + | MatchScrut(t, list((UPat.t, DHExp.t(list(Id.t))))) | MatchRule( - DHExp.t, + DHExp.t(list(Id.t)), UPat.t, t, - (list((UPat.t, DHExp.t)), list((UPat.t, DHExp.t))), + ( + list((UPat.t, DHExp.t(list(Id.t)))), + list((UPat.t, DHExp.t(list(Id.t)))), + ), ) and t = | Mark @@ -46,7 +53,7 @@ and t = ids: list(Id.t), }); -let rec compose = (ctx: t, d: DHExp.t): DHExp.t => { +let rec compose = (ctx: t, d: DHExp.t(list(Id.t))): DHExp.t(list(Id.t)) => { switch (ctx) { | Mark => d | Term({term, ids}) => diff --git a/src/haz3lcore/dynamics/Evaluator.re b/src/haz3lcore/dynamics/Evaluator.re index fb877accd7..4407ef3285 100644 --- a/src/haz3lcore/dynamics/Evaluator.re +++ b/src/haz3lcore/dynamics/Evaluator.re @@ -1,10 +1,12 @@ open Transition; +open Sexplib.Conv; +open Ppx_yojson_conv_lib.Yojson_conv; module Result = { [@deriving (show({with_path: false}), sexp, yojson)] type t = - | BoxedValue(DHExp.t) - | Indet(DHExp.t); + | BoxedValue(DHExp.t(list(Id.t))) + | Indet(DHExp.t(list(Id.t))); let unbox = fun @@ -29,14 +31,15 @@ module EvaluatorEVMode: { include EV_MODE with - type state = ref(EvaluatorState.t) and type result = (status, DHExp.t); + type state = ref(EvaluatorState.t) and + type result = (status, DHExp.t(list(Id.t))); } = { type status = | BoxedValue | Indet | Uneval; - type result = (status, DHExp.t); + type result = (status, DHExp.t(list(Id.t))); type reqstate = | BoxedReady diff --git a/src/haz3lcore/dynamics/EvaluatorError.re b/src/haz3lcore/dynamics/EvaluatorError.re index 1ae23a7e7a..f5a9311d3b 100644 --- a/src/haz3lcore/dynamics/EvaluatorError.re +++ b/src/haz3lcore/dynamics/EvaluatorError.re @@ -5,18 +5,18 @@ type t = | OutOfFuel | StepDoesNotMatch | 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) - | InvalidBoxedSumConstructor(DHExp.t) - | InvalidBoxedTuple(DHExp.t) + | CastBVHoleGround(DHExp.t(list(Id.t))) + | InvalidBoxedTypFun(DHExp.t(list(Id.t))) + | InvalidBoxedFun(DHExp.t(list(Id.t))) + | InvalidBoxedBoolLit(DHExp.t(list(Id.t))) + | InvalidBoxedIntLit(DHExp.t(list(Id.t))) + | InvalidBoxedFloatLit(DHExp.t(list(Id.t))) + | InvalidBoxedListLit(DHExp.t(list(Id.t))) + | InvalidBoxedStringLit(DHExp.t(list(Id.t))) + | InvalidBoxedSumConstructor(DHExp.t(list(Id.t))) + | InvalidBoxedTuple(DHExp.t(list(Id.t))) | InvalidBuiltin(string) - | BadBuiltinAp(string, list(DHExp.t)) + | BadBuiltinAp(string, list(DHExp.t(list(Id.t)))) | InvalidProjection(int); exception Exception(t); diff --git a/src/haz3lcore/dynamics/EvaluatorStep.re b/src/haz3lcore/dynamics/EvaluatorStep.re index f25f25603f..580877cc2d 100644 --- a/src/haz3lcore/dynamics/EvaluatorStep.re +++ b/src/haz3lcore/dynamics/EvaluatorStep.re @@ -1,11 +1,13 @@ open Transition; +open Sexplib.Conv; +open Ppx_yojson_conv_lib.Yojson_conv; [@deriving (show({with_path: false}), sexp, yojson)] type step = { - d: DHExp.t, // technically can be calculated from d_loc and ctx + d: DHExp.t(list(Id.t)), // technically can be calculated from d_loc and ctx state: EvaluatorState.t, - d_loc: DHExp.t, // the expression at the location given by ctx - d_loc': DHExp.t, + d_loc: DHExp.t(list(Id.t)), // the expression at the location given by ctx + d_loc': DHExp.t(list(Id.t)), ctx: EvalCtx.t, knd: step_kind, }; @@ -14,7 +16,7 @@ module EvalObj = { [@deriving (show({with_path: false}), sexp, yojson)] type t = { env: ClosureEnvironment.t, // technically can be calculated from ctx - d_loc: DHExp.t, + d_loc: DHExp.t(list(Id.t)), ctx: EvalCtx.t, knd: step_kind, }; @@ -129,7 +131,8 @@ module Decompose = { req_all_final'(cont, wr, [], ds); }; - let (let.): (requirements('a, DHExp.t), 'a => rule) => result = + let (let.): + (requirements('a, DHExp.t(list(Id.t))), 'a => rule) => result = (rq, rl) => switch (rq) { | (_, Result.Indet, _, _) => Result.Indet @@ -166,12 +169,13 @@ module TakeStep = { module TakeStepEVMode: { include EV_MODE with - type result = option(DHExp.t) and type state = ref(EvaluatorState.t); + type result = option(DHExp.t(list(Id.t))) and + type state = ref(EvaluatorState.t); } = { type state = ref(EvaluatorState.t); type requirement('a) = 'a; type requirements('a, 'b) = 'a; - type result = option(DHExp.t); + type result = option(DHExp.t(list(Id.t))); // Assume that everything is either value or final as required. let req_value = (_, _, d) => d; @@ -181,7 +185,8 @@ module TakeStep = { let req_final_or_value = (_, _, d) => (d, true); - let (let.) = (rq: requirements('a, DHExp.t), rl: 'a => rule) => + let (let.) = + (rq: requirements('a, DHExp.t(list(Id.t))), rl: 'a => rule) => switch (rl(rq)) { | Step({expr, state_update, _}) => state_update(); @@ -206,7 +211,7 @@ module TakeStep = { let take_step = TakeStep.take_step; -let decompose = (d: DHExp.t, es: EvaluatorState.t) => { +let decompose = (d: DHExp.t(list(Id.t)), es: EvaluatorState.t) => { let env = ClosureEnvironment.of_environment(Builtins.env_init); let rs = Decompose.decompose(ref(es), env, d); Decompose.Result.unbox(rs); @@ -217,7 +222,7 @@ let rec matches = env: ClosureEnvironment.t, flt: FilterEnvironment.t, ctx: EvalCtx.t, - exp: DHExp.t, + exp: DHExp.t(list(Id.t)), act: FilterAction.t, idx: int, ) diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index fc70d83756..df48180bdb 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -1,9 +1,9 @@ let rec matches_exp = ( ~denv: ClosureEnvironment.t, - d: DHExp.t, + d: DHExp.t(list(Id.t)), ~fenv: ClosureEnvironment.t, - f: DHExp.t, + f: DHExp.t(list(Id.t)), ) : bool => { let matches_exp = (~denv=denv, ~fenv=fenv, d, f) => @@ -286,10 +286,10 @@ and matches_fun = ( ~denv: ClosureEnvironment.t, dp: DHPat.t, - d: DHExp.t, + d: DHExp.t(list(Id.t)), ~fenv: ClosureEnvironment.t, fp: DHPat.t, - f: DHExp.t, + f: DHExp.t(list(Id.t)), ) => { matches_pat(dp, fp) && matches_exp( @@ -366,7 +366,7 @@ and matches_utpat = (d: TPat.t, f: TPat.t): bool => { let matches = ( ~env: ClosureEnvironment.t, - ~exp: DHExp.t, + ~exp: DHExp.t(list(Id.t)), ~flt: TermBase.StepperFilterKind.filter, ) : option(FilterAction.t) => @@ -377,7 +377,12 @@ let matches = }; let matches = - (~env: ClosureEnvironment.t, ~exp: DHExp.t, ~act: FilterAction.t, flt_env) + ( + ~env: ClosureEnvironment.t, + ~exp: DHExp.t(list(Id.t)), + ~act: FilterAction.t, + flt_env, + ) : (FilterAction.t, int) => { let len = List.length(flt_env); let rec matches' = (~env, ~exp, ~act, flt_env, idx) => { diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index 329ca1efd8..e29c1ff84e 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -11,7 +11,7 @@ let combine_result = (r1: match_result, r2: match_result): match_result => Matches(Environment.union(env1, env2)) }; -let rec matches = (dp: Pat.t, d: DHExp.t): match_result => +let rec matches = (dp: Pat.t, d: DHExp.t(list(Id.t))): match_result => switch (DHPat.term_of(dp)) { | Invalid(_) | EmptyHole diff --git a/src/haz3lcore/dynamics/Stepper.re b/src/haz3lcore/dynamics/Stepper.re index e922aacf52..c37bd2294c 100644 --- a/src/haz3lcore/dynamics/Stepper.re +++ b/src/haz3lcore/dynamics/Stepper.re @@ -12,7 +12,7 @@ type stepper_state = | StepTimeout(EvalObj.t); [@deriving (show({with_path: false}), sexp, yojson)] -type history = Aba.t((DHExp.t, EvaluatorState.t), step); +type history = Aba.t((DHExp.t(list(Id.t)), EvaluatorState.t), step); [@deriving (show({with_path: false}), sexp, yojson)] type t = { @@ -26,7 +26,7 @@ let rec matches = env: ClosureEnvironment.t, flt: FilterEnvironment.t, ctx: EvalCtx.t, - exp: DHExp.t, + exp: DHExp.t(list(Id.t)), act: FilterAction.t, idx: int, ) @@ -247,7 +247,7 @@ let rec evaluate_pending = (~settings, s: t) => { } ) |> DHExp.repair_ids; - let _ = print_endline(d_loc' |> DHExp.show); + let _ = print_endline(d_loc' |> [%derive.show: DHExp.t(list(Id.t))]); let d' = EvalCtx.compose(eo.ctx, d_loc'); let new_step = { d, @@ -351,7 +351,7 @@ let get_justification: step_kind => string = | UnOp(Meta(Unquote)) => failwith("INVALID STEP"); type step_info = { - d: DHExp.t, + d: DHExp.t(list(Id.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) @@ -376,7 +376,7 @@ let get_history = (~settings, stepper) => { ( ( chosen_step: option(step), - (d: DHExp.t, hidden_steps: list(step)), + (d: DHExp.t(list(Id.t)), hidden_steps: list(step)), previous_step: option(step), ), ) => { diff --git a/src/haz3lcore/dynamics/Substitution.re b/src/haz3lcore/dynamics/Substitution.re index 5d918e520b..7b781689f6 100644 --- a/src/haz3lcore/dynamics/Substitution.re +++ b/src/haz3lcore/dynamics/Substitution.re @@ -1,5 +1,7 @@ /* closed substitution [d1/x]d2 */ -let rec subst_var = (m, d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => { +let rec subst_var = + (m, d1: DHExp.t(list(Id.t)), x: Var.t, d2: DHExp.t(list(Id.t))) + : DHExp.t(list(Id.t)) => { let (term, rewrap) = DHExp.unwrap(d2); switch (term) { | Var(y) => @@ -130,14 +132,14 @@ let rec subst_var = (m, d1: DHExp.t, x: Var.t, d2: DHExp.t): DHExp.t => { } and subst_var_env = - (m, d1: DHExp.t, x: Var.t, env: ClosureEnvironment.t) + (m, d1: DHExp.t(list(Id.t)), x: Var.t, env: ClosureEnvironment.t) : ClosureEnvironment.t => { let id = env |> ClosureEnvironment.id_of; let map = env |> ClosureEnvironment.map_of |> Environment.foldo( - ((x', d': DHExp.t), map) => { + ((x', d': DHExp.t(list(Id.t))), map) => { let d' = switch (DHExp.term_of(d')) { /* Substitute each previously substituted binding into the @@ -162,15 +164,21 @@ and subst_var_env = } and subst_var_filter = - (m, d1: DHExp.t, x: Var.t, flt: TermBase.StepperFilterKind.t) + ( + m, + d1: DHExp.t(list(Id.t)), + x: Var.t, + flt: TermBase.StepperFilterKind.t, + ) : TermBase.StepperFilterKind.t => { flt |> TermBase.StepperFilterKind.map(subst_var(m, d1, x)); }; -let subst = (m, env: Environment.t, d: DHExp.t): DHExp.t => +let subst = + (m, env: Environment.t, d: DHExp.t(list(Id.t))): DHExp.t(list(Id.t)) => env |> Environment.foldo( - (xd: (Var.t, DHExp.t), d2) => { + (xd: (Var.t, DHExp.t(list(Id.t))), d2) => { let (x, d1) = xd; subst_var(m, d1, x, d2); }, diff --git a/src/haz3lcore/dynamics/Substitution.rei b/src/haz3lcore/dynamics/Substitution.rei index 49b1e2e92f..83fcbaf525 100644 --- a/src/haz3lcore/dynamics/Substitution.rei +++ b/src/haz3lcore/dynamics/Substitution.rei @@ -1,3 +1,7 @@ /* closed substitution [d1/x]d2 */ -let subst_var: (Statics.Map.t, DHExp.t, Var.t, DHExp.t) => DHExp.t; -let subst: (Statics.Map.t, Environment.t, DHExp.t) => DHExp.t; +let subst_var: + (Statics.Map.t, DHExp.t(list(Id.t)), Var.t, DHExp.t(list(Id.t))) => + DHExp.t(list(Id.t)); +let subst: + (Statics.Map.t, Environment.t, DHExp.t(list(Id.t))) => + DHExp.t(list(Id.t)); diff --git a/src/haz3lcore/dynamics/TestMap.re b/src/haz3lcore/dynamics/TestMap.re index 74a5f8f550..d24f509eaf 100644 --- a/src/haz3lcore/dynamics/TestMap.re +++ b/src/haz3lcore/dynamics/TestMap.re @@ -2,7 +2,7 @@ open Util; /* FIXME: Make more obvious names. */ [@deriving (show({with_path: false}), sexp, yojson)] -type instance_report = (DHExp.t, TestStatus.t); +type instance_report = (DHExp.t(list(Id.t)), TestStatus.t); let joint_status: list(instance_report) => TestStatus.t = reports => TestStatus.join_all(List.map(((_, x)) => x, reports)); diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index a54c9d18d8..e94bc6fd1b 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -85,7 +85,7 @@ let evaluate_extend_env = type rule = | Step({ - expr: DHExp.t, + expr: DHExp.t(list(Id.t)), state_update: unit => unit, kind: step_kind, is_value: bool, @@ -107,30 +107,50 @@ module type EV_MODE = { type requirements('a, 'b); let req_value: - (DHExp.t => result, EvalCtx.t => EvalCtx.t, DHExp.t) => - requirement(DHExp.t); + ( + DHExp.t(list(Id.t)) => result, + EvalCtx.t => EvalCtx.t, + DHExp.t(list(Id.t)) + ) => + requirement(DHExp.t(list(Id.t))); let req_all_value: ( - DHExp.t => result, - (EvalCtx.t, (list(DHExp.t), list(DHExp.t))) => EvalCtx.t, - list(DHExp.t) + DHExp.t(list(Id.t)) => result, + ( + EvalCtx.t, + (list(DHExp.t(list(Id.t))), list(DHExp.t(list(Id.t)))) + ) => + EvalCtx.t, + list(DHExp.t(list(Id.t))) ) => - requirement(list(DHExp.t)); + requirement(list(DHExp.t(list(Id.t)))); let req_final: - (DHExp.t => result, EvalCtx.t => EvalCtx.t, DHExp.t) => - requirement(DHExp.t); + ( + DHExp.t(list(Id.t)) => result, + EvalCtx.t => EvalCtx.t, + DHExp.t(list(Id.t)) + ) => + requirement(DHExp.t(list(Id.t))); let req_all_final: ( - DHExp.t => result, - (EvalCtx.t, (list(DHExp.t), list(DHExp.t))) => EvalCtx.t, - list(DHExp.t) + DHExp.t(list(Id.t)) => result, + ( + EvalCtx.t, + (list(DHExp.t(list(Id.t))), list(DHExp.t(list(Id.t)))) + ) => + EvalCtx.t, + list(DHExp.t(list(Id.t))) ) => - requirement(list(DHExp.t)); + requirement(list(DHExp.t(list(Id.t)))); let req_final_or_value: - (DHExp.t => result, EvalCtx.t => EvalCtx.t, DHExp.t) => - requirement((DHExp.t, bool)); + ( + DHExp.t(list(Id.t)) => result, + EvalCtx.t => EvalCtx.t, + DHExp.t(list(Id.t)) + ) => + requirement((DHExp.t(list(Id.t)), bool)); - let (let.): (requirements('a, DHExp.t), 'a => rule) => result; + let (let.): (requirements('a, DHExp.t(list(Id.t))), 'a => rule) => result; let (and.): (requirements('a, 'c => 'b), requirement('c)) => requirements(('a, 'c), 'b); @@ -399,14 +419,14 @@ module Transition = (EV: EV_MODE) => { List.map( fun | {term: Deferral(_), _} => true - | _ => false: Exp.t => bool, + | _ => false: Exp.t(list(Id.t)) => bool, d4s, ), ); let-unbox args = (Tuple(n_args), d2); let new_args = { let rec go = (deferred, args) => - switch ((deferred: list(Exp.t))) { + switch ((deferred: list(Exp.t(list(Id.t))))) { | [] => [] | [{term: Deferral(_), _}, ...deferred] => /* I can use List.hd and List.tl here because let-unbox ensure that @@ -425,8 +445,8 @@ module Transition = (EV: EV_MODE) => { | Cast(_) | FailedCast(_) => Indet | FixF(_) => - print_endline(Exp.show(d1)); - print_endline(Exp.show(d1')); + print_endline([%derive.show: Exp.t(list(Id.t))](d1)); + print_endline([%derive.show: Exp.t(list(Id.t))](d1')); print_endline("FIXF"); failwith("FixF in Ap"); | _ => diff --git a/src/haz3lcore/dynamics/TypeAssignment.re b/src/haz3lcore/dynamics/TypeAssignment.re index f4979d94bf..b90e6fc6c7 100644 --- a/src/haz3lcore/dynamics/TypeAssignment.re +++ b/src/haz3lcore/dynamics/TypeAssignment.re @@ -121,7 +121,8 @@ let rec env_extend_ctx = 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) => { +and typ_of_dhexp = + (ctx: Ctx.t, m: Statics.Map.t, dh: DHExp.t(list(Id.t))): option(Typ.t) => { switch (dh |> DHExp.term_of) { | Invalid(_) | MultiHole(_) @@ -316,7 +317,7 @@ and typ_of_dhexp = (ctx: Ctx.t, m: Statics.Map.t, dh: DHExp.t): option(Typ.t) => | Match(_, []) => Some(Unknown(Internal) |> Typ.temp) | Match(d_scrut, [rule, ...rules]) => let* ty' = typ_of_dhexp(ctx, m, d_scrut); - let rule_to_ty = ((dhpat, dhexp): (Pat.t, Exp.t)) => { + let rule_to_ty = ((dhpat, dhexp): (Pat.t, Exp.t(list(Id.t)))) => { let* ctx = dhpat_extend_ctx(dhpat, ty', ctx); typ_of_dhexp(ctx, m, dhexp); }; @@ -348,7 +349,8 @@ and typ_of_dhexp = (ctx: Ctx.t, m: Statics.Map.t, dh: DHExp.t): option(Typ.t) => }; }; -let property_test = (uexp_typ: Typ.t, dhexp: DHExp.t, m: Statics.Map.t): bool => { +let property_test = + (uexp_typ: Typ.t, dhexp: DHExp.t(list(Id.t)), m: Statics.Map.t): bool => { let dhexp_typ = typ_of_dhexp(Builtins.ctx_init, m, dhexp); switch (dhexp_typ) { diff --git a/src/haz3lcore/dynamics/Unboxing.re b/src/haz3lcore/dynamics/Unboxing.re index 400620026c..d2625d22e5 100644 --- a/src/haz3lcore/dynamics/Unboxing.re +++ b/src/haz3lcore/dynamics/Unboxing.re @@ -20,11 +20,11 @@ type unbox_request('a) = | 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)) + | Tuple(int): unbox_request(list(DHExp.t(list(Id.t)))) + | List: unbox_request(list(DHExp.t(list(Id.t)))) + | Cons: unbox_request((DHExp.t(list(Id.t)), DHExp.t(list(Id.t)))) | SumNoArg(string): unbox_request(unit) - | SumWithArg(string): unbox_request(DHExp.t); + | SumWithArg(string): unbox_request(DHExp.t(list(Id.t))); type unboxed('a) = | DoesNotMatch @@ -45,7 +45,8 @@ let fixup_cast = Casts.transition_multiple; 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) = +let rec unbox: + type a. (unbox_request(a), DHExp.t(list(Id.t))) => unboxed(a) = (request, expr) => { switch (request, DHExp.term_of(expr)) { /* Remove parentheses from casts */ diff --git a/src/haz3lcore/lang/term/IdTagged.re b/src/haz3lcore/lang/term/IdTagged.re index 084a252de4..14cf0581f6 100644 --- a/src/haz3lcore/lang/term/IdTagged.re +++ b/src/haz3lcore/lang/term/IdTagged.re @@ -1,9 +1,9 @@ open Util; [@deriving (show({with_path: false}), sexp, yojson)] -type t('a) = { +type t('a, 'id) = { [@show.opaque] - ids: list(Id.t), + ids: 'id, [@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 diff --git a/src/haz3lcore/prog/CachedStatics.re b/src/haz3lcore/prog/CachedStatics.re index f2bc13d113..9f5898ec1d 100644 --- a/src/haz3lcore/prog/CachedStatics.re +++ b/src/haz3lcore/prog/CachedStatics.re @@ -2,7 +2,7 @@ open Util; [@deriving (show({with_path: false}), sexp, yojson)] type statics = { - term: UExp.t, + term: UExp.t(list(Id.t)), info_map: Statics.Map.t, error_ids: list(Id.t), }; diff --git a/src/haz3lcore/prog/Interface.re b/src/haz3lcore/prog/Interface.re index 3249b1aef2..c97f2b645c 100644 --- a/src/haz3lcore/prog/Interface.re +++ b/src/haz3lcore/prog/Interface.re @@ -1,10 +1,11 @@ -let dh_err = (error: string): DHExp.t => Var(error) |> DHExp.fresh; +let dh_err = (error: string): DHExp.t(list(Id.t)) => + Var(error) |> DHExp.fresh; let elaborate = Core.Memo.general(~cache_size_bound=1000, Elaborator.uexp_elab); exception DoesNotElaborate; -let elaborate = (~settings: CoreSettings.t, map, term): DHExp.t => +let elaborate = (~settings: CoreSettings.t, map, term): DHExp.t(list(Id.t)) => switch () { | _ when !settings.statics => dh_err("Statics disabled") | _ when !settings.dynamics && !settings.elaborate => @@ -17,7 +18,11 @@ let elaborate = (~settings: CoreSettings.t, map, term): DHExp.t => }; let evaluate = - (~settings: CoreSettings.t, ~env=Builtins.env_init, elab: DHExp.t) + ( + ~settings: CoreSettings.t, + ~env=Builtins.env_init, + elab: DHExp.t(list(Id.t)), + ) : ProgramResult.t => switch () { | _ when !settings.dynamics => Off({d: elab}) diff --git a/src/haz3lcore/statics/Info.re b/src/haz3lcore/statics/Info.re index 8aaaeaae3d..6a186461ee 100644 --- a/src/haz3lcore/statics/Info.re +++ b/src/haz3lcore/statics/Info.re @@ -192,7 +192,7 @@ type status_tpat = [@deriving (show({with_path: false}), sexp, yojson)] type exp = { - term: UExp.t, /* The term under consideration */ + term: UExp.t(list(Id.t)), /* The term under consideration */ ancestors, /* Ascending list of containing term ids */ ctx: Ctx.t, /* Typing context for the term */ mode: Mode.t, /* Parental type expectations */ @@ -610,7 +610,8 @@ let fixed_typ_exp = (ctx, mode: Mode.t, self: Self.exp): Typ.t => /* Add derivable attributes for expression terms */ let derived_exp = - (~uexp: UExp.t, ~ctx, ~mode, ~ancestors, ~self, ~co_ctx): exp => { + (~uexp: UExp.t(list(Id.t)), ~ctx, ~mode, ~ancestors, ~self, ~co_ctx) + : exp => { let cls = Cls.Exp(UExp.cls_of_term(uexp.term)); let status = status_exp(ctx, mode, self); let ty = fixed_typ_exp(ctx, mode, self); diff --git a/src/haz3lcore/statics/MakeTerm.re b/src/haz3lcore/statics/MakeTerm.re index 75e3a90a4e..4006395963 100644 --- a/src/haz3lcore/statics/MakeTerm.re +++ b/src/haz3lcore/statics/MakeTerm.re @@ -36,7 +36,7 @@ type unsorted = | Bin(t, tiles, t); type t = { - term: UExp.t, + term: UExp.t(list(Id.t)), terms: TermMap.t, projectors: Id.Map.t(Piece.projector(Id.t)), }; @@ -58,7 +58,8 @@ let is_typ_bsum = is_nary(Any.is_typ, "+"); let is_grout = tiles => Aba.get_as(tiles) |> List.map(snd) |> List.for_all((==)(([" "], []))); -let is_rules = ((ts, kids): tiles): option(Aba.t(UPat.t, UExp.t)) => { +let is_rules = + ((ts, kids): tiles): option(Aba.t(UPat.t, UExp.t(list(Id.t)))) => { open OptUtil.Syntax; let+ ps = ts @@ -170,8 +171,8 @@ and exp = unsorted => { let ids = ids(unsorted) @ inner_ids; return(e => Exp(e), ids, {ids, copied: false, term}); } -and exp_term: unsorted => (UExp.term, list(Id.t)) = { - let ret = (tm: UExp.term) => (tm, []); +and exp_term: unsorted => (UExp.term(list(Id.t)), list(Id.t)) = { + let ret = (tm: UExp.term(list(Id.t))) => (tm, []); let hole = unsorted => UExp.hole(kids_of_unsorted(unsorted)); fun | Op(tiles) as tm => @@ -250,7 +251,7 @@ and exp_term: unsorted => (UExp.term, list(Id.t)) = { ), ) | (["(", ")"], [Exp(arg)]) => - let use_deferral = (arg: UExp.t): UExp.t => { + let use_deferral = (arg: UExp.t(list(Id.t))): UExp.t(list(Id.t)) => { ids: arg.ids, copied: false, term: Deferral(InAp), diff --git a/src/haz3lcore/statics/Statics.re b/src/haz3lcore/statics/Statics.re index 2bb472edf9..67f0bad705 100644 --- a/src/haz3lcore/statics/Statics.re +++ b/src/haz3lcore/statics/Statics.re @@ -172,7 +172,7 @@ and uexp_to_info_map = ~mode=Mode.Syn, ~is_in_filter=false, ~ancestors, - {ids, copied: _, term} as uexp: UExp.t, + {ids, copied: _, term} as uexp: UExp.t(list(Id.t)), m: Map.t, ) : (Info.exp, Map.t) => { @@ -195,7 +195,7 @@ and uexp_to_info_map = ~mode=Mode.Syn, ~is_in_filter=is_in_filter, ~ancestors=ancestors, - uexp: UExp.t, + uexp: UExp.t(list(Id.t)), m: Map.t, ) => { uexp_to_info_map(~ctx, ~mode, ~is_in_filter, ~ancestors, uexp, m); @@ -271,7 +271,7 @@ and uexp_to_info_map = 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 = { + let e: UExp.t(list(Id.t)) = { ids: e.ids, copied: false, term: diff --git a/src/haz3lcore/statics/Term.re b/src/haz3lcore/statics/Term.re index 0493150865..fab423acd4 100644 --- a/src/haz3lcore/statics/Term.re +++ b/src/haz3lcore/statics/Term.re @@ -318,17 +318,19 @@ module Exp = { | Cast | ListConcat; - let hole = (tms: list(TermBase.Any.t)): term => + let hole = (tms: list(TermBase.Any.t)): term(list(Id.t)) => switch (tms) { | [] => EmptyHole | [_, ..._] => MultiHole(tms) }; - let rep_id: t => Id.t = IdTagged.rep_id; - let fresh: term => t = IdTagged.fresh; - let unwrap: t => (term, term => t) = IdTagged.unwrap; + let rep_id: t(list(Id.t)) => Id.t = IdTagged.rep_id; + let fresh: term(list(Id.t)) => t(list(Id.t)) = IdTagged.fresh; + let unwrap: + t(list(Id.t)) => + (term(list(Id.t)), term(list(Id.t)) => t(list(Id.t))) = IdTagged.unwrap; - let cls_of_term: term => cls = + let cls_of_term: term(list(Id.t)) => cls = fun | Invalid(_) => Invalid | EmptyHole => EmptyHole @@ -411,7 +413,7 @@ module Exp = { // 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) => { + let rec is_fun = (e: t(list(Id.t))) => { switch (e.term) { | Parens(e) => is_fun(e) | Cast(e, _, _) => is_fun(e) @@ -452,7 +454,7 @@ module Exp = { }; }; - let rec is_tuple_of_functions = (e: t) => + let rec is_tuple_of_functions = (e: t(list(Id.t))) => is_fun(e) || ( switch (e.term) { @@ -495,20 +497,20 @@ module Exp = { } ); - let ctr_name = (e: t): option(Constructor.t) => + let ctr_name = (e: t(list(Id.t))): option(Constructor.t) => switch (e.term) { | Constructor(name, _) => Some(name) | _ => None }; - let is_deferral = (e: t) => { + let is_deferral = (e: t(list(Id.t))) => { switch (e.term) { | Deferral(_) => true | _ => false }; }; - let rec get_num_of_functions = (e: t) => + let rec get_num_of_functions = (e: t(list(Id.t))) => if (is_fun(e)) { Some(1); } else { @@ -584,7 +586,7 @@ module Rul = { module Any = { include TermBase.Any; - let is_exp: t => option(TermBase.Exp.t) = + let is_exp: t => option(TermBase.Exp.t(list(Id.t))) = fun | Exp(e) => Some(e) | _ => None; diff --git a/src/haz3lcore/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index f0585955c6..b5c58f0db2 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -19,7 +19,7 @@ let stop = (_, x) => x; map_term: ( - ~f_exp: (Exp.t => Exp.t, Exp.t) => Exp.t=?, + ~f_exp: (Exp.t('id) => Exp.t('id) , Exp.t('id) ) => Exp.t('id) =?, ~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=?, @@ -45,7 +45,7 @@ let stop = (_, x) => x; module rec Any: { [@deriving (show({with_path: false}), sexp, yojson)] type t = - | Exp(Exp.t) + | Exp(Exp.t(list(Id.t))) | Pat(Pat.t) | Typ(Typ.t) | TPat(TPat.t) @@ -55,7 +55,12 @@ module rec Any: { let map_term: ( - ~f_exp: (Exp.t => Exp.t, Exp.t) => Exp.t=?, + ~f_exp: ( + Exp.t(list(Id.t)) => Exp.t(list(Id.t)), + Exp.t(list(Id.t)) + ) => + Exp.t(list(Id.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=?, @@ -69,7 +74,7 @@ module rec Any: { } = { [@deriving (show({with_path: false}), sexp, yojson)] type t = - | Exp(Exp.t) + | Exp(Exp.t(list(Id.t))) | Pat(Pat.t) | Typ(Typ.t) | TPat(TPat.t) @@ -132,66 +137,71 @@ and Exp: { | OutsideAp; [@deriving (show({with_path: false}), sexp, yojson)] - type term = + type term('id) = | Invalid(string) | EmptyHole | MultiHole(list(Any.t)) - | DynamicErrorHole(t, InvalidOperationError.t) - | FailedCast(t, Typ.t, Typ.t) + | DynamicErrorHole(t('id), InvalidOperationError.t) + | FailedCast(t('id), Typ.t, Typ.t) | Deferral(deferral_position) | Undefined | Bool(bool) | Int(int) | Float(float) | String(string) - | ListLit(list(t)) + | ListLit(list(t('id))) | Constructor(string, Typ.t) // Typ.t field is only meaningful in dynamic expressions | Fun( Pat.t, - t, + t('id), [@show.opaque] option(ClosureEnvironment.t), option(Var.t), ) - | TypFun(TPat.t, t, option(Var.t)) - | Tuple(list(t)) + | TypFun(TPat.t, t('id), option(Var.t)) + | Tuple(list(t('id))) | Var(Var.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)) - | If(t, t, t) - | Seq(t, t) - | Test(t) - | Filter(StepperFilterKind.t, t) - | Closure([@show.opaque] ClosureEnvironment.t, t) - | Parens(t) // ( - | Cons(t, t) - | ListConcat(t, t) - | UnOp(Operators.op_un, t) - | BinOp(Operators.op_bin, t, t) + | Let(Pat.t, t('id), t('id)) + | FixF(Pat.t, t('id), option(ClosureEnvironment.t)) + | TyAlias(TPat.t, Typ.t, t('id)) + | Ap(Operators.ap_direction, t('id), t('id)) + | TypAp(t('id), Typ.t) + | DeferredAp(t('id), list(t('id))) + | If(t('id), t('id), t('id)) + | Seq(t('id), t('id)) + | Test(t('id)) + | Filter(StepperFilterKind.t, t('id)) + | Closure([@show.opaque] ClosureEnvironment.t, t('id)) + | Parens(t('id)) // ( + | Cons(t('id), t('id)) + | ListConcat(t('id), t('id)) + | UnOp(Operators.op_un, t('id)) + | BinOp(Operators.op_bin, t('id), t('id)) | BuiltinFun(string) - | Match(t, list((Pat.t, t))) + | Match(t('id), list((Pat.t, t('id)))) /* 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); + | Cast(t('id), Typ.t, Typ.t) // first Typ.t field is only meaningful in dynamic expressions + and t('id) = IdTagged.t(term('id), 'id); let map_term: ( - ~f_exp: (Exp.t => Exp.t, Exp.t) => Exp.t=?, + ~f_exp: ( + Exp.t(list(Id.t)) => Exp.t(list(Id.t)), + Exp.t(list(Id.t)) + ) => + Exp.t(list(Id.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(list(Id.t)) ) => - t; + t(list(Id.t)); - let fast_equal: (t, t) => bool; + let fast_equal: (t('id), t('id)) => bool; } = { [@deriving (show({with_path: false}), sexp, yojson)] type deferral_position = @@ -199,49 +209,52 @@ and Exp: { | OutsideAp; [@deriving (show({with_path: false}), sexp, yojson)] - type term = + type term('id) = | Invalid(string) | EmptyHole | MultiHole(list(Any.t)) - | DynamicErrorHole(t, InvalidOperationError.t) - | FailedCast(t, Typ.t, Typ.t) + | DynamicErrorHole(t('id), InvalidOperationError.t) + | FailedCast(t('id), Typ.t, Typ.t) | Deferral(deferral_position) | Undefined | Bool(bool) | Int(int) | Float(float) | String(string) - | ListLit(list(t)) - | Constructor(string, Typ.t) + | ListLit(list(t('id))) + | Constructor(string, Typ.t) // Typ.t field is only meaningful in dynamic expressions | Fun( Pat.t, - t, + t('id), [@show.opaque] option(ClosureEnvironment.t), option(Var.t), ) - | TypFun(TPat.t, t, option(string)) - | Tuple(list(t)) + | TypFun(TPat.t, t('id), option(Var.t)) + | Tuple(list(t('id))) | Var(Var.t) - | Let(Pat.t, t, t) - | FixF(Pat.t, t, [@show.opaque] option(ClosureEnvironment.t)) - | TyAlias(TPat.t, Typ.t, t) - | Ap(Operators.ap_direction, t, t) // note: function is always first then argument; even in pipe mode - | TypAp(t, Typ.t) - | DeferredAp(t, list(t)) - | If(t, t, t) - | Seq(t, t) - | Test(t) - | Filter(StepperFilterKind.t, t) - | Closure([@show.opaque] ClosureEnvironment.t, t) - | Parens(t) - | Cons(t, t) - | ListConcat(t, t) - | UnOp(Operators.op_un, t) - | BinOp(Operators.op_bin, t, t) - | BuiltinFun(string) /// Doesn't currently have a distinguishable syntax - | Match(t, list((Pat.t, t))) - | Cast(t, Typ.t, Typ.t) - and t = IdTagged.t(term); + | Let(Pat.t, t('id), t('id)) + | FixF(Pat.t, t('id), option(ClosureEnvironment.t)) + | TyAlias(TPat.t, Typ.t, t('id)) + | Ap(Operators.ap_direction, t('id), t('id)) + | TypAp(t('id), Typ.t) + | DeferredAp(t('id), list(t('id))) + | If(t('id), t('id), t('id)) + | Seq(t('id), t('id)) + | Test(t('id)) + | Filter(StepperFilterKind.t, t('id)) + | Closure([@show.opaque] ClosureEnvironment.t, t('id)) + | Parens(t('id)) // ( + | Cons(t('id), t('id)) + | ListConcat(t('id), t('id)) + | UnOp(Operators.op_un, t('id)) + | BinOp(Operators.op_bin, t('id), t('id)) + | BuiltinFun(string) + | Match(t('id), list((Pat.t, t('id)))) + /* 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('id), Typ.t, Typ.t) // first Typ.t field is only meaningful in dynamic expressions + and t('id) = IdTagged.t(term('id), 'id); let map_term = ( @@ -272,7 +285,7 @@ and Exp: { ~f_rul, ~f_any, ); - let rec_call = ({term, _} as exp: t) => { + let rec_call = ({term, _} as exp: t(list(Id.t))) => { ...exp, term: switch (term) { @@ -287,7 +300,9 @@ and Exp: { | Var(_) | Undefined => term | MultiHole(things) => MultiHole(List.map(any_map_term, things)) - | DynamicErrorHole(e, err) => DynamicErrorHole(exp_map_term(e), err) + | DynamicErrorHole(e, err: InvalidOperationError.t) => + let foo = exp_map_term(e); + DynamicErrorHole(foo, 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) => @@ -465,11 +480,16 @@ and Pat: { | Parens(t) | Ap(t, t) | Cast(t, Typ.t, Typ.t) // The second Typ.t field is only meaningful in dynamic patterns - and t = IdTagged.t(term); + and t = IdTagged.t(term, list(Id.t)); let map_term: ( - ~f_exp: (Exp.t => Exp.t, Exp.t) => Exp.t=?, + ~f_exp: ( + Exp.t(list(Id.t)) => Exp.t(list(Id.t)), + Exp.t(list(Id.t)) + ) => + Exp.t(list(Id.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=?, @@ -499,7 +519,7 @@ and Pat: { | Parens(t) | Ap(t, t) | Cast(t, Typ.t, Typ.t) // The second one is hidden from the user - and t = IdTagged.t(term); + and t = IdTagged.t(term, list(Id.t)); let map_term = ( @@ -619,13 +639,18 @@ and Typ: { | Ap(t, t) | Rec(TPat.t, t) | Forall(TPat.t, t) - and t = IdTagged.t(term); + and t = IdTagged.t(term, list(Id.t)); type sum_map = ConstructorMap.t(t); let map_term: ( - ~f_exp: (Exp.t => Exp.t, Exp.t) => Exp.t=?, + ~f_exp: ( + Exp.t(list(Id.t)) => Exp.t(list(Id.t)), + Exp.t(list(Id.t)) + ) => + Exp.t(list(Id.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=?, @@ -671,7 +696,7 @@ and Typ: { | Ap(t, t) | Rec(TPat.t, t) | Forall(TPat.t, t) - and t = IdTagged.t(term); + and t = IdTagged.t(term, list(Id.t)); type sum_map = ConstructorMap.t(t); @@ -816,11 +841,16 @@ and TPat: { | EmptyHole | MultiHole(list(Any.t)) | Var(string) - and t = IdTagged.t(term); + and t = IdTagged.t(term, list(Id.t)); let map_term: ( - ~f_exp: (Exp.t => Exp.t, Exp.t) => Exp.t=?, + ~f_exp: ( + Exp.t(list(Id.t)) => Exp.t(list(Id.t)), + Exp.t(list(Id.t)) + ) => + Exp.t(list(Id.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=?, @@ -840,7 +870,7 @@ and TPat: { | EmptyHole | MultiHole(list(Any.t)) | Var(string) - and t = IdTagged.t(term); + and t = IdTagged.t(term, list(Id.t)); let map_term = ( @@ -892,12 +922,17 @@ and Rul: { type term = | Invalid(string) | Hole(list(Any.t)) - | Rules(Exp.t, list((Pat.t, Exp.t))) - and t = IdTagged.t(term); + | Rules(Exp.t(list(Id.t)), list((Pat.t, Exp.t(list(Id.t))))) + and t = IdTagged.t(term, list(Id.t)); let map_term: ( - ~f_exp: (Exp.t => Exp.t, Exp.t) => Exp.t=?, + ~f_exp: ( + Exp.t(list(Id.t)) => Exp.t(list(Id.t)), + Exp.t(list(Id.t)) + ) => + Exp.t(list(Id.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=?, @@ -913,8 +948,8 @@ and Rul: { type term = | Invalid(string) | Hole(list(Any.t)) - | Rules(Exp.t, list((Pat.t, Exp.t))) - and t = IdTagged.t(term); + | Rules(Exp.t(list(Id.t)), list((Pat.t, Exp.t(list(Id.t))))) + and t = IdTagged.t(term, list(Id.t)); let map_term = ( @@ -978,12 +1013,12 @@ and Environment: { type t_('a) = VarBstMap.Ordered.t_('a); [@deriving (show({with_path: false}), sexp, yojson)] - type t = t_(Exp.t); + type t = t_(Exp.t(list(Id.t))); } = { include VarBstMap.Ordered; [@deriving (show({with_path: false}), sexp, yojson)] - type t = t_(Exp.t); + type t = t_(Exp.t(list(Id.t))); } and ClosureEnvironment: { @@ -995,7 +1030,7 @@ and ClosureEnvironment: { let id_of: t => Id.t; let map_of: t => Environment.t; - let to_list: t => list((Var.t, Exp.t)); + let to_list: t => list((Var.t, Exp.t(list(Id.t)))); let of_environment: Environment.t => t; @@ -1005,19 +1040,20 @@ and ClosureEnvironment: { let is_empty: t => bool; let length: t => int; - let lookup: (t, Var.t) => option(Exp.t); + let lookup: (t, Var.t) => option(Exp.t(list(Id.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 extend: (t, (Var.t, Exp.t(list(Id.t)))) => t; + let extend_keep_id: (t, (Var.t, Exp.t(list(Id.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 map: (((Var.t, Exp.t(list(Id.t)))) => Exp.t(list(Id.t)), t) => t; + let map_keep_id: + (((Var.t, Exp.t(list(Id.t)))) => Exp.t(list(Id.t)), t) => t; + let filter: (((Var.t, Exp.t(list(Id.t)))) => bool, t) => t; + let filter_keep_id: (((Var.t, Exp.t(list(Id.t)))) => bool, t) => t; + let fold: (((Var.t, Exp.t(list(Id.t))), 'b) => 'b, 'b, t) => 'b; let without_keys: (list(Var.t), t) => t; @@ -1101,7 +1137,7 @@ and ClosureEnvironment: { and StepperFilterKind: { [@deriving (show({with_path: false}), sexp, yojson)] type filter = { - pat: Exp.t, + pat: Exp.t(list(Id.t)), act: FilterAction.t, }; @@ -1112,7 +1148,12 @@ and StepperFilterKind: { let map_term: ( - ~f_exp: (Exp.t => Exp.t, Exp.t) => Exp.t=?, + ~f_exp: ( + Exp.t(list(Id.t)) => Exp.t(list(Id.t)), + Exp.t(list(Id.t)) + ) => + Exp.t(list(Id.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=?, @@ -1122,13 +1163,13 @@ and StepperFilterKind: { ) => t; - let map: (Exp.t => Exp.t, t) => t; + let map: (Exp.t(list(Id.t)) => Exp.t(list(Id.t)), t) => t; let fast_equal: (t, t) => bool; } = { [@deriving (show({with_path: false}), sexp, yojson)] type filter = { - pat: Exp.t, + pat: Exp.t(list(Id.t)), act: FilterAction.t, }; diff --git a/src/haz3lcore/zipper/Editor.re b/src/haz3lcore/zipper/Editor.re index 427a833f79..fc0ef65c27 100644 --- a/src/haz3lcore/zipper/Editor.re +++ b/src/haz3lcore/zipper/Editor.re @@ -2,7 +2,7 @@ open Util; module CachedStatics = { type t = { - term: UExp.t, + term: UExp.t(list(Id.t)), info_map: Statics.Map.t, error_ids: list(Id.t), }; @@ -43,7 +43,7 @@ module CachedSyntax = { tiles: TileMap.t, holes: list(Grout.t), selection_ids: list(Id.t), - term: UExp.t, + term: UExp.t(list(Id.t)), /* This term, and the term-derived data structured below, may differ * from the term used for semantics. These terms are identical when * the backpack is empty. If the backpack is non-empty, then when we diff --git a/src/haz3lcore/zipper/EditorUtil.re b/src/haz3lcore/zipper/EditorUtil.re index ff59e48f55..2105a774d5 100644 --- a/src/haz3lcore/zipper/EditorUtil.re +++ b/src/haz3lcore/zipper/EditorUtil.re @@ -1,4 +1,6 @@ -let rec append_exp = (e1: Exp.t, e2: Exp.t): Exp.t => { +let rec append_exp = + (e1: Exp.t(list(Id.t)), e2: Exp.t(list(Id.t))) + : Exp.t(list(Id.t)) => { Exp.( switch (e1.term) { | EmptyHole diff --git a/src/haz3lschool/Exercise.re b/src/haz3lschool/Exercise.re index b5e7dfc76d..2b4d467b96 100644 --- a/src/haz3lschool/Exercise.re +++ b/src/haz3lschool/Exercise.re @@ -568,7 +568,9 @@ module F = (ExerciseEnv: ExerciseEnv) => { hidden_tests: 'a, }; - let wrap_filter = (act: FilterAction.action, term: UExp.t): UExp.t => + let wrap_filter = + (act: FilterAction.action, term: UExp.t(list(Id.t))) + : UExp.t(list(Id.t)) => Exp.{ term: Exp.Filter( @@ -586,7 +588,7 @@ module F = (ExerciseEnv: ExerciseEnv) => { ids: [Id.mk()], }; - let term_of = (editor: Editor.t): UExp.t => + let term_of = (editor: Editor.t): UExp.t(list(Id.t)) => MakeTerm.from_zip_for_sem(editor.state.zipper).term; let stitch3 = (ed1: Editor.t, ed2: Editor.t, ed3: Editor.t) => @@ -595,7 +597,7 @@ module F = (ExerciseEnv: ExerciseEnv) => { term_of(ed3), ); - let stitch_term = ({eds, _}: state): stitched(UExp.t) => { + let stitch_term = ({eds, _}: state): stitched(UExp.t(list(Id.t))) => { let instructor = stitch3(eds.prelude, eds.correct_impl, eds.hidden_tests.tests); let user_impl_term = { @@ -620,7 +622,8 @@ module F = (ExerciseEnv: ExerciseEnv) => { instructor, hidden_bugs: List.map( - (t): UExp.t => stitch3(eds.prelude, t.impl, eds.your_tests.tests), + (t): UExp.t(list(Id.t)) => + stitch3(eds.prelude, t.impl, eds.your_tests.tests), eds.hidden_bugs, ), hidden_tests: hidden_tests_term, @@ -636,8 +639,9 @@ module F = (ExerciseEnv: ExerciseEnv) => { Stitching is necessary to concatenate terms from different editors, which are then typechecked. */ let stitch_static = - (settings: CoreSettings.t, t: stitched(UExp.t)): stitched_statics => { - let mk = (term: UExp.t): Editor.CachedStatics.t => { + (settings: CoreSettings.t, t: stitched(UExp.t(list(Id.t)))) + : stitched_statics => { + let mk = (term: UExp.t(list(Id.t))): Editor.CachedStatics.t => { let info_map = Statics.mk(settings, Builtins.ctx_init, term); {term, error_ids: Statics.Map.error_ids(info_map), info_map}; }; diff --git a/src/haz3lschool/SyntaxTest.re b/src/haz3lschool/SyntaxTest.re index 23dff72251..911c7031a5 100644 --- a/src/haz3lschool/SyntaxTest.re +++ b/src/haz3lschool/SyntaxTest.re @@ -44,8 +44,13 @@ let rec find_var_upat = (name: string, upat: Pat.t): bool => { if name="a", then l=[fun x -> x+1] */ let rec find_in_let = - (name: string, upat: UPat.t, def: UExp.t, l: list(UExp.t)) - : list(UExp.t) => { + ( + name: string, + upat: UPat.t, + def: UExp.t(list(Id.t)), + l: list(UExp.t(list(Id.t))), + ) + : list(UExp.t(list(Id.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) @@ -81,7 +86,12 @@ let rec find_in_let = Find any function expressions in uexp that are bound to variable name */ let rec find_fn = - (name: string, uexp: UExp.t, l: list(UExp.t)): list(UExp.t) => { + ( + name: string, + uexp: UExp.t(list(Id.t)), + l: list(UExp.t(list(Id.t))), + ) + : list(UExp.t(list(Id.t))) => { switch (uexp.term) { | Let(up, def, body) => l |> find_in_let(name, up, def) |> find_fn(name, body) @@ -167,7 +177,7 @@ let rec var_mention_upat = (name: string, upat: Pat.t): bool => { /* Finds whether variable name is ever mentioned in uexp. */ -let rec var_mention = (name: string, uexp: Exp.t): bool => { +let rec var_mention = (name: string, uexp: Exp.t(list(Id.t))): bool => { switch (uexp.term) { | Var(x) => x == name | EmptyHole @@ -228,7 +238,7 @@ let rec var_mention = (name: string, uexp: Exp.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: Exp.t): bool => { +let rec var_applied = (name: string, uexp: Exp.t(list(Id.t))): bool => { switch (uexp.term) { | Var(_) | EmptyHole @@ -299,7 +309,7 @@ let rec var_applied = (name: string, uexp: Exp.t): bool => { /* Check whether all functions bound to variable name are recursive. */ -let is_recursive = (name: string, uexp: Exp.t): bool => { +let is_recursive = (name: string, uexp: Exp.t(list(Id.t))): bool => { let fn_bodies = [] |> find_fn(name, uexp); if (List.length(fn_bodies) == 0) { false; @@ -317,7 +327,7 @@ let is_recursive = (name: string, uexp: Exp.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: Exp.t): bool => { +let rec tail_check = (name: string, uexp: Exp.t(list(Id.t))): bool => { switch (uexp.term) { | EmptyHole | Deferral(_) @@ -378,7 +388,7 @@ let rec tail_check = (name: string, uexp: Exp.t): bool => { /* Check whether all functions bound to variable name are tail recursive. */ -let is_tail_recursive = (name: string, uexp: UExp.t): bool => { +let is_tail_recursive = (name: string, uexp: UExp.t(list(Id.t))): bool => { let fn_bodies = [] |> find_fn(name, uexp); if (List.length(fn_bodies) == 0) { false; @@ -391,7 +401,12 @@ let is_tail_recursive = (name: string, uexp: UExp.t): bool => { }; }; -let check = (uexp: UExp.t, predicates: list(UExp.t => bool)): syntax_result => { +let check = + ( + uexp: UExp.t(list(Id.t)), + predicates: list(UExp.t(list(Id.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 4ef2c3a288..8f7a0b12b0 100644 --- a/src/haz3lweb/DebugConsole.re +++ b/src/haz3lweb/DebugConsole.re @@ -16,7 +16,7 @@ let print = ({settings, editors, _}: Model.t, key: string): unit => { |> Zipper.unselect_and_zip |> ((seg: Segment.t(Uuidm.t)) => [%derive.show: Segment.t(Id.t)](seg)) |> print - | "F3" => term |> UExp.show |> print + | "F3" => term |> [%derive.show: UExp.t(list(Id.t))] |> print | "F4" => map |> Statics.Map.show |> print | "F5" => let env = Editors.get_env_init(~settings, editors); diff --git a/src/haz3lweb/view/ExplainThis.re b/src/haz3lweb/view/ExplainThis.re index cfca701ebb..40fc6f1b45 100644 --- a/src/haz3lweb/view/ExplainThis.re +++ b/src/haz3lweb/view/ExplainThis.re @@ -407,7 +407,7 @@ let rec bypass_parens_pat = (pat: Pat.t) => { }; }; -let rec bypass_parens_exp = (exp: Exp.t) => { +let rec bypass_parens_exp = (exp: Exp.t(list(Id.t))) => { switch (exp.term) { | Parens(e) => bypass_parens_exp(e) | _ => exp @@ -532,7 +532,7 @@ let get_doc = let rec get_message_exp = (term) : (list(Node.t), (list(Node.t), ColorSteps.t), list(Node.t)) => - switch ((term: Exp.term)) { + switch ((term: Exp.term(list(Id.t)))) { | Exp.Invalid(_) => simple("Not a valid expression") | DynamicErrorHole(_) | FailedCast(_) @@ -1663,7 +1663,7 @@ 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: Exp.t) => { + let add = (mapping, arg: Exp.t(list(Id.t))) => { let arg_id = List.nth(arg.ids, 0); Haz3lcore.Id.Map.add( arg_id, diff --git a/src/haz3lweb/view/dhcode/DHCode.re b/src/haz3lweb/view/dhcode/DHCode.re index b28f9e18bf..cdb22187a5 100644 --- a/src/haz3lweb/view/dhcode/DHCode.re +++ b/src/haz3lweb/view/dhcode/DHCode.re @@ -135,7 +135,7 @@ let view = ~next_steps: list((int, Id.t))=[], ~result_key: string, ~infomap, - d: DHExp.t, + d: DHExp.t(list(Id.t)), ) : Node.t => { DHDoc_Exp.mk( diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index 34efdf0735..dd08c99475 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -42,7 +42,7 @@ let precedence_bin_string_op = (bso: Operators.op_bin_string) => | Concat => DHDoc_common.precedence_Plus | Equals => DHDoc_common.precedence_Equals }; -let rec precedence = (~show_casts: bool, d: DHExp.t) => { +let rec precedence = (~show_casts: bool, d: DHExp.t(list(Id.t))) => { let precedence' = precedence(~show_casts); switch (DHExp.term_of(d)) { | Var(_) @@ -114,13 +114,13 @@ let mk = ~next_steps: list((int, Id.t)), // The options for the next step, if it hasn't been chosen yet ~env: ClosureEnvironment.t, ~infomap: Statics.Map.t, - d: DHExp.t, + d: DHExp.t(list(Id.t)), ) : DHDoc.t => { let precedence = precedence(~show_casts=settings.show_casts); let rec go = ( - d: DHExp.t, + d: DHExp.t(list(Id.t)), env: ClosureEnvironment.t, enforce_inline: bool, recent_subst: list(Var.t), From 2693f230922461a60ddd2bb17a7f359a2af4b3aa Mon Sep 17 00:00:00 2001 From: Alexander Bandukwala <7h3kk1d@gmail.com> Date: Wed, 14 Aug 2024 09:47:57 -0400 Subject: [PATCH 3/8] Fix tests --- test/Test_Elaboration.re | 34 +++++++++++++++++++++++----------- test/dune | 2 +- 2 files changed, 24 insertions(+), 12 deletions(-) diff --git a/test/Test_Elaboration.re b/test/Test_Elaboration.re index 1c5a7c7271..d12e7e92ad 100644 --- a/test/Test_Elaboration.re +++ b/test/Test_Elaboration.re @@ -3,7 +3,11 @@ open Haz3lcore; /*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(Exp.show, Fmt.string), DHExp.fast_equal); +let dhexp_typ = + testable( + Fmt.using([%derive.show: Exp.t(list(Id.t))], Fmt.string), + DHExp.fast_equal, + ); let ids = List.init(12, _ => Id.mk()); let id_at = x => x |> List.nth(ids); @@ -11,14 +15,22 @@ let mk_map = Statics.mk(CoreSettings.on, Builtins.ctx_init); let dhexp_of_uexp = u => Elaborator.elaborate(mk_map(u), u) |> fst; let alco_check = dhexp_typ |> Alcotest.check; -let u1: Exp.t = {ids: [id_at(0)], term: Int(8), copied: false}; +let u1: Exp.t(list(Id.t)) = { + ids: [id_at(0)], + term: Int(8), + copied: false, +}; let single_integer = () => alco_check("Integer literal 8", u1, dhexp_of_uexp(u1)); -let u2: Exp.t = {ids: [id_at(0)], term: EmptyHole, copied: false}; +let u2: Exp.t(list(Id.t)) = { + ids: [id_at(0)], + term: EmptyHole, + copied: false, +}; let empty_hole = () => alco_check("Empty hole", u2, dhexp_of_uexp(u2)); -let u3: Exp.t = { +let u3: Exp.t(list(Id.t)) = { ids: [id_at(0)], term: Parens({ids: [id_at(1)], term: Var("y"), copied: false}), copied: false, @@ -26,7 +38,7 @@ let u3: Exp.t = { let free_var = () => alco_check("free variable", u3, dhexp_of_uexp(u3)); -let u4: Exp.t = +let u4: Exp.t(list(Id.t)) = Let( Tuple([Var("a") |> Pat.fresh, Var("b") |> Pat.fresh]) |> Pat.fresh, Tuple([Int(4) |> Exp.fresh, Int(6) |> Exp.fresh]) |> Exp.fresh, @@ -63,7 +75,7 @@ let bin_op = () => dhexp_of_uexp(u5), ); -let u6: Exp.t = +let u6: Exp.t(list(Id.t)) = If(Bool(false) |> Exp.fresh, Int(8) |> Exp.fresh, Int(6) |> Exp.fresh) |> Exp.fresh; @@ -74,7 +86,7 @@ let consistent_if = () => dhexp_of_uexp(u6), ); -let u7: Exp.t = +let u7: Exp.t(list(Id.t)) = Ap( Forward, Fun( @@ -92,7 +104,7 @@ let u7: Exp.t = let ap_fun = () => alco_check("Application of a function", u7, dhexp_of_uexp(u7)); -let u8: Exp.t = +let u8: Exp.t(list(Id.t)) = Match( BinOp(Int(Equals), Int(4) |> Exp.fresh, Int(3) |> Exp.fresh) |> Exp.fresh, @@ -103,7 +115,7 @@ let u8: Exp.t = ) |> Exp.fresh; -let d8: Exp.t = +let d8: Exp.t(list(Id.t)) = Match( BinOp(Int(Equals), Int(4) |> Exp.fresh, Int(3) |> Exp.fresh) |> Exp.fresh, @@ -137,7 +149,7 @@ let inconsistent_case = () => dhexp_of_uexp(u8), ); -let u9: Exp.t = +let u9: Exp.t(list(Id.t)) = Let( Cast( Var("f") |> Pat.fresh, @@ -157,7 +169,7 @@ let u9: Exp.t = ) |> Exp.fresh; -let d9: Exp.t = +let d9: Exp.t(list(Id.t)) = Let( Var("f") |> Pat.fresh, Fun( diff --git a/test/dune b/test/dune index 832c9689f2..12c177c749 100644 --- a/test/dune +++ b/test/dune @@ -5,4 +5,4 @@ (libraries haz3lcore alcotest junit junit_alcotest) (modes js) (preprocess - (pps js_of_ocaml-ppx))) + (pps js_of_ocaml-ppx ppx_deriving.show))) From b96242619b40ca0284e6cb8f1f95000094da139d Mon Sep 17 00:00:00 2001 From: Alexander Bandukwala <7h3kk1d@gmail.com> Date: Thu, 22 Aug 2024 10:45:58 -0400 Subject: [PATCH 4/8] Add id params to the other TermBase types - Still need to fix every callsite --- src/haz3lcore/lang/term/IdTag.re | 26 ++ src/haz3lcore/statics/TermBase.re | 547 +++++++++++++++--------------- 2 files changed, 300 insertions(+), 273 deletions(-) create mode 100644 src/haz3lcore/lang/term/IdTag.re diff --git a/src/haz3lcore/lang/term/IdTag.re b/src/haz3lcore/lang/term/IdTag.re new file mode 100644 index 0000000000..134d467640 --- /dev/null +++ b/src/haz3lcore/lang/term/IdTag.re @@ -0,0 +1,26 @@ +open Util; + +[@deriving (show({with_path: false}), sexp, yojson)] +type t = { + [@show.opaque] + ids: list(Id.t), /* TODO Should this still be a type param */ + [@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, +}; + +// 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/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index b5c58f0db2..c9dafb5885 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -19,7 +19,7 @@ let stop = (_, x) => x; map_term: ( - ~f_exp: (Exp.t('id) => Exp.t('id) , Exp.t('id) ) => Exp.t('id) =?, + ~f_exp: (Exp.t('a) => Exp.t('a) , Exp.t('a) ) => Exp.t('a) =?, ~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=?, @@ -44,41 +44,36 @@ let stop = (_, x) => x; module rec Any: { [@deriving (show({with_path: false}), sexp, yojson)] - type t = - | Exp(Exp.t(list(Id.t))) - | Pat(Pat.t) - | Typ(Typ.t) - | TPat(TPat.t) - | Rul(Rul.t) + type t('a) = + | Exp(Exp.t('a)) + | Pat(Pat.t('a)) + | Typ(Typ.t('a)) + | TPat(TPat.t('a)) + | Rul(Rul.t('a)) | Nul(unit) | Any(unit); let map_term: ( - ~f_exp: ( - Exp.t(list(Id.t)) => Exp.t(list(Id.t)), - Exp.t(list(Id.t)) - ) => - Exp.t(list(Id.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 + ~f_exp: (Exp.t('a) => Exp.t('a), Exp.t('a)) => Exp.t('a)=?, + ~f_pat: (Pat.t('a) => Pat.t('a), Pat.t('a)) => Pat.t('a)=?, + ~f_typ: (Typ.t('a) => Typ.t('a), Typ.t('a)) => Typ.t('a)=?, + ~f_tpat: (TPat.t('a) => TPat.t('a), TPat.t('a)) => TPat.t('a)=?, + ~f_rul: (Rul.t('a) => Rul.t('a), Rul.t('a)) => Rul.t('a)=?, + ~f_any: (Any.t('a) => Any.t('a), Any.t('a)) => Any.t('a)=?, + t('a) ) => - t; + t('a); - let fast_equal: (t, t) => bool; + let fast_equal: (t('a), t('a)) => bool; } = { [@deriving (show({with_path: false}), sexp, yojson)] - type t = - | Exp(Exp.t(list(Id.t))) - | Pat(Pat.t) - | Typ(Typ.t) - | TPat(TPat.t) - | Rul(Rul.t) + type t('a) = + | Exp(Exp.t('a)) + | Pat(Pat.t('a)) + | Typ(Typ.t('a)) + | TPat(TPat.t('a)) + | Rul(Rul.t('a)) | Nul(unit) | Any(unit); @@ -137,71 +132,69 @@ and Exp: { | OutsideAp; [@deriving (show({with_path: false}), sexp, yojson)] - type term('id) = + type term('a) = | Invalid(string) | EmptyHole - | MultiHole(list(Any.t)) - | DynamicErrorHole(t('id), InvalidOperationError.t) - | FailedCast(t('id), Typ.t, Typ.t) + | MultiHole(list(Any.t('a))) + | DynamicErrorHole(t('a), InvalidOperationError.t) + | FailedCast(t('a), Typ.t('a), Typ.t('a)) | Deferral(deferral_position) | Undefined | Bool(bool) | Int(int) | Float(float) | String(string) - | ListLit(list(t('id))) - | Constructor(string, Typ.t) // Typ.t field is only meaningful in dynamic expressions + | ListLit(list(t('a))) + | Constructor(string, Typ.t('a)) // Typ.t field is only meaningful in dynamic expressions | Fun( - Pat.t, - t('id), + Pat.t('a), + t('a), [@show.opaque] option(ClosureEnvironment.t), option(Var.t), ) - | TypFun(TPat.t, t('id), option(Var.t)) - | Tuple(list(t('id))) + | TypFun(TPat.t('a), t('a), option(Var.t)) + | Tuple(list(t('a))) | Var(Var.t) - | Let(Pat.t, t('id), t('id)) - | FixF(Pat.t, t('id), option(ClosureEnvironment.t)) - | TyAlias(TPat.t, Typ.t, t('id)) - | Ap(Operators.ap_direction, t('id), t('id)) - | TypAp(t('id), Typ.t) - | DeferredAp(t('id), list(t('id))) - | If(t('id), t('id), t('id)) - | Seq(t('id), t('id)) - | Test(t('id)) - | Filter(StepperFilterKind.t, t('id)) - | Closure([@show.opaque] ClosureEnvironment.t, t('id)) - | Parens(t('id)) // ( - | Cons(t('id), t('id)) - | ListConcat(t('id), t('id)) - | UnOp(Operators.op_un, t('id)) - | BinOp(Operators.op_bin, t('id), t('id)) + | Let(Pat.t('a), t('a), t('a)) + | FixF(Pat.t('a), t('a), option(ClosureEnvironment.t)) + | TyAlias(TPat.t('a), Typ.t('a), t('a)) + | Ap(Operators.ap_direction, t('a), t('a)) + | TypAp(t('a), Typ.t('a)) + | DeferredAp(t('a), list(t('a))) + | If(t('a), t('a), t('a)) + | Seq(t('a), t('a)) + | Test(t('a)) + | Filter(StepperFilterKind.t('a), t('a)) + | Closure([@show.opaque] ClosureEnvironment.t, t('a)) + | Parens(t('a)) // ( + | Cons(t('a), t('a)) + | ListConcat(t('a), t('a)) + | UnOp(Operators.op_un, t('a)) + | BinOp(Operators.op_bin, t('a), t('a)) | BuiltinFun(string) - | Match(t('id), list((Pat.t, t('id)))) + | Match(t('a), list((Pat.t('a), t('a)))) /* 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('id), Typ.t, Typ.t) // first Typ.t field is only meaningful in dynamic expressions - and t('id) = IdTagged.t(term('id), 'id); + | Cast(t('a), Typ.t('a), Typ.t('a)) // first Typ.t field is only meaningful in dynamic expressions + and t('a) = { + term: term('a), + annotation: 'a, + }; let map_term: ( - ~f_exp: ( - Exp.t(list(Id.t)) => Exp.t(list(Id.t)), - Exp.t(list(Id.t)) - ) => - Exp.t(list(Id.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(list(Id.t)) + ~f_exp: (Exp.t('a) => Exp.t('a), Exp.t('a)) => Exp.t('a)=?, + ~f_pat: (Pat.t('a) => Pat.t('a), Pat.t('a)) => Pat.t('a)=?, + ~f_typ: (Typ.t('a) => Typ.t('a), Typ.t('a)) => Typ.t('a)=?, + ~f_tpat: (TPat.t('a) => TPat.t('a), TPat.t('a)) => TPat.t('a)=?, + ~f_rul: (Rul.t('a) => Rul.t('a), Rul.t('a)) => Rul.t('a)=?, + ~f_any: (Any.t('a) => Any.t('a), Any.t('a)) => Any.t('a)=?, + t('a) ) => - t(list(Id.t)); + t('a); - let fast_equal: (t('id), t('id)) => bool; + let fast_equal: (t('a), t('a)) => bool; } = { [@deriving (show({with_path: false}), sexp, yojson)] type deferral_position = @@ -209,52 +202,55 @@ and Exp: { | OutsideAp; [@deriving (show({with_path: false}), sexp, yojson)] - type term('id) = + type term('a) = | Invalid(string) | EmptyHole - | MultiHole(list(Any.t)) - | DynamicErrorHole(t('id), InvalidOperationError.t) - | FailedCast(t('id), Typ.t, Typ.t) + | MultiHole(list(Any.t('a))) + | DynamicErrorHole(t('a), InvalidOperationError.t) + | FailedCast(t('a), Typ.t('a), Typ.t('a)) | Deferral(deferral_position) | Undefined | Bool(bool) | Int(int) | Float(float) | String(string) - | ListLit(list(t('id))) - | Constructor(string, Typ.t) // Typ.t field is only meaningful in dynamic expressions + | ListLit(list(t('a))) + | Constructor(string, Typ.t('a)) // Typ.t field is only meaningful in dynamic expressions | Fun( - Pat.t, - t('id), + Pat.t('a), + t('a), [@show.opaque] option(ClosureEnvironment.t), option(Var.t), ) - | TypFun(TPat.t, t('id), option(Var.t)) - | Tuple(list(t('id))) + | TypFun(TPat.t('a), t('a), option(Var.t)) + | Tuple(list(t('a))) | Var(Var.t) - | Let(Pat.t, t('id), t('id)) - | FixF(Pat.t, t('id), option(ClosureEnvironment.t)) - | TyAlias(TPat.t, Typ.t, t('id)) - | Ap(Operators.ap_direction, t('id), t('id)) - | TypAp(t('id), Typ.t) - | DeferredAp(t('id), list(t('id))) - | If(t('id), t('id), t('id)) - | Seq(t('id), t('id)) - | Test(t('id)) - | Filter(StepperFilterKind.t, t('id)) - | Closure([@show.opaque] ClosureEnvironment.t, t('id)) - | Parens(t('id)) // ( - | Cons(t('id), t('id)) - | ListConcat(t('id), t('id)) - | UnOp(Operators.op_un, t('id)) - | BinOp(Operators.op_bin, t('id), t('id)) + | Let(Pat.t('a), t('a), t('a)) + | FixF(Pat.t('a), t('a), option(ClosureEnvironment.t)) + | TyAlias(TPat.t('a), Typ.t('a), t('a)) + | Ap(Operators.ap_direction, t('a), t('a)) + | TypAp(t('a), Typ.t('a)) + | DeferredAp(t('a), list(t('a))) + | If(t('a), t('a), t('a)) + | Seq(t('a), t('a)) + | Test(t('a)) + | Filter(StepperFilterKind.t('a), t('a)) + | Closure([@show.opaque] ClosureEnvironment.t, t('a)) + | Parens(t('a)) // ( + | Cons(t('a), t('a)) + | ListConcat(t('a), t('a)) + | UnOp(Operators.op_un, t('a)) + | BinOp(Operators.op_bin, t('a), t('a)) | BuiltinFun(string) - | Match(t('id), list((Pat.t, t('id)))) + | Match(t('a), list((Pat.t('a), t('a)))) /* 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('id), Typ.t, Typ.t) // first Typ.t field is only meaningful in dynamic expressions - and t('id) = IdTagged.t(term('id), 'id); + | Cast(t('a), Typ.t('a), Typ.t('a)) // first Typ.t field is only meaningful in dynamic expressions + and t('a) = { + term: term('a), + annotation: 'a, + }; let map_term = ( @@ -285,7 +281,7 @@ and Exp: { ~f_rul, ~f_any, ); - let rec_call = ({term, _} as exp: t(list(Id.t))) => { + let rec_call = ({term, _} as exp: t('a)) => { ...exp, term: switch (term) { @@ -347,7 +343,7 @@ and Exp: { }; let rec fast_equal = (e1, e2) => - switch (e1 |> IdTagged.term_of, e2 |> IdTagged.term_of) { + switch (e1.term, e2.term) { | (DynamicErrorHole(x, _), _) | (Parens(x), _) => fast_equal(x, e2) | (_, DynamicErrorHole(x, _)) @@ -463,63 +459,64 @@ and Exp: { } and Pat: { [@deriving (show({with_path: false}), sexp, yojson)] - type term = + type term('a) = | Invalid(string) | EmptyHole - | MultiHole(list(Any.t)) + | MultiHole(list(Any.t('a))) | Wild | Int(int) | Float(float) | Bool(bool) | String(string) - | ListLit(list(t)) - | Constructor(string, Typ.t) // Typ.t field is only meaningful in dynamic patterns - | Cons(t, t) + | ListLit(list(t('a))) + | Constructor(string, Typ.t('a)) // Typ.t field is only meaningful in dynamic patterns + | Cons(t('a), t('a)) | Var(Var.t) - | Tuple(list(t)) - | Parens(t) - | Ap(t, t) - | Cast(t, Typ.t, Typ.t) // The second Typ.t field is only meaningful in dynamic patterns - and t = IdTagged.t(term, list(Id.t)); + | Tuple(list(t('a))) + | Parens(t('a)) + | Ap(t('a), t('a)) + | Cast(t('a), Typ.t('a), Typ.t('a)) // The second Typ.t field is only meaningful in dynamic patterns + and t('a) = { + term: term('a), + annotation: 'a, + }; let map_term: ( - ~f_exp: ( - Exp.t(list(Id.t)) => Exp.t(list(Id.t)), - Exp.t(list(Id.t)) - ) => - Exp.t(list(Id.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 + ~f_exp: (Exp.t('a) => Exp.t('a), Exp.t('a)) => Exp.t('a)=?, + ~f_pat: (Pat.t('a) => Pat.t('a), Pat.t('a)) => Pat.t('a)=?, + ~f_typ: (Typ.t('a) => Typ.t('a), Typ.t('a)) => Typ.t('a)=?, + ~f_tpat: (TPat.t('a) => TPat.t('a), TPat.t('a)) => TPat.t('a)=?, + ~f_rul: (Rul.t('a) => Rul.t('a), Rul.t('a)) => Rul.t('a)=?, + ~f_any: (Any.t('a) => Any.t('a), Any.t('a)) => Any.t('a)=?, + t('a) ) => - t; + t('a); - let fast_equal: (t, t) => bool; + let fast_equal: (t('a), t('a)) => bool; } = { [@deriving (show({with_path: false}), sexp, yojson)] - type term = + type term('a) = | Invalid(string) | EmptyHole - | MultiHole(list(Any.t)) + | MultiHole(list(Any.t('a))) | Wild | Int(int) | Float(float) | Bool(bool) | String(string) - | ListLit(list(t)) - | Constructor(string, Typ.t) - | Cons(t, t) + | ListLit(list(t('a))) + | Constructor(string, Typ.t('a)) + | Cons(t('a), t('a)) | Var(Var.t) - | Tuple(list(t)) - | Parens(t) - | Ap(t, t) - | Cast(t, Typ.t, Typ.t) // The second one is hidden from the user - and t = IdTagged.t(term, list(Id.t)); + | Tuple(list(t('a))) + | Parens(t('a)) + | Ap(t('a), t('a)) + | Cast(t('a), Typ.t('a), Typ.t('a)) // The second one is hidden from the user + and t('a) = { + term: term('a), + annotation: 'a, + }; let map_term = ( @@ -537,7 +534,7 @@ and Pat: { 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) => { + let rec_call = ({term, _} as exp: t('a)) => { ...exp, term: switch (term) { @@ -564,7 +561,7 @@ and Pat: { }; let rec fast_equal = (p1, p2) => - switch (p1 |> IdTagged.term_of, p2 |> IdTagged.term_of) { + switch (p1.term, p2.term) { | (Parens(x), _) => fast_equal(x, p2) | (_, Parens(x)) => fast_equal(p1, x) | (EmptyHole, EmptyHole) => true @@ -608,97 +605,98 @@ and Pat: { } and Typ: { [@deriving (show({with_path: false}), sexp, yojson)] - type type_hole = + type type_hole('a) = | Invalid(string) | EmptyHole - | MultiHole(list(Any.t)); + | MultiHole(list(Any.t('a))); /* 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 = + type type_provenance('a) = | SynSwitch - | Hole(type_hole) + | Hole(type_hole('a)) | Internal; [@deriving (show({with_path: false}), sexp, yojson)] - type term = - | Unknown(Typ.type_provenance) + type term('a) = + | Unknown(Typ.type_provenance('a)) | Int | Float | Bool | String | Var(string) - | List(t) - | Arrow(t, t) - | Sum(ConstructorMap.t(t)) - | Prod(list(t)) - | Parens(t) - | Ap(t, t) - | Rec(TPat.t, t) - | Forall(TPat.t, t) - and t = IdTagged.t(term, list(Id.t)); - - type sum_map = ConstructorMap.t(t); + | List(t('a)) + | Arrow(t('a), t('a)) + | Sum(ConstructorMap.t(t('a))) + | Prod(list(t('a))) + | Parens(t('a)) + | Ap(t('a), t('a)) + | Rec(TPat.t('a), t('a)) + | Forall(TPat.t('a), t('a)) + and t('a) = { + term: term('a), + annotation: 'a, + }; + + type sum_map('a) = ConstructorMap.t(t('a)); let map_term: ( - ~f_exp: ( - Exp.t(list(Id.t)) => Exp.t(list(Id.t)), - Exp.t(list(Id.t)) - ) => - Exp.t(list(Id.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 + ~f_exp: (Exp.t('a) => Exp.t('a), Exp.t('a)) => Exp.t('a)=?, + ~f_pat: (Pat.t('a) => Pat.t('a), Pat.t('a)) => Pat.t('a)=?, + ~f_typ: (Typ.t('a) => Typ.t('a), Typ.t('a)) => Typ.t('a)=?, + ~f_tpat: (TPat.t('a) => TPat.t('a), TPat.t('a)) => TPat.t('a)=?, + ~f_rul: (Rul.t('a) => Rul.t('a), Rul.t('a)) => Rul.t('a)=?, + ~f_any: (Any.t('a) => Any.t('a), Any.t('a)) => Any.t('a)=?, + t('a) ) => - t; + t('a); - let subst: (t, TPat.t, t) => t; + let subst: (t('a), TPat.t('a), t('a)) => t('a); - let fast_equal: (t, t) => bool; + let fast_equal: (t('a), t('a)) => bool; } = { [@deriving (show({with_path: false}), sexp, yojson)] - type type_hole = + type type_hole('a) = | Invalid(string) | EmptyHole - | MultiHole(list(Any.t)); + | MultiHole(list(Any.t('a))); /* 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 = + type type_provenance('a) = | SynSwitch - | Hole(type_hole) + | Hole(type_hole('a)) | Internal; [@deriving (show({with_path: false}), sexp, yojson)] - type term = - | Unknown(Typ.type_provenance) + type term('a) = + | Unknown(Typ.type_provenance('a)) | Int | Float | Bool | String | Var(string) - | List(t) - | Arrow(t, t) - | Sum(ConstructorMap.t(t)) - | Prod(list(t)) - | Parens(t) - | Ap(t, t) - | Rec(TPat.t, t) - | Forall(TPat.t, t) - and t = IdTagged.t(term, list(Id.t)); - - type sum_map = ConstructorMap.t(t); + | List(t('a)) + | Arrow(t('a), t('a)) + | Sum(ConstructorMap.t(t('a))) + | Prod(list(t('a))) + | Parens(t('a)) + | Ap(t('a), t('a)) + | Rec(TPat.t('a), t('a)) + | Forall(TPat.t('a), t('a)) + and t('a) = { + term: term('a), + annotation: 'a, + }; + + type sum_map('a) = ConstructorMap.t(t('a)); let map_term = ( @@ -716,7 +714,7 @@ and Typ: { 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) => { + let rec_call = ({term, _} as exp: t('a)) => { ...exp, term: switch (term) { @@ -754,10 +752,17 @@ and Typ: { x |> f_typ(rec_call); }; - let rec subst = (s: t, x: TPat.t, ty: t) => { + let rec subst = (s, x, ty) => { switch (TPat.tyvar_of_utpat(x)) { | Some(str) => - let (term, rewrap) = IdTagged.unwrap(ty); + let (term, rewrap) = ( + ty.term, + ( + (term': term('a)) => ( + {term: term', annotation: ty.annotation}: t('a) + ) + ), + ); switch (term) { | Int => Int |> rewrap | Float => Float |> rewrap @@ -788,18 +793,17 @@ and Typ: { /* 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)) { + let rec eq_internal = (n: int, t1: t('a), t2: t('a)): bool => { + switch (t1.term, t2.term) { | (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], - }); + let foo: t('a) = { + term: Var("=" ++ string_of_int(n)), + annotation: t1.annotation // TODO I don't think this matters in this case. I'd like to just pass unit + }; + let alpha_subst = subst(foo); eq_internal(n + 1, alpha_subst(x1, t1), alpha_subst(x2, t2)); | (Rec(_), _) => false | (Forall(_), _) => false @@ -832,45 +836,46 @@ and Typ: { }; }; - let fast_equal = eq_internal(0); + let fast_equal = (x, y) => eq_internal(0, x, y); } and TPat: { [@deriving (show({with_path: false}), sexp, yojson)] - type term = + type term('a) = | Invalid(string) | EmptyHole - | MultiHole(list(Any.t)) + | MultiHole(list(Any.t('a))) | Var(string) - and t = IdTagged.t(term, list(Id.t)); + and t('a) = { + term: term('a), + annotation: 'a, + }; let map_term: ( - ~f_exp: ( - Exp.t(list(Id.t)) => Exp.t(list(Id.t)), - Exp.t(list(Id.t)) - ) => - Exp.t(list(Id.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 + ~f_exp: (Exp.t('a) => Exp.t('a), Exp.t('a)) => Exp.t('a)=?, + ~f_pat: (Pat.t('a) => Pat.t('a), Pat.t('a)) => Pat.t('a)=?, + ~f_typ: (Typ.t('a) => Typ.t('a), Typ.t('a)) => Typ.t('a)=?, + ~f_tpat: (TPat.t('a) => TPat.t('a), TPat.t('a)) => TPat.t('a)=?, + ~f_rul: (Rul.t('a) => Rul.t('a), Rul.t('a)) => Rul.t('a)=?, + ~f_any: (Any.t('a) => Any.t('a), Any.t('a)) => Any.t('a)=?, + t('a) ) => - t; + t('a); - let tyvar_of_utpat: t => option(string); + let tyvar_of_utpat: t('a) => option(string); - let fast_equal: (t, t) => bool; + let fast_equal: (t('a), t('a)) => bool; } = { [@deriving (show({with_path: false}), sexp, yojson)] - type term = + type term('a) = | Invalid(string) | EmptyHole - | MultiHole(list(Any.t)) + | MultiHole(list(Any.t('a))) | Var(string) - and t = IdTagged.t(term, list(Id.t)); + and t('a) = { + term: term('a), + annotation: 'a, + }; let map_term = ( @@ -884,27 +889,27 @@ and TPat: { ) => { let any_map_term = Any.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); - let rec_call = ({term, _} as exp: t) => { + let rec_call = exp => { ...exp, term: - switch (term) { + switch (exp.term) { | EmptyHole | Invalid(_) - | Var(_) => term + | Var(_) => exp.term | MultiHole(things) => MultiHole(List.map(any_map_term, things)) }, }; x |> f_tpat(rec_call); }; - let tyvar_of_utpat = ({term, _}: t) => + let tyvar_of_utpat = ({term, _}: t('a)) => switch (term) { | Var(x) => Some(x) | _ => None }; - let fast_equal = (tp1: t, tp2: t) => - switch (tp1 |> IdTagged.term_of, tp2 |> IdTagged.term_of) { + let fast_equal = (tp1: t('a), tp2: t('a)) => + switch (tp1.term, tp2.term) { | (EmptyHole, EmptyHole) => true | (Invalid(s1), Invalid(s2)) => s1 == s2 | (MultiHole(xs), MultiHole(ys)) => @@ -919,37 +924,38 @@ and TPat: { } and Rul: { [@deriving (show({with_path: false}), sexp, yojson)] - type term = + type term('a) = | Invalid(string) - | Hole(list(Any.t)) - | Rules(Exp.t(list(Id.t)), list((Pat.t, Exp.t(list(Id.t))))) - and t = IdTagged.t(term, list(Id.t)); + | Hole(list(Any.t('a))) + | Rules(Exp.t('a), list((Pat.t('a), Exp.t('a)))) + and t('a) = { + term: term('a), + annotation: 'a, + }; let map_term: ( - ~f_exp: ( - Exp.t(list(Id.t)) => Exp.t(list(Id.t)), - Exp.t(list(Id.t)) - ) => - Exp.t(list(Id.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 + ~f_exp: (Exp.t('a) => Exp.t('a), Exp.t('a)) => Exp.t('a)=?, + ~f_pat: (Pat.t('a) => Pat.t('a), Pat.t('a)) => Pat.t('a)=?, + ~f_typ: (Typ.t('a) => Typ.t('a), Typ.t('a)) => Typ.t('a)=?, + ~f_tpat: (TPat.t('a) => TPat.t('a), TPat.t('a)) => TPat.t('a)=?, + ~f_rul: (Rul.t('a) => Rul.t('a), Rul.t('a)) => Rul.t('a)=?, + ~f_any: (Any.t('a) => Any.t('a), Any.t('a)) => Any.t('a)=?, + t('a) ) => - t; + t('a); - let fast_equal: (t, t) => bool; + let fast_equal: (t('a), t('a)) => bool; } = { [@deriving (show({with_path: false}), sexp, yojson)] - type term = + type term('a) = | Invalid(string) - | Hole(list(Any.t)) - | Rules(Exp.t(list(Id.t)), list((Pat.t, Exp.t(list(Id.t))))) - and t = IdTagged.t(term, list(Id.t)); + | Hole(list(Any.t('a))) + | Rules(Exp.t('a), list((Pat.t('a), Exp.t('a)))) + and t('a) = { + term: term('a), + annotation: 'a, + }; let map_term = ( @@ -967,7 +973,7 @@ and Rul: { Pat.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); let any_map_term = Any.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); - let rec_call = ({term, _} as exp: t) => { + let rec_call = ({term, _} as exp: t('a)) => { ...exp, term: switch (term) { @@ -986,8 +992,8 @@ and Rul: { x |> f_rul(rec_call); }; - let fast_equal = (r1: t, r2: t) => - switch (r1 |> IdTagged.term_of, r2 |> IdTagged.term_of) { + let fast_equal = (r1: t('a), r2: t('a)) => + switch (r1.term, r2.term) { | (Invalid(s1), Invalid(s2)) => s1 == s2 | (Hole(xs), Hole(ys)) => List.length(xs) == List.length(ys) @@ -1136,46 +1142,41 @@ and ClosureEnvironment: { } and StepperFilterKind: { [@deriving (show({with_path: false}), sexp, yojson)] - type filter = { - pat: Exp.t(list(Id.t)), + type filter('a) = { + pat: Exp.t('a), act: FilterAction.t, }; [@deriving (show({with_path: false}), sexp, yojson)] - type t = - | Filter(filter) + type t('a) = + | Filter(filter('a)) | Residue(int, FilterAction.t); let map_term: ( - ~f_exp: ( - Exp.t(list(Id.t)) => Exp.t(list(Id.t)), - Exp.t(list(Id.t)) - ) => - Exp.t(list(Id.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 + ~f_exp: (Exp.t('a) => Exp.t('a), Exp.t('a)) => Exp.t('a)=?, + ~f_pat: (Pat.t('a) => Pat.t('a), Pat.t('a)) => Pat.t('a)=?, + ~f_typ: (Typ.t('a) => Typ.t('a), Typ.t('a)) => Typ.t('a)=?, + ~f_tpat: (TPat.t('a) => TPat.t('a), TPat.t('a)) => TPat.t('a)=?, + ~f_rul: (Rul.t('a) => Rul.t('a), Rul.t('a)) => Rul.t('a)=?, + ~f_any: (Any.t('a) => Any.t('a), Any.t('a)) => Any.t('a)=?, + t('a) ) => - t; + t('a); - let map: (Exp.t(list(Id.t)) => Exp.t(list(Id.t)), t) => t; + let map: (Exp.t('a) => Exp.t('a), t('a)) => t('a); - let fast_equal: (t, t) => bool; + let fast_equal: (t('a), t('a)) => bool; } = { [@deriving (show({with_path: false}), sexp, yojson)] - type filter = { - pat: Exp.t(list(Id.t)), + type filter('a) = { + pat: Exp.t('a), act: FilterAction.t, }; [@deriving (show({with_path: false}), sexp, yojson)] - type t = - | Filter(filter) + type t('a) = + | Filter(filter('a)) | Residue(int, FilterAction.t); let map = (mapper, filter) => { From 00005b1e57b587363520e556e6b86380924d49c2 Mon Sep 17 00:00:00 2001 From: Alexander Bandukwala <7h3kk1d@gmail.com> Date: Thu, 22 Aug 2024 11:22:45 -0400 Subject: [PATCH 5/8] Add annotated type --- src/haz3lcore/lang/term/Annotated.re | 26 +++++++++++ src/haz3lcore/statics/TermBase.re | 67 +++++++--------------------- 2 files changed, 41 insertions(+), 52 deletions(-) create mode 100644 src/haz3lcore/lang/term/Annotated.re diff --git a/src/haz3lcore/lang/term/Annotated.re b/src/haz3lcore/lang/term/Annotated.re new file mode 100644 index 0000000000..70ed522c78 --- /dev/null +++ b/src/haz3lcore/lang/term/Annotated.re @@ -0,0 +1,26 @@ +// open Util; + +[@deriving (show({with_path: false}), sexp, yojson)] +type t('term, 'a) = { + [@show.opaque] + annotation: 'a, + term: 'term, +}; + +let fresh = (term: 'term): t('term, IdTag.t) => { + { + annotation: { + ids: [Id.mk()], + copied: false, + }, + term, + }; +}; + +// let term_of = x => x.term; +let unwrap = x => (x.term, term' => {...x, term: term'}); +let rep_id = (t: t('term, IdTag.t)) => List.hd(t.annotation.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/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index c9dafb5885..459db2b59e 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -177,10 +177,7 @@ and Exp: { two consistent types. Both types should be normalized in dynamics for the cast calculus to work right. */ | Cast(t('a), Typ.t('a), Typ.t('a)) // first Typ.t field is only meaningful in dynamic expressions - and t('a) = { - term: term('a), - annotation: 'a, - }; + and t('a) = Annotated.t(term('a), IdTag.t); let map_term: ( @@ -247,10 +244,7 @@ and Exp: { two consistent types. Both types should be normalized in dynamics for the cast calculus to work right. */ | Cast(t('a), Typ.t('a), Typ.t('a)) // first Typ.t field is only meaningful in dynamic expressions - and t('a) = { - term: term('a), - annotation: 'a, - }; + and t('a) = Annotated.t(term('a), IdTag.t); let map_term = ( @@ -342,7 +336,7 @@ and Exp: { x |> f_exp(rec_call); }; - let rec fast_equal = (e1, e2) => + let rec fast_equal = (e1: t('a), e2: t('a)) => switch (e1.term, e2.term) { | (DynamicErrorHole(x, _), _) | (Parens(x), _) => fast_equal(x, e2) @@ -476,10 +470,7 @@ and Pat: { | Parens(t('a)) | Ap(t('a), t('a)) | Cast(t('a), Typ.t('a), Typ.t('a)) // The second Typ.t field is only meaningful in dynamic patterns - and t('a) = { - term: term('a), - annotation: 'a, - }; + and t('a) = Annotated.t(term('a), IdTag.t); let map_term: ( @@ -513,10 +504,7 @@ and Pat: { | Parens(t('a)) | Ap(t('a), t('a)) | Cast(t('a), Typ.t('a), Typ.t('a)) // The second one is hidden from the user - and t('a) = { - term: term('a), - annotation: 'a, - }; + and t('a) = Annotated.t(term('a), IdTag.t); let map_term = ( @@ -560,7 +548,7 @@ and Pat: { x |> f_pat(rec_call); }; - let rec fast_equal = (p1, p2) => + let rec fast_equal = (p1: t('a), p2: t('a)) => switch (p1.term, p2.term) { | (Parens(x), _) => fast_equal(x, p2) | (_, Parens(x)) => fast_equal(p1, x) @@ -636,10 +624,7 @@ and Typ: { | Ap(t('a), t('a)) | Rec(TPat.t('a), t('a)) | Forall(TPat.t('a), t('a)) - and t('a) = { - term: term('a), - annotation: 'a, - }; + and t('a) = Annotated.t(term('a), IdTag.t); type sum_map('a) = ConstructorMap.t(t('a)); @@ -691,10 +676,7 @@ and Typ: { | Ap(t('a), t('a)) | Rec(TPat.t('a), t('a)) | Forall(TPat.t('a), t('a)) - and t('a) = { - term: term('a), - annotation: 'a, - }; + and t('a) = Annotated.t(term('a), IdTag.t); type sum_map('a) = ConstructorMap.t(t('a)); @@ -752,17 +734,10 @@ and Typ: { x |> f_typ(rec_call); }; - let rec subst = (s, x, ty) => { + let rec subst = (s, x, ty: t('a)) => { switch (TPat.tyvar_of_utpat(x)) { | Some(str) => - let (term, rewrap) = ( - ty.term, - ( - (term': term('a)) => ( - {term: term', annotation: ty.annotation}: t('a) - ) - ), - ); + let (term, rewrap) = Annotated.unwrap(ty); switch (term) { | Int => Int |> rewrap | Float => Float |> rewrap @@ -845,10 +820,7 @@ and TPat: { | EmptyHole | MultiHole(list(Any.t('a))) | Var(string) - and t('a) = { - term: term('a), - annotation: 'a, - }; + and t('a) = Annotated.t(term('a), IdTag.t); let map_term: ( @@ -872,10 +844,7 @@ and TPat: { | EmptyHole | MultiHole(list(Any.t('a))) | Var(string) - and t('a) = { - term: term('a), - annotation: 'a, - }; + and t('a) = Annotated.t(term('a), IdTag.t); let map_term = ( @@ -889,7 +858,7 @@ and TPat: { ) => { let any_map_term = Any.map_term(~f_exp, ~f_pat, ~f_typ, ~f_tpat, ~f_rul, ~f_any); - let rec_call = exp => { + let rec_call = (exp: t('a)) => { ...exp, term: switch (exp.term) { @@ -928,10 +897,7 @@ and Rul: { | Invalid(string) | Hole(list(Any.t('a))) | Rules(Exp.t('a), list((Pat.t('a), Exp.t('a)))) - and t('a) = { - term: term('a), - annotation: 'a, - }; + and t('a) = Annotated.t(term('a), IdTag.t); let map_term: ( @@ -952,10 +918,7 @@ and Rul: { | Invalid(string) | Hole(list(Any.t('a))) | Rules(Exp.t('a), list((Pat.t('a), Exp.t('a)))) - and t('a) = { - term: term('a), - annotation: 'a, - }; + and t('a) = Annotated.t(term('a), IdTag.t); let map_term = ( From ff86788e9a5a6b3a7cacc8b8922ddbcedaec966f Mon Sep 17 00:00:00 2001 From: Alexander Bandukwala <7h3kk1d@gmail.com> Date: Thu, 22 Aug 2024 15:07:27 -0400 Subject: [PATCH 6/8] Sunk cost fallacy --- src/haz3lcore/TermMap.re | 4 +- src/haz3lcore/assistant/AssistantCtx.re | 24 ++- src/haz3lcore/assistant/AssistantForms.re | 22 +-- src/haz3lcore/assistant/Suggestion.re | 8 +- src/haz3lcore/dynamics/Builtins.re | 48 +++--- src/haz3lcore/dynamics/Casts.re | 51 ++++--- src/haz3lcore/dynamics/DHExp.re | 81 ++++++++-- src/haz3lcore/dynamics/DHPat.re | 4 +- src/haz3lcore/dynamics/Delta.re | 2 +- src/haz3lcore/dynamics/Delta.rei | 2 +- src/haz3lcore/dynamics/Elaborator.re | 60 +++++--- src/haz3lcore/dynamics/EvalCtx.re | 66 ++++----- src/haz3lcore/dynamics/Evaluator.re | 12 +- src/haz3lcore/dynamics/EvaluatorError.re | 22 +-- src/haz3lcore/dynamics/EvaluatorStep.re | 26 ++-- src/haz3lcore/dynamics/FilterEnvironment.re | 2 +- src/haz3lcore/dynamics/FilterMatcher.re | 24 +-- src/haz3lcore/dynamics/PatternMatch.re | 2 +- src/haz3lcore/dynamics/Stepper.re | 12 +- src/haz3lcore/dynamics/Substitution.re | 19 ++- src/haz3lcore/dynamics/Substitution.rei | 7 +- src/haz3lcore/dynamics/TestMap.re | 2 +- src/haz3lcore/dynamics/Transition.re | 58 +++----- src/haz3lcore/dynamics/TypeAssignment.re | 30 ++-- src/haz3lcore/dynamics/Unboxing.re | 18 ++- src/haz3lcore/dynamics/VarCtx.re | 2 +- src/haz3lcore/lang/term/Annotated.re | 22 ++- src/haz3lcore/lang/term/TPat.re | 8 +- src/haz3lcore/lang/term/Typ.re | 65 ++++---- src/haz3lcore/prog/CachedStatics.re | 11 +- src/haz3lcore/prog/Interface.re | 7 +- src/haz3lcore/statics/CoCtx.re | 18 +-- src/haz3lcore/statics/Ctx.re | 74 ++++++---- src/haz3lcore/statics/Info.re | 121 ++++++++------- src/haz3lcore/statics/MakeTerm.re | 155 +++++++++++++++----- src/haz3lcore/statics/Mode.re | 42 +++--- src/haz3lcore/statics/Self.re | 29 ++-- src/haz3lcore/statics/Statics.re | 63 +++++--- src/haz3lcore/statics/Term.re | 79 +++++----- src/haz3lcore/statics/TermBase.re | 43 +++--- src/haz3lcore/zipper/Editor.re | 13 +- src/haz3lcore/zipper/EditorUtil.re | 44 +++++- src/haz3lcore/zipper/projectors/InfoProj.re | 6 +- src/haz3lschool/Exercise.re | 25 ++-- src/haz3lschool/SyntaxTest.re | 35 ++--- 45 files changed, 869 insertions(+), 599 deletions(-) diff --git a/src/haz3lcore/TermMap.re b/src/haz3lcore/TermMap.re index df0f6341de..de2a3e9d54 100644 --- a/src/haz3lcore/TermMap.re +++ b/src/haz3lcore/TermMap.re @@ -1,5 +1,5 @@ include Id.Map; -type t = Id.Map.t(Any.t); +type t = Id.Map.t(Any.t(IdTag.t)); -let add_all = (ids: list(Id.t), tm: Any.t, map: t) => +let add_all = (ids: list(Id.t), tm: Any.t(IdTag.t), map: t) => ids |> List.fold_left((map, id) => add(id, tm, map), map); diff --git a/src/haz3lcore/assistant/AssistantCtx.re b/src/haz3lcore/assistant/AssistantCtx.re index 0caee1f921..461b9ed502 100644 --- a/src/haz3lcore/assistant/AssistantCtx.re +++ b/src/haz3lcore/assistant/AssistantCtx.re @@ -3,7 +3,12 @@ open Suggestion; /* For suggestions in patterns, suggest variables which * occur free in that pattern's scope. */ let free_variables = - (expected_ty: Typ.t, ctx: Ctx.t, co_ctx: CoCtx.t): list(Suggestion.t) => { + ( + expected_ty: Typ.t(IdTag.t), + ctx: Ctx.t(IdTag.t), + co_ctx: CoCtx.t(IdTag.t), + ) + : list(Suggestion.t) => { List.filter_map( ((name, entries)) => switch (Ctx.lookup_var(ctx, name)) { @@ -21,7 +26,8 @@ let free_variables = }; /* For suggestsions in expressions, suggest variables from the ctx */ -let bound_variables = (ty_expect: Typ.t, ctx: Ctx.t): list(Suggestion.t) => +let bound_variables = + (ty_expect: Typ.t(IdTag.t), ctx: Ctx.t(IdTag.t)): list(Suggestion.t) => List.filter_map( fun | Ctx.VarEntry({typ, name, _}) @@ -32,7 +38,11 @@ let bound_variables = (ty_expect: Typ.t, ctx: Ctx.t): list(Suggestion.t) => ); let bound_constructors = - (wrap: strategy_common => strategy, ty: Typ.t, ctx: Ctx.t) + ( + wrap: strategy_common => strategy, + ty: Typ.t(IdTag.t), + ctx: Ctx.t(IdTag.t), + ) : list(Suggestion.t) => /* get names of all constructor entries consistent with ty */ List.filter_map( @@ -45,7 +55,8 @@ let bound_constructors = ); /* Suggest applying a function from the ctx which returns an appropriate type */ -let bound_aps = (ty_expect: Typ.t, ctx: Ctx.t): list(Suggestion.t) => +let bound_aps = + (ty_expect: Typ.t(IdTag.t), ctx: Ctx.t(IdTag.t)): list(Suggestion.t) => List.filter_map( fun | Ctx.VarEntry({typ: {term: Arrow(_, ty_out), _} as ty_arr, name, _}) @@ -61,7 +72,8 @@ let bound_aps = (ty_expect: Typ.t, ctx: Ctx.t): list(Suggestion.t) => ctx, ); -let bound_constructor_aps = (wrap, ty: Typ.t, ctx: Ctx.t): list(Suggestion.t) => +let bound_constructor_aps = + (wrap, ty: Typ.t(IdTag.t), ctx: Ctx.t(IdTag.t)): list(Suggestion.t) => List.filter_map( fun | Ctx.ConstructorEntry({ @@ -78,7 +90,7 @@ let bound_constructor_aps = (wrap, ty: Typ.t, ctx: Ctx.t): list(Suggestion.t) => ); /* Suggest bound type aliases in type annotations or definitions */ -let typ_context_entries = (ctx: Ctx.t): list(Suggestion.t) => +let typ_context_entries = (ctx: Ctx.t(IdTag.t)): list(Suggestion.t) => List.filter_map( fun | Ctx.TVarEntry({kind: Singleton(_), name, _}) => diff --git a/src/haz3lcore/assistant/AssistantForms.re b/src/haz3lcore/assistant/AssistantForms.re index 928a159f4a..2244f73cd2 100644 --- a/src/haz3lcore/assistant/AssistantForms.re +++ b/src/haz3lcore/assistant/AssistantForms.re @@ -11,9 +11,9 @@ let leading_expander = " "; * running Statics, but for now, new forms e.g. operators must be added * below manually. */ module Typ = { - let unk: Typ.t = Unknown(Internal) |> Typ.fresh; + let unk: Typ.t(IdTag.t) = Unknown(Internal) |> Typ.fresh; - let of_const_mono_delim: list((Token.t, Typ.t)) = [ + let of_const_mono_delim: list((Token.t, Typ.t(IdTag.t))) = [ ("true", Bool |> Typ.fresh), ("false", Bool |> Typ.fresh), //("[]", List(unk)), / *NOTE: would need to refactor buffer for this to show up */ @@ -22,12 +22,12 @@ module Typ = { ("_", unk), ]; - let of_leading_delim: list((Token.t, Typ.t)) = [ + let of_leading_delim: list((Token.t, Typ.t(IdTag.t))) = [ ("case" ++ leading_expander, unk), ("fun" ++ leading_expander, Arrow(unk, unk) |> Typ.fresh), ( "typfun" ++ leading_expander, - Forall(Var("") |> TPat.fresh, unk) |> Typ.fresh, + Forall((Var(""): TPat.term(IdTag.t)) |> TPat.fresh, unk) |> Typ.fresh, ), ("if" ++ leading_expander, unk), ("let" ++ leading_expander, unk), @@ -35,7 +35,7 @@ module Typ = { ("type" ++ leading_expander, unk), ]; - let of_infix_delim: list((Token.t, Typ.term)) = [ + let of_infix_delim: list((Token.t, Typ.term(IdTag.t))) = [ //("|>", Unknown(Internal)), /* annoying during case rules */ (",", Prod([unk, unk])), /* NOTE: Current approach doesn't work for this, but irrelevant as 1-char */ ("::", List(unk)), /* annoying in patterns */ @@ -71,7 +71,7 @@ module Typ = { ("++", String), ]; - let expected: Info.t => Typ.t = + let expected: Info.t => Typ.t(IdTag.t) = fun | InfoExp({mode, _}) | InfoPat({mode, _}) => Mode.ty_of(mode) @@ -79,12 +79,12 @@ module Typ = { let filter_by = ( - ctx: Ctx.t, - expected_ty: Typ.t, - self_tys: list((Token.t, Typ.t)), + ctx: Ctx.t(IdTag.t), + expected_ty: Typ.t(IdTag.t), + self_tys: list((Token.t, Typ.t(IdTag.t))), delims: list(string), ) - : list((Token.t, Typ.t)) => + : list((Token.t, Typ.t(IdTag.t))) => List.filter_map( delim => { let* self_ty = List.assoc_opt(delim, self_tys); @@ -198,7 +198,7 @@ let suggest_form = (ty_map, delims_of_sort, ci: Info.t): list(Suggestion.t) => { let suggest_operator: Info.t => list(Suggestion.t) = suggest_form( - List.map(((a, b)) => (a, IdTagged.fresh(b)), Typ.of_infix_delim), + List.map(((a, b)) => (a, Annotated.fresh(b)), Typ.of_infix_delim), Delims.infix, ); diff --git a/src/haz3lcore/assistant/Suggestion.re b/src/haz3lcore/assistant/Suggestion.re index 2f416a80f4..57dde1c609 100644 --- a/src/haz3lcore/assistant/Suggestion.re +++ b/src/haz3lcore/assistant/Suggestion.re @@ -37,9 +37,9 @@ type strategy_all = [@deriving (show({with_path: false}), sexp, yojson)] type strategy_common = - | NewForm(Typ.t) - | FromCtx(Typ.t) - | FromCtxAp(Typ.t); + | NewForm(Typ.t(IdTag.t)) + | FromCtx(Typ.t(IdTag.t)) + | FromCtxAp(Typ.t(IdTag.t)); [@deriving (show({with_path: false}), sexp, yojson)] type strategy_exp = @@ -48,7 +48,7 @@ type strategy_exp = [@deriving (show({with_path: false}), sexp, yojson)] type strategy_pat = | Common(strategy_common) - | FromCoCtx(Typ.t); + | FromCoCtx(Typ.t(IdTag.t)); [@deriving (show({with_path: false}), sexp, yojson)] type strategy_typ = diff --git a/src/haz3lcore/dynamics/Builtins.re b/src/haz3lcore/dynamics/Builtins.re index a16d0db583..41533e0506 100644 --- a/src/haz3lcore/dynamics/Builtins.re +++ b/src/haz3lcore/dynamics/Builtins.re @@ -1,5 +1,5 @@ open DHExp; -open Sexplib.Conv; +// open Sexplib.Conv; /* Built-in functions for Hazel. @@ -10,29 +10,32 @@ open Sexplib.Conv; See the existing ones for reference. */ [@deriving (show({with_path: false}), sexp)] -type foo = DHExp.t(list(Id.t)); -[@deriving (show({with_path: false}), sexp)] type builtin = - | Const(Typ.t, foo) - | Fn(Typ.t, Typ.t, DHExp.t(list(Id.t)) => DHExp.t(list(Id.t))); + | Const(Typ.t(IdTag.t), DHExp.t(IdTag.t)) + | Fn( + Typ.t(IdTag.t), + Typ.t(IdTag.t), + DHExp.t(IdTag.t) => DHExp.t(IdTag.t), + ); [@deriving (show({with_path: false}), sexp)] type t = VarMap.t_(builtin); [@deriving (show({with_path: false}), sexp)] -type forms = VarMap.t_(DHExp.t(list(Id.t)) => DHExp.t(list(Id.t))); +type forms = VarMap.t_(DHExp.t(IdTag.t) => DHExp.t(IdTag.t)); -type result = Result.t(DHExp.t(list(Id.t)), EvaluatorError.t); +type result = Result.t(DHExp.t(IdTag.t), EvaluatorError.t); let const = - (name: Var.t, typ: Typ.term, v: DHExp.t(list(Id.t)), builtins: t): t => + (name: Var.t, typ: Typ.term(IdTag.t), v: DHExp.t(IdTag.t), builtins: t) + : t => VarMap.extend(builtins, (name, Const(typ |> Typ.fresh, v))); let fn = ( name: Var.t, - t1: Typ.term, - t2: Typ.term, - impl: DHExp.t(list(Id.t)) => DHExp.t(list(Id.t)), + t1: Typ.term(IdTag.t), + t2: Typ.term(IdTag.t), + impl: DHExp.t(IdTag.t) => DHExp.t(IdTag.t), builtins: t, ) : t => @@ -52,7 +55,7 @@ module Pervasives = { let max_int = DHExp.Int(Int.max_int) |> fresh; let min_int = DHExp.Int(Int.min_int) |> fresh; - let unary = (f: DHExp.t(list(Id.t)) => result, d: DHExp.t(list(Id.t))) => { + let unary = (f: DHExp.t(IdTag.t) => result, d: DHExp.t(IdTag.t)) => { switch (f(d)) { | Ok(r') => r' | Error(e) => EvaluatorError.Exception(e) |> raise @@ -61,8 +64,8 @@ module Pervasives = { let binary = ( - f: (DHExp.t(list(Id.t)), DHExp.t(list(Id.t))) => result, - d: DHExp.t(list(Id.t)), + f: (DHExp.t(IdTag.t), DHExp.t(IdTag.t)) => result, + d: DHExp.t(IdTag.t), ) => { switch (term_of(d)) { | Tuple([d1, d2]) => @@ -77,13 +80,8 @@ module Pervasives = { let ternary = ( f: - ( - DHExp.t(list(Id.t)), - DHExp.t(list(Id.t)), - DHExp.t(list(Id.t)) - ) => - result, - d: DHExp.t(list(Id.t)), + (DHExp.t(IdTag.t), DHExp.t(IdTag.t), DHExp.t(IdTag.t)) => result, + d: DHExp.t(IdTag.t), ) => { switch (term_of(d)) { | Tuple([d1, d2, d3]) => @@ -192,7 +190,7 @@ module Pervasives = { let of_string = ( convert: string => option('a), - wrap: 'a => DHExp.t(list(Id.t)), + wrap: 'a => DHExp.t(IdTag.t), name: string, ) => unary(d => @@ -266,7 +264,7 @@ module Pervasives = { } ); - let string_of: DHExp.t(list(Id.t)) => option(string) = + let string_of: DHExp.t(IdTag.t) => option(string) = d => switch (term_of(d)) { | String(s) => Some(s) @@ -370,8 +368,8 @@ module Pervasives = { ); }; -let ctx_init: Ctx.t = { - let meta_cons_map: ConstructorMap.t(Typ.t) = [ +let ctx_init: Ctx.t(IdTag.t) = { + let meta_cons_map: ConstructorMap.t(Typ.t(IdTag.t)) = [ Variant("$e", [Id.mk()], None), Variant("$v", [Id.mk()], None), ]; diff --git a/src/haz3lcore/dynamics/Casts.re b/src/haz3lcore/dynamics/Casts.re index 566c966cba..060ca385fa 100644 --- a/src/haz3lcore/dynamics/Casts.re +++ b/src/haz3lcore/dynamics/Casts.re @@ -25,7 +25,7 @@ open Util; type ground_cases = | Hole | Ground - | NotGroundOrHole(Typ.t) /* the argument is the corresponding ground type */; + | NotGroundOrHole(Typ.t(IdTag.t)) /* the argument is the corresponding ground type */; let grounded_Arrow = NotGroundOrHole( @@ -34,7 +34,10 @@ let grounded_Arrow = ); let grounded_Forall = NotGroundOrHole( - Forall(EmptyHole |> TPat.fresh, Unknown(Internal) |> Typ.temp) + Forall( + (EmptyHole: TPat.term(IdTag.t)) |> TPat.fresh, + Unknown(Internal) |> Typ.temp, + ) |> Typ.temp, ); let grounded_Prod = length => @@ -42,13 +45,13 @@ let grounded_Prod = length => Prod(ListUtil.replicate(length, Typ.Unknown(Internal) |> Typ.temp)) |> Typ.temp, ); -let grounded_Sum: unit => Typ.sum_map = +let grounded_Sum: unit => Typ.sum_map(IdTag.t) = () => [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 = +let rec ground_cases_of = (ty: Typ.t('a)): ground_cases => { + let is_hole: Typ.t(IdTag.t) => bool = fun | {term: Typ.Unknown(_), _} => true | _ => false; @@ -67,7 +70,7 @@ let rec ground_cases_of = (ty: Typ.t): ground_cases => { | Prod(tys) => if (List.for_all( fun - | ({term: Typ.Unknown(_), _}: Typ.t) => true + | ({term: Typ.Unknown(_), _}: Typ.t('a)) => true | _ => false, tys, )) { @@ -91,8 +94,7 @@ let rec ground_cases_of = (ty: Typ.t): ground_cases => { /* gives a transition step that can be taken by the cast calculus here if applicable. */ let rec transition = - (~recursive=false, d: DHExp.t(list(Id.t))) - : option(DHExp.t(list(Id.t))) => { + (~recursive=false, d: DHExp.t(IdTag.t)): option(DHExp.t(IdTag.t)) => { switch (DHExp.term_of(d)) { | Cast(d1, t1, t2) => let d1 = @@ -170,8 +172,7 @@ let rec transition = }; }; -let rec transition_multiple = - (d: DHExp.t(list(Id.t))): DHExp.t(list(Id.t)) => { +let rec transition_multiple = (d: DHExp.t(IdTag.t)): DHExp.t(IdTag.t) => { switch (transition(~recursive=true, d)) { | Some(d'') => transition_multiple(d'') | None => d @@ -183,25 +184,39 @@ 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(list(Id.t))) => { +let pattern_fixup = (p: DHPat.t(IdTag.t)): DHPat.t(IdTag.t) => { + let rec unwrap_casts = + (p: DHPat.t(IdTag.t)): (DHPat.t(IdTag.t), DHExp.t(IdTag.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} + { + term: DHExp.Cast(d1, t1, t2), + annotation: { + copied: p.annotation.copied, + ids: p.annotation.ids, + }, + } |> transition_multiple, ); | _ => (p, hole) }; }; - let rec rewrap_casts = ((p: DHPat.t, d: DHExp.t(list(Id.t)))): DHPat.t => { + let rec rewrap_casts = + ((p: DHPat.t(IdTag.t), d: DHExp.t(IdTag.t))): DHPat.t(IdTag.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}; + { + term: DHPat.Cast(p1, t1, t2), + annotation: { + copied: d.annotation.copied, + ids: d.annotation.ids, + }, + }; | FailedCast(d1, t1, t2) => let p1 = rewrap_casts((p, d1)); { @@ -211,8 +226,10 @@ let pattern_fixup = (p: DHPat.t): DHPat.t => { Typ.fresh(Unknown(Internal)), t2, ), - copied: d.copied, - ids: d.ids, + annotation: { + copied: d.annotation.copied, + ids: d.annotation.ids, + }, }; | _ => failwith("unexpected term in rewrap_casts") }; diff --git a/src/haz3lcore/dynamics/DHExp.re b/src/haz3lcore/dynamics/DHExp.re index e1834ded7e..f8c5ff0a8a 100644 --- a/src/haz3lcore/dynamics/DHExp.re +++ b/src/haz3lcore/dynamics/DHExp.re @@ -7,29 +7,82 @@ include Exp; -let term_of: t(list(Id.t)) => term(list(Id.t)) = IdTagged.term_of; -let fast_copy: (Id.t, t(list(Id.t))) => t(list(Id.t)) = IdTagged.fast_copy; +let term_of: t(IdTag.t) => term(IdTag.t) = Annotated.term_of; +let fast_copy: (Id.t, t(IdTag.t)) => t(IdTag.t) = Annotated.fast_copy; -let mk = (ids, term): t(list(Id.t)) => { - {ids, copied: true, term}; +let mk = (ids: list(Id.t), term): t(IdTag.t) => { + { + term, + annotation: { + ids, + copied: true, + }, + }; }; // TODO: make this function emit a map of changes -let replace_all_ids = +let replace_all_ids = (x: t(IdTag.t)): t(IdTag.t) => 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, + ~f_exp= + (continue, exp: TermBase.Exp.t(IdTag.t)) => { + { + ...exp, + annotation: { + ...exp.annotation, + ids: [Id.mk()], + }, + } + |> continue + }, + ~f_pat= + (continue, exp) => + { + ...exp, + annotation: { + ...exp.annotation, + ids: [Id.mk()], + }, + } + |> continue, + ~f_typ= + (continue, exp) => + { + ...exp, + annotation: { + ...exp.annotation, + ids: [Id.mk()], + }, + } + |> continue, + ~f_tpat= + (continue, exp) => + { + ...exp, + annotation: { + ...exp.annotation, + ids: [Id.mk()], + }, + } + |> continue, + ~f_rul= + (continue, exp) => + { + ...exp, + annotation: { + ...exp.annotation, + ids: [Id.mk()], + }, + } + |> continue, + x, ); // TODO: make this function emit a map of changes let repair_ids = map_term( ~f_exp= - (continue, exp) => - if (exp.copied) { + (continue, exp: TermBase.Exp.t(IdTag.t)) => + if (exp.annotation.copied) { replace_all_ids(exp); } else { continue(exp); @@ -95,7 +148,9 @@ let assign_name_if_none = (t, name) => { }; }; -let ty_subst = (s: Typ.t, tpat: TPat.t, exp: t(list(Id.t))): t(list(Id.t)) => { +let ty_subst = + (s: Typ.t(IdTag.t), tpat: TPat.t(IdTag.t), exp: t(IdTag.t)) + : t(IdTag.t) => { switch (TPat.tyvar_of_utpat(tpat)) { | None => exp | Some(x) => diff --git a/src/haz3lcore/dynamics/DHPat.re b/src/haz3lcore/dynamics/DHPat.re index f9e4adbddb..00bf55e93d 100644 --- a/src/haz3lcore/dynamics/DHPat.re +++ b/src/haz3lcore/dynamics/DHPat.re @@ -7,7 +7,7 @@ include Pat; /** * Whether dp contains the variable x outside of a hole. */ -let rec binds_var = (m: Statics.Map.t, x: Var.t, dp: t): bool => +let rec binds_var = (m: Statics.Map.t, x: Var.t, dp: t('a)): bool => switch (Statics.get_pat_error_at(m, rep_id(dp))) { | Some(_) => false | None => @@ -33,7 +33,7 @@ let rec binds_var = (m: Statics.Map.t, x: Var.t, dp: t): bool => } }; -let rec bound_vars = (dp: t): list(Var.t) => +let rec bound_vars = (dp: t('a)): list(Var.t) => switch (dp |> term_of) { | EmptyHole | MultiHole(_) diff --git a/src/haz3lcore/dynamics/Delta.re b/src/haz3lcore/dynamics/Delta.re index fee0455685..bba9cff4cc 100644 --- a/src/haz3lcore/dynamics/Delta.re +++ b/src/haz3lcore/dynamics/Delta.re @@ -4,7 +4,7 @@ type hole_sort = | PatternHole; [@deriving sexp] -type val_ty = (hole_sort, Typ.t, Ctx.t); +type val_ty = (hole_sort, Typ.t(IdTag.t), Ctx.t(IdTag.t)); [@deriving sexp] type t = Id.Map.t(val_ty); diff --git a/src/haz3lcore/dynamics/Delta.rei b/src/haz3lcore/dynamics/Delta.rei index ce58db058d..03dae61d2f 100644 --- a/src/haz3lcore/dynamics/Delta.rei +++ b/src/haz3lcore/dynamics/Delta.rei @@ -4,7 +4,7 @@ type hole_sort = | PatternHole; [@deriving sexp] -type val_ty = (hole_sort, Typ.t, Ctx.t); +type val_ty = (hole_sort, Typ.t(IdTag.t), Ctx.t(IdTag.t)); [@deriving sexp] type t = Id.Map.t(val_ty); diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/dynamics/Elaborator.re index 482bc71ff9..af366bdd26 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/dynamics/Elaborator.re @@ -8,18 +8,19 @@ exception MissingTypeInfo; module Elaboration = { [@deriving (show({with_path: false}), sexp, yojson)] - type t = {d: DHExp.t(list(Id.t))}; + type t = {d: DHExp.t(IdTag.t)}; }; module ElaborationResult = { [@deriving sexp] type t = - | Elaborates(DHExp.t(list(Id.t)), Typ.t, Delta.t) + | Elaborates(DHExp.t(IdTag.t), Typ.t(IdTag.t), Delta.t) | DoesNotElaborate; }; let fresh_cast = - (d: DHExp.t(list(Id.t)), t1: Typ.t, t2: Typ.t): DHExp.t(list(Id.t)) => { + (d: DHExp.t(IdTag.t), t1: Typ.t(IdTag.t), t2: Typ.t(IdTag.t)) + : DHExp.t(IdTag.t) => { Typ.eq(t1, t2) ? d : { @@ -33,7 +34,9 @@ let fresh_cast = }; }; -let fresh_pat_cast = (p: DHPat.t, t1: Typ.t, t2: Typ.t): DHPat.t => { +let fresh_pat_cast = + (p: DHPat.t(IdTag.t), t1: Typ.t(IdTag.t), t2: Typ.t(IdTag.t)) + : DHPat.t(IdTag.t) => { Typ.eq(t1, t2) ? p : { @@ -49,7 +52,8 @@ let fresh_pat_cast = (p: DHPat.t, t1: Typ.t, t2: Typ.t): DHPat.t => { }; let elaborated_type = - (m: Statics.Map.t, uexp: UExp.t(list(Id.t))): (Typ.t, Ctx.t, 'a) => { + (m: Statics.Map.t, uexp: UExp.t(IdTag.t)) + : (Typ.t(IdTag.t), Ctx.t(IdTag.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, _})) => ( @@ -68,7 +72,11 @@ let elaborated_type = 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)); + let tpat = + Option.value( + tpat, + ~default=TPat.fresh(EmptyHole: TPat.term(IdTag.t)), + ); 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) @@ -76,7 +84,9 @@ let elaborated_type = (elab_ty |> Typ.normalize(ctx), ctx, co_ctx); }; -let elaborated_pat_type = (m: Statics.Map.t, upat: UPat.t): (Typ.t, Ctx.t) => { +let elaborated_pat_type = + (m: Statics.Map.t, upat: UPat.t(IdTag.t)) + : (Typ.t(IdTag.t), Ctx.t(IdTag.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, _})) => ( @@ -95,7 +105,11 @@ let elaborated_pat_type = (m: Statics.Map.t, upat: UPat.t): (Typ.t, Ctx.t) => { 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)); + let tpat = + Option.value( + tpat, + ~default=TPat.fresh(EmptyHole: TPat.term(IdTag.t)), + ); Typ.Forall(tpat, ty) |> Typ.temp; | Ana(ana_ty) => switch (prev_synswitch) { @@ -107,7 +121,8 @@ let elaborated_pat_type = (m: Statics.Map.t, upat: UPat.t): (Typ.t, Ctx.t) => { }; let rec elaborate_pattern = - (m: Statics.Map.t, upat: UPat.t): (DHPat.t, Typ.t) => { + (m: Statics.Map.t, upat: UPat.t(IdTag.t)) + : (DHPat.t(IdTag.t), Typ.t(IdTag.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); @@ -161,7 +176,9 @@ let rec elaborate_pattern = upat |> cast_from( Ctx.lookup_var(ctx, v) - |> Option.map((x: Ctx.var_entry) => x.typ |> Typ.normalize(ctx)) + |> Option.map((x: Ctx.var_entry(IdTag.t)) => + x.typ |> Typ.normalize(ctx) + ) |> Option.value(~default=Typ.temp(Unknown(Internal))), ) // Type annotations should already appear @@ -208,8 +225,8 @@ let rec elaborate_pattern = 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(list(Id.t))) - : (DHExp.t(list(Id.t)), Typ.t) => { + (m: Statics.Map.t, uexp: UExp.t(IdTag.t)) + : (DHExp.t(IdTag.t), Typ.t(IdTag.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); @@ -285,12 +302,13 @@ let rec elaborate = uexp |> cast_from( Ctx.lookup_var(ctx, v) - |> Option.map((x: Ctx.var_entry) => x.typ |> Typ.normalize(ctx)) + |> Option.map((x: Ctx.var_entry(IdTag.t)) => + x.typ |> Typ.normalize(ctx) + ) |> Option.value(~default=Typ.temp(Typ.Unknown(Internal))), ) | Let(p, def, body) => - let add_name: - (option(string), DHExp.t(list(Id.t))) => DHExp.t(list(Id.t)) = ( + let add_name: (option(string), DHExp.t(IdTag.t)) => DHExp.t(IdTag.t) = ( (name, exp) => { let (term, rewrap) = DHExp.unwrap(exp); switch (term) { @@ -366,7 +384,10 @@ let rec elaborate = let tye'' = Typ.subst( ut', - tpat |> Option.value(~default=TPat.fresh(EmptyHole)), + tpat + |> Option.value( + ~default=TPat.fresh(EmptyHole: TPat.term(IdTag.t)), + ), tye', ); TypAp(e', ut) |> rewrap |> cast_from(tye''); @@ -537,7 +558,7 @@ let rec elaborate = uexp |> cast_from( Ctx.lookup_var(Builtins.ctx_init, fn) - |> Option.map((x: Ctx.var_entry) => x.typ) + |> Option.map((x: Ctx.var_entry(IdTag.t)) => x.typ) |> Option.value(~default=Typ.temp(Typ.Unknown(Internal))), ) | Match(e, cases) => @@ -571,10 +592,9 @@ let rec elaborate = 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); + Exp.map_term(~f_typ=(cont, e) => e |> Annotated.new_ids |> cont); -let uexp_elab = - (m: Statics.Map.t, uexp: UExp.t(list(Id.t))): ElaborationResult.t => +let uexp_elab = (m: Statics.Map.t, uexp: UExp.t('a)): ElaborationResult.t => switch (elaborate(m, uexp)) { | exception MissingTypeInfo => DoesNotElaborate | (d, ty) => Elaborates(d, ty, Delta.empty) diff --git a/src/haz3lcore/dynamics/EvalCtx.re b/src/haz3lcore/dynamics/EvalCtx.re index 23227822f9..e8c71d9c87 100644 --- a/src/haz3lcore/dynamics/EvalCtx.re +++ b/src/haz3lcore/dynamics/EvalCtx.re @@ -3,47 +3,47 @@ open Util; [@deriving (show({with_path: false}), sexp, yojson)] type term = | Closure([@show.opaque] ClosureEnvironment.t, t) - | Filter(TermBase.StepperFilterKind.t, t) - | Seq1(t, DHExp.t(list(Id.t))) - | Seq2(DHExp.t(list(Id.t)), t) - | Let1(Pat.t, t, DHExp.t(list(Id.t))) - | Let2(Pat.t, DHExp.t(list(Id.t)), t) - | Fun(Pat.t, t, option(ClosureEnvironment.t), option(Var.t)) - | FixF(Pat.t, t, option(ClosureEnvironment.t)) - | TypAp(t, Typ.t) - | Ap1(Operators.ap_direction, t, DHExp.t(list(Id.t))) - | Ap2(Operators.ap_direction, DHExp.t(list(Id.t)), t) - | DeferredAp1(t, list(DHExp.t(list(Id.t)))) + | Filter(TermBase.StepperFilterKind.t(IdTag.t), t) + | Seq1(t, DHExp.t(IdTag.t)) + | Seq2(DHExp.t(IdTag.t), t) + | Let1(Pat.t(IdTag.t), t, DHExp.t(IdTag.t)) + | Let2(Pat.t(IdTag.t), DHExp.t(IdTag.t), t) + | Fun(Pat.t(IdTag.t), t, option(ClosureEnvironment.t), option(Var.t)) + | FixF(Pat.t(IdTag.t), t, option(ClosureEnvironment.t)) + | TypAp(t, Typ.t(IdTag.t)) + | Ap1(Operators.ap_direction, t, DHExp.t(IdTag.t)) + | Ap2(Operators.ap_direction, DHExp.t(IdTag.t), t) + | DeferredAp1(t, list(DHExp.t(IdTag.t))) | DeferredAp2( - DHExp.t(list(Id.t)), + DHExp.t(IdTag.t), t, - (list(DHExp.t(list(Id.t))), list(DHExp.t(list(Id.t)))), + (list(DHExp.t(IdTag.t)), list(DHExp.t(IdTag.t))), ) - | If1(t, DHExp.t(list(Id.t)), DHExp.t(list(Id.t))) - | If2(DHExp.t(list(Id.t)), t, DHExp.t(list(Id.t))) - | If3(DHExp.t(list(Id.t)), DHExp.t(list(Id.t)), t) + | If1(t, DHExp.t(IdTag.t), DHExp.t(IdTag.t)) + | If2(DHExp.t(IdTag.t), t, DHExp.t(IdTag.t)) + | If3(DHExp.t(IdTag.t), DHExp.t(IdTag.t), t) | UnOp(Operators.op_un, t) - | BinOp1(Operators.op_bin, t, DHExp.t(list(Id.t))) - | BinOp2(Operators.op_bin, DHExp.t(list(Id.t)), t) - | Tuple(t, (list(DHExp.t(list(Id.t))), list(DHExp.t(list(Id.t))))) + | BinOp1(Operators.op_bin, t, DHExp.t(IdTag.t)) + | BinOp2(Operators.op_bin, DHExp.t(IdTag.t), t) + | Tuple(t, (list(DHExp.t(IdTag.t)), list(DHExp.t(IdTag.t)))) | Test(t) - | ListLit(t, (list(DHExp.t(list(Id.t))), list(DHExp.t(list(Id.t))))) - | MultiHole(t, (list(Any.t), list(Any.t))) - | Cons1(t, DHExp.t(list(Id.t))) - | Cons2(DHExp.t(list(Id.t)), t) - | ListConcat1(t, DHExp.t(list(Id.t))) - | ListConcat2(DHExp.t(list(Id.t)), t) - | Cast(t, Typ.t, Typ.t) - | FailedCast(t, Typ.t, Typ.t) + | ListLit(t, (list(DHExp.t(IdTag.t)), list(DHExp.t(IdTag.t)))) + | MultiHole(t, (list(Any.t(IdTag.t)), list(Any.t(IdTag.t)))) + | Cons1(t, DHExp.t(IdTag.t)) + | Cons2(DHExp.t(IdTag.t), t) + | ListConcat1(t, DHExp.t(IdTag.t)) + | ListConcat2(DHExp.t(IdTag.t), t) + | Cast(t, Typ.t(IdTag.t), Typ.t(IdTag.t)) + | FailedCast(t, Typ.t(IdTag.t), Typ.t(IdTag.t)) | DynamicErrorHole(t, InvalidOperationError.t) - | MatchScrut(t, list((UPat.t, DHExp.t(list(Id.t))))) + | MatchScrut(t, list((UPat.t(IdTag.t), DHExp.t(IdTag.t)))) | MatchRule( - DHExp.t(list(Id.t)), - UPat.t, + DHExp.t(IdTag.t), + UPat.t(IdTag.t), t, ( - list((UPat.t, DHExp.t(list(Id.t)))), - list((UPat.t, DHExp.t(list(Id.t)))), + list((UPat.t(IdTag.t), DHExp.t(IdTag.t))), + list((UPat.t(IdTag.t), DHExp.t(IdTag.t))), ), ) and t = @@ -53,7 +53,7 @@ and t = ids: list(Id.t), }); -let rec compose = (ctx: t, d: DHExp.t(list(Id.t))): DHExp.t(list(Id.t)) => { +let rec compose = (ctx: t, d: DHExp.t(IdTag.t)): DHExp.t(IdTag.t) => { switch (ctx) { | Mark => d | Term({term, ids}) => diff --git a/src/haz3lcore/dynamics/Evaluator.re b/src/haz3lcore/dynamics/Evaluator.re index 4407ef3285..f75b161237 100644 --- a/src/haz3lcore/dynamics/Evaluator.re +++ b/src/haz3lcore/dynamics/Evaluator.re @@ -1,12 +1,12 @@ open Transition; -open Sexplib.Conv; -open Ppx_yojson_conv_lib.Yojson_conv; +// open Sexplib.Conv; +// open Ppx_yojson_conv_lib.Yojson_conv; module Result = { [@deriving (show({with_path: false}), sexp, yojson)] type t = - | BoxedValue(DHExp.t(list(Id.t))) - | Indet(DHExp.t(list(Id.t))); + | BoxedValue(DHExp.t(IdTag.t)) + | Indet(DHExp.t(IdTag.t)); let unbox = fun @@ -32,14 +32,14 @@ module EvaluatorEVMode: { include EV_MODE with type state = ref(EvaluatorState.t) and - type result = (status, DHExp.t(list(Id.t))); + type result = (status, DHExp.t(IdTag.t)); } = { type status = | BoxedValue | Indet | Uneval; - type result = (status, DHExp.t(list(Id.t))); + type result = (status, DHExp.t(IdTag.t)); type reqstate = | BoxedReady diff --git a/src/haz3lcore/dynamics/EvaluatorError.re b/src/haz3lcore/dynamics/EvaluatorError.re index f5a9311d3b..8bbd8d948c 100644 --- a/src/haz3lcore/dynamics/EvaluatorError.re +++ b/src/haz3lcore/dynamics/EvaluatorError.re @@ -5,18 +5,18 @@ type t = | OutOfFuel | StepDoesNotMatch | BadPatternMatch - | CastBVHoleGround(DHExp.t(list(Id.t))) - | InvalidBoxedTypFun(DHExp.t(list(Id.t))) - | InvalidBoxedFun(DHExp.t(list(Id.t))) - | InvalidBoxedBoolLit(DHExp.t(list(Id.t))) - | InvalidBoxedIntLit(DHExp.t(list(Id.t))) - | InvalidBoxedFloatLit(DHExp.t(list(Id.t))) - | InvalidBoxedListLit(DHExp.t(list(Id.t))) - | InvalidBoxedStringLit(DHExp.t(list(Id.t))) - | InvalidBoxedSumConstructor(DHExp.t(list(Id.t))) - | InvalidBoxedTuple(DHExp.t(list(Id.t))) + | CastBVHoleGround(DHExp.t(IdTag.t)) + | InvalidBoxedTypFun(DHExp.t(IdTag.t)) + | InvalidBoxedFun(DHExp.t(IdTag.t)) + | InvalidBoxedBoolLit(DHExp.t(IdTag.t)) + | InvalidBoxedIntLit(DHExp.t(IdTag.t)) + | InvalidBoxedFloatLit(DHExp.t(IdTag.t)) + | InvalidBoxedListLit(DHExp.t(IdTag.t)) + | InvalidBoxedStringLit(DHExp.t(IdTag.t)) + | InvalidBoxedSumConstructor(DHExp.t(IdTag.t)) + | InvalidBoxedTuple(DHExp.t(IdTag.t)) | InvalidBuiltin(string) - | BadBuiltinAp(string, list(DHExp.t(list(Id.t)))) + | BadBuiltinAp(string, list(DHExp.t(IdTag.t))) | InvalidProjection(int); exception Exception(t); diff --git a/src/haz3lcore/dynamics/EvaluatorStep.re b/src/haz3lcore/dynamics/EvaluatorStep.re index 580877cc2d..42fed5e3e3 100644 --- a/src/haz3lcore/dynamics/EvaluatorStep.re +++ b/src/haz3lcore/dynamics/EvaluatorStep.re @@ -1,13 +1,13 @@ open Transition; open Sexplib.Conv; -open Ppx_yojson_conv_lib.Yojson_conv; +// open Ppx_yojson_conv_lib.Yojson_conv; [@deriving (show({with_path: false}), sexp, yojson)] type step = { - d: DHExp.t(list(Id.t)), // technically can be calculated from d_loc and ctx + d: DHExp.t(IdTag.t), // technically can be calculated from d_loc and ctx state: EvaluatorState.t, - d_loc: DHExp.t(list(Id.t)), // the expression at the location given by ctx - d_loc': DHExp.t(list(Id.t)), + d_loc: DHExp.t(IdTag.t), // the expression at the location given by ctx + d_loc': DHExp.t(IdTag.t), ctx: EvalCtx.t, knd: step_kind, }; @@ -16,7 +16,7 @@ module EvalObj = { [@deriving (show({with_path: false}), sexp, yojson)] type t = { env: ClosureEnvironment.t, // technically can be calculated from ctx - d_loc: DHExp.t(list(Id.t)), + d_loc: DHExp.t(IdTag.t), ctx: EvalCtx.t, knd: step_kind, }; @@ -131,8 +131,7 @@ module Decompose = { req_all_final'(cont, wr, [], ds); }; - let (let.): - (requirements('a, DHExp.t(list(Id.t))), 'a => rule) => result = + let (let.): (requirements('a, DHExp.t(IdTag.t)), 'a => rule) => result = (rq, rl) => switch (rq) { | (_, Result.Indet, _, _) => Result.Indet @@ -169,13 +168,13 @@ module TakeStep = { module TakeStepEVMode: { include EV_MODE with - type result = option(DHExp.t(list(Id.t))) and + type result = option(DHExp.t(IdTag.t)) and type state = ref(EvaluatorState.t); } = { type state = ref(EvaluatorState.t); type requirement('a) = 'a; type requirements('a, 'b) = 'a; - type result = option(DHExp.t(list(Id.t))); + type result = option(DHExp.t(IdTag.t)); // Assume that everything is either value or final as required. let req_value = (_, _, d) => d; @@ -185,8 +184,7 @@ module TakeStep = { let req_final_or_value = (_, _, d) => (d, true); - let (let.) = - (rq: requirements('a, DHExp.t(list(Id.t))), rl: 'a => rule) => + let (let.) = (rq: requirements('a, DHExp.t(IdTag.t)), rl: 'a => rule) => switch (rl(rq)) { | Step({expr, state_update, _}) => state_update(); @@ -211,7 +209,7 @@ module TakeStep = { let take_step = TakeStep.take_step; -let decompose = (d: DHExp.t(list(Id.t)), es: EvaluatorState.t) => { +let decompose = (d: DHExp.t(IdTag.t), es: EvaluatorState.t) => { let env = ClosureEnvironment.of_environment(Builtins.env_init); let rs = Decompose.decompose(ref(es), env, d); Decompose.Result.unbox(rs); @@ -220,9 +218,9 @@ let decompose = (d: DHExp.t(list(Id.t)), es: EvaluatorState.t) => { let rec matches = ( env: ClosureEnvironment.t, - flt: FilterEnvironment.t, + flt: FilterEnvironment.t(IdTag.t), ctx: EvalCtx.t, - exp: DHExp.t(list(Id.t)), + exp: DHExp.t(IdTag.t), act: FilterAction.t, idx: int, ) diff --git a/src/haz3lcore/dynamics/FilterEnvironment.re b/src/haz3lcore/dynamics/FilterEnvironment.re index 284e7353d3..25f91d37f5 100644 --- a/src/haz3lcore/dynamics/FilterEnvironment.re +++ b/src/haz3lcore/dynamics/FilterEnvironment.re @@ -1,2 +1,2 @@ -type t = list(TermBase.StepperFilterKind.filter); +type t('a) = list(TermBase.StepperFilterKind.filter('a)); let extends = (flt, env) => [flt, ...env]; diff --git a/src/haz3lcore/dynamics/FilterMatcher.re b/src/haz3lcore/dynamics/FilterMatcher.re index df48180bdb..8ceb806495 100644 --- a/src/haz3lcore/dynamics/FilterMatcher.re +++ b/src/haz3lcore/dynamics/FilterMatcher.re @@ -1,9 +1,9 @@ let rec matches_exp = ( ~denv: ClosureEnvironment.t, - d: DHExp.t(list(Id.t)), + d: DHExp.t(IdTag.t), ~fenv: ClosureEnvironment.t, - f: DHExp.t(list(Id.t)), + f: DHExp.t(IdTag.t), ) : bool => { let matches_exp = (~denv=denv, ~fenv=fenv, d, f) => @@ -285,11 +285,11 @@ let rec matches_exp = and matches_fun = ( ~denv: ClosureEnvironment.t, - dp: DHPat.t, - d: DHExp.t(list(Id.t)), + dp: DHPat.t(IdTag.t), + d: DHExp.t(IdTag.t), ~fenv: ClosureEnvironment.t, - fp: DHPat.t, - f: DHExp.t(list(Id.t)), + fp: DHPat.t(IdTag.t), + f: DHExp.t(IdTag.t), ) => { matches_pat(dp, fp) && matches_exp( @@ -300,7 +300,7 @@ and matches_fun = ); } -and matches_pat = (d: Pat.t, f: Pat.t): bool => { +and matches_pat = (d: Pat.t(IdTag.t), f: Pat.t(IdTag.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) @@ -349,10 +349,10 @@ and matches_pat = (d: Pat.t, f: Pat.t): bool => { | (Invalid(_), _) => false }; } -and matches_typ = (d: Typ.t, f: Typ.t) => { +and matches_typ = (d: Typ.t(IdTag.t), f: Typ.t(IdTag.t)) => { Typ.eq(d, f); } -and matches_utpat = (d: TPat.t, f: TPat.t): bool => { +and matches_utpat = (d: TPat.t(IdTag.t), f: TPat.t(IdTag.t)): bool => { switch (d.term, f.term) { | (Invalid(_), _) => false | (_, Invalid(_)) => false @@ -366,8 +366,8 @@ and matches_utpat = (d: TPat.t, f: TPat.t): bool => { let matches = ( ~env: ClosureEnvironment.t, - ~exp: DHExp.t(list(Id.t)), - ~flt: TermBase.StepperFilterKind.filter, + ~exp: DHExp.t(IdTag.t), + ~flt: TermBase.StepperFilterKind.filter(IdTag.t), ) : option(FilterAction.t) => if (matches_exp(~denv=env, exp, ~fenv=env, flt.pat)) { @@ -379,7 +379,7 @@ let matches = let matches = ( ~env: ClosureEnvironment.t, - ~exp: DHExp.t(list(Id.t)), + ~exp: DHExp.t(IdTag.t), ~act: FilterAction.t, flt_env, ) diff --git a/src/haz3lcore/dynamics/PatternMatch.re b/src/haz3lcore/dynamics/PatternMatch.re index e29c1ff84e..f2e7d24779 100644 --- a/src/haz3lcore/dynamics/PatternMatch.re +++ b/src/haz3lcore/dynamics/PatternMatch.re @@ -11,7 +11,7 @@ let combine_result = (r1: match_result, r2: match_result): match_result => Matches(Environment.union(env1, env2)) }; -let rec matches = (dp: Pat.t, d: DHExp.t(list(Id.t))): match_result => +let rec matches = (dp: Pat.t(IdTag.t), d: DHExp.t(IdTag.t)): match_result => switch (DHPat.term_of(dp)) { | Invalid(_) | EmptyHole diff --git a/src/haz3lcore/dynamics/Stepper.re b/src/haz3lcore/dynamics/Stepper.re index c37bd2294c..c8748d1000 100644 --- a/src/haz3lcore/dynamics/Stepper.re +++ b/src/haz3lcore/dynamics/Stepper.re @@ -12,7 +12,7 @@ type stepper_state = | StepTimeout(EvalObj.t); [@deriving (show({with_path: false}), sexp, yojson)] -type history = Aba.t((DHExp.t(list(Id.t)), EvaluatorState.t), step); +type history = Aba.t((DHExp.t(IdTag.t), EvaluatorState.t), step); [@deriving (show({with_path: false}), sexp, yojson)] type t = { @@ -24,9 +24,9 @@ type t = { let rec matches = ( env: ClosureEnvironment.t, - flt: FilterEnvironment.t, + flt: FilterEnvironment.t(IdTag.t), ctx: EvalCtx.t, - exp: DHExp.t(list(Id.t)), + exp: DHExp.t(IdTag.t), act: FilterAction.t, idx: int, ) @@ -247,7 +247,7 @@ let rec evaluate_pending = (~settings, s: t) => { } ) |> DHExp.repair_ids; - let _ = print_endline(d_loc' |> [%derive.show: DHExp.t(list(Id.t))]); + let _ = print_endline(d_loc' |> [%derive.show: DHExp.t(IdTag.t)]); let d' = EvalCtx.compose(eo.ctx, d_loc'); let new_step = { d, @@ -351,7 +351,7 @@ let get_justification: step_kind => string = | UnOp(Meta(Unquote)) => failwith("INVALID STEP"); type step_info = { - d: DHExp.t(list(Id.t)), + d: DHExp.t(IdTag.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) @@ -376,7 +376,7 @@ let get_history = (~settings, stepper) => { ( ( chosen_step: option(step), - (d: DHExp.t(list(Id.t)), hidden_steps: list(step)), + (d: DHExp.t(IdTag.t), hidden_steps: list(step)), previous_step: option(step), ), ) => { diff --git a/src/haz3lcore/dynamics/Substitution.re b/src/haz3lcore/dynamics/Substitution.re index 7b781689f6..f96595fcf9 100644 --- a/src/haz3lcore/dynamics/Substitution.re +++ b/src/haz3lcore/dynamics/Substitution.re @@ -1,7 +1,7 @@ /* closed substitution [d1/x]d2 */ let rec subst_var = - (m, d1: DHExp.t(list(Id.t)), x: Var.t, d2: DHExp.t(list(Id.t))) - : DHExp.t(list(Id.t)) => { + (m, d1: DHExp.t(IdTag.t), x: Var.t, d2: DHExp.t(IdTag.t)) + : DHExp.t(IdTag.t) => { let (term, rewrap) = DHExp.unwrap(d2); switch (term) { | Var(y) => @@ -132,14 +132,14 @@ let rec subst_var = } and subst_var_env = - (m, d1: DHExp.t(list(Id.t)), x: Var.t, env: ClosureEnvironment.t) + (m, d1: DHExp.t(IdTag.t), x: Var.t, env: ClosureEnvironment.t) : ClosureEnvironment.t => { let id = env |> ClosureEnvironment.id_of; let map = env |> ClosureEnvironment.map_of |> Environment.foldo( - ((x', d': DHExp.t(list(Id.t))), map) => { + ((x', d': DHExp.t(IdTag.t)), map) => { let d' = switch (DHExp.term_of(d')) { /* Substitute each previously substituted binding into the @@ -166,19 +166,18 @@ and subst_var_env = and subst_var_filter = ( m, - d1: DHExp.t(list(Id.t)), + d1: DHExp.t(IdTag.t), x: Var.t, - flt: TermBase.StepperFilterKind.t, + flt: TermBase.StepperFilterKind.t(IdTag.t), ) - : TermBase.StepperFilterKind.t => { + : TermBase.StepperFilterKind.t(IdTag.t) => { flt |> TermBase.StepperFilterKind.map(subst_var(m, d1, x)); }; -let subst = - (m, env: Environment.t, d: DHExp.t(list(Id.t))): DHExp.t(list(Id.t)) => +let subst = (m, env: Environment.t, d: DHExp.t(IdTag.t)): DHExp.t(IdTag.t) => env |> Environment.foldo( - (xd: (Var.t, DHExp.t(list(Id.t))), d2) => { + (xd: (Var.t, DHExp.t(IdTag.t)), d2) => { let (x, d1) = xd; subst_var(m, d1, x, d2); }, diff --git a/src/haz3lcore/dynamics/Substitution.rei b/src/haz3lcore/dynamics/Substitution.rei index 83fcbaf525..db30b07afd 100644 --- a/src/haz3lcore/dynamics/Substitution.rei +++ b/src/haz3lcore/dynamics/Substitution.rei @@ -1,7 +1,6 @@ /* closed substitution [d1/x]d2 */ let subst_var: - (Statics.Map.t, DHExp.t(list(Id.t)), Var.t, DHExp.t(list(Id.t))) => - DHExp.t(list(Id.t)); + (Statics.Map.t, DHExp.t(IdTag.t), Var.t, DHExp.t(IdTag.t)) => + DHExp.t(IdTag.t); let subst: - (Statics.Map.t, Environment.t, DHExp.t(list(Id.t))) => - DHExp.t(list(Id.t)); + (Statics.Map.t, Environment.t, DHExp.t(IdTag.t)) => DHExp.t(IdTag.t); diff --git a/src/haz3lcore/dynamics/TestMap.re b/src/haz3lcore/dynamics/TestMap.re index d24f509eaf..28f9a599bb 100644 --- a/src/haz3lcore/dynamics/TestMap.re +++ b/src/haz3lcore/dynamics/TestMap.re @@ -2,7 +2,7 @@ open Util; /* FIXME: Make more obvious names. */ [@deriving (show({with_path: false}), sexp, yojson)] -type instance_report = (DHExp.t(list(Id.t)), TestStatus.t); +type instance_report = (DHExp.t(IdTag.t), TestStatus.t); let joint_status: list(instance_report) => TestStatus.t = reports => TestStatus.join_all(List.map(((_, x)) => x, reports)); diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index e94bc6fd1b..1c1d6363c3 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -85,7 +85,7 @@ let evaluate_extend_env = type rule = | Step({ - expr: DHExp.t(list(Id.t)), + expr: DHExp.t(IdTag.t), state_update: unit => unit, kind: step_kind, is_value: bool, @@ -107,50 +107,32 @@ module type EV_MODE = { type requirements('a, 'b); let req_value: - ( - DHExp.t(list(Id.t)) => result, - EvalCtx.t => EvalCtx.t, - DHExp.t(list(Id.t)) - ) => - requirement(DHExp.t(list(Id.t))); + (DHExp.t(IdTag.t) => result, EvalCtx.t => EvalCtx.t, DHExp.t(IdTag.t)) => + requirement(DHExp.t(IdTag.t)); let req_all_value: ( - DHExp.t(list(Id.t)) => result, - ( - EvalCtx.t, - (list(DHExp.t(list(Id.t))), list(DHExp.t(list(Id.t)))) - ) => + DHExp.t(IdTag.t) => result, + (EvalCtx.t, (list(DHExp.t(IdTag.t)), list(DHExp.t(IdTag.t)))) => EvalCtx.t, - list(DHExp.t(list(Id.t))) + list(DHExp.t(IdTag.t)) ) => - requirement(list(DHExp.t(list(Id.t)))); + requirement(list(DHExp.t(IdTag.t))); let req_final: - ( - DHExp.t(list(Id.t)) => result, - EvalCtx.t => EvalCtx.t, - DHExp.t(list(Id.t)) - ) => - requirement(DHExp.t(list(Id.t))); + (DHExp.t(IdTag.t) => result, EvalCtx.t => EvalCtx.t, DHExp.t(IdTag.t)) => + requirement(DHExp.t(IdTag.t)); let req_all_final: ( - DHExp.t(list(Id.t)) => result, - ( - EvalCtx.t, - (list(DHExp.t(list(Id.t))), list(DHExp.t(list(Id.t)))) - ) => + DHExp.t(IdTag.t) => result, + (EvalCtx.t, (list(DHExp.t(IdTag.t)), list(DHExp.t(IdTag.t)))) => EvalCtx.t, - list(DHExp.t(list(Id.t))) + list(DHExp.t(IdTag.t)) ) => - requirement(list(DHExp.t(list(Id.t)))); + requirement(list(DHExp.t(IdTag.t))); let req_final_or_value: - ( - DHExp.t(list(Id.t)) => result, - EvalCtx.t => EvalCtx.t, - DHExp.t(list(Id.t)) - ) => - requirement((DHExp.t(list(Id.t)), bool)); + (DHExp.t(IdTag.t) => result, EvalCtx.t => EvalCtx.t, DHExp.t(IdTag.t)) => + requirement((DHExp.t(IdTag.t), bool)); - let (let.): (requirements('a, DHExp.t(list(Id.t))), 'a => rule) => result; + let (let.): (requirements('a, DHExp.t(IdTag.t)), 'a => rule) => result; let (and.): (requirements('a, 'c => 'b), requirement('c)) => requirements(('a, 'c), 'b); @@ -419,14 +401,14 @@ module Transition = (EV: EV_MODE) => { List.map( fun | {term: Deferral(_), _} => true - | _ => false: Exp.t(list(Id.t)) => bool, + | _ => false: Exp.t(IdTag.t) => bool, d4s, ), ); let-unbox args = (Tuple(n_args), d2); let new_args = { let rec go = (deferred, args) => - switch ((deferred: list(Exp.t(list(Id.t))))) { + switch ((deferred: list(Exp.t(IdTag.t)))) { | [] => [] | [{term: Deferral(_), _}, ...deferred] => /* I can use List.hd and List.tl here because let-unbox ensure that @@ -445,8 +427,8 @@ module Transition = (EV: EV_MODE) => { | Cast(_) | FailedCast(_) => Indet | FixF(_) => - print_endline([%derive.show: Exp.t(list(Id.t))](d1)); - print_endline([%derive.show: Exp.t(list(Id.t))](d1')); + print_endline([%derive.show: Exp.t(IdTag.t)](d1)); + print_endline([%derive.show: Exp.t(IdTag.t)](d1')); print_endline("FIXF"); failwith("FixF in Ap"); | _ => diff --git a/src/haz3lcore/dynamics/TypeAssignment.re b/src/haz3lcore/dynamics/TypeAssignment.re index b90e6fc6c7..530dc6034a 100644 --- a/src/haz3lcore/dynamics/TypeAssignment.re +++ b/src/haz3lcore/dynamics/TypeAssignment.re @@ -23,16 +23,19 @@ open OptUtil.Syntax; // }; // }; -let ground = (ty: Typ.t): bool => { +let ground = (ty: Typ.t(IdTag.t)): bool => { switch (Casts.ground_cases_of(ty)) { | Casts.Ground => true | _ => false }; }; -let dhpat_extend_ctx = (dhpat: DHPat.t, ty: Typ.t, ctx: Ctx.t): option(Ctx.t) => { +let dhpat_extend_ctx = + (dhpat: DHPat.t(IdTag.t), ty: Typ.t(IdTag.t), ctx: Ctx.t(IdTag.t)) + : option(Ctx.t(IdTag.t)) => { let rec dhpat_var_entry = - (dhpat: DHPat.t, ty: Typ.t): option(list(Ctx.entry)) => { + (dhpat: DHPat.t(IdTag.t), ty: Typ.t(IdTag.t)) + : option(list(Ctx.entry(IdTag.t))) => { switch (dhpat |> Pat.term_of) { | Var(name) => let entry = Ctx.VarEntry({name, id: Id.invalid, typ: ty}); @@ -79,7 +82,9 @@ let dhpat_extend_ctx = (dhpat: DHPat.t, ty: Typ.t, ctx: Ctx.t): option(Ctx.t) => }; /* patterns in functions and fixpoints must have a synthesizable type */ -let rec dhpat_synthesize = (dhpat: DHPat.t, ctx: Ctx.t): option(Typ.t) => { +let rec dhpat_synthesize = + (dhpat: DHPat.t(IdTag.t), ctx: Ctx.t(IdTag.t)) + : option(Typ.t(IdTag.t)) => { switch (dhpat |> Pat.term_of) { | Var(_) | Constructor(_) @@ -108,8 +113,8 @@ let rec dhpat_synthesize = (dhpat: DHPat.t, ctx: Ctx.t): option(Typ.t) => { }; let rec env_extend_ctx = - (env: ClosureEnvironment.t, m: Statics.Map.t, ctx: Ctx.t) - : option(Ctx.t) => { + (env: ClosureEnvironment.t, m: Statics.Map.t, ctx: Ctx.t(IdTag.t)) + : option(Ctx.t(IdTag.t)) => { let+ l = env |> ClosureEnvironment.to_list @@ -122,7 +127,8 @@ let rec env_extend_ctx = } and typ_of_dhexp = - (ctx: Ctx.t, m: Statics.Map.t, dh: DHExp.t(list(Id.t))): option(Typ.t) => { + (ctx: Ctx.t(IdTag.t), m: Statics.Map.t, dh: DHExp.t(IdTag.t)) + : option(Typ.t(IdTag.t)) => { switch (dh |> DHExp.term_of) { | Invalid(_) | MultiHole(_) @@ -171,7 +177,10 @@ and typ_of_dhexp = Some(Typ.Forall(utpat, ty) |> Typ.temp); | TypFun(_, d, _) => let* ty = typ_of_dhexp(ctx, m, d); - Some(Typ.Forall(Var("?") |> TPat.fresh, ty) |> Typ.temp); + Some( + Typ.Forall((Var("?"): TPat.term(IdTag.t)) |> TPat.fresh, ty) + |> Typ.temp, + ); | TypAp(d, ty1) => let* ty = typ_of_dhexp(ctx, m, d); let* (name, ty2) = Typ.matched_forall_strict(ctx, ty); @@ -317,7 +326,7 @@ and typ_of_dhexp = | Match(_, []) => Some(Unknown(Internal) |> Typ.temp) | Match(d_scrut, [rule, ...rules]) => let* ty' = typ_of_dhexp(ctx, m, d_scrut); - let rule_to_ty = ((dhpat, dhexp): (Pat.t, Exp.t(list(Id.t)))) => { + let rule_to_ty = ((dhpat, dhexp): (Pat.t(IdTag.t), Exp.t(IdTag.t))) => { let* ctx = dhpat_extend_ctx(dhpat, ty', ctx); typ_of_dhexp(ctx, m, dhexp); }; @@ -350,7 +359,8 @@ and typ_of_dhexp = }; let property_test = - (uexp_typ: Typ.t, dhexp: DHExp.t(list(Id.t)), m: Statics.Map.t): bool => { + (uexp_typ: Typ.t(IdTag.t), dhexp: DHExp.t(IdTag.t), m: Statics.Map.t) + : bool => { let dhexp_typ = typ_of_dhexp(Builtins.ctx_init, m, dhexp); switch (dhexp_typ) { diff --git a/src/haz3lcore/dynamics/Unboxing.re b/src/haz3lcore/dynamics/Unboxing.re index d2625d22e5..8ba6822d1d 100644 --- a/src/haz3lcore/dynamics/Unboxing.re +++ b/src/haz3lcore/dynamics/Unboxing.re @@ -20,11 +20,11 @@ type unbox_request('a) = | Float: unbox_request(float) | Bool: unbox_request(bool) | String: unbox_request(string) - | Tuple(int): unbox_request(list(DHExp.t(list(Id.t)))) - | List: unbox_request(list(DHExp.t(list(Id.t)))) - | Cons: unbox_request((DHExp.t(list(Id.t)), DHExp.t(list(Id.t)))) + | Tuple(int): unbox_request(list(DHExp.t(IdTag.t))) + | List: unbox_request(list(DHExp.t(IdTag.t))) + | Cons: unbox_request((DHExp.t(IdTag.t), DHExp.t(IdTag.t))) | SumNoArg(string): unbox_request(unit) - | SumWithArg(string): unbox_request(DHExp.t(list(Id.t))); + | SumWithArg(string): unbox_request(DHExp.t(IdTag.t)); type unboxed('a) = | DoesNotMatch @@ -45,8 +45,7 @@ let fixup_cast = Casts.transition_multiple; it avoids having to write a separate unbox function for each kind of request. */ -let rec unbox: - type a. (unbox_request(a), DHExp.t(list(Id.t))) => unboxed(a) = +let rec unbox: type a. (unbox_request(a), DHExp.t(IdTag.t)) => unboxed(a) = (request, expr) => { switch (request, DHExp.term_of(expr)) { /* Remove parentheses from casts */ @@ -61,9 +60,12 @@ let rec unbox: | (String, String(s)) => Matches(s) /* Lists can be either lists or list casts */ - | (List, ListLit(l)) => Matches(l) + | (List, ListLit(l: list(DHExp.t(IdTag.t)))) => Matches(l) | (Cons, ListLit([x, ...xs])) => - Matches((x, ListLit(xs) |> DHExp.fresh)) + Matches(( + x: DHExp.t(IdTag.t), + (ListLit(xs): DHExp.term(IdTag.t)) |> DHExp.fresh, + )) | (Cons, ListLit([])) => DoesNotMatch | (List, Cast(l, {term: List(t1), _}, {term: List(t2), _})) => let* l = unbox(List, l); diff --git a/src/haz3lcore/dynamics/VarCtx.re b/src/haz3lcore/dynamics/VarCtx.re index 14331e6ea5..691f19f1e7 100644 --- a/src/haz3lcore/dynamics/VarCtx.re +++ b/src/haz3lcore/dynamics/VarCtx.re @@ -1,3 +1,3 @@ [@deriving sexp] -type t = VarMap.t_(Typ.t); +type t('a) = VarMap.t_(Typ.t('a)); include VarMap; diff --git a/src/haz3lcore/lang/term/Annotated.re b/src/haz3lcore/lang/term/Annotated.re index 70ed522c78..3ee4970ae2 100644 --- a/src/haz3lcore/lang/term/Annotated.re +++ b/src/haz3lcore/lang/term/Annotated.re @@ -17,10 +17,22 @@ let fresh = (term: 'term): t('term, IdTag.t) => { }; }; -// let term_of = x => x.term; +let term_of = x => x.term; let unwrap = x => (x.term, term' => {...x, term: term'}); let rep_id = (t: t('term, IdTag.t)) => List.hd(t.annotation.ids); -// let fast_copy = (id, {term, _}) => {ids: [id], term, copied: true}; -// let new_ids = -// fun -// | {ids: _, term, copied} => {ids: [Id.mk()], term, copied}; +let fast_copy = (id, {term, _}): t('term, IdTag.t) => { + term, + annotation: { + ids: [id], + copied: true, + }, +}; +let new_ids = + ({term, annotation: {ids: _, copied}}: t('term, IdTag.t)) + : t('term, IdTag.t) => { + term, + annotation: { + ids: [Id.mk()], + copied, + }, +}; diff --git a/src/haz3lcore/lang/term/TPat.re b/src/haz3lcore/lang/term/TPat.re index 3dade36b54..6cfd7a5d39 100644 --- a/src/haz3lcore/lang/term/TPat.re +++ b/src/haz3lcore/lang/term/TPat.re @@ -7,16 +7,16 @@ type cls = include TermBase.TPat; -let rep_id: t => Id.t = IdTagged.rep_id; -let fresh: term => t = IdTagged.fresh; +let rep_id = (x: t(IdTag.t)) => Annotated.rep_id(x); +let fresh = Annotated.fresh; -let hole = (tms: list(TermBase.Any.t)) => +let hole = (tms: list(TermBase.Any.t('a))) => switch (tms) { | [] => EmptyHole | [_, ..._] => MultiHole(tms) }; -let cls_of_term: term => cls = +let cls_of_term: term('a) => cls = fun | Invalid(_) => Invalid | EmptyHole => EmptyHole diff --git a/src/haz3lcore/lang/term/Typ.re b/src/haz3lcore/lang/term/Typ.re index 3cb7f47b3c..b257511c03 100644 --- a/src/haz3lcore/lang/term/Typ.re +++ b/src/haz3lcore/lang/term/Typ.re @@ -25,22 +25,29 @@ type cls = include TermBase.Typ; -let term_of: t => term = IdTagged.term_of; -let unwrap: t => (term, term => t) = IdTagged.unwrap; -let fresh: term => t = IdTagged.fresh; +let term_of: t('a) => term('a) = Annotated.term_of; +let unwrap: t('a) => (term('a), term('a) => t('a)) = Annotated.unwrap; +let fresh: term('a) => t('a) = Annotated.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 temp: term('a) => t(IdTag.t) = + term => { + term, + annotation: { + ids: [Id.invalid], + copied: false, + }, + }; +let rep_id: t('a) => Id.t = Annotated.rep_id; -let hole = (tms: list(TermBase.Any.t)) => +let hole = (tms: list(TermBase.Any.t('a))) => switch (tms) { | [] => Unknown(Hole(EmptyHole)) | [_, ..._] => Unknown(Hole(MultiHole(tms))) }; -let cls_of_term: term => cls = +let cls_of_term: term('a) => cls = fun | Unknown(Hole(Invalid(_))) => Invalid | Unknown(Hole(EmptyHole)) => EmptyHole @@ -83,7 +90,7 @@ let show_cls: cls => string = | Rec => "Recursive type" | Forall => "Forall type"; -let rec is_arrow = (typ: t) => { +let rec is_arrow = (typ: t('a)) => { switch (typ.term) { | Parens(typ) => is_arrow(typ) | Arrow(_) => true @@ -102,7 +109,7 @@ let rec is_arrow = (typ: t) => { }; }; -let rec is_forall = (typ: t) => { +let rec is_forall = (typ: t('a)) => { switch (typ.term) { | Parens(typ) => is_forall(typ) | Forall(_) => true @@ -126,18 +133,18 @@ let rec is_forall = (typ: t) => { [@deriving (show({with_path: false}), sexp, yojson)] type source = { id: Id.t, - ty: t, + ty: t(IdTag.t), }; /* Strip location information from a list of sources */ -let of_source = List.map((source: source) => source.ty); +let of_source = x => List.map((source: source) => source.ty, x); /* 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 => + (p1: type_provenance('a), p2: type_provenance('a)): type_provenance('a) => switch (p1, p2) { | (Hole(h1), Hole(h2)) when h1 == h2 => Hole(h1) | (Hole(EmptyHole), Hole(EmptyHole) | SynSwitch) @@ -149,7 +156,7 @@ let join_type_provenance = | (SynSwitch, SynSwitch) => SynSwitch }; -let rec free_vars = (~bound=[], ty: t): list(Var.t) => +let rec free_vars = (~bound=[], ty: t('a)): list(Var.t) => switch (term_of(ty)) { | Unknown(_) | Int @@ -175,7 +182,7 @@ let fresh_var = (var_name: string) => { var_name ++ "_α" ++ string_of_int(x); }; -let unroll = (ty: t): t => +let unroll = (ty: t('a)): t('a) => switch (term_of(ty)) { | Rec(tp, ty_body) => subst(ty, tp, ty_body) | _ => ty @@ -183,14 +190,16 @@ let unroll = (ty: t): t => /* Type Equality: This coincides with alpha equivalence for normalized types. Other types may be equivalent but this will not detect so if they are not normalized. */ -let eq = (t1: t, t2: t): bool => fast_equal(t1, t2); +let eq = (t1: t('a), t2: t('a)): 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 rec join = + (~resolve=false, ~fix, ctx: Ctx.t('a), ty1: t('a), ty2: t('a)) + : option(t('a)) => { let join' = join(~resolve, ~fix, ctx); switch (term_of(ty1), term_of(ty2)) { | (_, Parens(ty2)) => join'(ty1, ty2) @@ -280,7 +289,7 @@ let rec join = (~resolve=false, ~fix, ctx: Ctx.t, ty1: t, ty2: t): option(t) => /* REQUIRES NORMALIZED TYPES Remove synswitches from t1 by matching against t2 */ -let rec match_synswitch = (t1: t, t2: t) => { +let rec match_synswitch = (t1: t('a), t2: t('a)) => { let (term1, rewrap1) = unwrap(t1); switch (term1, term_of(t2)) { | (Parens(t1), _) => Parens(match_synswitch(t1, t2)) |> rewrap1 @@ -314,17 +323,18 @@ let rec match_synswitch = (t1: t, t2: t) => { let join_fix = join(~fix=true); -let join_all = (~empty: t, ctx: Ctx.t, ts: list(t)): option(t) => +let join_all = + (~empty: t('a), ctx: Ctx.t('a), ts: list(t('a))): option(t('a)) => 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 => +let is_consistent = (ctx: Ctx.t('a), ty1: t('a), ty2: t('a)): bool => join(~fix=false, ctx, ty1, ty2) != None; -let rec weak_head_normalize = (ctx: Ctx.t, ty: t): t => +let rec weak_head_normalize = (ctx: Ctx.t('a), ty: t('a)): t('a) => switch (term_of(ty)) { | Var(x) => switch (Ctx.lookup_alias(ctx, x)) { @@ -334,7 +344,7 @@ let rec weak_head_normalize = (ctx: Ctx.t, ty: t): t => | _ => ty }; -let rec normalize = (ctx: Ctx.t, ty: t): t => { +let rec normalize = (ctx: Ctx.t('a), ty: t('a)): t('a) => { let (term, rewrap) = unwrap(ty); switch (term) { | Var(x) => @@ -427,7 +437,8 @@ let rec matched_args = (ctx, default_arity, ty) => { }; }; -let rec get_sum_constructors = (ctx: Ctx.t, ty: t): option(sum_map) => { +let rec get_sum_constructors = + (ctx: Ctx.t('a), ty: t('a)): option(sum_map('a)) => { let ty = weak_head_normalize(ctx, ty); switch (term_of(ty)) { | Parens(ty) => get_sum_constructors(ctx, ty) @@ -460,7 +471,7 @@ let rec get_sum_constructors = (ctx: Ctx.t, ty: t): option(sum_map) => { }; }; -let rec is_unknown = (ty: t): bool => +let rec is_unknown = (ty: t('a)): bool => switch (ty |> term_of) { | Parens(x) => is_unknown(x) | Unknown(_) => true @@ -468,7 +479,7 @@ let rec is_unknown = (ty: t): bool => }; /* Does the type require parentheses when on the left of an arrow for printing? */ -let rec needs_parens = (ty: t): bool => +let rec needs_parens = (ty: t('a)): bool => switch (term_of(ty)) { | Parens(ty) => needs_parens(ty) | Ap(_) @@ -486,8 +497,8 @@ let rec needs_parens = (ty: t): bool => | Sum(_) => true /* disambiguate between (A + B) -> C and A + (B -> C) */ }; -let pretty_print_tvar = (tv: TPat.t): string => - switch (IdTagged.term_of(tv)) { +let pretty_print_tvar = (tv: TPat.t('a)): string => + switch (Annotated.term_of(tv)) { | Var(x) => x | Invalid(_) | EmptyHole @@ -495,7 +506,7 @@ let pretty_print_tvar = (tv: TPat.t): string => }; /* Essentially recreates haz3lweb/view/Type.re's view_ty but with string output */ -let rec pretty_print = (ty: t): string => +let rec pretty_print = (ty: t('a)): string => switch (term_of(ty)) { | Parens(ty) => pretty_print(ty) | Ap(_) diff --git a/src/haz3lcore/prog/CachedStatics.re b/src/haz3lcore/prog/CachedStatics.re index 9f5898ec1d..5a37c7f8ca 100644 --- a/src/haz3lcore/prog/CachedStatics.re +++ b/src/haz3lcore/prog/CachedStatics.re @@ -2,13 +2,20 @@ open Util; [@deriving (show({with_path: false}), sexp, yojson)] type statics = { - term: UExp.t(list(Id.t)), + term: UExp.t(IdTag.t), info_map: Statics.Map.t, error_ids: list(Id.t), }; let empty_statics: statics = { - term: UExp.{ids: [Id.invalid], copied: false, term: Tuple([])}, + term: + UExp.{ + annotation: { + 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 c97f2b645c..fce4a152bf 100644 --- a/src/haz3lcore/prog/Interface.re +++ b/src/haz3lcore/prog/Interface.re @@ -1,11 +1,10 @@ -let dh_err = (error: string): DHExp.t(list(Id.t)) => - Var(error) |> DHExp.fresh; +let dh_err = (error: string): DHExp.t(IdTag.t) => Var(error) |> DHExp.fresh; let elaborate = Core.Memo.general(~cache_size_bound=1000, Elaborator.uexp_elab); exception DoesNotElaborate; -let elaborate = (~settings: CoreSettings.t, map, term): DHExp.t(list(Id.t)) => +let elaborate = (~settings: CoreSettings.t, map, term): DHExp.t(IdTag.t) => switch () { | _ when !settings.statics => dh_err("Statics disabled") | _ when !settings.dynamics && !settings.elaborate => @@ -21,7 +20,7 @@ let evaluate = ( ~settings: CoreSettings.t, ~env=Builtins.env_init, - elab: DHExp.t(list(Id.t)), + elab: DHExp.t(IdTag.t), ) : ProgramResult.t => switch () { diff --git a/src/haz3lcore/statics/CoCtx.re b/src/haz3lcore/statics/CoCtx.re index 3088ef4a28..a0ac57861c 100644 --- a/src/haz3lcore/statics/CoCtx.re +++ b/src/haz3lcore/statics/CoCtx.re @@ -28,19 +28,19 @@ open Util; */ [@deriving (show({with_path: false}), sexp, yojson)] -type entry = { +type entry('a) = { id: Id.t, - expected_ty: Typ.t, + expected_ty: Typ.t('a), }; /* Each co-context entry is a list of the uses of a variable within some scope, including their type demands */ [@deriving (show({with_path: false}), sexp, yojson)] -type t = VarMap.t_(list(entry)); +type t('a) = VarMap.t_(list(entry('a))); -let empty: t = VarMap.empty; +let empty: t('a) = VarMap.empty; -let mk = (ctx_before: Ctx.t, ctx_after, co_ctx: t): t => { +let mk = (ctx_before: Ctx.t('a), ctx_after, co_ctx: t('a)): t('a) => { let added_bindings = Ctx.added_bindings(ctx_after, ctx_before); VarMap.filter( ((name, _)) => @@ -53,14 +53,14 @@ let mk = (ctx_before: Ctx.t, ctx_after, co_ctx: t): t => { }; /* Note: this currently shadows in the case of duplicates */ -let union: list(t) => t = - List.fold_left((co_ctx1, co_ctx2) => co_ctx1 @ co_ctx2, []); +let union: list(t('a)) => t('a) = + xs => List.fold_left((co_ctx1, co_ctx2) => co_ctx1 @ co_ctx2, [], xs); -let singleton = (name, id, expected_ty): t => [ +let singleton = (name, id, expected_ty): t(IdTag.t) => [ (name, [{id, expected_ty}]), ]; -let join: (Ctx.t, list(entry)) => Typ.t = +let join: (Ctx.t('a), list(entry('a))) => Typ.t('a) = (ctx, entries) => { let expected_tys = List.map(entry => entry.expected_ty, entries); switch ( diff --git a/src/haz3lcore/statics/Ctx.re b/src/haz3lcore/statics/Ctx.re index 9791b6cd0f..27a67ed542 100644 --- a/src/haz3lcore/statics/Ctx.re +++ b/src/haz3lcore/statics/Ctx.re @@ -1,48 +1,49 @@ open Util; [@deriving (show({with_path: false}), sexp, yojson)] -type kind = - | Singleton(TermBase.Typ.t) +type kind('a) = + | Singleton(TermBase.Typ.t('a)) | Abstract; [@deriving (show({with_path: false}), sexp, yojson)] -type var_entry = { +type var_entry('a) = { name: Var.t, - id: Id.t, - typ: TermBase.Typ.t, + id: Id.t, // TODO: Should this be a type param? + typ: TermBase.Typ.t('a), }; [@deriving (show({with_path: false}), sexp, yojson)] -type tvar_entry = { +type tvar_entry('a) = { name: string, id: Id.t, - kind, + kind: kind('a), }; [@deriving (show({with_path: false}), sexp, yojson)] -type entry = - | VarEntry(var_entry) - | ConstructorEntry(var_entry) - | TVarEntry(tvar_entry); +type entry('a) = + | VarEntry(var_entry('a)) + | ConstructorEntry(var_entry('a)) + | TVarEntry(tvar_entry('a)); [@deriving (show({with_path: false}), sexp, yojson)] -type t = list(entry); +type t('a) = list(entry('a)); let extend = (ctx, entry) => List.cons(entry, ctx); -let extend_tvar = (ctx: t, tvar_entry: tvar_entry): t => +let extend_tvar = (ctx: t('a), tvar_entry: tvar_entry('a)): t('a) => extend(ctx, TVarEntry(tvar_entry)); -let extend_alias = (ctx: t, name: string, id: Id.t, ty: TermBase.Typ.t): t => +let extend_alias = + (ctx: t('a), name: string, id: Id.t, ty: TermBase.Typ.t('a)): t('a) => extend_tvar(ctx, {name, id, kind: Singleton(ty)}); -let extend_dummy_tvar = (ctx: t, tvar: TPat.t) => +let extend_dummy_tvar = (ctx: t('a), tvar: TPat.t('a)) => 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) => +let lookup_tvar = (ctx: t('a), name: string): option(kind('a)) => List.find_map( fun | TVarEntry(v) when v.name == name => Some(v.kind) @@ -50,7 +51,7 @@ let lookup_tvar = (ctx: t, name: string): option(kind) => ctx, ); -let lookup_tvar_id = (ctx: t, name: string): option(Id.t) => +let lookup_tvar_id = (ctx: t('a), name: string): option(Id.t) => List.find_map( fun | TVarEntry(v) when v.name == name => Some(v.id) @@ -58,13 +59,13 @@ let lookup_tvar_id = (ctx: t, name: string): option(Id.t) => ctx, ); -let get_id: entry => Id.t = +let get_id: entry('a) => Id.t = fun | VarEntry({id, _}) | ConstructorEntry({id, _}) | TVarEntry({id, _}) => id; -let lookup_var = (ctx: t, name: string): option(var_entry) => +let lookup_var = (ctx: t('a), name: string): option(var_entry('a)) => List.find_map( fun | VarEntry(v) when v.name == name => Some(v) @@ -72,7 +73,7 @@ let lookup_var = (ctx: t, name: string): option(var_entry) => ctx, ); -let lookup_ctr = (ctx: t, name: string): option(var_entry) => +let lookup_ctr = (ctx: t('a), name: string): option(var_entry('a)) => List.find_map( fun | ConstructorEntry(t) when t.name == name => Some(t) @@ -80,29 +81,38 @@ let lookup_ctr = (ctx: t, name: string): option(var_entry) => ctx, ); -let is_alias = (ctx: t, name: string): bool => +let is_alias = (ctx: t('a), name: string): bool => switch (lookup_tvar(ctx, name)) { | Some(Singleton(_)) => true | Some(Abstract) | None => false }; -let is_abstract = (ctx: t, name: string): bool => +let is_abstract = (ctx: t('a), 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) => +// TODO Should this return back a fresh ID or should this function just not operate on ids +let lookup_alias = + (ctx: t(IdTag.t), name: string): option(TermBase.Typ.t(IdTag.t)) => switch (lookup_tvar(ctx, name)) { | Some(Singleton(ty)) => Some(ty) | Some(Abstract) => None | None => - Some(TermBase.Typ.Unknown(Hole(Invalid(name))) |> IdTagged.fresh) + Some(TermBase.Typ.Unknown(Hole(Invalid(name))) |> Annotated.fresh) }; -let add_ctrs = (ctx: t, name: string, id: Id.t, ctrs: TermBase.Typ.sum_map): t => +let add_ctrs = + ( + ctx: t(IdTag.t), + name: string, + id: Id.t, + ctrs: TermBase.Typ.sum_map(IdTag.t), + ) + : t(IdTag.t) => List.filter_map( fun | ConstructorMap.Variant(ctr, _, typ) => @@ -112,13 +122,13 @@ let add_ctrs = (ctx: t, name: string, id: Id.t, ctrs: TermBase.Typ.sum_map): t = id, typ: switch (typ) { - | None => TermBase.Typ.Var(name) |> IdTagged.fresh + | None => TermBase.Typ.Var(name) |> Annotated.fresh | Some(typ) => TermBase.Typ.Arrow( typ, - TermBase.Typ.Var(name) |> IdTagged.fresh, + TermBase.Typ.Var(name) |> Annotated.fresh, ) - |> IdTagged.fresh + |> Annotated.fresh }, }), ) @@ -127,7 +137,7 @@ let add_ctrs = (ctx: t, name: string, id: Id.t, ctrs: TermBase.Typ.sum_map): t = ) @ ctx; -let subtract_prefix = (ctx: t, prefix_ctx: t): option(t) => { +let subtract_prefix = (ctx: t('a), prefix_ctx: t('a)): option(t('a)) => { // NOTE: does not check that the prefix is an actual prefix let prefix_length = List.length(prefix_ctx); let ctx_length = List.length(ctx); @@ -142,7 +152,7 @@ let subtract_prefix = (ctx: t, prefix_ctx: t): option(t) => { }; }; -let added_bindings = (ctx_after: t, ctx_before: t): t => { +let added_bindings = (ctx_after: t('a), ctx_before: t('a)): t('a) => { /* 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)) { @@ -154,7 +164,7 @@ let added_bindings = (ctx_after: t, ctx_before: t): t => { module VarSet = Set.Make(Var); // Note: filter out duplicates when rendering -let filter_duplicates = (ctx: t): t => +let filter_duplicates = (ctx: t('a)): t('a) => ctx |> List.fold_left( ((ctx, term_set, typ_set), entry) => { @@ -174,5 +184,5 @@ let filter_duplicates = (ctx: t): t => ) |> (((ctx, _, _)) => List.rev(ctx)); -let shadows_typ = (ctx: t, name: string): bool => +let shadows_typ = (ctx: t('a), 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 6a186461ee..47383b4fcf 100644 --- a/src/haz3lcore/statics/Info.re +++ b/src/haz3lcore/statics/Info.re @@ -36,20 +36,20 @@ type ancestors = list(Id.t); type error_inconsistent = /* Self type (syn) inconsistent with expected type (ana) */ | Expectation({ - ana: Typ.t, - syn: Typ.t, + ana: Typ.t(IdTag.t), + syn: Typ.t(IdTag.t), }) /* Inconsistent match or listlit */ - | Internal(list(Typ.t)) + | Internal(list(Typ.t(IdTag.t))) /* Bad function position */ - | WithArrow(Typ.t); + | WithArrow(Typ.t(IdTag.t)); [@deriving (show({with_path: false}), sexp, yojson)] type error_no_type = /* Invalid expression token, treated as hole */ | BadToken(Token.t) /* Empty application of function with inconsistent type */ - | BadTrivAp(Typ.t) + | BadTrivAp(Typ.t(IdTag.t)) /* Sum constructor neiter bound nor in ana type */ | FreeConstructor(Constructor.t); @@ -80,27 +80,27 @@ type ok_ana = /* The expected (ana) type and the self (syn) type are consistent, as witnessed by their joint type (join) */ | Consistent({ - ana: Typ.t, - syn: Typ.t, - join: Typ.t, + ana: Typ.t(IdTag.t), + syn: Typ.t(IdTag.t), + join: Typ.t(IdTag.t), }) /* A match expression or list literal which, in synthetic position, would be marked as internally inconsistent, but is considered fine as the expected type provides a consistent lower bound (often Unknown) for the types of the branches/elements */ | InternallyInconsistent({ - ana: Typ.t, - nojoin: list(Typ.t), + ana: Typ.t(IdTag.t), + nojoin: list(Typ.t(IdTag.t)), }); [@deriving (show({with_path: false}), sexp, yojson)] type ok_common = - | Syn(Typ.t) + | Syn(Typ.t(IdTag.t)) | Ana(ok_ana); [@deriving (show({with_path: false}), sexp, yojson)] type ok_exp = - | AnaDeferralConsistent(Typ.t) + | AnaDeferralConsistent(Typ.t(IdTag.t)) | Common(ok_common); [@deriving (show({with_path: false}), sexp, yojson)] @@ -132,8 +132,8 @@ type status_variant = [@deriving (show({with_path: false}), sexp, yojson)] type typ_expects = | TypeExpected - | ConstructorExpected(status_variant, Typ.t) - | VariantExpected(status_variant, Typ.t); + | ConstructorExpected(status_variant, Typ.t(IdTag.t)) + | VariantExpected(status_variant, Typ.t(IdTag.t)); /* Type term errors TODO: The three additional errors statuses @@ -145,16 +145,16 @@ type error_typ = | FreeTypeVariable(string) /* Free type variable */ | DuplicateConstructor(Constructor.t) /* Duplicate ctr in same sum */ | WantTypeFoundAp - | WantConstructorFoundType(Typ.t) + | WantConstructorFoundType(Typ.t(IdTag.t)) | WantConstructorFoundAp; /* Type ok statuses for cursor inspector */ [@deriving (show({with_path: false}), sexp, yojson)] type ok_typ = - | Variant(Constructor.t, Typ.t) - | VariantIncomplete(Typ.t) - | TypeAlias(string, Typ.t) - | Type(Typ.t); + | Variant(Constructor.t, Typ.t(IdTag.t)) + | VariantIncomplete(Typ.t(IdTag.t)) + | TypeAlias(string, Typ.t(IdTag.t)) + | Type(Typ.t(IdTag.t)); [@deriving (show({with_path: false}), sexp, yojson)] type status_typ = @@ -192,37 +192,37 @@ type status_tpat = [@deriving (show({with_path: false}), sexp, yojson)] type exp = { - term: UExp.t(list(Id.t)), /* The term under consideration */ + term: UExp.t(IdTag.t), /* The term under consideration */ ancestors, /* Ascending list of containing term ids */ - ctx: Ctx.t, /* Typing context for the term */ + ctx: Ctx.t(IdTag.t), /* Typing context for the term */ mode: Mode.t, /* Parental type expectations */ self: Self.exp, /* Expectation-independent type info */ - co_ctx: CoCtx.t, /* Locally free variables */ + co_ctx: CoCtx.t(IdTag.t), /* Locally free variables */ 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 */ + ty: Typ.t(IdTag.t) /* DERIVED: Type after nonempty hole fixing */ }; [@deriving (show({with_path: false}), sexp, yojson)] type pat = { - term: UPat.t, + term: UPat.t(IdTag.t), 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. + ctx: Ctx.t(IdTag.t), + co_ctx: CoCtx.t(IdTag.t), + prev_synswitch: option(Typ.t(IdTag.t)), // If a pattern is first synthesized, then analysed, the initial syn is stored here. mode: Mode.t, self: Self.pat, cls: Cls.t, status: status_pat, - ty: Typ.t, + ty: Typ.t(IdTag.t), constraint_: Constraint.t, }; [@deriving (show({with_path: false}), sexp, yojson)] type typ = { - term: Typ.t, + term: Typ.t(IdTag.t), ancestors, - ctx: Ctx.t, + ctx: Ctx.t(IdTag.t), expects: typ_expects, cls: Cls.t, status: status_typ, @@ -230,9 +230,9 @@ type typ = { [@deriving (show({with_path: false}), sexp, yojson)] type tpat = { - term: TPat.t, + term: TPat.t(IdTag.t), ancestors, - ctx: Ctx.t, + ctx: Ctx.t(IdTag.t), cls: Cls.t, status: status_tpat, }; @@ -242,7 +242,7 @@ type secondary = { id: Id.t, // Id of term static info is sourced from cls: Cls.t, // Cls of secondary, not source term sort: Sort.t, // from source term - ctx: Ctx.t // from source term + ctx: Ctx.t(IdTag.t) // from source term }; /* The static information collated for each term */ @@ -277,7 +277,7 @@ let cls_of: t => Cls.t = | InfoTPat({cls, _}) | Secondary({cls, _}) => cls; -let ctx_of: t => Ctx.t = +let ctx_of: t => Ctx.t(IdTag.t) = fun | InfoExp({ctx, _}) | InfoPat({ctx, _}) @@ -313,14 +313,14 @@ let error_of: t => option(error) = | InfoTPat({status: InHole(err), _}) => Some(TPat(err)) | Secondary(_) => None; -let exp_co_ctx: exp => CoCtx.t = ({co_ctx, _}) => co_ctx; -let exp_ty: exp => Typ.t = ({ty, _}) => ty; -let pat_ctx: pat => Ctx.t = ({ctx, _}) => ctx; -let pat_ty: pat => Typ.t = ({ty, _}) => ty; +let exp_co_ctx: exp => CoCtx.t(IdTag.t) = ({co_ctx, _}) => co_ctx; +let exp_ty: exp => Typ.t(IdTag.t) = ({ty, _}) => ty; +let pat_ctx: pat => Ctx.t(IdTag.t) = ({ctx, _}) => ctx; +let pat_ty: pat => Typ.t(IdTag.t) = ({ty, _}) => ty; let pat_constraint: pat => Constraint.t = ({constraint_, _}) => constraint_; let rec status_common = - (ctx: Ctx.t, mode: Mode.t, self: Self.t): status_common => + (ctx: Ctx.t(IdTag.t), mode: Mode.t, self: Self.t): status_common => switch (self, mode) { | (Just(ty), Syn) => NotInHole(Syn(ty)) | (Just(ty), SynFun) => @@ -339,7 +339,10 @@ let rec status_common = switch ( Typ.join_fix( ctx, - Forall(Var("?") |> TPat.fresh, Unknown(Internal) |> Typ.temp) + Forall( + (Var("?"): TPat.term(IdTag.t)) |> TPat.fresh, + Unknown(Internal) |> Typ.temp, + ) |> Typ.temp, ty, ) @@ -372,7 +375,8 @@ let rec status_common = | (BadTrivAp(ty), _) => InHole(NoType(BadTrivAp(ty))) | (IsMulti, _) => NotInHole(Syn(Unknown(Internal) |> Typ.temp)) | (NoJoin(wrap, tys), Ana(ana)) => - let syn: Typ.t = Self.join_of(wrap, Unknown(Internal) |> Typ.temp); + let syn: Typ.t(IdTag.t) = + Self.join_of(wrap, Unknown(Internal) |> Typ.temp); switch (Typ.join_fix(ctx, ana, syn)) { | None => InHole(Inconsistent(Expectation({ana, syn}))) | Some(_) => @@ -384,7 +388,8 @@ let rec status_common = InHole(Inconsistent(Internal(Typ.of_source(tys)))) }; -let rec status_pat = (ctx: Ctx.t, mode: Mode.t, self: Self.pat): status_pat => +let rec status_pat = + (ctx: Ctx.t(IdTag.t), mode: Mode.t, self: Self.pat): status_pat => switch (mode, self) { | (_, Redundant(self)) => let additional_err = @@ -417,7 +422,8 @@ let rec status_pat = (ctx: Ctx.t, mode: Mode.t, self: Self.pat): status_pat => depending on the mode, which represents the expectations of the surrounding syntactic context, and the self which represents the makeup of the expression / pattern itself. */ -let rec status_exp = (ctx: Ctx.t, mode: Mode.t, self: Self.exp): status_exp => +let rec status_exp = + (ctx: Ctx.t(IdTag.t), mode: Mode.t, self: Self.exp): status_exp => switch (self, mode) { | (Free(name), _) => InHole(FreeVariable(name)) | (InexhaustiveMatch(self), _) => @@ -452,7 +458,9 @@ 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, ty: Typ.t): status_typ => +let status_typ = + (ctx: Ctx.t(IdTag.t), expects: typ_expects, ty: Typ.t(IdTag.t)) + : status_typ => switch (ty.term) { | Unknown(Hole(Invalid(token))) => InHole(BadToken(token)) | Unknown(Hole(EmptyHole)) => NotInHole(Type(ty)) @@ -494,7 +502,7 @@ let status_typ = (ctx: Ctx.t, expects: typ_expects, ty: Typ.t): status_typ => } }; -let status_tpat = (ctx: Ctx.t, utpat: TPat.t): status_tpat => +let status_tpat = (ctx: Ctx.t(IdTag.t), utpat: TPat.t(IdTag.t)): status_tpat => switch (utpat.term) { | EmptyHole => NotInHole(Empty) | Var(name) when Ctx.shadows_typ(ctx, name) => @@ -541,13 +549,13 @@ let is_error = (ci: t): bool => { /* Determined the type of an expression or pattern 'after hole fixing'; 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 = +let fixed_typ_ok: ok_pat => Typ.t(IdTag.t) = fun | Syn(syn) => syn | Ana(Consistent({join, _})) => join | Ana(InternallyInconsistent({ana, _})) => ana; -let fixed_typ_err_common: error_common => Typ.t = +let fixed_typ_err_common: error_common => Typ.t(IdTag.t) = fun | NoType(_) => Unknown(Internal) |> Typ.temp | Inconsistent(Expectation({ana, _})) => ana @@ -556,7 +564,7 @@ let fixed_typ_err_common: error_common => Typ.t = Arrow(Unknown(Internal) |> Typ.temp, Unknown(Internal) |> Typ.temp) |> Typ.temp; -let fixed_typ_err: error_exp => Typ.t = +let fixed_typ_err: error_exp => Typ.t(IdTag.t) = fun | FreeVariable(_) => Unknown(Internal) |> Typ.temp | UnusedDeferral => Unknown(Internal) |> Typ.temp @@ -564,13 +572,13 @@ let fixed_typ_err: error_exp => Typ.t = | InexhaustiveMatch(_) => Unknown(Internal) |> Typ.temp | Common(err) => fixed_typ_err_common(err); -let fixed_typ_err_pat: error_pat => Typ.t = +let fixed_typ_err_pat: error_pat => Typ.t(IdTag.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 => { +let fixed_typ_pat = (ctx, mode: Mode.t, self: Self.pat): Typ.t(IdTag.t) => { // TODO: get rid of unwrapping (probably by changing the implementation of error_exp.Redundant) let self = switch (self) { @@ -585,7 +593,7 @@ let fixed_typ_pat = (ctx, mode: Mode.t, self: Self.pat): Typ.t => { let fixed_constraint_pat = ( - upat: UPat.t, + upat: UPat.t(IdTag.t), ctx, mode: Mode.t, self: Self.pat, @@ -601,7 +609,7 @@ let fixed_constraint_pat = } }; -let fixed_typ_exp = (ctx, mode: Mode.t, self: Self.exp): Typ.t => +let fixed_typ_exp = (ctx, mode: Mode.t, self: Self.exp): Typ.t(IdTag.t) => switch (status_exp(ctx, mode, self)) { | InHole(err) => fixed_typ_err(err) | NotInHole(AnaDeferralConsistent(ana)) => ana @@ -610,8 +618,7 @@ let fixed_typ_exp = (ctx, mode: Mode.t, self: Self.exp): Typ.t => /* Add derivable attributes for expression terms */ let derived_exp = - (~uexp: UExp.t(list(Id.t)), ~ctx, ~mode, ~ancestors, ~self, ~co_ctx) - : exp => { + (~uexp: UExp.t(IdTag.t), ~ctx, ~mode, ~ancestors, ~self, ~co_ctx): exp => { let cls = Cls.Exp(UExp.cls_of_term(uexp.term)); let status = status_exp(ctx, mode, self); let ty = fixed_typ_exp(ctx, mode, self); @@ -621,7 +628,7 @@ let derived_exp = /* Add derivable attributes for pattern terms */ let derived_pat = ( - ~upat: UPat.t, + ~upat: UPat.t(IdTag.t), ~ctx, ~co_ctx, ~prev_synswitch, @@ -651,7 +658,7 @@ let derived_pat = }; /* Add derivable attributes for types */ -let derived_typ = (~utyp: UTyp.t, ~ctx, ~ancestors, ~expects): typ => { +let derived_typ = (~utyp: UTyp.t(IdTag.t), ~ctx, ~ancestors, ~expects): typ => { let cls: Cls.t = /* Hack to improve CI display */ switch (expects, UTyp.cls_of_term(utyp.term)) { @@ -664,7 +671,7 @@ let derived_typ = (~utyp: UTyp.t, ~ctx, ~ancestors, ~expects): typ => { }; /* Add derivable attributes for type patterns */ -let derived_tpat = (~utpat: TPat.t, ~ctx, ~ancestors): tpat => { +let derived_tpat = (~utpat: TPat.t(IdTag.t), ~ctx, ~ancestors): tpat => { let cls = Cls.TPat(TPat.cls_of_term(utpat.term)); let status = status_tpat(ctx, utpat); {cls, ancestors, status, ctx, term: utpat}; diff --git a/src/haz3lcore/statics/MakeTerm.re b/src/haz3lcore/statics/MakeTerm.re index 4006395963..c276242629 100644 --- a/src/haz3lcore/statics/MakeTerm.re +++ b/src/haz3lcore/statics/MakeTerm.re @@ -23,26 +23,30 @@ let tokens = ); [@deriving (show({with_path: false}), sexp, yojson)] -type tile = (Id.t, Aba.t(Token.t, t)); +type tile = (Id.t, Aba.t(Token.t, t(IdTag.t))); [@deriving (show({with_path: false}), sexp, yojson)] -type tiles = Aba.t(tile, t); +type tiles = Aba.t(tile, t(IdTag.t)); let single = (id, subst) => ([(id, subst)], []); [@deriving (show({with_path: false}), sexp, yojson)] type unsorted = | Op(tiles) - | Pre(tiles, t) - | Post(t, tiles) - | Bin(t, tiles, t); + | Pre(tiles, t(IdTag.t)) + | Post(t(IdTag.t), tiles) + | Bin(t(IdTag.t), tiles, t(IdTag.t)); type t = { - term: UExp.t(list(Id.t)), + term: UExp.t(IdTag.t), terms: TermMap.t, projectors: Id.Map.t(Piece.projector(Id.t)), }; let is_nary = - (is_sort: Any.t => option('sort), delim: Token.t, (delims, kids): tiles) + ( + is_sort: Any.t(IdTag.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; @@ -59,7 +63,7 @@ let is_grout = tiles => Aba.get_as(tiles) |> List.map(snd) |> List.for_all((==)(([" "], []))); let is_rules = - ((ts, kids): tiles): option(Aba.t(UPat.t, UExp.t(list(Id.t)))) => { + ((ts, kids): tiles): option(Aba.t(UPat.t(IdTag.t), UExp.t(IdTag.t))) => { open OptUtil.Syntax; let+ ps = ts @@ -125,22 +129,34 @@ let rm_and_log_projectors = (seg: Segment.t(Id.t)): Segment.t(Id.t) => seg, ); -let parse_sum_term: UTyp.t => ConstructorMap.variant(UTyp.t) = +let parse_sum_term: + UTyp.t(IdTag.t) => ConstructorMap.variant(UTyp.t(IdTag.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), annotation: {ids, _}, _} => Variant(ctr, ids, None) + | { + term: Ap({term: Var(ctr), annotation: {ids: ids_ctr, _}, _}, u), + annotation: {ids: ids_ap, _}, + _, + } => Variant(ctr, ids_ctr @ ids_ap, Some(u)) | t => BadEntry(t); let mk_bad = (ctr, ids, value) => { - let t: Typ.t = {ids, copied: false, term: Var(ctr)}; + let t: Typ.t(IdTag.t) = { + annotation: { + 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(Id.t)): Term.Any.t => +let rec go_s = + (s: Sort.t, skel: Skel.t, seg: Segment.t(Id.t)): Term.Any.t(IdTag.t) => switch (s) { | Pat => Pat(pat(unsorted(skel, seg))) | TPat => TPat(tpat(unsorted(skel, seg))) @@ -169,10 +185,16 @@ let rec go_s = (s: Sort.t, skel: Skel.t, seg: Segment.t(Id.t)): Term.Any.t => and exp = unsorted => { let (term, inner_ids) = exp_term(unsorted); let ids = ids(unsorted) @ inner_ids; - return(e => Exp(e), ids, {ids, copied: false, term}); + return(e => Exp(e), ids, { + annotation: { + ids, + copied: false, + }, + term, + }); } -and exp_term: unsorted => (UExp.term(list(Id.t)), list(Id.t)) = { - let ret = (tm: UExp.term(list(Id.t))) => (tm, []); +and exp_term: unsorted => (UExp.term(IdTag.t), list(Id.t)) = { + let ret = (tm: UExp.term(IdTag.t)) => (tm, []); let hole = unsorted => UExp.hole(kids_of_unsorted(unsorted)); fun | Op(tiles) as tm => @@ -195,11 +217,17 @@ and exp_term: unsorted => (UExp.term(list(Id.t)), list(Id.t)) = { | (["(", ")"], [Exp(body)]) => ret(Parens(body)) | (["[", "]"], [Exp(body)]) => switch (body) { - | {ids, copied: false, term: Tuple(es)} => (ListLit(es), ids) + | {annotation: {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({annotation: {ids, _}, term: Rules(scrut, rules), _})], + ) => ( Match(scrut, rules), ids, ) @@ -247,13 +275,21 @@ and exp_term: unsorted => (UExp.term(list(Id.t)), list(Id.t)) = { Ap( Forward, l, - {ids: [Id.nullary_ap_flag], copied: false, term: Tuple([])}, + { + annotation: { + ids: [Id.nullary_ap_flag], + copied: false, + }, + term: Tuple([]), + }, ), ) | (["(", ")"], [Exp(arg)]) => - let use_deferral = (arg: UExp.t(list(Id.t))): UExp.t(list(Id.t)) => { - ids: arg.ids, - copied: false, + let use_deferral = (arg: UExp.t(IdTag.t)): UExp.t(IdTag.t) => { + annotation: { + ids: arg.annotation.ids, + copied: false, + }, term: Deferral(InAp), }; switch (arg.term) { @@ -267,7 +303,7 @@ and exp_term: unsorted => (UExp.term(list(Id.t)), list(Id.t)) = { es, ), ), - arg.ids, + arg.annotation.ids, ) | _ => ret(Ap(Forward, l, arg)) }; @@ -325,10 +361,16 @@ and exp_term: unsorted => (UExp.term(list(Id.t)), 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, copied: false}); + return(p => Pat(p), ids, { + term, + annotation: { + ids, + copied: false, + }, + }); } -and pat_term: unsorted => (UPat.term, list(Id.t)) = { - let ret = (term: UPat.term) => (term, []); +and pat_term: unsorted => (UPat.term(IdTag.t), list(Id.t)) = { + let ret = (term: UPat.term(IdTag.t)) => (term, []); let hole = unsorted => UPat.hole(kids_of_unsorted(unsorted)); fun | Op(tiles) as tm => @@ -391,10 +433,16 @@ 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, copied: false}); + return(ty => Typ(ty), ids, { + term, + annotation: { + ids, + copied: false, + }, + }); } -and typ_term: unsorted => (UTyp.term, list(Id.t)) = { - let ret = (term: UTyp.term) => (term, []); +and typ_term: unsorted => (UTyp.term(IdTag.t), list(Id.t)) = { + let ret = (term: UTyp.term(IdTag.t)) => (term, []); let hole = unsorted => UTyp.hole(kids_of_unsorted(unsorted)); fun | Op(tiles) as tm => @@ -429,7 +477,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), annotation: {ids, _}})) as tm => /* Case for leading prefix + preceeding a sum */ switch (tiles) { | ([(_, (["+"], []))], []) => (Sum(t0), ids) @@ -466,10 +514,16 @@ 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, copied: false}); + return(ty => TPat(ty), ids, { + term, + annotation: { + copied: false, + ids, + }, + }); } -and tpat_term: unsorted => TPat.term = { - let ret = (term: TPat.term) => term; +and tpat_term: unsorted => TPat.term(IdTag.t) = { + let ret = (term: TPat.term(IdTag.t)) => term; let hole = unsorted => TPat.hole(kids_of_unsorted(unsorted)); fun | Op(tiles) as tm => @@ -494,7 +548,7 @@ and tpat_term: unsorted => TPat.term = { // let ids = ids(unsorted); // return(r => Rul(r), ids, {ids, term}); // } -and rul = (unsorted: unsorted): Rul.t => { +and rul = (unsorted: unsorted): Rul.t(IdTag.t) => { let hole = Rul.Hole(kids_of_unsorted(unsorted)); switch (exp(unsorted)) { | {term: MultiHole(_), _} => @@ -502,16 +556,37 @@ and rul = (unsorted: unsorted): Rul.t => { | Bin(Exp(scrut), tiles, Exp(last_clause)) => switch (is_rules(tiles)) { | Some((ps, leading_clauses)) => { - ids: ids(unsorted), term: Rules(scrut, List.combine(ps, leading_clauses @ [last_clause])), - copied: false, + annotation: { + ids: ids(unsorted), + + copied: false, + }, + } + | None => { + term: hole, + annotation: { + ids: ids(unsorted), + copied: false, + }, } - | None => {ids: ids(unsorted), term: hole, copied: false} } - | _ => {ids: ids(unsorted), term: hole, copied: false} + | _ => { + term: hole, + annotation: { + ids: ids(unsorted), + copied: false, + }, + } + } + | e => { + term: Rules(e, []), + annotation: { + ids: [], + copied: false, + }, } - | e => {ids: [], term: Rules(e, []), copied: false} }; } @@ -519,7 +594,7 @@ and unsorted = (skel: Skel.t, seg: Segment.t(Id.t)): unsorted => { /* Remove projectors. We do this here as opposed to removing * them in an external call to save a whole-syntax pass. */ let seg = rm_and_log_projectors(seg); - let tile_kids = (p: Piece.t(Id.t)): list(Term.Any.t) => + let tile_kids = (p: Piece.t(Id.t)): list(Term.Any.t(IdTag.t)) => switch (p) { | Secondary(_) | Grout(_) => [] diff --git a/src/haz3lcore/statics/Mode.re b/src/haz3lcore/statics/Mode.re index 5a85dbecd9..cee499c9b3 100644 --- a/src/haz3lcore/statics/Mode.re +++ b/src/haz3lcore/statics/Mode.re @@ -22,23 +22,27 @@ type t = | SynFun /* Used only in function position of applications */ | SynTypFun | Syn - | Ana(Typ.t); + | Ana(Typ.t(IdTag.t)); -let ana: Typ.t => t = ty => Ana(ty); +let ana: Typ.t(IdTag.t) => t = ty => Ana(ty); /* The expected type imposed by a mode */ -let ty_of: t => Typ.t = +let ty_of: t => Typ.t(IdTag.t) = fun | Ana(ty) => ty | 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? */ + | SynTypFun => { + Forall( + TPat.fresh(Var("syntypfun"): TPat.term(IdTag.t)), + Unknown(SynSwitch) |> Typ.temp, + ) + |> Typ.temp /* TODO: naming the type variable? */; + }; -let of_arrow = (ctx: Ctx.t, mode: t): (t, t) => +let of_arrow = (ctx: Ctx.t(IdTag.t), mode: t): (t, t) => switch (mode) { | Syn | SynFun @@ -46,7 +50,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(string), mode: t): t => +let of_forall = (ctx: Ctx.t(IdTag.t), name_opt: option(string), mode: t): t => switch (mode) { | Syn | SynFun @@ -60,7 +64,7 @@ let of_forall = (ctx: Ctx.t, name_opt: option(string), mode: t): t => }; }; -let of_prod = (ctx: Ctx.t, mode: t, length): list(t) => +let of_prod = (ctx: Ctx.t(IdTag.t), mode: t, length): list(t) => switch (mode) { | Syn | SynFun @@ -68,7 +72,7 @@ let of_prod = (ctx: Ctx.t, mode: t, length): list(t) => | Ana(ty) => ty |> Typ.matched_prod(ctx, length) |> List.map(ana) }; -let of_cons_hd = (ctx: Ctx.t, mode: t): t => +let of_cons_hd = (ctx: Ctx.t(IdTag.t), mode: t): t => switch (mode) { | Syn | SynFun @@ -76,7 +80,7 @@ let of_cons_hd = (ctx: Ctx.t, mode: t): t => | Ana(ty) => Ana(Typ.matched_list(ctx, ty)) }; -let of_cons_tl = (ctx: Ctx.t, mode: t, hd_ty: Typ.t): t => +let of_cons_tl = (ctx: Ctx.t(IdTag.t), mode: t, hd_ty: Typ.t(IdTag.t)): t => switch (mode) { | Syn | SynFun @@ -84,7 +88,7 @@ let of_cons_tl = (ctx: Ctx.t, mode: t, hd_ty: Typ.t): t => | Ana(ty) => Ana(List(Typ.matched_list(ctx, ty)) |> Typ.temp) }; -let of_list = (ctx: Ctx.t, mode: t): t => +let of_list = (ctx: Ctx.t(IdTag.t), mode: t): t => switch (mode) { | Syn | SynFun @@ -92,7 +96,7 @@ let of_list = (ctx: Ctx.t, mode: t): t => | Ana(ty) => Ana(Typ.matched_list(ctx, ty)) }; -let of_list_concat = (ctx: Ctx.t, mode: t): t => +let of_list_concat = (ctx: Ctx.t(IdTag.t), mode: t): t => switch (mode) { | Syn | SynFun @@ -100,10 +104,12 @@ let of_list_concat = (ctx: Ctx.t, mode: t): t => | Ana(ty) => Ana(List(Typ.matched_list(ctx, ty)) |> Typ.temp) }; -let of_list_lit = (ctx: Ctx.t, length, mode: t): list(t) => +let of_list_lit = (ctx: Ctx.t(IdTag.t), length, mode: t): list(t) => List.init(length, _ => of_list(ctx, mode)); -let ctr_ana_typ = (ctx: Ctx.t, mode: t, ctr: Constructor.t): option(Typ.t) => { +let ctr_ana_typ = + (ctx: Ctx.t(IdTag.t), mode: t, ctr: Constructor.t) + : option(Typ.t(IdTag.t)) => { /* If a ctr is being analyzed against (an arrow type returning) a sum type having that ctr as a variant, we consider the ctr's type to be determined by the sum type */ @@ -120,7 +126,8 @@ 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) => +let of_ctr_in_ap = + (ctx: Ctx.t(IdTag.t), mode: t, ctr: Constructor.t): option(t) => switch (ctr_ana_typ(ctx, mode, ctr)) { | Some({term: Arrow(_), _} as ty_ana) => Some(Ana(ty_ana)) | Some(ty_ana) => @@ -149,7 +156,8 @@ let of_ap = (ctx, mode, ctr: option(Constructor.t)): t => let typap_mode: t = SynTypFun; -let of_deferred_ap_args = (length: int, ty_ins: list(Typ.t)): list(t) => +let of_deferred_ap_args = + (length: int, ty_ins: list(Typ.t(IdTag.t))): list(t) => ( List.length(ty_ins) == length ? ty_ins : List.init(length, _ => Typ.Unknown(Internal) |> Typ.temp) diff --git a/src/haz3lcore/statics/Self.re b/src/haz3lcore/statics/Self.re index cece7d2b0b..ade133ed28 100644 --- a/src/haz3lcore/statics/Self.re +++ b/src/haz3lcore/statics/Self.re @@ -27,14 +27,14 @@ type join_type = [@deriving (show({with_path: false}), sexp, yojson)] type t = - | Just(Typ.t) /* Just a regular type */ + | Just(Typ.t(IdTag.t)) /* Just a regular type */ | NoJoin(join_type, list(Typ.source)) /* Inconsistent types for e.g match, listlits */ | BadToken(Token.t) /* Invalid expression token, treated as hole */ - | BadTrivAp(Typ.t) /* Trivial (nullary) ap on function that doesn't take triv */ + | BadTrivAp(Typ.t(IdTag.t)) /* Trivial (nullary) ap on function that doesn't take triv */ | IsMulti /* Multihole, treated as hole */ | IsConstructor({ name: Constructor.t, - syn_ty: option(Typ.t), + syn_ty: option(Typ.t(IdTag.t)), }); /* Constructors have special ana logic */ [@deriving (show({with_path: false}), sexp, yojson)] @@ -59,7 +59,7 @@ type pat = | Redundant(pat) | Common(t); -let join_of = (j: join_type, ty: Typ.t): Typ.t => +let join_of = (j: join_type, ty: Typ.t('a)): Typ.t('a) => switch (j) { | Id => ty | List => List(ty) |> Typ.fresh @@ -68,7 +68,7 @@ let join_of = (j: join_type, ty: Typ.t): Typ.t => /* What the type would be if the position had been synthetic, so no hole fixing. Returns none if there's no applicable synthetic rule. */ -let typ_of: (Ctx.t, t) => option(Typ.t) = +let typ_of: (Ctx.t('a), t) => option(Typ.t('a)) = _ctx => fun | Just(typ) => Some(typ) @@ -78,7 +78,7 @@ let typ_of: (Ctx.t, t) => option(Typ.t) = | IsMulti | NoJoin(_) => None; -let typ_of_exp: (Ctx.t, exp) => option(Typ.t) = +let typ_of_exp: (Ctx.t('a), exp) => option(Typ.t('a)) = ctx => fun | Free(_) @@ -87,7 +87,7 @@ let typ_of_exp: (Ctx.t, exp) => option(Typ.t) = | IsBadPartialAp(_) => None | Common(self) => typ_of(ctx, self); -let rec typ_of_pat: (Ctx.t, pat) => option(Typ.t) = +let rec typ_of_pat: (Ctx.t('a), pat) => option(Typ.t('a)) = ctx => fun | Redundant(pat) => typ_of_pat(ctx, pat) @@ -95,7 +95,7 @@ let rec typ_of_pat: (Ctx.t, pat) => option(Typ.t) = /* The self of a var depends on the ctx; if the lookup fails, it is a free variable */ -let of_exp_var = (ctx: Ctx.t, name: Var.t): exp => +let of_exp_var = (ctx: Ctx.t('a), name: Var.t): exp => switch (Ctx.lookup_var(ctx, name)) { | None => Free(name) | Some(var) => Common(Just(var.typ)) @@ -104,7 +104,7 @@ let of_exp_var = (ctx: Ctx.t, name: Var.t): exp => /* The self of a ctr depends on the ctx, but a lookup failure doesn't necessarily means its free; it may be given a type analytically */ -let of_ctr = (ctx: Ctx.t, name: Constructor.t): t => +let of_ctr = (ctx: Ctx.t('a), name: Constructor.t): t => IsConstructor({ name, syn_ty: @@ -114,7 +114,8 @@ let of_ctr = (ctx: Ctx.t, name: Constructor.t): t => }, }); -let of_deferred_ap = (args, ty_ins: list(Typ.t), ty_out: Typ.t): exp => { +let of_deferred_ap = + (args, ty_ins: list(Typ.t('a)), ty_out: Typ.t('a)): exp => { let expected = List.length(ty_ins); let actual = List.length(args); if (expected != actual) { @@ -135,19 +136,21 @@ let of_deferred_ap = (args, ty_ins: list(Typ.t), ty_out: Typ.t): exp => { let add_source = List.map2((id, ty) => Typ.{id, ty}); -let match = (ctx: Ctx.t, tys: list(Typ.t), ids: list(Id.t)): t => +let match = (ctx: Ctx.t('a), tys: list(Typ.t('a)), ids: list(Id.t)): t => switch (Typ.join_all(~empty=Unknown(Internal) |> Typ.fresh, ctx, tys)) { | None => NoJoin(Id, add_source(ids, tys)) | Some(ty) => Just(ty) }; -let listlit = (~empty, ctx: Ctx.t, tys: list(Typ.t), ids: list(Id.t)): t => +let listlit = + (~empty, ctx: Ctx.t('a), tys: list(Typ.t('a)), ids: list(Id.t)): t => switch (Typ.join_all(~empty, ctx, tys)) { | None => NoJoin(List, add_source(ids, tys)) | Some(ty) => Just(List(ty) |> Typ.fresh) }; -let list_concat = (ctx: Ctx.t, tys: list(Typ.t), ids: list(Id.t)): t => +let list_concat = + (ctx: Ctx.t('a), tys: list(Typ.t('a)), ids: list(Id.t)): t => 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 67f0bad705..39cefa74e0 100644 --- a/src/haz3lcore/statics/Statics.re +++ b/src/haz3lcore/statics/Statics.re @@ -55,7 +55,7 @@ let map_m = (f, xs, m: Map.t) => 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) => { +let rec is_arrow_like = (t: Typ.t(IdTag.t)) => { switch (t |> Typ.term_of) { | Unknown(_) => true | Arrow(_) => true @@ -64,7 +64,7 @@ let rec is_arrow_like = (t: Typ.t) => { }; }; -let is_recursive = (ctx, p, def, syn: Typ.t) => { +let is_recursive = (ctx, p, def, syn: Typ.t(IdTag.t)) => { 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 => @@ -79,7 +79,7 @@ let is_recursive = (ctx, p, def, syn: Typ.t) => { }; }; -let typ_exp_binop_bin_int: Operators.op_bin_int => Typ.t = +let typ_exp_binop_bin_int: Operators.op_bin_int => Typ.t(IdTag.t) = fun | (Plus | Minus | Times | Power | Divide) as _op => Int |> Typ.temp | ( @@ -88,7 +88,7 @@ let typ_exp_binop_bin_int: Operators.op_bin_int => Typ.t = ) as _op => Bool |> Typ.temp; -let typ_exp_binop_bin_float: Operators.op_bin_float => Typ.t = +let typ_exp_binop_bin_float: Operators.op_bin_float => Typ.t(IdTag.t) = fun | (Plus | Minus | Times | Power | Divide) as _op => Float |> Typ.temp | ( @@ -97,12 +97,13 @@ let typ_exp_binop_bin_float: Operators.op_bin_float => Typ.t = ) as _op => Bool |> Typ.temp; -let typ_exp_binop_bin_string: Operators.op_bin_string => Typ.t = +let typ_exp_binop_bin_string: Operators.op_bin_string => Typ.t(IdTag.t) = fun | Concat => String |> Typ.temp | Equals => Bool |> Typ.temp; -let typ_exp_binop: Operators.op_bin => (Typ.t, Typ.t, Typ.t) = +let typ_exp_binop: + Operators.op_bin => (Typ.t(IdTag.t), Typ.t(IdTag.t), Typ.t(IdTag.t)) = fun | 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)) @@ -117,7 +118,7 @@ let typ_exp_binop: Operators.op_bin => (Typ.t, Typ.t, Typ.t) = typ_exp_binop_bin_string(op), ); -let typ_exp_unop: Operators.op_un => (Typ.t, Typ.t) = +let typ_exp_unop: Operators.op_un => (Typ.t(IdTag.t), Typ.t(IdTag.t)) = fun | Meta(Unquote) => ( Var("$Meta") |> Typ.temp, @@ -127,7 +128,8 @@ let typ_exp_unop: Operators.op_un => (Typ.t, Typ.t) = | Int(Minus) => (Int |> Typ.temp, Int |> Typ.temp); let rec any_to_info_map = - (~ctx: Ctx.t, ~ancestors, any: Any.t, m: Map.t): (CoCtx.t, Map.t) => + (~ctx: Ctx.t(IdTag.t), ~ancestors, any: Any.t(IdTag.t), m: Map.t) + : (CoCtx.t(IdTag.t), Map.t) => switch (any) { | Exp(e) => let ({co_ctx, _}: Info.exp, m) = @@ -168,11 +170,11 @@ and multi = (~ctx, ~ancestors, m, tms) => ) and uexp_to_info_map = ( - ~ctx: Ctx.t, + ~ctx: Ctx.t(IdTag.t), ~mode=Mode.Syn, ~is_in_filter=false, ~ancestors, - {ids, copied: _, term} as uexp: UExp.t(list(Id.t)), + {annotation: {ids, copied: _}, term} as uexp: UExp.t(IdTag.t), m: Map.t, ) : (Info.exp, Map.t) => { @@ -195,7 +197,7 @@ and uexp_to_info_map = ~mode=Mode.Syn, ~is_in_filter=is_in_filter, ~ancestors=ancestors, - uexp: UExp.t(list(Id.t)), + uexp: UExp.t(IdTag.t), m: Map.t, ) => { uexp_to_info_map(~ctx, ~mode, ~is_in_filter, ~ancestors, uexp, m); @@ -271,9 +273,11 @@ and uexp_to_info_map = 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(list(Id.t)) = { - ids: e.ids, - copied: false, + let e: UExp.t(IdTag.t) = { + annotation: { + ids: e.annotation.ids, + copied: false, + }, term: switch (e.term) { | Var("e") => UExp.Constructor("$e", Unknown(Internal) |> Typ.temp) @@ -333,7 +337,7 @@ and uexp_to_info_map = 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) + Id.is_nullary_ap_flag(arg.term.annotation.ids) && !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); @@ -526,7 +530,7 @@ and uexp_to_info_map = let (self, m) = switch (constraint_ty) { | Some(constraint_ty) => - let pats_to_info_map = (ps: list(UPat.t), m) => { + let pats_to_info_map = (ps: list(UPat.t(IdTag.t)), m) => { /* Add co-ctxs to patterns */ List.fold_left( ((m, acc_constraint), (p, co_ctx)) => { @@ -566,7 +570,7 @@ and uexp_to_info_map = ); ( // Override the info for the single upat - add_info(p.term.ids, InfoPat(info), m), + add_info(p.term.annotation.ids, InfoPat(info), m), is_redundant ? acc_constraint // Redundant patterns are ignored : Constraint.Or(p_constraint, acc_constraint), @@ -616,7 +620,7 @@ and uexp_to_info_map = use a different name than the alias for the recursive parameter */ //let ty_rec = Typ.Rec("α", Typ.subst(Var("α"), name, ty_pre)); let ty_rec = - Typ.Rec(TPat.Var(name) |> IdTagged.fresh, utyp) |> Typ.temp; + Typ.Rec(TPat.Var(name) |> Annotated.fresh, utyp) |> Typ.temp; let ctx_def = Ctx.extend_alias(ctx, name, TPat.rep_id(typat), ty_rec); (ty_rec, ctx_def, ctx_def); @@ -669,7 +673,7 @@ and upat_to_info_map = ~co_ctx, ~ancestors: Info.ancestors, ~mode: Mode.t=Mode.Syn, - {ids, term, _} as upat: UPat.t, + {annotation: {ids, _}, term, _} as upat: UPat.t(IdTag.t), m: Map.t, ) : (Info.pat, Map.t) => { @@ -698,7 +702,7 @@ and upat_to_info_map = 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) |> Typ.temp; - let ctx_fold = (ctx: Ctx.t, m) => + let ctx_fold = (ctx: Ctx.t(IdTag.t), m) => List.fold_left2( ((ctx, tys, cons, m), e, mode) => go(~ctx, ~mode, e, m) @@ -822,7 +826,7 @@ and utyp_to_info_map = ~ctx, ~expects=Info.TypeExpected, ~ancestors, - {ids, term, _} as utyp: UTyp.t, + {annotation: {ids, _}, term, _} as utyp: UTyp.t(IdTag.t), m: Map.t, ) : (Info.typ, Map.t) => { @@ -920,7 +924,12 @@ and utyp_to_info_map = }; } and utpat_to_info_map = - (~ctx, ~ancestors, {ids, term, _} as utpat: TPat.t, m: Map.t) + ( + ~ctx, + ~ancestors, + {annotation: {ids, _}, term, _} as utpat: TPat.t(IdTag.t), + m: Map.t, + ) : (Info.tpat, Map.t) => { let add = m => { let info = Info.derived_tpat(~utpat, ~ctx, ~ancestors); @@ -942,7 +951,7 @@ and variant_to_info_map = ~ancestors, ~ty_sum, (m, ctrs), - uty: ConstructorMap.variant(UTyp.t), + uty: ConstructorMap.variant(UTyp.t(IdTag.t)), ) => { let go = expects => utyp_to_info_map(~ctx, ~ancestors, ~expects); switch (uty) { @@ -956,7 +965,13 @@ and variant_to_info_map = List.mem(ctr, ctrs) ? Duplicate : Unique, ty_sum, ), - {term: Var(ctr), ids, copied: false}, + { + term: Var(ctr), + annotation: { + ids, + copied: false, + }, + }, m, ) |> snd; diff --git a/src/haz3lcore/statics/Term.re b/src/haz3lcore/statics/Term.re index fab423acd4..283ae663d5 100644 --- a/src/haz3lcore/statics/Term.re +++ b/src/haz3lcore/statics/Term.re @@ -20,24 +20,25 @@ module Pat = { include TermBase.Pat; - let rep_id = ({ids, _}: t) => { + let rep_id = (t: t(IdTag.t)) => { + let ids = t.annotation.ids; assert(ids != []); List.hd(ids); }; - let term_of: t => TermBase.Pat.term = IdTagged.term_of; + let term_of: t('a) => TermBase.Pat.term('a) = Annotated.term_of; - let unwrap: t => (term, term => t) = IdTagged.unwrap; + let unwrap: t('a) => (term('a), term('a) => t('a)) = Annotated.unwrap; - let fresh: term => t = IdTagged.fresh; + let fresh: term(IdTag.t) => t(IdTag.t) = Annotated.fresh; - let hole = (tms: list(TermBase.Any.t)) => + let hole = (tms: list(TermBase.Any.t('a))) => switch (tms) { | [] => EmptyHole | [_, ..._] => MultiHole(tms) }; - let cls_of_term: term => cls = + let cls_of_term: term('a) => cls = fun | Invalid(_) => Invalid | EmptyHole => EmptyHole @@ -75,7 +76,7 @@ module Pat = { | Ap => "Constructor application" | Cast => "Annotation"; - let rec is_var = (pat: t) => { + let rec is_var = (pat: t('a)) => { switch (pat.term) { | Parens(pat) | Cast(pat, _, _) => is_var(pat) @@ -96,7 +97,7 @@ module Pat = { }; }; - let rec is_fun_var = (pat: t) => { + let rec is_fun_var = (pat: t('a)) => { switch (pat.term) { | Parens(pat) => is_fun_var(pat) | Cast(pat, typ, _) => @@ -118,7 +119,7 @@ module Pat = { }; }; - let rec is_tuple_of_arrows = (pat: t) => + let rec is_tuple_of_arrows = (pat: t('a)) => is_fun_var(pat) || ( switch (pat.term) { @@ -141,7 +142,7 @@ module Pat = { } ); - let rec is_tuple_of_vars = (pat: t) => + let rec is_tuple_of_vars = (pat: t('a)) => is_var(pat) || ( switch (pat.term) { @@ -164,7 +165,7 @@ module Pat = { } ); - let rec get_var = (pat: t) => { + let rec get_var = (pat: t('a)) => { switch (pat.term) { | Parens(pat) => get_var(pat) | Var(x) => Some(x) @@ -185,7 +186,7 @@ module Pat = { }; }; - let rec get_fun_var = (pat: t) => { + let rec get_fun_var = (pat: t('a)) => { switch (pat.term) { | Parens(pat) => get_fun_var(pat) | Cast(pat, t1, _) => @@ -211,7 +212,7 @@ module Pat = { }; }; - let rec get_bindings = (pat: t) => + let rec get_bindings = (pat: t('a)) => switch (get_var(pat)) { | Some(x) => Some([x]) | None => @@ -241,7 +242,7 @@ module Pat = { } }; - let rec get_num_of_vars = (pat: t) => + let rec get_num_of_vars = (pat: t('a)) => if (is_var(pat)) { Some(1); } else { @@ -266,7 +267,7 @@ module Pat = { }; }; - let ctr_name = (p: t): option(Constructor.t) => + let ctr_name = (p: t('a)): option(Constructor.t) => switch (p.term) { | Constructor(name, _) => Some(name) | _ => None @@ -318,19 +319,17 @@ module Exp = { | Cast | ListConcat; - let hole = (tms: list(TermBase.Any.t)): term(list(Id.t)) => + let hole = (tms: list(TermBase.Any.t('a))): term('a) => switch (tms) { | [] => EmptyHole | [_, ..._] => MultiHole(tms) }; - let rep_id: t(list(Id.t)) => Id.t = IdTagged.rep_id; - let fresh: term(list(Id.t)) => t(list(Id.t)) = IdTagged.fresh; - let unwrap: - t(list(Id.t)) => - (term(list(Id.t)), term(list(Id.t)) => t(list(Id.t))) = IdTagged.unwrap; + let rep_id: t(IdTag.t) => Id.t = Annotated.rep_id; + let fresh: term(IdTag.t) => t(IdTag.t) = Annotated.fresh; + let unwrap: t(IdTag.t) => (term(IdTag.t), term(IdTag.t) => t(IdTag.t)) = Annotated.unwrap; - let cls_of_term: term(list(Id.t)) => cls = + let cls_of_term: term(IdTag.t) => cls = fun | Invalid(_) => Invalid | EmptyHole => EmptyHole @@ -413,7 +412,7 @@ module Exp = { // 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(list(Id.t))) => { + let rec is_fun = (e: t('a)) => { switch (e.term) { | Parens(e) => is_fun(e) | Cast(e, _, _) => is_fun(e) @@ -454,7 +453,7 @@ module Exp = { }; }; - let rec is_tuple_of_functions = (e: t(list(Id.t))) => + let rec is_tuple_of_functions = (e: t('a)) => is_fun(e) || ( switch (e.term) { @@ -497,20 +496,20 @@ module Exp = { } ); - let ctr_name = (e: t(list(Id.t))): option(Constructor.t) => + let ctr_name = (e: t('a)): option(Constructor.t) => switch (e.term) { | Constructor(name, _) => Some(name) | _ => None }; - let is_deferral = (e: t(list(Id.t))) => { + let is_deferral = (e: t('a)) => { switch (e.term) { | Deferral(_) => true | _ => false }; }; - let rec get_num_of_functions = (e: t(list(Id.t))) => + let rec get_num_of_functions = (e: t('a)) => if (is_fun(e)) { Some(1); } else { @@ -565,13 +564,13 @@ module Rul = { // example of awkwardness induced by having forms like rules // that may have a different-sorted child with no delimiters // (eg scrut with no rules) - let ids = (~any_ids, {ids, term, _}: t) => - switch (ids) { - | [_, ..._] => ids + let ids = (~any_ids, t: t(IdTag.t)) => + switch (t.annotation.ids) { + | [_, ..._] => t.annotation.ids | [] => - switch (term) { + switch (t.term) { | Hole([tm, ..._]) => any_ids(tm) - | Rules(scrut, []) => scrut.ids + | Rules(scrut, []) => scrut.annotation.ids | _ => [] } }; @@ -586,25 +585,25 @@ module Rul = { module Any = { include TermBase.Any; - let is_exp: t => option(TermBase.Exp.t(list(Id.t))) = + let is_exp: t('a) => option(TermBase.Exp.t('a)) = fun | Exp(e) => Some(e) | _ => None; - let is_pat: t => option(TermBase.Pat.t) = + let is_pat: t('a) => option(TermBase.Pat.t('a)) = fun | Pat(p) => Some(p) | _ => None; - let is_typ: t => option(TermBase.Typ.t) = + let is_typ: t('a) => option(TermBase.Typ.t('a)) = fun | Typ(t) => Some(t) | _ => None; - let rec ids = + let rec ids: t(IdTag.t) => list(Id.t) = fun - | Exp(tm) => tm.ids - | Pat(tm) => tm.ids - | Typ(tm) => tm.ids - | TPat(tm) => tm.ids + | Exp(tm) => tm.annotation.ids + | Pat(tm) => tm.annotation.ids + | Typ(tm) => tm.annotation.ids + | TPat(tm) => tm.annotation.ids | Rul(tm) => Rul.ids(~any_ids=ids, tm) | Nul () | Any () => []; diff --git a/src/haz3lcore/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index 459db2b59e..40d5943f9c 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -177,7 +177,7 @@ and Exp: { two consistent types. Both types should be normalized in dynamics for the cast calculus to work right. */ | Cast(t('a), Typ.t('a), Typ.t('a)) // first Typ.t field is only meaningful in dynamic expressions - and t('a) = Annotated.t(term('a), IdTag.t); + and t('a) = Annotated.t(term('a), 'a); let map_term: ( @@ -244,7 +244,7 @@ and Exp: { two consistent types. Both types should be normalized in dynamics for the cast calculus to work right. */ | Cast(t('a), Typ.t('a), Typ.t('a)) // first Typ.t field is only meaningful in dynamic expressions - and t('a) = Annotated.t(term('a), IdTag.t); + and t('a) = Annotated.t(term('a), 'a); let map_term = ( @@ -470,7 +470,7 @@ and Pat: { | Parens(t('a)) | Ap(t('a), t('a)) | Cast(t('a), Typ.t('a), Typ.t('a)) // The second Typ.t field is only meaningful in dynamic patterns - and t('a) = Annotated.t(term('a), IdTag.t); + and t('a) = Annotated.t(term('a), 'a); let map_term: ( @@ -504,7 +504,7 @@ and Pat: { | Parens(t('a)) | Ap(t('a), t('a)) | Cast(t('a), Typ.t('a), Typ.t('a)) // The second one is hidden from the user - and t('a) = Annotated.t(term('a), IdTag.t); + and t('a) = Annotated.t(term('a), 'a); let map_term = ( @@ -624,7 +624,7 @@ and Typ: { | Ap(t('a), t('a)) | Rec(TPat.t('a), t('a)) | Forall(TPat.t('a), t('a)) - and t('a) = Annotated.t(term('a), IdTag.t); + and t('a) = Annotated.t(term('a), 'a); type sum_map('a) = ConstructorMap.t(t('a)); @@ -676,7 +676,7 @@ and Typ: { | Ap(t('a), t('a)) | Rec(TPat.t('a), t('a)) | Forall(TPat.t('a), t('a)) - and t('a) = Annotated.t(term('a), IdTag.t); + and t('a) = Annotated.t(term('a), 'a); type sum_map('a) = ConstructorMap.t(t('a)); @@ -820,7 +820,7 @@ and TPat: { | EmptyHole | MultiHole(list(Any.t('a))) | Var(string) - and t('a) = Annotated.t(term('a), IdTag.t); + and t('a) = Annotated.t(term('a), 'a); let map_term: ( @@ -844,7 +844,7 @@ and TPat: { | EmptyHole | MultiHole(list(Any.t('a))) | Var(string) - and t('a) = Annotated.t(term('a), IdTag.t); + and t('a) = Annotated.t(term('a), 'a); let map_term = ( @@ -897,7 +897,7 @@ and Rul: { | Invalid(string) | Hole(list(Any.t('a))) | Rules(Exp.t('a), list((Pat.t('a), Exp.t('a)))) - and t('a) = Annotated.t(term('a), IdTag.t); + and t('a) = Annotated.t(term('a), 'a); let map_term: ( @@ -918,7 +918,7 @@ and Rul: { | Invalid(string) | Hole(list(Any.t('a))) | Rules(Exp.t('a), list((Pat.t('a), Exp.t('a)))) - and t('a) = Annotated.t(term('a), IdTag.t); + and t('a) = Annotated.t(term('a), 'a); let map_term = ( @@ -982,12 +982,12 @@ and Environment: { type t_('a) = VarBstMap.Ordered.t_('a); [@deriving (show({with_path: false}), sexp, yojson)] - type t = t_(Exp.t(list(Id.t))); + type t = t_(Exp.t(IdTag.t)); } = { include VarBstMap.Ordered; [@deriving (show({with_path: false}), sexp, yojson)] - type t = t_(Exp.t(list(Id.t))); + type t = t_(Exp.t(IdTag.t)); } and ClosureEnvironment: { @@ -999,7 +999,7 @@ and ClosureEnvironment: { let id_of: t => Id.t; let map_of: t => Environment.t; - let to_list: t => list((Var.t, Exp.t(list(Id.t)))); + let to_list: t => list((Var.t, Exp.t(IdTag.t))); let of_environment: Environment.t => t; @@ -1009,20 +1009,19 @@ and ClosureEnvironment: { let is_empty: t => bool; let length: t => int; - let lookup: (t, Var.t) => option(Exp.t(list(Id.t))); + let lookup: (t, Var.t) => option(Exp.t(IdTag.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(list(Id.t)))) => t; - let extend_keep_id: (t, (Var.t, Exp.t(list(Id.t)))) => t; + let extend: (t, (Var.t, Exp.t(IdTag.t))) => t; + let extend_keep_id: (t, (Var.t, Exp.t(IdTag.t))) => t; let union: (t, t) => t; let union_keep_id: (t, t) => t; - let map: (((Var.t, Exp.t(list(Id.t)))) => Exp.t(list(Id.t)), t) => t; - let map_keep_id: - (((Var.t, Exp.t(list(Id.t)))) => Exp.t(list(Id.t)), t) => t; - let filter: (((Var.t, Exp.t(list(Id.t)))) => bool, t) => t; - let filter_keep_id: (((Var.t, Exp.t(list(Id.t)))) => bool, t) => t; - let fold: (((Var.t, Exp.t(list(Id.t))), 'b) => 'b, 'b, t) => 'b; + let map: (((Var.t, Exp.t(IdTag.t))) => Exp.t(IdTag.t), t) => t; + let map_keep_id: (((Var.t, Exp.t(IdTag.t))) => Exp.t(IdTag.t), t) => t; + let filter: (((Var.t, Exp.t(IdTag.t))) => bool, t) => t; + let filter_keep_id: (((Var.t, Exp.t(IdTag.t))) => bool, t) => t; + let fold: (((Var.t, Exp.t(IdTag.t)), 'b) => 'b, 'b, t) => 'b; let without_keys: (list(Var.t), t) => t; diff --git a/src/haz3lcore/zipper/Editor.re b/src/haz3lcore/zipper/Editor.re index fc0ef65c27..3e44557f43 100644 --- a/src/haz3lcore/zipper/Editor.re +++ b/src/haz3lcore/zipper/Editor.re @@ -2,13 +2,20 @@ open Util; module CachedStatics = { type t = { - term: UExp.t(list(Id.t)), + term: UExp.t(IdTag.t), info_map: Statics.Map.t, error_ids: list(Id.t), }; let empty: t = { - term: UExp.{ids: [Id.invalid], copied: false, term: Tuple([])}, + term: + UExp.{ + annotation: { + ids: [Id.invalid], + copied: false, + }, + term: Tuple([]), + }, info_map: Id.Map.empty, error_ids: [], }; @@ -43,7 +50,7 @@ module CachedSyntax = { tiles: TileMap.t, holes: list(Grout.t), selection_ids: list(Id.t), - term: UExp.t(list(Id.t)), + term: UExp.t(IdTag.t), /* This term, and the term-derived data structured below, may differ * from the term used for semantics. These terms are identical when * the backpack is empty. If the backpack is non-empty, then when we diff --git a/src/haz3lcore/zipper/EditorUtil.re b/src/haz3lcore/zipper/EditorUtil.re index 2105a774d5..f4063948b8 100644 --- a/src/haz3lcore/zipper/EditorUtil.re +++ b/src/haz3lcore/zipper/EditorUtil.re @@ -1,6 +1,5 @@ let rec append_exp = - (e1: Exp.t(list(Id.t)), e2: Exp.t(list(Id.t))) - : Exp.t(list(Id.t)) => { + (e1: Exp.t(IdTag.t), e2: Exp.t(IdTag.t)): Exp.t(IdTag.t) => { Exp.( switch (e1.term) { | EmptyHole @@ -34,19 +33,50 @@ let rec append_exp = | BinOp(_) | BuiltinFun(_) | Cast(_) - | Match(_) => Exp.{ids: [Id.mk()], copied: false, term: Seq(e1, e2)} + | Match(_) => + Exp.{ + annotation: { + 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')}; + { + annotation: { + ids: e1.annotation.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')}; + { + annotation: { + ids: e1.annotation.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')}; + { + annotation: { + ids: e1.annotation.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')}; + { + annotation: { + ids: e1.annotation.ids, + copied: false, + }, + term: TyAlias(tp, tdef, ebody'), + }; } ); }; diff --git a/src/haz3lcore/zipper/projectors/InfoProj.re b/src/haz3lcore/zipper/projectors/InfoProj.re index 6102d7f689..5639266a5f 100644 --- a/src/haz3lcore/zipper/projectors/InfoProj.re +++ b/src/haz3lcore/zipper/projectors/InfoProj.re @@ -9,20 +9,20 @@ let mode = (info: option(Info.t)): option(Mode.t) => | _ => None }; -let expected_ty = (info: option(Info.t)): option(Typ.t) => +let expected_ty = (info: option(Info.t)): option(Typ.t(IdTag.t)) => switch (mode(info)) { | Some(mode) => Some(Mode.ty_of(mode)) | _ => None }; -let self_ty = (info: option(Info.t)): option(Typ.t) => +let self_ty = (info: option(Info.t)): option(Typ.t(IdTag.t)) => switch (info) { | Some(InfoExp({self, ctx, _})) => Self.typ_of_exp(ctx, self) | Some(InfoPat({self, ctx, _})) => Self.typ_of_pat(ctx, self) | _ => None }; -let totalize_ty = (expected_ty: option(Typ.t)): Typ.t => +let totalize_ty = (expected_ty: option(Typ.t(IdTag.t))): Typ.t(IdTag.t) => switch (expected_ty) { | Some(expected_ty) => expected_ty | None => Typ.fresh(Unknown(Internal)) diff --git a/src/haz3lschool/Exercise.re b/src/haz3lschool/Exercise.re index 2b4d467b96..dc9245d964 100644 --- a/src/haz3lschool/Exercise.re +++ b/src/haz3lschool/Exercise.re @@ -569,8 +569,7 @@ module F = (ExerciseEnv: ExerciseEnv) => { }; let wrap_filter = - (act: FilterAction.action, term: UExp.t(list(Id.t))) - : UExp.t(list(Id.t)) => + (act: FilterAction.action, term: UExp.t(IdTag.t)): UExp.t(IdTag.t) => Exp.{ term: Exp.Filter( @@ -578,17 +577,21 @@ module F = (ExerciseEnv: ExerciseEnv) => { act: FilterAction.(act, One), pat: { term: Constructor("$e", Unknown(Internal) |> Typ.temp), - copied: false, - ids: [Id.mk()], + annotation: { + copied: false, + ids: [Id.mk()], + }, }, }), term, ), - copied: false, - ids: [Id.mk()], + annotation: { + copied: false, + ids: [Id.mk()], + }, }; - let term_of = (editor: Editor.t): UExp.t(list(Id.t)) => + let term_of = (editor: Editor.t): UExp.t(IdTag.t) => MakeTerm.from_zip_for_sem(editor.state.zipper).term; let stitch3 = (ed1: Editor.t, ed2: Editor.t, ed3: Editor.t) => @@ -597,7 +600,7 @@ module F = (ExerciseEnv: ExerciseEnv) => { term_of(ed3), ); - let stitch_term = ({eds, _}: state): stitched(UExp.t(list(Id.t))) => { + let stitch_term = ({eds, _}: state): stitched(UExp.t(IdTag.t)) => { let instructor = stitch3(eds.prelude, eds.correct_impl, eds.hidden_tests.tests); let user_impl_term = { @@ -622,7 +625,7 @@ module F = (ExerciseEnv: ExerciseEnv) => { instructor, hidden_bugs: List.map( - (t): UExp.t(list(Id.t)) => + (t): UExp.t(IdTag.t) => stitch3(eds.prelude, t.impl, eds.your_tests.tests), eds.hidden_bugs, ), @@ -639,9 +642,9 @@ module F = (ExerciseEnv: ExerciseEnv) => { Stitching is necessary to concatenate terms from different editors, which are then typechecked. */ let stitch_static = - (settings: CoreSettings.t, t: stitched(UExp.t(list(Id.t)))) + (settings: CoreSettings.t, t: stitched(UExp.t(IdTag.t))) : stitched_statics => { - let mk = (term: UExp.t(list(Id.t))): Editor.CachedStatics.t => { + let mk = (term: UExp.t(IdTag.t)): Editor.CachedStatics.t => { let info_map = Statics.mk(settings, Builtins.ctx_init, term); {term, error_ids: Statics.Map.error_ids(info_map), info_map}; }; diff --git a/src/haz3lschool/SyntaxTest.re b/src/haz3lschool/SyntaxTest.re index 911c7031a5..41eb4ba912 100644 --- a/src/haz3lschool/SyntaxTest.re +++ b/src/haz3lschool/SyntaxTest.re @@ -14,7 +14,7 @@ type syntax_result = { percentage: float, }; -let rec find_var_upat = (name: string, upat: Pat.t): bool => { +let rec find_var_upat = (name: string, upat: Pat.t(IdTag.t)): bool => { switch (upat.term) { | Var(x) => x == name | EmptyHole @@ -46,11 +46,11 @@ let rec find_var_upat = (name: string, upat: Pat.t): bool => { let rec find_in_let = ( name: string, - upat: UPat.t, - def: UExp.t(list(Id.t)), - l: list(UExp.t(list(Id.t))), + upat: UPat.t(IdTag.t), + def: UExp.t(IdTag.t), + l: list(UExp.t(IdTag.t)), ) - : list(UExp.t(list(Id.t))) => { + : list(UExp.t(IdTag.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) @@ -86,12 +86,8 @@ let rec find_in_let = Find any function expressions in uexp that are bound to variable name */ let rec find_fn = - ( - name: string, - uexp: UExp.t(list(Id.t)), - l: list(UExp.t(list(Id.t))), - ) - : list(UExp.t(list(Id.t))) => { + (name: string, uexp: UExp.t(IdTag.t), l: list(UExp.t(IdTag.t))) + : list(UExp.t(IdTag.t)) => { switch (uexp.term) { | Let(up, def, body) => l |> find_in_let(name, up, def) |> find_fn(name, body) @@ -146,7 +142,7 @@ let rec find_fn = /* Finds whether variable name is ever mentioned in upat. */ -let rec var_mention_upat = (name: string, upat: Pat.t): bool => { +let rec var_mention_upat = (name: string, upat: Pat.t(IdTag.t)): bool => { switch (upat.term) { | Var(x) => x == name | EmptyHole @@ -177,7 +173,7 @@ let rec var_mention_upat = (name: string, upat: Pat.t): bool => { /* Finds whether variable name is ever mentioned in uexp. */ -let rec var_mention = (name: string, uexp: Exp.t(list(Id.t))): bool => { +let rec var_mention = (name: string, uexp: Exp.t(IdTag.t)): bool => { switch (uexp.term) { | Var(x) => x == name | EmptyHole @@ -238,7 +234,7 @@ let rec var_mention = (name: string, uexp: Exp.t(list(Id.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: Exp.t(list(Id.t))): bool => { +let rec var_applied = (name: string, uexp: Exp.t(IdTag.t)): bool => { switch (uexp.term) { | Var(_) | EmptyHole @@ -309,7 +305,7 @@ let rec var_applied = (name: string, uexp: Exp.t(list(Id.t))): bool => { /* Check whether all functions bound to variable name are recursive. */ -let is_recursive = (name: string, uexp: Exp.t(list(Id.t))): bool => { +let is_recursive = (name: string, uexp: Exp.t(IdTag.t)): bool => { let fn_bodies = [] |> find_fn(name, uexp); if (List.length(fn_bodies) == 0) { false; @@ -327,7 +323,7 @@ let is_recursive = (name: string, uexp: Exp.t(list(Id.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: Exp.t(list(Id.t))): bool => { +let rec tail_check = (name: string, uexp: Exp.t(IdTag.t)): bool => { switch (uexp.term) { | EmptyHole | Deferral(_) @@ -388,7 +384,7 @@ let rec tail_check = (name: string, uexp: Exp.t(list(Id.t))): bool => { /* Check whether all functions bound to variable name are tail recursive. */ -let is_tail_recursive = (name: string, uexp: UExp.t(list(Id.t))): bool => { +let is_tail_recursive = (name: string, uexp: UExp.t(IdTag.t)): bool => { let fn_bodies = [] |> find_fn(name, uexp); if (List.length(fn_bodies) == 0) { false; @@ -402,10 +398,7 @@ let is_tail_recursive = (name: string, uexp: UExp.t(list(Id.t))): bool => { }; let check = - ( - uexp: UExp.t(list(Id.t)), - predicates: list(UExp.t(list(Id.t)) => bool), - ) + (uexp: UExp.t(IdTag.t), predicates: list(UExp.t(IdTag.t) => bool)) : syntax_result => { let results = List.map(pred => {uexp |> pred}, predicates); let length = List.length(predicates); From bc56c2fa85c9a3e07546e91fd41095c227f8653f Mon Sep 17 00:00:00 2001 From: Alexander Bandukwala <7h3kk1d@gmail.com> Date: Thu, 22 Aug 2024 15:22:12 -0400 Subject: [PATCH 7/8] Back to working --- src/haz3lweb/DebugConsole.re | 2 +- src/haz3lweb/Editors.re | 2 +- src/haz3lweb/view/CtxInspector.re | 5 +- src/haz3lweb/view/ExplainThis.re | 196 ++++++++++--------- src/haz3lweb/view/Kind.re | 2 +- src/haz3lweb/view/Type.re | 11 +- src/haz3lweb/view/dhcode/DHCode.re | 2 +- src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re | 6 +- src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re | 4 +- src/haz3lweb/view/dhcode/layout/DHDoc_Typ.re | 2 +- src/haz3lweb/view/dhcode/layout/HTypDoc.re | 5 +- src/haz3lweb/view/dhcode/layout/HTypDoc.rei | 2 +- 12 files changed, 126 insertions(+), 113 deletions(-) diff --git a/src/haz3lweb/DebugConsole.re b/src/haz3lweb/DebugConsole.re index 8f7a0b12b0..1d61f460b2 100644 --- a/src/haz3lweb/DebugConsole.re +++ b/src/haz3lweb/DebugConsole.re @@ -16,7 +16,7 @@ let print = ({settings, editors, _}: Model.t, key: string): unit => { |> Zipper.unselect_and_zip |> ((seg: Segment.t(Uuidm.t)) => [%derive.show: Segment.t(Id.t)](seg)) |> print - | "F3" => term |> [%derive.show: UExp.t(list(Id.t))] |> print + | "F3" => term |> [%derive.show: UExp.t(IdTag.t)] |> print | "F4" => map |> Statics.Map.show |> print | "F5" => let env = Editors.get_env_init(~settings, editors); diff --git a/src/haz3lweb/Editors.re b/src/haz3lweb/Editors.re index 7b5512fc10..5f3c3ca377 100644 --- a/src/haz3lweb/Editors.re +++ b/src/haz3lweb/Editors.re @@ -66,7 +66,7 @@ let perform_action = let update_current_editor_statics = settings => update(Editor.update_statics(~settings)); -let get_ctx_init = (~settings as _: Settings.t, editors: t): Ctx.t => +let get_ctx_init = (~settings as _: Settings.t, editors: t): Ctx.t(IdTag.t) => switch (editors) { | Scratch(_) | Exercises(_) diff --git a/src/haz3lweb/view/CtxInspector.re b/src/haz3lweb/view/CtxInspector.re index 81b3050cc7..46f26c2797 100644 --- a/src/haz3lweb/view/CtxInspector.re +++ b/src/haz3lweb/view/CtxInspector.re @@ -5,7 +5,8 @@ open Util.Web; let jump_to = entry => UpdateAction.PerformAction(Jump(TileId(Haz3lcore.Ctx.get_id(entry)))); -let context_entry_view = (~inject, entry: Haz3lcore.Ctx.entry): Node.t => { +let context_entry_view = + (~inject, entry: Haz3lcore.Ctx.entry(Haz3lcore.IdTag.t)): Node.t => { let div_name = div( ~attrs=[clss(["name"]), Attr.on_click(_ => inject(jump_to(entry)))], @@ -33,7 +34,7 @@ let context_entry_view = (~inject, entry: Haz3lcore.Ctx.entry): Node.t => { }; }; -let ctx_view = (~inject, ctx: Haz3lcore.Ctx.t): Node.t => +let ctx_view = (~inject, ctx: Haz3lcore.Ctx.t(Haz3lcore.IdTag.t)): Node.t => div( ~attrs=[clss(["context-entries"])], List.map( diff --git a/src/haz3lweb/view/ExplainThis.re b/src/haz3lweb/view/ExplainThis.re index 40fc6f1b45..87d555721d 100644 --- a/src/haz3lweb/view/ExplainThis.re +++ b/src/haz3lweb/view/ExplainThis.re @@ -392,7 +392,7 @@ let example_view = ]; }; -let rec bypass_parens_and_annot_pat = (pat: Pat.t) => { +let rec bypass_parens_and_annot_pat = (pat: Pat.t(IdTag.t)) => { switch (pat.term) { | Parens(p) | Cast(p, _, _) => bypass_parens_and_annot_pat(p) @@ -400,21 +400,21 @@ let rec bypass_parens_and_annot_pat = (pat: Pat.t) => { }; }; -let rec bypass_parens_pat = (pat: Pat.t) => { +let rec bypass_parens_pat = (pat: Pat.t(IdTag.t)) => { switch (pat.term) { | Parens(p) => bypass_parens_pat(p) | _ => pat }; }; -let rec bypass_parens_exp = (exp: Exp.t(list(Id.t))) => { +let rec bypass_parens_exp = (exp: Exp.t(IdTag.t)) => { switch (exp.term) { | Parens(e) => bypass_parens_exp(e) | _ => exp }; }; -let rec bypass_parens_typ = (typ: Typ.t) => { +let rec bypass_parens_typ = (typ: Typ.t(IdTag.t)) => { switch (typ.term) { | Parens(t) => bypass_parens_typ(t) | _ => typ @@ -532,7 +532,7 @@ let get_doc = let rec get_message_exp = (term) : (list(Node.t), (list(Node.t), ColorSteps.t), list(Node.t)) => - switch ((term: Exp.term(list(Id.t)))) { + switch ((term: Exp.term(IdTag.t))) { | Exp.Invalid(_) => simple("Not a valid expression") | DynamicErrorHole(_) | FailedCast(_) @@ -542,8 +542,8 @@ let get_doc = | EmptyHole => get_message(HoleExp.empty_hole_exps) | MultiHole(_children) => get_message(HoleExp.multi_hole_exps) | TyAlias(ty_pat, ty_def, _body) => - let tpat_id = List.nth(ty_pat.ids, 0); - let def_id = List.nth(ty_def.ids, 0); + let tpat_id = List.nth(ty_pat.annotation.ids, 0); + let def_id = List.nth(ty_def.annotation.ids, 0); get_message( ~colorings= TyAliasExp.tyalias_base_exp_coloring_ids(~tpat_id, ~def_id), @@ -578,8 +578,8 @@ let get_doc = ) | TypFun(tpat, body, _) => let basic = group_id => { - let tpat_id = List.nth(tpat.ids, 0); - let body_id = List.nth(body.ids, 0); + let tpat_id = List.nth(tpat.annotation.ids, 0); + let body_id = List.nth(body.annotation.ids, 0); get_message( ~colorings= FunctionExp.function_exp_coloring_ids( @@ -602,8 +602,8 @@ let get_doc = basic(TypFunctionExp.type_functions_basic); | Fun(pat, body, _, _) => let basic = group_id => { - let pat_id = List.nth(pat.ids, 0); - let body_id = List.nth(body.ids, 0); + let pat_id = List.nth(pat.annotation.ids, 0); + let body_id = List.nth(body.annotation.ids, 0); get_message( ~colorings= FunctionExp.function_exp_coloring_ids(~pat_id, ~body_id), @@ -620,8 +620,8 @@ let get_doc = ); }; let pat = bypass_parens_and_annot_pat(pat); - let pat_id = List.nth(pat.ids, 0); - let body_id = List.nth(body.ids, 0); + let pat_id = List.nth(pat.annotation.ids, 0); + let body_id = List.nth(body.annotation.ids, 0); switch (pat.term) { | EmptyHole => if (FunctionExp.function_empty_hole_exp.id @@ -864,8 +864,8 @@ let get_doc = | Cons(hd, tl) => if (FunctionExp.function_cons_exp.id == get_specificity_level(FunctionExp.functions_cons)) { - let hd_id = List.nth(hd.ids, 0); - let tl_id = List.nth(tl.ids, 0); + let hd_id = List.nth(hd.annotation.ids, 0); + let tl_id = List.nth(tl.annotation.ids, 0); get_message( ~colorings= FunctionExp.function_cons_exp_coloring_ids( @@ -910,8 +910,8 @@ let get_doc = basic(FunctionExp.functions_var); } | Tuple(elements) => - let pat_id = List.nth(pat.ids, 0); - let body_id = List.nth(body.ids, 0); + let pat_id = List.nth(pat.annotation.ids, 0); + let body_id = List.nth(body.annotation.ids, 0); let basic_tuple = group_id => { get_message( ~colorings= @@ -938,8 +938,10 @@ let get_doc = | 2 => let doc_id = get_specificity_level(FunctionExp.functions_tuple2); if (FunctionExp.function_tuple2_exp.id == doc_id) { - let pat1_id = List.nth(List.nth(elements, 0).ids, 0); - let pat2_id = List.nth(List.nth(elements, 1).ids, 0); + let pat1_id = + List.nth(List.nth(elements, 0).annotation.ids, 0); + let pat2_id = + List.nth(List.nth(elements, 1).annotation.ids, 0); get_message( ~colorings= FunctionExp.function_tuple2_exp_coloring_ids( @@ -967,9 +969,12 @@ let get_doc = | 3 => let doc_id = get_specificity_level(FunctionExp.functions_tuple3); if (FunctionExp.function_tuple3_exp.id == doc_id) { - let pat1_id = List.nth(List.nth(elements, 0).ids, 0); - let pat2_id = List.nth(List.nth(elements, 1).ids, 0); - let pat3_id = List.nth(List.nth(elements, 2).ids, 0); + let pat1_id = + List.nth(List.nth(elements, 0).annotation.ids, 0); + let pat2_id = + List.nth(List.nth(elements, 1).annotation.ids, 0); + let pat3_id = + List.nth(List.nth(elements, 2).annotation.ids, 0); get_message( ~colorings= FunctionExp.function_tuple3_exp_coloring_ids( @@ -1007,8 +1012,8 @@ let get_doc = | Ap(con, arg) => if (FunctionExp.function_ap_exp.id == get_specificity_level(FunctionExp.functions_ap)) { - let con_id = List.nth(con.ids, 0); - let arg_id = List.nth(arg.ids, 0); + let con_id = List.nth(con.annotation.ids, 0); + let arg_id = List.nth(arg.annotation.ids, 0); get_message( ~colorings= FunctionExp.function_ap_exp_coloring_ids( @@ -1034,8 +1039,8 @@ let get_doc = | Constructor(v, _) => if (FunctionExp.function_ctr_exp.id == get_specificity_level(FunctionExp.functions_ctr)) { - let pat_id = List.nth(pat.ids, 0); - let body_id = List.nth(body.ids, 0); + let pat_id = List.nth(pat.annotation.ids, 0); + let body_id = List.nth(body.annotation.ids, 0); get_message( ~colorings= FunctionExp.function_ctr_exp_coloring_ids(~pat_id, ~body_id), @@ -1076,8 +1081,8 @@ let get_doc = | 2 => if (TupleExp.tuple_exp_size2.id == get_specificity_level(TupleExp.tuples2)) { - let exp1_id = List.nth(List.nth(terms, 0).ids, 0); - let exp2_id = List.nth(List.nth(terms, 1).ids, 0); + let exp1_id = List.nth(List.nth(terms, 0).annotation.ids, 0); + let exp2_id = List.nth(List.nth(terms, 1).annotation.ids, 0); get_message( ~colorings= TupleExp.tuple_exp_size2_coloring_ids(~exp1_id, ~exp2_id), @@ -1098,9 +1103,9 @@ let get_doc = | 3 => if (TupleExp.tuple_exp_size3.id == get_specificity_level(TupleExp.tuples3)) { - let exp1_id = List.nth(List.nth(terms, 0).ids, 0); - let exp2_id = List.nth(List.nth(terms, 1).ids, 0); - let exp3_id = List.nth(List.nth(terms, 2).ids, 0); + let exp1_id = List.nth(List.nth(terms, 0).annotation.ids, 0); + let exp2_id = List.nth(List.nth(terms, 1).annotation.ids, 0); + let exp3_id = List.nth(List.nth(terms, 2).annotation.ids, 0); get_message( ~colorings= TupleExp.tuple_exp_size3_coloring_ids( @@ -1128,9 +1133,9 @@ let get_doc = | Var(n) => get_message(TerminalExp.var_exps(n)) | Let(pat, def, body) => let pat = bypass_parens_and_annot_pat(pat); - let pat_id = List.nth(pat.ids, 0); - let def_id = List.nth(def.ids, 0); - let body_id = List.nth(body.ids, 0); + let pat_id = List.nth(pat.annotation.ids, 0); + let def_id = List.nth(def.annotation.ids, 0); + let body_id = List.nth(body.annotation.ids, 0); let basic = group_id => { get_message( ~colorings=LetExp.let_base_exp_coloring_ids(~pat_id, ~def_id), @@ -1387,8 +1392,8 @@ let get_doc = | Cons(hd, tl) => if (LetExp.let_cons_exp.id == get_specificity_level(LetExp.lets_cons)) { - let hd_id = List.nth(hd.ids, 0); - let tl_id = List.nth(tl.ids, 0); + let hd_id = List.nth(hd.annotation.ids, 0); + let tl_id = List.nth(tl.annotation.ids, 0); get_message( ~colorings= LetExp.let_cons_exp_coloring_ids(~hd_id, ~tl_id, ~def_id), @@ -1450,8 +1455,10 @@ let get_doc = | 2 => let doc_id = get_specificity_level(LetExp.lets_tuple2); if (LetExp.let_tuple2_exp.id == doc_id) { - let pat1_id = List.nth(List.nth(elements, 0).ids, 0); - let pat2_id = List.nth(List.nth(elements, 1).ids, 0); + let pat1_id = + List.nth(List.nth(elements, 0).annotation.ids, 0); + let pat2_id = + List.nth(List.nth(elements, 1).annotation.ids, 0); get_message( ~colorings= LetExp.let_tuple2_exp_coloring_ids( @@ -1480,9 +1487,12 @@ let get_doc = let doc_id = get_specificity_level(LetExp.lets_tuple3); // TODO Syntactic form can go off page - so can examples - but can scroll, just can't see bottom scroll bar if (LetExp.let_tuple3_exp.id == doc_id) { - let pat1_id = List.nth(List.nth(elements, 0).ids, 0); - let pat2_id = List.nth(List.nth(elements, 1).ids, 0); - let pat3_id = List.nth(List.nth(elements, 2).ids, 0); + let pat1_id = + List.nth(List.nth(elements, 0).annotation.ids, 0); + let pat2_id = + List.nth(List.nth(elements, 1).annotation.ids, 0); + let pat3_id = + List.nth(List.nth(elements, 2).annotation.ids, 0); get_message( ~colorings= LetExp.let_tuple3_exp_coloring_ids( @@ -1519,8 +1529,8 @@ let get_doc = }; | Ap(con, arg) => if (LetExp.let_ap_exp.id == get_specificity_level(LetExp.lets_ap)) { - let con_id = List.nth(con.ids, 0); - let arg_id = List.nth(arg.ids, 0); + let con_id = List.nth(con.annotation.ids, 0); + let arg_id = List.nth(arg.annotation.ids, 0); get_message( ~colorings= LetExp.let_ap_exp_coloring_ids(~con_id, ~arg_id, ~def_id), @@ -1580,8 +1590,8 @@ let get_doc = ), ) | TypAp(f, typ) => - let f_id = List.nth(f.ids, 0); - let typ_id = List.nth(typ.ids, 0); + let f_id = List.nth(f.annotation.ids, 0); + let typ_id = List.nth(typ.annotation.ids, 0); let basic = (group, format, coloring_ids) => { get_message( ~colorings=coloring_ids(~f_id, ~typ_id), @@ -1601,8 +1611,8 @@ let get_doc = ); | Ap(Forward, x, arg) => - let x_id = List.nth(x.ids, 0); - let arg_id = List.nth(arg.ids, 0); + let x_id = List.nth(x.annotation.ids, 0); + let arg_id = List.nth(arg.annotation.ids, 0); let basic = (group, format, coloring_ids) => { get_message( ~colorings=coloring_ids(~x_id, ~arg_id), @@ -1636,11 +1646,11 @@ let get_doc = ) }; | DeferredAp(x, args) => - let x_id = List.nth(x.ids, 0); + let x_id = List.nth(x.annotation.ids, 0); let supplied_id = Id.mk(); let deferred_id = { let deferral = List.find(Exp.is_deferral, args); - List.nth(deferral.ids, 0); + List.nth(deferral.annotation.ids, 0); }; switch (mode) { | MessageContent(_) => @@ -1663,8 +1673,8 @@ 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: Exp.t(list(Id.t))) => { - let arg_id = List.nth(arg.ids, 0); + let add = (mapping, arg: Exp.t(IdTag.t)) => { + let arg_id = List.nth(arg.annotation.ids, 0); Haz3lcore.Id.Map.add( arg_id, Exp.is_deferral(arg) ? color_deferred : color_supplied, @@ -1677,9 +1687,9 @@ let get_doc = ([], ([], color_map), []); }; | If(cond, then_, else_) => - let cond_id = List.nth(cond.ids, 0); - let then_id = List.nth(then_.ids, 0); - let else_id = List.nth(else_.ids, 0); + let cond_id = List.nth(cond.annotation.ids, 0); + let then_id = List.nth(then_.annotation.ids, 0); + let else_id = List.nth(else_.annotation.ids, 0); get_message( ~colorings=IfExp.if_exp_coloring_ids(~cond_id, ~then_id, ~else_id), ~format= @@ -1695,8 +1705,8 @@ let get_doc = IfExp.ifs, ); | Seq(left, right) => - let exp1_id = List.nth(left.ids, 0); - let exp2_id = List.nth(right.ids, 0); + let exp1_id = List.nth(left.annotation.ids, 0); + let exp2_id = List.nth(right.annotation.ids, 0); get_message( ~colorings=SeqExp.seq_exp_coloring_ids(~exp1_id, ~exp2_id), ~format= @@ -1740,7 +1750,7 @@ let get_doc = ) | Filter(_) => simple("Internal expression") | Test(body) => - let body_id = List.nth(body.ids, 0); + let body_id = List.nth(body.annotation.ids, 0); get_message( ~colorings=TestExp.test_exp_coloring_ids(~body_id), ~format= @@ -1755,8 +1765,8 @@ let get_doc = ); | Parens(term) => get_message_exp(term.term) // No Special message? | Cons(hd, tl) => - let hd_id = List.nth(hd.ids, 0); - let tl_id = List.nth(tl.ids, 0); + let hd_id = List.nth(hd.annotation.ids, 0); + let tl_id = List.nth(tl.annotation.ids, 0); get_message( ~colorings=ListExp.cons_exp_coloring_ids(~hd_id, ~tl_id), ~format= @@ -1771,8 +1781,8 @@ let get_doc = ListExp.listcons, ); | ListConcat(xs, ys) => - let xs_id = List.nth(xs.ids, 0); - let ys_id = List.nth(ys.ids, 0); + let xs_id = List.nth(xs.annotation.ids, 0); + let ys_id = List.nth(ys.annotation.ids, 0); get_message( ~colorings=ListExp.concat_exp_coloring_ids(~xs_id, ~ys_id), ~format= @@ -1789,7 +1799,7 @@ let get_doc = | UnOp(op, exp) => switch (op) { | Bool(Not) => - let exp_id = List.nth(exp.ids, 0); + let exp_id = List.nth(exp.annotation.ids, 0); get_message( ~colorings=OpExp.bool_unary_not_exp_coloring_ids(~exp_id), ~format= @@ -1803,7 +1813,7 @@ let get_doc = OpExp.bool_un_not, ); | Int(Minus) => - let exp_id = List.nth(exp.ids, 0); + let exp_id = List.nth(exp.annotation.ids, 0); get_message( ~colorings=OpExp.int_unary_minus_exp_coloring_ids(~exp_id), ~format= @@ -1865,8 +1875,8 @@ let get_doc = | String(Equals) => (string_equal, str_eq_exp_coloring_ids) | String(Concat) => (string_concat, str_concat_exp_coloring_ids) }; - let left_id = List.nth(left.ids, 0); - let right_id = List.nth(right.ids, 0); + let left_id = List.nth(left.annotation.ids, 0); + let right_id = List.nth(right.annotation.ids, 0); get_message( ~colorings=coloring_ids(~left_id, ~right_id), ~format= @@ -1881,7 +1891,7 @@ let get_doc = group, ); | Match(scrut, _rules) => - let scrut_id = List.nth(scrut.ids, 0); + let scrut_id = List.nth(scrut.annotation.ids, 0); get_message( ~colorings=CaseExp.case_exp_coloring_ids(~scrut_id), ~format= @@ -1963,8 +1973,8 @@ let get_doc = ); } | Cons(hd, tl) => - let hd_id = List.nth(hd.ids, 0); - let tl_id = List.nth(tl.ids, 0); + let hd_id = List.nth(hd.annotation.ids, 0); + let tl_id = List.nth(tl.annotation.ids, 0); let basic = doc => get_message( ~colorings=ListPat.cons_base_pat_coloring_ids(~hd_id, ~tl_id), @@ -1982,8 +1992,8 @@ let get_doc = switch (tl.term) { | 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); + let hd2_id = List.nth(hd2.annotation.ids, 0); + let tl2_id = List.nth(tl2.annotation.ids, 0); get_message( ~colorings= ListPat.cons2_pat_coloring_ids( @@ -2033,8 +2043,8 @@ let get_doc = | 2 => if (TuplePat.tuple_pat_size2.id == get_specificity_level(TuplePat.tuple2)) { - let elem1_id = List.nth(List.nth(elements, 0).ids, 0); - let elem2_id = List.nth(List.nth(elements, 1).ids, 0); + let elem1_id = List.nth(List.nth(elements, 0).annotation.ids, 0); + let elem2_id = List.nth(List.nth(elements, 1).annotation.ids, 0); get_message( ~colorings= TuplePat.tuple_pat_size2_coloring_ids(~elem1_id, ~elem2_id), @@ -2055,9 +2065,9 @@ let get_doc = | 3 => if (TuplePat.tuple_pat_size3.id == get_specificity_level(TuplePat.tuple3)) { - let elem1_id = List.nth(List.nth(elements, 0).ids, 0); - let elem2_id = List.nth(List.nth(elements, 1).ids, 0); - let elem3_id = List.nth(List.nth(elements, 2).ids, 0); + let elem1_id = List.nth(List.nth(elements, 0).annotation.ids, 0); + let elem2_id = List.nth(List.nth(elements, 1).annotation.ids, 0); + let elem3_id = List.nth(List.nth(elements, 2).annotation.ids, 0); get_message( ~colorings= TuplePat.tuple_pat_size3_coloring_ids( @@ -2083,8 +2093,8 @@ let get_doc = | _ => basic(TuplePat.tuple) }; | Ap(con, arg) => - let con_id = List.nth(con.ids, 0); - let arg_id = List.nth(arg.ids, 0); + let con_id = List.nth(con.annotation.ids, 0); + let arg_id = List.nth(arg.annotation.ids, 0); get_message( ~colorings=AppPat.ap_pat_coloring_ids(~con_id, ~arg_id), ~format= @@ -2107,8 +2117,8 @@ let get_doc = TerminalPat.ctr(con), ) | Cast(pat, typ, _) => - let pat_id = List.nth(pat.ids, 0); - let typ_id = List.nth(typ.ids, 0); + let pat_id = List.nth(pat.annotation.ids, 0); + let typ_id = List.nth(typ.annotation.ids, 0); get_message( ~colorings=TypAnnPat.typann_pat_coloring_ids(~pat_id, ~typ_id), ~format= @@ -2138,7 +2148,7 @@ let get_doc = | Bool => get_message(TerminalTyp.bool) | String => get_message(TerminalTyp.str) | List(elem) => - let elem_id = List.nth(elem.ids, 0); + let elem_id = List.nth(elem.annotation.ids, 0); get_message( ~colorings=ListTyp.list_typ_coloring_ids(~elem_id), ~format= @@ -2152,8 +2162,8 @@ let get_doc = ListTyp.list, ); | Forall(tpat, typ) => - let tpat_id = List.nth(tpat.ids, 0); - let tbody_id = List.nth(typ.ids, 0); + let tpat_id = List.nth(tpat.annotation.ids, 0); + let tbody_id = List.nth(typ.annotation.ids, 0); get_message( ~colorings=ForallTyp.forall_typ_coloring_ids(~tpat_id, ~tbody_id), ~format= @@ -2168,8 +2178,8 @@ let get_doc = ForallTyp.forall, ); | Rec(tpat, typ) => - let tpat_id = List.nth(tpat.ids, 0); - let tbody_id = List.nth(typ.ids, 0); + let tpat_id = List.nth(tpat.annotation.ids, 0); + let tbody_id = List.nth(typ.annotation.ids, 0); get_message( ~colorings=RecTyp.rec_typ_coloring_ids(~tpat_id, ~tbody_id), ~format= @@ -2184,8 +2194,8 @@ let get_doc = RecTyp.rec_, ); | Arrow(arg, result) => - let arg_id = List.nth(arg.ids, 0); - let result_id = List.nth(result.ids, 0); + let arg_id = List.nth(arg.annotation.ids, 0); + let result_id = List.nth(result.annotation.ids, 0); let basic = doc => get_message( ~colorings=ArrowTyp.arrow_typ_coloring_ids(~arg_id, ~result_id), @@ -2203,8 +2213,8 @@ let get_doc = switch (result.term) { | 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); + let arg2_id = List.nth(arg2.annotation.ids, 0); + let result2_id = List.nth(result2.annotation.ids, 0); get_message( ~colorings= ArrowTyp.arrow3_typ_coloring_ids( @@ -2255,8 +2265,8 @@ let get_doc = } | 2 => if (TupleTyp.tuple2_typ.id == get_specificity_level(TupleTyp.tuple2)) { - let elem1_id = List.nth(List.nth(elements, 0).ids, 0); - let elem2_id = List.nth(List.nth(elements, 1).ids, 0); + let elem1_id = List.nth(List.nth(elements, 0).annotation.ids, 0); + let elem2_id = List.nth(List.nth(elements, 1).annotation.ids, 0); get_message( ~colorings=TupleTyp.tuple2_typ_coloring_ids(~elem1_id, ~elem2_id), ~format= @@ -2275,9 +2285,9 @@ let get_doc = } | 3 => if (TupleTyp.tuple3_typ.id == get_specificity_level(TupleTyp.tuple3)) { - let elem1_id = List.nth(List.nth(elements, 0).ids, 0); - let elem2_id = List.nth(List.nth(elements, 1).ids, 0); - let elem3_id = List.nth(List.nth(elements, 2).ids, 0); + let elem1_id = List.nth(List.nth(elements, 0).annotation.ids, 0); + let elem2_id = List.nth(List.nth(elements, 1).annotation.ids, 0); + let elem3_id = List.nth(List.nth(elements, 2).annotation.ids, 0); get_message( ~colorings= TupleTyp.tuple3_typ_coloring_ids( diff --git a/src/haz3lweb/view/Kind.re b/src/haz3lweb/view/Kind.re index 8feb3af0b0..a13659f229 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.Ctx.kind): Node.t => +let view = (kind: Haz3lcore.Ctx.kind(Haz3lcore.IdTag.t)): Node.t => switch (kind) { | Singleton(ty) => div_c("kind-view", [Type.view(ty)]) | Abstract => div_c("kind-view", [text("Type")]) diff --git a/src/haz3lweb/view/Type.re b/src/haz3lweb/view/Type.re index 4ee4f29af2..cb9d9b0144 100644 --- a/src/haz3lweb/view/Type.re +++ b/src/haz3lweb/view/Type.re @@ -3,7 +3,7 @@ open Node; open Util.Web; open Haz3lcore; -let tpat_view = (tpat: Haz3lcore.TPat.t): string => +let tpat_view = (tpat: Haz3lcore.TPat.t('a)): string => switch (tpat.term) { | Var(x) => x | _ => "?" @@ -15,13 +15,14 @@ let ty_view = (cls: string, s: string): Node.t => let alias_view = (s: string): Node.t => div(~attrs=[clss(["typ-alias-view"])], [text(s)]); -let rec view_ty = (~strip_outer_parens=false, ty: Haz3lcore.Typ.t): Node.t => +let rec view_ty = + (~strip_outer_parens=false, ty: Haz3lcore.Typ.t(IdTag.t)): Node.t => switch (Typ.term_of(ty)) { | Unknown(prov) => div( ~attrs=[ clss(["typ-view", "atom", "unknown"]), - Attr.title(Typ.show_type_provenance(prov)), + Attr.title([%derive.show: Typ.type_provenance(IdTag.t)](prov)), ], [text("?") /*, prov_view(prov)*/], ) @@ -98,7 +99,7 @@ let rec view_ty = (~strip_outer_parens=false, ty: Haz3lcore.Typ.t): Node.t => div( ~attrs=[ clss(["typ-view", "atom", "unknown"]), - Attr.title(Typ.show_type_provenance(Internal)), + Attr.title([%derive.show: Typ.type_provenance(IdTag.t)](Internal)), ], [text("?") /*, prov_view(prov)*/], ) @@ -120,5 +121,5 @@ and paren_view = typ => [view_ty(typ)]; }; -let view = (ty: Haz3lcore.Typ.t): Node.t => +let view = (ty: Haz3lcore.Typ.t(IdTag.t)): Node.t => div_c("typ-wrapper", [view_ty(ty)]); diff --git a/src/haz3lweb/view/dhcode/DHCode.re b/src/haz3lweb/view/dhcode/DHCode.re index cdb22187a5..231341e262 100644 --- a/src/haz3lweb/view/dhcode/DHCode.re +++ b/src/haz3lweb/view/dhcode/DHCode.re @@ -135,7 +135,7 @@ let view = ~next_steps: list((int, Id.t))=[], ~result_key: string, ~infomap, - d: DHExp.t(list(Id.t)), + d: DHExp.t(IdTag.t), ) : Node.t => { DHDoc_Exp.mk( diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re index dd08c99475..9b0a08a773 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re @@ -42,7 +42,7 @@ let precedence_bin_string_op = (bso: Operators.op_bin_string) => | Concat => DHDoc_common.precedence_Plus | Equals => DHDoc_common.precedence_Equals }; -let rec precedence = (~show_casts: bool, d: DHExp.t(list(Id.t))) => { +let rec precedence = (~show_casts: bool, d: DHExp.t(IdTag.t)) => { let precedence' = precedence(~show_casts); switch (DHExp.term_of(d)) { | Var(_) @@ -114,13 +114,13 @@ let mk = ~next_steps: list((int, Id.t)), // The options for the next step, if it hasn't been chosen yet ~env: ClosureEnvironment.t, ~infomap: Statics.Map.t, - d: DHExp.t(list(Id.t)), + d: DHExp.t(IdTag.t), ) : DHDoc.t => { let precedence = precedence(~show_casts=settings.show_casts); let rec go = ( - d: DHExp.t(list(Id.t)), + d: DHExp.t(IdTag.t), env: ClosureEnvironment.t, enforce_inline: bool, recent_subst: list(Var.t), diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re index 8996bd4b03..c08ab11e5c 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re @@ -1,7 +1,7 @@ open Pretty; open Haz3lcore; -let precedence = (dp: Pat.t) => +let precedence = (dp: Pat.t(IdTag.t)) => switch (DHPat.term_of(dp)) { | EmptyHole | MultiHole(_) @@ -27,7 +27,7 @@ let rec mk = ~parenthesize=false, ~show_casts, ~enforce_inline: bool, - dp: Pat.t, + dp: Pat.t(IdTag.t), ) : DHDoc.t => { let mk' = mk(~enforce_inline, ~infomap, ~show_casts); diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Typ.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Typ.re index 143e36d3e3..73e54b8c2c 100644 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Typ.re +++ b/src/haz3lweb/view/dhcode/layout/DHDoc_Typ.re @@ -8,5 +8,5 @@ let promote_annot = | HTypAnnot.HoleLabel => DHAnnot.HoleLabel | HTypAnnot.Delim => DHAnnot.Delim; let promote = (d: HTypDoc.t): DHDoc.t => d |> Doc.map_annot(promote_annot); -let mk = (~enforce_inline: bool, ty: Typ.t): DHDoc.t => +let mk = (~enforce_inline: bool, ty: Typ.t(IdTag.t)): DHDoc.t => ty |> HTypDoc.mk(~enforce_inline) |> promote; diff --git a/src/haz3lweb/view/dhcode/layout/HTypDoc.re b/src/haz3lweb/view/dhcode/layout/HTypDoc.re index 996d01f607..f616e7f9c2 100644 --- a/src/haz3lweb/view/dhcode/layout/HTypDoc.re +++ b/src/haz3lweb/view/dhcode/layout/HTypDoc.re @@ -12,7 +12,7 @@ let precedence_Sum = 3; let precedence_Ap = 4; let precedence_Const = 5; -let precedence = (ty: Typ.t): int => +let precedence = (ty: Typ.t(IdTag.t)): int => switch (Typ.term_of(ty)) { | Int | Float @@ -51,7 +51,8 @@ let pad_child = let mk_delim = s => Doc.(annot(HTypAnnot.Delim, text(s))); -let rec mk = (~parenthesize=false, ~enforce_inline: bool, ty: Typ.t): t => { +let rec mk = + (~parenthesize=false, ~enforce_inline: bool, ty: Typ.t(IdTag.t)): t => { open Doc; let mk' = mk(~enforce_inline); let mk_right_associative_operands = (precedence_op, ty1, ty2) => ( diff --git a/src/haz3lweb/view/dhcode/layout/HTypDoc.rei b/src/haz3lweb/view/dhcode/layout/HTypDoc.rei index ab07b0e81e..2253bed749 100644 --- a/src/haz3lweb/view/dhcode/layout/HTypDoc.rei +++ b/src/haz3lweb/view/dhcode/layout/HTypDoc.rei @@ -2,4 +2,4 @@ open Haz3lcore; type t = Pretty.Doc.t(HTypAnnot.t); -let mk: (~parenthesize: bool=?, ~enforce_inline: bool, Typ.t) => t; +let mk: (~parenthesize: bool=?, ~enforce_inline: bool, Typ.t(IdTag.t)) => t; From 6d6f2347be273ef61ab2850fb117df4b2b7ed05d Mon Sep 17 00:00:00 2001 From: Alexander Bandukwala <7h3kk1d@gmail.com> Date: Tue, 27 Aug 2024 11:26:45 -0400 Subject: [PATCH 8/8] Fix tests --- test/Test_Elaboration.re | 49 +++++++++++++++++++++++++--------------- 1 file changed, 31 insertions(+), 18 deletions(-) diff --git a/test/Test_Elaboration.re b/test/Test_Elaboration.re index d12e7e92ad..5b126619d7 100644 --- a/test/Test_Elaboration.re +++ b/test/Test_Elaboration.re @@ -5,7 +5,7 @@ open Haz3lcore; an equal function (dhexp_eq) and a print function (dhexp_print) */ let dhexp_typ = testable( - Fmt.using([%derive.show: Exp.t(list(Id.t))], Fmt.string), + Fmt.using([%derive.show: Exp.t(IdTag.t)], Fmt.string), DHExp.fast_equal, ); @@ -15,30 +15,43 @@ let mk_map = Statics.mk(CoreSettings.on, Builtins.ctx_init); let dhexp_of_uexp = u => Elaborator.elaborate(mk_map(u), u) |> fst; let alco_check = dhexp_typ |> Alcotest.check; -let u1: Exp.t(list(Id.t)) = { - ids: [id_at(0)], +let u1: Exp.t(IdTag.t) = { term: Int(8), - copied: false, + annotation: { + ids: [id_at(0)], + copied: false, + }, }; let single_integer = () => alco_check("Integer literal 8", u1, dhexp_of_uexp(u1)); -let u2: Exp.t(list(Id.t)) = { - ids: [id_at(0)], +let u2: Exp.t(IdTag.t) = { term: EmptyHole, - copied: false, + annotation: { + ids: [id_at(0)], + copied: false, + }, }; let empty_hole = () => alco_check("Empty hole", u2, dhexp_of_uexp(u2)); -let u3: Exp.t(list(Id.t)) = { - ids: [id_at(0)], - term: Parens({ids: [id_at(1)], term: Var("y"), copied: false}), - copied: false, +let u3: Exp.t(IdTag.t) = { + annotation: { + ids: [id_at(0)], + copied: false, + }, + term: + Parens({ + term: Var("y"), + annotation: { + ids: [id_at(1)], + copied: false, + }, + }), }; let free_var = () => alco_check("free variable", u3, dhexp_of_uexp(u3)); -let u4: Exp.t(list(Id.t)) = +let u4: Exp.t(IdTag.t) = Let( Tuple([Var("a") |> Pat.fresh, Var("b") |> Pat.fresh]) |> Pat.fresh, Tuple([Int(4) |> Exp.fresh, Int(6) |> Exp.fresh]) |> Exp.fresh, @@ -75,7 +88,7 @@ let bin_op = () => dhexp_of_uexp(u5), ); -let u6: Exp.t(list(Id.t)) = +let u6: Exp.t(IdTag.t) = If(Bool(false) |> Exp.fresh, Int(8) |> Exp.fresh, Int(6) |> Exp.fresh) |> Exp.fresh; @@ -86,7 +99,7 @@ let consistent_if = () => dhexp_of_uexp(u6), ); -let u7: Exp.t(list(Id.t)) = +let u7: Exp.t(IdTag.t) = Ap( Forward, Fun( @@ -104,7 +117,7 @@ let u7: Exp.t(list(Id.t)) = let ap_fun = () => alco_check("Application of a function", u7, dhexp_of_uexp(u7)); -let u8: Exp.t(list(Id.t)) = +let u8: Exp.t(IdTag.t) = Match( BinOp(Int(Equals), Int(4) |> Exp.fresh, Int(3) |> Exp.fresh) |> Exp.fresh, @@ -115,7 +128,7 @@ let u8: Exp.t(list(Id.t)) = ) |> Exp.fresh; -let d8: Exp.t(list(Id.t)) = +let d8: Exp.t(IdTag.t) = Match( BinOp(Int(Equals), Int(4) |> Exp.fresh, Int(3) |> Exp.fresh) |> Exp.fresh, @@ -149,7 +162,7 @@ let inconsistent_case = () => dhexp_of_uexp(u8), ); -let u9: Exp.t(list(Id.t)) = +let u9: Exp.t(IdTag.t) = Let( Cast( Var("f") |> Pat.fresh, @@ -169,7 +182,7 @@ let u9: Exp.t(list(Id.t)) = ) |> Exp.fresh; -let d9: Exp.t(list(Id.t)) = +let d9: Exp.t(IdTag.t) = Let( Var("f") |> Pat.fresh, Fun(