From fcb26c8b1bad62fec1a51b86ab37983cfbc7d55b Mon Sep 17 00:00:00 2001 From: butterunderflow Date: Sat, 17 Aug 2024 16:03:32 +0800 Subject: [PATCH] standarize constructor names --- lib/back/closure_translator.ml | 62 +- lib/clos/closure.ml | 38 +- lib/clos/lift.ml | 68 +- lib/lam/compile.ml | 138 +-- lib/lam/tree.ml | 46 +- lib/syntax/parser.mly | 128 +-- lib/syntax/parsetree.ml | 127 +-- lib/typing/alias.ml | 34 +- lib/typing/check.ml | 291 ++++--- lib/typing/env.ml | 26 +- lib/typing/poly.ml | 40 +- lib/typing/render.ml | 104 +-- lib/typing/report.ml | 18 +- lib/typing/subtype.ml | 22 +- lib/typing/typedtree.ml | 104 +-- lib/typing/types_in.ml | 52 +- lib/typing/unify.ml | 32 +- tests/cram/test_dirs/simple.t/run.t | 58 +- tests/regular/lift_test.ml | 36 +- tests/regular/lower_test.ml | 153 ++-- tests/regular/parse_test.ml | 627 ++++++------- tests/regular/typing_test.ml | 1255 ++++++++++++++------------- tests/regular/unify_test.ml | 20 +- 23 files changed, 1791 insertions(+), 1688 deletions(-) diff --git a/lib/back/closure_translator.ml b/lib/back/closure_translator.ml index f157dba..9cbe161 100644 --- a/lib/back/closure_translator.ml +++ b/lib/back/closure_translator.ml @@ -122,8 +122,8 @@ let get_all_member_names (mems : object_field list) = mems |> List.map (fun mem -> match mem with - | FSimple (x, _) -> [ x ] - | FLetRec (_, binds) -> fst (List.split binds)) + | Field_simple (x, _) -> [ x ] + | Field_letrec (_, binds) -> fst (List.split binds)) |> List.flatten let rec trans_main_expr buf (_e : expr) = @@ -141,11 +141,11 @@ int main() and trans_expr ctx e = match e with - | EVar x -> (List.assoc x ctx.dict, []) - | EExt ff_name -> + | Exp_var x -> (List.assoc x ctx.dict, []) + | Exp_external ff_name -> ( ff_name (* assume we can access an ff object by its external name*), [] ) - | ELet (x, e0, e1) -> + | Exp_let (x, e0, e1) -> let e0_v, e0_stmts = trans_expr ctx e0 in let result_stmt = e0_stmts in let x, ctx = create_var ~need_decl:true x ctx in @@ -155,10 +155,10 @@ and trans_expr ctx e = let e1_v, e1_stmts = trans_expr ctx e1 in let result_stmt = result_stmt @ e1_stmts in (e1_v, result_stmt) - | EConst c -> + | Exp_const c -> let ret_v = create_decl "temp" ctx in (ret_v, [ make_assign (VARIABLE ret_v) (trans_const c) ]) - | ETuple es -> + | Exp_tuple es -> let es_v, stmts_list = List.split (List.map (trans_expr ctx) es) in let stmts = List.flatten stmts_list in let tu = create_decl "tu" ctx in @@ -180,7 +180,7 @@ and trans_expr ctx e = ] in (tu, stmts) - | EIf (e0, e1, e2) -> + | Exp_if (e0, e1, e2) -> let ifel_v = create_decl "ifel_res" ctx in let e0_v, e0_stmts = trans_expr ctx e0 in let e1_v, e1_stmts = trans_expr ctx e1 in @@ -198,7 +198,7 @@ and trans_expr ctx e = (e2_stmts @ [ make_assign (VARIABLE ifel_v) (VARIABLE e2_v) ]) )); ] ) - | EApp (e0, e1s) -> + | Exp_app (e0, e1s) -> let app_v = create_decl "app_res" ctx in let e0_v, e0_stmts = trans_expr ctx e0 in let e1_vs, e1_stmts = List.(split (map (trans_expr ctx) e1s)) in @@ -211,21 +211,21 @@ and trans_expr ctx e = ( ff_apply, VARIABLE e0_v :: List.map (fun x -> C.VARIABLE x) e1_vs )); ] ) - | ECons i -> + | Exp_constr i -> let constr_v = create_decl (Printf.sprintf "constr%d" i) ctx in ( constr_v, [ make_assign (VARIABLE constr_v) (CALL (ff_constr_np, [ CONSTANT (CONST_INT (string_of_int i)) ])); ] ) - | EConsWith i -> + | Exp_payload_constr i -> let constr_v = create_decl (Printf.sprintf "constr%d" i) ctx in ( constr_v, [ make_assign (VARIABLE constr_v) (CALL (ff_constr_p, [ CONSTANT (CONST_INT (string_of_int i)) ])); ] ) - | EField (e, name) -> + | Exp_field (e, name) -> let field = create_decl "field" ctx in let e_v, e_stmts = trans_expr ctx e in ( field, @@ -235,7 +235,7 @@ and trans_expr ctx e = (CALL (ff_get_mem, [ VARIABLE e_v; CONSTANT (CONST_STRING name) ])); ] ) - | EClosure (fvs, cfunc) -> + | Exp_closure (fvs, cfunc) -> let clos_v = create_decl "clos" ctx in let fvs_c = List.map (fun fv -> List.assoc fv ctx.dict) fvs in let cfn_name = to_c_ident_fn cfunc in @@ -250,23 +250,23 @@ and trans_expr ctx e = CAST (ff_erased_fptr_typename, VARIABLE cfn_name); ] )); ] ) - | ELetRec ((fvs, binds), body) -> + | Exp_letrec ((fvs, binds), body) -> let _binds_c, letrec_init, ctx = trans_letrec fvs binds ctx in let body_c, body_stmts = trans_expr ctx body in (body_c, letrec_init @ body_stmts) - | EModObject members -> + | Exp_mod_obj members -> let stmts, mems_c, ctx = List.fold_left (fun (stmts_acc, mems_c_acc, ctx) mem -> match mem with - | FSimple (x, e) -> + | Field_simple (x, e) -> let e_c, e_stmts = trans_expr ctx e in let x_c, ctx = create_var ~need_decl:true x ctx in ( stmts_acc @ e_stmts @ [ make_assign (VARIABLE x_c) (VARIABLE e_c) ], mems_c_acc @ [ x_c ], ctx ) - | FLetRec (fvs, binds) -> + | Field_letrec (fvs, binds) -> let binds_c, bind_stmts, ctx = trans_letrec fvs binds ctx in (stmts_acc @ bind_stmts, mems_c_acc @ binds_c, ctx)) ([], [], ctx) members @@ -288,7 +288,7 @@ and trans_expr ctx e = make_compound (List.map (fun x -> C.VARIABLE x) mems_c); ] )); ] ) - | ESwitch (e, bs) -> + | Exp_switch (e, bs) -> (* match x with | Cons[1](y, z, w) -> e * => @@ -313,7 +313,7 @@ and trans_expr ctx e = C.DOWHILE (C.CONSTANT (C.CONST_INT "0"), make_stmt_seq (e_stmts @ branches)); ] ) - | ECmp (op, e0, e1) -> + | Exp_cmp (op, e0, e1) -> let is_eq_v = create_decl "is_eq" ctx in let e0_v, e0_stmts = trans_expr ctx e0 in let e1_v, e1_stmts = trans_expr ctx e1 in @@ -328,18 +328,19 @@ and trans_expr ctx e = make_assign (VARIABLE is_eq_v) (CALL (eq_fn, [ VARIABLE e0_v; VARIABLE e1_v ])); ] ) - | ESeq (e0, e1) -> + | Exp_seq (e0, e1) -> let _e0_v, e0_stmts = trans_expr ctx e0 in let e1_v, e1_stmts = trans_expr ctx e1 in (e1_v, e0_stmts @ e1_stmts) - | EStruct _ -> ("todo", []) + | Exp_struct _ -> ("todo", []) and trans_const (c : S.constant) = match c with - | CBool b -> + | Const_bool b -> C.CALL (ff_make_bool, [ CONSTANT (CONST_INT (if b then "1" else "0")) ]) - | CInt i -> C.CALL (ff_make_int, [ CONSTANT (CONST_INT (string_of_int i)) ]) - | CString s -> + | Const_int i -> + C.CALL (ff_make_int, [ CONSTANT (CONST_INT (string_of_int i)) ]) + | Const_string s -> C.CALL ( ff_make_str, [ @@ -347,7 +348,8 @@ and trans_const (c : S.constant) = (CONST_STRING (Scanf.unescaped (String.sub s 1 (String.length s - 2)))); ] ) - | CUnit -> C.CALL (ff_make_int, [ CONSTANT (CONST_INT (string_of_int 0)) ]) + | Const_unit -> + C.CALL (ff_make_int, [ CONSTANT (CONST_INT (string_of_int 0)) ]) and trans_switch res cond p e ctx = let match_seq, ctx = analyze_match_sequence cond p ctx in @@ -366,16 +368,16 @@ and trans_switch res cond p e ctx = and analyze_match_sequence (cond_var : string) (p : pattern) ctx : match_operation list * context = match p with - | PVar x -> + | Pat_var x -> let x, ctx = create_var ~need_decl:true x ctx in ([ Bind C.(BINARY (ASSIGN, VARIABLE x, VARIABLE cond_var)) ], ctx) - | PVal c -> + | Pat_val c -> ( [ CheckPat (C.CALL (ff_is_equal_aux, [ VARIABLE cond_var; trans_const c ])); ], ctx ) - | PCons (id, None) -> + | Pat_constr (id, None) -> ( [ CheckPat (C.CALL @@ -385,7 +387,7 @@ and analyze_match_sequence (cond_var : string) (p : pattern) ctx : ] )); ], ctx ) - | PCons (id, Some p) -> + | Pat_constr (id, Some p) -> let pat_var = create_decl "pat_var" ctx in let check = CheckPat @@ -399,7 +401,7 @@ and analyze_match_sequence (cond_var : string) (p : pattern) ctx : in let match_seq, ctx = analyze_match_sequence pat_var p ctx in (check :: match_seq, ctx) - | PTuple ps -> + | Pat_tuple ps -> let pat_vars = List.mapi (fun index _ -> create_decl (Printf.sprintf "tu_%dth" index) ctx) diff --git a/lib/clos/closure.ml b/lib/clos/closure.ml index 5f6d8c1..cae68bd 100644 --- a/lib/clos/closure.ml +++ b/lib/clos/closure.ml @@ -5,31 +5,31 @@ module L = Lam.Tree type constant = T.constant [@@deriving sexp] type expr = - | ETuple of expr list - | EModObject of object_field list + | Exp_tuple of expr list + | Exp_mod_obj of object_field list (** 1. An object can cast to another when possible ; 2. Field of an object is visible in the scope following its declaration. *) - | EStruct of (string * expr) list - | EVar of string - | EExt of string - | ECons of int - | EConsWith of int - | EConst of constant - | EApp of expr * expr list - | ESwitch of expr * branch list - | ELet of string * expr * expr - | EIf of expr * expr * expr - | EClosure of closure - | ELetRec of closure_rec * expr - | EField of expr * string - | ECmp of T.cmp_op * expr * expr - | ESeq of expr * expr + | Exp_struct of (string * expr) list + | Exp_var of string + | Exp_external of string + | Exp_constr of int + | Exp_payload_constr of int + | Exp_const of constant + | Exp_app of expr * expr list + | Exp_switch of expr * branch list + | Exp_let of string * expr * expr + | Exp_if of expr * expr * expr + | Exp_closure of closure + | Exp_letrec of closure_rec * expr + | Exp_field of expr * string + | Exp_cmp of T.cmp_op * expr * expr + | Exp_seq of expr * expr and pattern = L.pattern and object_field = - | FSimple of string * expr - | FLetRec of closure_rec + | Field_simple of string * expr + | Field_letrec of closure_rec and closure = string list * Ident.ident diff --git a/lib/clos/lift.ml b/lib/clos/lift.ml index b4ace56..39cf125 100644 --- a/lib/clos/lift.ml +++ b/lib/clos/lift.ml @@ -4,27 +4,27 @@ module L = Lam.Tree let rec lift ?(hint = "temp") (e : L.expr) (vars : string list) : C.expr * C.func list = match e with - | L.ETuple es -> + | L.Exp_tuple es -> es |> List.map (fun e -> lift e vars ~hint) |> List.split - |> fun (es, fns) -> (C.ETuple es, List.flatten fns) - | L.EModObject mems -> + |> fun (es, fns) -> (C.Exp_tuple es, List.flatten fns) + | L.Exp_mod_obj mems -> let _, mems, fns = List.fold_left (fun (vars, mem_acc, fn_acc) mem -> match mem with - | L.FSimple (x, e) -> + | L.Field_simple (x, e) -> let e, fns = lift ~hint:x e vars in - (x :: vars, C.FSimple (x, e) :: mem_acc, fns @ fn_acc) - | L.FLetRec binds -> + (x :: vars, C.Field_simple (x, e) :: mem_acc, fns @ fn_acc) + | L.Field_letrec binds -> let xs, _ = List.split binds in let binds, fns = lift_letrec binds vars in - (xs @ vars, C.FLetRec binds :: mem_acc, fns @ fn_acc)) + (xs @ vars, C.Field_letrec binds :: mem_acc, fns @ fn_acc)) (vars, [], []) mems in - (C.EModObject (List.rev mems), fns) - | L.EStruct mems -> + (C.Exp_mod_obj (List.rev mems), fns) + | L.Exp_struct mems -> let mems, fns = List.fold_left (fun (acc_mems, acc_fns) (name, e) -> @@ -33,28 +33,28 @@ let rec lift ?(hint = "temp") (e : L.expr) (vars : string list) : ([], []) mems in let mems = List.rev mems in - (C.EStruct mems, fns) - | L.EVar x -> + (C.Exp_struct mems, fns) + | L.Exp_var x -> assert (List.mem x vars); - (C.EVar x, []) - | L.EExt x -> (C.EExt x, []) - | L.ECons i -> (C.ECons i, []) - | L.EConsWith i -> (C.EConsWith i, []) - | L.EConst c -> (C.EConst c, []) - | L.EApp (e0, e1s) -> + (C.Exp_var x, []) + | L.Exp_external x -> (C.Exp_external x, []) + | L.Exp_constr i -> (C.Exp_constr i, []) + | L.Exp_payload_constr i -> (C.Exp_payload_constr i, []) + | L.Exp_const c -> (C.Exp_const c, []) + | L.Exp_app (e0, e1s) -> let e0, fns0 = lift e0 vars in let e1s, fns1 = List.(split (map (fun e1 -> lift e1 vars) e1s)) in let fns1 = List.flatten fns1 in - (C.EApp (e0, e1s), fns0 @ fns1) - | L.ECmp (op, e0, e1) -> + (C.Exp_app (e0, e1s), fns0 @ fns1) + | L.Exp_cmp (op, e0, e1) -> let e0, fns0 = lift e0 vars in let e1, fns1 = lift e1 vars in - (C.ECmp (op, e0, e1), fns0 @ fns1) - | L.ESeq (e0, e1) -> + (C.Exp_cmp (op, e0, e1), fns0 @ fns1) + | L.Exp_seq (e0, e1) -> let e0, fns0 = lift e0 vars in let e1, fns1 = lift e1 vars in - (C.ESeq (e0, e1), fns0 @ fns1) - | L.ESwitch (e0, bs) -> + (C.Exp_seq (e0, e1), fns0 @ fns1) + | L.Exp_switch (e0, bs) -> let e0, fns0 = lift e0 vars in let es, fns1 = bs @@ -64,29 +64,29 @@ let rec lift ?(hint = "temp") (e : L.expr) (vars : string list) : |> fun (e, fns) -> (e, List.flatten fns) in let ps, _ = List.split bs in - (C.ESwitch (e0, List.combine ps es), fns0 @ fns1) - | L.ELet (x, e0, e1) -> + (C.Exp_switch (e0, List.combine ps es), fns0 @ fns1) + | L.Exp_let (x, e0, e1) -> let e0, fns0 = lift ~hint:x e0 vars in let e1, fns1 = lift e1 (x :: vars) ~hint in - (C.ELet (x, e0, e1), fns0 @ fns1) - | L.EIf (e0, e1, e2) -> + (C.Exp_let (x, e0, e1), fns0 @ fns1) + | L.Exp_if (e0, e1, e2) -> let e0, fns0 = lift ~hint e0 vars in let e1, fns1 = lift ~hint e1 vars in let e2, fns2 = lift ~hint e2 vars in - (C.EIf (e0, e1, e2), fns0 @ fns1 @ fns2) - | L.ELam (xs, e, fvs) -> + (C.Exp_if (e0, e1, e2), fns0 @ fns1 @ fns2) + | L.Exp_lam (xs, e, fvs) -> let fn_id = Ident.create ~hint in let e', fns = lift e (xs @ vars) ~hint in let new_fn = (fn_id, !fvs, xs, e') in - (C.EClosure (!fvs, fn_id), new_fn :: fns) - | L.ELetRec (binds, e) -> + (C.Exp_closure (!fvs, fn_id), new_fn :: fns) + | L.Exp_letrec (binds, e) -> let xs, _ = List.split binds in let cls, fns = lift_letrec binds vars in let e, fns' = lift e (xs @ vars) ~hint in - (C.ELetRec (cls, e), fns' @ fns) - | L.EField (e, name) -> + (C.Exp_letrec (cls, e), fns' @ fns) + | L.Exp_field (e, name) -> let e', fns = lift e vars ~hint in - (C.EField (e', name), fns) + (C.Exp_field (e', name), fns) and lift_letrec binds vars = let xs = List.map fst binds in diff --git a/lib/lam/compile.ml b/lib/lam/compile.ml index f8d5bae..919910e 100644 --- a/lib/lam/compile.ml +++ b/lib/lam/compile.ml @@ -3,27 +3,31 @@ module L = Tree let rec compile_expr (e : T.expr) = match e with - | T.EConst (c, _) -> L.EConst c - | T.EVar (x, _) -> L.EVar x - | T.ELet (x, e0, e1, _) -> L.ELet (x, compile_expr e0, compile_expr e1) - | T.ELetrec (lams, e, _) -> - L.ELetRec + | T.Exp_const (c, _) -> L.Exp_const c + | T.Exp_var (x, _) -> L.Exp_var x + | T.Exp_let (x, e0, e1, _) -> + L.Exp_let (x, compile_expr e0, compile_expr e1) + | T.Exp_letrec (lams, e, _) -> + L.Exp_letrec (List.map (fun (x, lam) -> (x, compile_lam lam)) lams, compile_expr e) - | T.ELam lam -> L.ELam (compile_lam lam) - | T.EIf (e0, e1, e2, _) -> - L.EIf (compile_expr e0, compile_expr e1, compile_expr e2) - | T.ECase (e0, bs, _) -> - L.ESwitch (compile_expr e0, List.map compile_branch bs) - | T.EApp (e0, e1, _) -> L.EApp (compile_expr e0, [ compile_expr e1 ]) - | T.EAnn (e, _) -> compile_expr e - | T.ETuple (es, _) -> L.ETuple (List.map compile_expr es) - | T.EField (me, name, _) -> L.EField (compile_mod_expr me, name) - | T.ECons (_, id, Typing.Types_in.TArrowI (_, _)) -> L.EConsWith id - | T.ECons (_, id, _) -> L.ECons id - | T.EFieldCons (_, _, id, Typing.Types_in.TArrowI (_, _)) -> L.EConsWith id - | T.EFieldCons (_, _, id, _) -> L.ECons id - | T.ECmp (op, e1, e2, _) -> L.ECmp (op, compile_expr e1, compile_expr e2) - | T.ESeq (e0, e1, _) -> L.ESeq (compile_expr e0, compile_expr e1) + | T.Exp_lam lam -> L.Exp_lam (compile_lam lam) + | T.Exp_if (e0, e1, e2, _) -> + L.Exp_if (compile_expr e0, compile_expr e1, compile_expr e2) + | T.Exp_case (e0, bs, _) -> + L.Exp_switch (compile_expr e0, List.map compile_branch bs) + | T.Exp_app (e0, e1, _) -> L.Exp_app (compile_expr e0, [ compile_expr e1 ]) + | T.Exp_ann (e, _) -> compile_expr e + | T.Exp_tuple (es, _) -> L.Exp_tuple (List.map compile_expr es) + | T.Exp_field (me, name, _) -> L.Exp_field (compile_mod_expr me, name) + | T.Exp_constr (_, id, Typing.Types_in.Ty_arrow (_, _)) -> + L.Exp_payload_constr id + | T.Exp_constr (_, id, _) -> L.Exp_constr id + | T.Exp_field_constr (_, _, id, Typing.Types_in.Ty_arrow (_, _)) -> + L.Exp_payload_constr id + | T.Exp_field_constr (_, _, id, _) -> L.Exp_constr id + | T.Exp_cmp (op, e1, e2, _) -> + L.Exp_cmp (op, compile_expr e1, compile_expr e2) + | T.Exp_seq (e0, e1, _) -> L.Exp_seq (compile_expr e0, compile_expr e1) and compile_lam (x, e, _) = ([ x ], compile_expr e, ref []) @@ -31,11 +35,11 @@ and compile_branch (p, e) : L.branch = let compile_pattern p = let rec go p = match p with - | T.PVal c -> L.PVal c - | T.PCons (_cname, id, None) -> L.PCons (id, None) - | T.PCons (_cname, id, Some p') -> L.PCons (id, Some (go p')) - | T.PVar (x, _) -> L.PVar x - | T.PTuple ps -> L.PTuple (List.map go ps) + | T.Pat_val c -> L.Pat_val c + | T.Pat_constr (_cname, id, None) -> L.Pat_constr (id, None) + | T.Pat_constr (_cname, id, Some p') -> L.Pat_constr (id, Some (go p')) + | T.Pat_var (x, _) -> L.Pat_var x + | T.Pat_tuple ps -> L.Pat_tuple (List.map go ps) in go p in @@ -43,30 +47,31 @@ and compile_branch (p, e) : L.branch = and compile_mod_expr me = match me with - | T.MEName (x, _) -> L.EVar x - | T.MEStruct (tops, _) -> compile_top_levels tops - | T.MEFunctor ((x, _), body) -> - L.ELam ([ x ], compile_mod_expr body, ref []) - | T.MEField (me, name, _) -> L.EField (compile_mod_expr me, name) - | T.MEApply (me0, me1, _) -> - L.EApp (compile_mod_expr me0, [ compile_mod_expr me1 ]) - | T.MERestrict (me', _, _) -> compile_mod_expr me' + | T.Mod_name (x, _) -> L.Exp_var x + | T.Mod_struct (tops, _) -> compile_top_levels tops + | T.Mod_functor ((x, _), body) -> + L.Exp_lam ([ x ], compile_mod_expr body, ref []) + | T.Mod_field (me, name, _) -> L.Exp_field (compile_mod_expr me, name) + | T.Mod_apply (me0, me1, _) -> + L.Exp_app (compile_mod_expr me0, [ compile_mod_expr me1 ]) + | T.Mod_restrict (me', _, _) -> compile_mod_expr me' and compile_top_levels tops = - L.EModObject + L.Exp_mod_obj (List.filter_map (fun (top : T.top_level) -> match top with - | T.TopLet (x, e) -> Some (L.FSimple (x, compile_expr e)) - | T.TopLetRec binds -> + | T.Top_let (x, e) -> Some (L.Field_simple (x, compile_expr e)) + | T.Top_letrec binds -> Some - (L.FLetRec + (L.Field_letrec (List.map (fun (x, lam) -> (x, compile_lam lam)) binds)) - | T.TopTypeDef _ -> None - | T.TopMod (x, me) -> Some (L.FSimple (x, compile_mod_expr me)) - | T.TopModSig (_, _) -> None - | T.TopExternal (name, _, ext_name) -> - Some (L.FSimple (name, L.EExt ext_name))) + | T.Top_type_def _ -> None + | T.Top_mod (x, me) -> + Some (L.Field_simple (x, compile_mod_expr me)) + | T.Top_mod_sig (_, _) -> None + | T.Top_external (name, _, ext_name) -> + Some (L.Field_simple (name, L.Exp_external ext_name))) tops) let capture fvs vars = List.filter (fun x -> not (List.mem x vars)) fvs @@ -75,32 +80,33 @@ let get_pat_vars (p : L.pattern) = let all = ref [] in let rec go p = match p with - | L.PVar x -> all := x :: !all - | L.PVal _ -> () - | L.PCons (_, None) -> () - | L.PCons (_, Some p) -> go p - | L.PTuple ps -> List.iter go ps + | L.Pat_var x -> all := x :: !all + | L.Pat_val _ -> () + | L.Pat_constr (_, None) -> () + | L.Pat_constr (_, Some p) -> go p + | L.Pat_tuple ps -> List.iter go ps in go p; !all let rec fva_expr e vars = match e with - | L.ETuple es -> List.fold_left (fun acc e -> fva_expr e vars @ acc) [] es - | L.EModObject mems -> + | L.Exp_tuple es -> + List.fold_left (fun acc e -> fva_expr e vars @ acc) [] es + | L.Exp_mod_obj mems -> let capture_vars = ref [] in let vars = ref vars in List.fold_left (fun acc mem -> match mem with - | L.FSimple (name, e) -> + | L.Field_simple (name, e) -> let fv_binds = capture (fva_expr e !vars @ acc) !capture_vars in vars := name :: !vars; capture_vars := name :: !capture_vars; fv_binds - | L.FLetRec binds -> + | L.Field_letrec binds -> let xs, _ = List.split binds in capture_vars := xs @ !capture_vars; let fvs_in_binds = fva_letrec binds !vars in @@ -108,39 +114,39 @@ let rec fva_expr e vars = vars := xs @ !vars; fvs @ acc) [] mems - | L.EStruct fields -> + | L.Exp_struct fields -> List.fold_left (fun acc (_, e) -> acc @ fva_expr e vars) [] fields - | L.EVar x' -> + | L.Exp_var x' -> assert (List.mem x' vars); [ x' ] - | L.EExt _x' -> [] - | L.ECons _ -> [] - | L.EConsWith _ -> [] - | L.EConst _ -> [] - | L.EApp (e0, e1s) -> + | L.Exp_external _x' -> [] + | L.Exp_constr _ -> [] + | L.Exp_payload_constr _ -> [] + | L.Exp_const _ -> [] + | L.Exp_app (e0, e1s) -> fva_expr e0 vars @ List.concat_map (fun e1 -> fva_expr e1 vars) e1s - | L.ECmp (_, e0, e1) -> fva_expr e0 vars @ fva_expr e1 vars - | L.ESeq (e0, e1) -> fva_expr e0 vars @ fva_expr e1 vars - | L.ESwitch (e0, bs) -> + | L.Exp_cmp (_, e0, e1) -> fva_expr e0 vars @ fva_expr e1 vars + | L.Exp_seq (e0, e1) -> fva_expr e0 vars @ fva_expr e1 vars + | L.Exp_switch (e0, bs) -> fva_expr e0 vars @ (bs |> List.map (fun (p, e) -> let p_vars = get_pat_vars p in capture (fva_expr e (p_vars @ vars)) p_vars) |> List.flatten) - | L.ELet (x', e0, e1) -> + | L.Exp_let (x', e0, e1) -> fva_expr e0 vars @ capture (fva_expr e1 (x' :: vars)) [ x' ] - | L.EIf (e0, e1, e2) -> + | L.Exp_if (e0, e1, e2) -> fva_expr e0 vars @ fva_expr e1 vars @ fva_expr e2 vars - | L.ELam (para, e, fvs) -> + | L.Exp_lam (para, e, fvs) -> let fvs' = fva_lambda para e vars in fvs := List_utils.remove_from_left fvs'; fvs' - | L.ELetRec (binds, e) -> + | L.Exp_letrec (binds, e) -> let xs, _ = List.split binds in let fvs_in_binds = fva_letrec binds vars in capture fvs_in_binds xs @ capture (fva_expr e (xs @ vars)) xs - | L.EField (e, _) -> fva_expr e vars + | L.Exp_field (e, _) -> fva_expr e vars and fva_lambda x e vars = let vars = x @ vars in diff --git a/lib/lam/tree.ml b/lib/lam/tree.ml index cd908df..920e191 100644 --- a/lib/lam/tree.ml +++ b/lib/lam/tree.ml @@ -4,33 +4,33 @@ module T = Syntax.Parsetree type constant = T.constant [@@deriving sexp] type expr = - | ETuple of expr list - | EModObject of object_field list - | EStruct of (string * expr) list - | EVar of string - | EExt of string - | ECons of int - | EConsWith of int - | EConst of constant - | EApp of expr * expr list - | ESwitch of expr * branch list - | ELet of string * expr * expr - | EIf of expr * expr * expr - | ELam of lambda - | ELetRec of (string * lambda) list * expr - | EField of expr * string - | ECmp of T.cmp_op * expr * expr - | ESeq of expr * expr + | Exp_tuple of expr list + | Exp_mod_obj of object_field list + | Exp_struct of (string * expr) list + | Exp_var of string + | Exp_external of string + | Exp_constr of int + | Exp_payload_constr of int + | Exp_const of constant + | Exp_app of expr * expr list + | Exp_switch of expr * branch list + | Exp_let of string * expr * expr + | Exp_if of expr * expr * expr + | Exp_lam of lambda + | Exp_letrec of (string * lambda) list * expr + | Exp_field of expr * string + | Exp_cmp of T.cmp_op * expr * expr + | Exp_seq of expr * expr and pattern = - | PVar of string - | PVal of constant - | PCons of int * pattern option - | PTuple of pattern list + | Pat_var of string + | Pat_val of constant + | Pat_constr of int * pattern option + | Pat_tuple of pattern list and object_field = - | FSimple of string * expr - | FLetRec of (string * lambda) list + | Field_simple of string * expr + | Field_letrec of (string * lambda) list and lambda = string list (* lambda parameters *) diff --git a/lib/syntax/parser.mly b/lib/syntax/parser.mly index fe3926d..bd253d7 100644 --- a/lib/syntax/parser.mly +++ b/lib/syntax/parser.mly @@ -2,8 +2,8 @@ open Parsetree let mk_type_ref fon t_args = match fon with - | Some p, n -> TField(p, n, t_args) - | None, n -> TCons(n, t_args) + | Some p, n -> Ty_field (p, n, t_args) + | None, n -> Ty_cons (n, t_args) %} @@ -79,9 +79,9 @@ let mk_type_ref fon t_args = %type constant %type variant -%type type_expr_dbg +%type type_expr_dbg %type mod_expr_dbg -%type mod_type_dbg +%type mod_type_dbg %type expr_dbg %type pattern_dbg @@ -96,29 +96,29 @@ top_levels: | (* empty *) { [] } | td=type_def rest=top_levels { - TopTypeDef td :: rest } + Top_type_def td :: rest } | LET x=IDENT EQ e=expr rest=top_levels { - TopLet (x, e) + Top_let (x, e) :: rest } | LET REC funcs=separated_list(AND, function_bind) rest=top_levels { - TopLetRec funcs + Top_letrec funcs :: rest } | EXTERNAL x=IDENT COLON te=type_expr EQ s=STRING rest=top_levels { - TopExternal (x, te, String.(sub s 1 (length s - 2))) + Top_external (x, te, String.(sub s 1 (length s - 2))) :: rest } | MODULE m_name=MIDENT EQ m_body=mod_expr rest=top_levels { - TopMod (m_name, m_body) + Top_mod (m_name, m_body) :: rest } | MODULE TYPE m_name=MIDENT EQ mt=mod_type rest=top_levels { - TopModSig (m_name, mt) + Top_mod_sig (m_name, mt) :: rest } ; @@ -127,17 +127,17 @@ mod_expr: | LPAREN me=mod_expr RPAREN { me } | m_name=MIDENT - { make_node (MEName m_name) $startpos $endpos } + { make_node (Mod_name m_name) $startpos $endpos } | STRUCT m_body=top_levels END - { make_node (MEStruct m_body) $startpos $endpos } + { make_node (Mod_struct m_body) $startpos $endpos } | FUNCTOR LPAREN mp=mod_para RPAREN ARROW f_body=mod_expr - { make_node (MEFunctor (mp, f_body)) $startpos $endpos } + { make_node (Mod_functor (mp, f_body)) $startpos $endpos } | m = mod_expr DOT n = MIDENT - { make_node (MEField (m, n)) $startpos $endpos } + { make_node (Mod_field (m, n)) $startpos $endpos } | m1 = mod_expr LPAREN m2 = mod_expr RPAREN - { make_node (MEApply (m1, m2)) $startpos $endpos } + { make_node (Mod_apply (m1, m2)) $startpos $endpos } | m1 = mod_expr COLON mt1 = mod_type - { make_node (MERestrict (m1, mt1)) $startpos $endpos } + { make_node (Mod_restrict (m1, mt1)) $startpos $endpos } ; mod_para : @@ -150,32 +150,32 @@ functor_bind: type_def: | TYPE LPAREN tvs=separated_list(COMMA, TYPEVAR) RPAREN n=IDENT EQ OR? vs=separated_list(OR, variant) %prec over_TOP - { TDAdt (n, (List.map Ident.from tvs), vs) } + { Ty_def_adt (n, (List.map Ident.from tvs), vs) } | TYPE UNIT n=IDENT EQ OR? vs=separated_list(OR, variant) %prec over_TOP - { TDAdt (n, [], vs) } + { Ty_def_adt (n, [], vs) } | TYPE tv=TYPEVAR n=IDENT EQ OR? vs=separated_list(OR, variant) %prec over_TOP - { TDAdt (n, [ Ident.from tv ], vs) } + { Ty_def_adt (n, [ Ident.from tv ], vs) } | TYPE n=IDENT EQ OR? vs=separated_list(OR, variant) %prec over_TOP - { TDAdt (n, [], vs) } + { Ty_def_adt (n, [], vs) } | TYPE n=IDENT EQ te=type_expr %prec over_TOP - { TDAlias (n, te) } + { Ty_def_alias (n, te) } pattern: - | n=IDENT { PVar n } (* variable pattern *) - | c=constant { PVal c } - | c=MIDENT pat=pattern? { PCons (c, pat) } - | m=mod_expr DOT n=MIDENT pat=pattern? { PFieldCons (m, n, pat) } + | n=IDENT { Pat_var n } (* variable pattern *) + | c=constant { Pat_val c } + | c=MIDENT pat=pattern? { Pat_constr (c, pat) } + | m=mod_expr DOT n=MIDENT pat=pattern? { Pat_field_constr (m, n, pat) } | LPAREN pats=separated_nontrivial_llist(COMMA, pattern) RPAREN - { PTuple (pats) } + { Pat_tuple (pats) } ; parameter: - | n=IDENT { PBare n } - | LPAREN n=IDENT COLON t=type_expr RPAREN { PAnn (n, t) } + | n=IDENT { Para_bare n } + | LPAREN n=IDENT COLON t=type_expr RPAREN { Para_ann (n, t) } function_bind: | name=IDENT EQ FUN para=parameter ARROW b=expr %prec over_TOP @@ -198,64 +198,64 @@ type_expr: | UNIT fon=field_or_name { mk_type_ref fon [] } | LPAREN te=type_expr RPAREN { te } - | ts=separated_nontrivial_llist(STAR, type_expr) { TTuple ts } + | ts=separated_nontrivial_llist(STAR, type_expr) { Ty_tuple ts } | t_arg = type_expr fon=field_or_name { mk_type_ref fon [t_arg] } | fon=field_or_name { mk_type_ref fon [] } - | n=IDENT { TCons (n, []) } - | tv=TYPEVAR { TVar (Ident.from tv) } - | arg=type_expr ARROW ret=type_expr { TArrow (arg, ret) } - | LBRACE fields=separated_nontrivial_llist(SEMI, field_def) RBRACE { TRecord fields } + | n=IDENT { Ty_cons (n, []) } + | tv=TYPEVAR { Ty_var (Ident.from tv) } + | arg=type_expr ARROW ret=type_expr { Ty_arrow (arg, ret) } + | LBRACE fields=separated_nontrivial_llist(SEMI, field_def) RBRACE { Ty_record fields } path: - | m_name=MIDENT { make_node (MEName m_name) $startpos $endpos } - | m = path DOT n = MIDENT { make_node (MEField (m, n)) $startpos $endpos } + | m_name=MIDENT { make_node (Mod_name m_name) $startpos $endpos } + | m = path DOT n = MIDENT { make_node (Mod_field (m, n)) $startpos $endpos } expr: | c=constant %prec over_TOP - { make_node (EConst c) $startpos $endpos } + { make_node (Exp_const c) $startpos $endpos } | func=expr arg=expr %prec below_APP - { make_node (EApp (func, arg)) $startpos $endpos } + { make_node (Exp_app (func, arg)) $startpos $endpos } | LPAREN e=expr RPAREN { e } | c=MIDENT - { make_node (ECons c) $startpos $endpos } + { make_node (Exp_constr c) $startpos $endpos } | p=path DOT v=IDENT - { make_node (EField (p, v)) $startpos $endpos } + { make_node (Exp_field (p, v)) $startpos $endpos } | p=path DOT v=MIDENT - { make_node (EFieldCons (p, v)) $startpos $endpos } + { make_node (Exp_field_constr (p, v)) $startpos $endpos } | v=IDENT %prec over_TOP - { make_node (EVar v) $startpos $endpos } + { make_node (Exp_var v) $startpos $endpos } | LET x=IDENT EQ e1=expr IN e2=expr - { make_node (ELet (x, e1, e2)) $startpos $endpos } + { make_node (Exp_let (x, e1, e2)) $startpos $endpos } | LET REC binds=separated_nonempty_list(AND, function_bind) IN body=expr %prec over_TOP - { make_node (ELetrec (binds, body)) $startpos $endpos } + { make_node (Exp_letrec (binds, body)) $startpos $endpos } | IF e0=expr THEN e1=expr ELSE e2=expr - { make_node (EIf (e0, e1, e2)) $startpos $endpos } + { make_node (Exp_if (e0, e1, e2)) $startpos $endpos } | tu=tuple_expr { tu } | FUN para=parameter ARROW body=expr %prec over_TOP { - make_node (ELam (para, body)) $startpos $endpos + make_node (Exp_lam (para, body)) $startpos $endpos } | MATCH e=expr WITH OR? branches=separated_nonempty_list(OR, branch) %prec over_TOP { - make_node (ECase (e, branches)) $startpos $endpos + make_node (Exp_case (e, branches)) $startpos $endpos } | e=bin_expr { e } - | e=expr COLON te=type_expr { make_node (EAnn (e, te)) $startpos $endpos } + | e=expr COLON te=type_expr { make_node (Exp_ann (e, te)) $startpos $endpos } ; bin_expr: | e0=expr EQ e1=expr %prec EQ { - make_node (ECmp (Eq, e0, e1)) $startpos $endpos + make_node (Exp_cmp (Eq, e0, e1)) $startpos $endpos } | e0=expr NEQ e1=expr %prec EQ { - make_node (ECmp (Neq, e0, e1)) $startpos $endpos + make_node (Exp_cmp (Neq, e0, e1)) $startpos $endpos } | e0=expr SEMI e1=expr %prec below_SEMI { - make_node (ESeq (e0, e1)) $startpos $endpos + make_node (Exp_seq (e0, e1)) $startpos $endpos } ; @@ -263,32 +263,32 @@ branch: p=pattern ARROW e=expr %prec over_TOP { ( p, e ) } tuple_expr: | es = separated_nontrivial_llist(COMMA, expr) %prec below_COMMA - { make_node (ETuple es) $startpos $endpos } + { make_node (Exp_tuple es) $startpos $endpos } mod_type: - | m=MIDENT { MTName m } - | p=mod_expr DOT m=MIDENT { MTField (p, m) } - | SIG comps=list(sig_comp) END { MTSig comps } + | m=MIDENT { Mod_ty_name m } + | p=mod_expr DOT m=MIDENT { Mod_ty_field (p, m) } + | SIG comps=list(sig_comp) END { Mod_ty_sig comps } | FUNCTOR LPAREN p=MIDENT COLON p_ty=mod_type RPAREN - ARROW body=mod_type { MTFunctor (p, p_ty, body) } + ARROW body=mod_type { Mod_ty_functor (p, p_ty, body) } sig_comp: - | VAL v=IDENT COLON ty=type_expr { TValueSpec (v, ty) } + | VAL v=IDENT COLON ty=type_expr { Spec_value (v, ty) } | TYPE LPAREN tvs=separated_list(COMMA, TYPEVAR) RPAREN t=IDENT - { TAbstTySpec (t, (List.map Ident.from tvs)) } + { Spec_abstr (t, (List.map Ident.from tvs)) } | TYPE UNIT t=IDENT - { TAbstTySpec (t, []) } - | def=type_def { TManiTySpec def } - | MODULE m_name=MIDENT COLON mt=mod_type { TModSpec (m_name, mt) } + { Spec_abstr (t, []) } + | def=type_def { Spec_mani_ty def } + | MODULE m_name=MIDENT COLON mt=mod_type { Spec_mod (m_name, mt) } ; constant: - | i = INT { CInt i } - | b = BOOL { CBool b } - | s = STRING { CString s } - | UNIT { CUnit } ; + | i = INT { Const_int i } + | b = BOOL { Const_bool b } + | s = STRING { Const_string s } + | UNIT { Const_unit } ; (* debug rules: which are normal rules append with an eof *) type_expr_dbg: diff --git a/lib/syntax/parsetree.ml b/lib/syntax/parsetree.ml index 8e847ce..0dbdc51 100644 --- a/lib/syntax/parsetree.ml +++ b/lib/syntax/parsetree.ml @@ -1,10 +1,10 @@ open Sexplib.Conv type constant = - | CBool of bool - | CInt of int - | CString of string - | CUnit + | Const_bool of bool + | Const_int of int + | Const_string of string + | Const_unit [@@deriving sexp] type position = Lexing.position = { @@ -25,16 +25,16 @@ type 'a node = { and program = top_level list and top_level = - | TopLet of string * expr - | TopLetRec of (string * lambda) list - | TopTypeDef of ety_def - | TopMod of string * mod_expr - | TopModSig of string * emod_ty - | TopExternal of string * ety * string + | Top_let of string * expr + | Top_letrec of (string * lambda) list + | Top_type_def of surface_ty_def + | Top_mod of string * mod_expr + | Top_mod_sig of string * surface_mod_ty + | Top_external of string * surface_ty * string and para = - | PAnn of string * ety - | PBare of string + | Para_ann of string * surface_ty + | Para_bare of string and paras = para list @@ -45,28 +45,29 @@ and cmp_op = and expr = expr_desc node and expr_desc = - | EConst of constant - | EVar of string - | ECons of string - | ELet of string * expr * expr - | ELetrec of (string * lambda) list * expr - | ELam of lambda - | EIf of expr * expr * expr - | ECase of expr * (pattern * expr) list - | EApp of expr * expr - | EAnn of expr * ety - | ETuple of expr list - | EField of mod_expr * string - | EFieldCons of mod_expr * string - | ECmp of cmp_op * expr * expr - | ESeq of expr * expr + | Exp_const of constant + | Exp_var of string + | Exp_constr of string + | Exp_let of string * expr * expr + | Exp_letrec of (string * lambda) list * expr + | Exp_lam of lambda + | Exp_if of expr * expr * expr + | Exp_case of expr * (pattern * expr) list + | Exp_app of expr * expr + | Exp_ann of expr * surface_ty + | Exp_tuple of expr list + | Exp_field of mod_expr * string + | Exp_field_constr of mod_expr * string + | Exp_cmp of cmp_op * expr * expr + | Exp_seq of expr * expr and pattern = - | PVal of constant - | PCons of string * pattern option (* Cons (1, 2) *) - | PFieldCons of mod_expr * string * pattern option (* T.M(M2).C (1, 2) *) - | PVar of string - | PTuple of pattern list (* (x, y, z) *) + | Pat_val of constant + | Pat_constr of string * pattern option (* Cons (1, 2) *) + | Pat_field_constr of + mod_expr * string * pattern option (* T.M(M2).C (1, 2) *) + | Pat_var of string + | Pat_tuple of pattern list (* (x, y, z) *) and lambda = para * expr @@ -75,47 +76,47 @@ and mod_body = top_level list and mod_expr = mod_expr_desc node and mod_expr_desc = - | MEName of string (* M *) - | MEStruct of mod_body (* struct ... end *) - | MEFunctor of functor_expr (* functor (M: MT) -> ... *) - | MEField of mod_expr * string (* M1.M2 *) - | MEApply of mod_expr * mod_expr (* M1(...) *) - | MERestrict of mod_expr * emod_ty (* M: M_ty *) + | Mod_name of string (* M *) + | Mod_struct of mod_body (* struct ... end *) + | Mod_functor of functor_expr (* functor (M: MT) -> ... *) + | Mod_field of mod_expr * string (* M1.M2 *) + | Mod_apply of mod_expr * mod_expr (* M1(...) *) + | Mod_restrict of mod_expr * surface_mod_ty (* M: M_ty *) -and functor_para = string * emod_ty +and functor_para = string * surface_mod_ty and functor_expr = functor_para * mod_expr -and adt_def = string * ety_paras * evariant list +and adt_def = string * surface_ty_paras * evariant list -and ety_comp = - | TValueSpec of string * ety - | TAbstTySpec of string * ety_paras - | TManiTySpec of ety_def - | TModSpec of (string * emod_ty) +and surface_spec = + | Spec_value of string * surface_ty + | Spec_abstr of string * surface_ty_paras + | Spec_mani_ty of surface_ty_def + | Spec_mod of (string * surface_mod_ty) -and ety = - | TField of mod_expr * string * ety list (* T.Cons *) - | TCons of string * ety list (* Cons x *) - | TVar of Ident.ident (* 'var *) - | TArrow of ety * ety - | TTuple of ety list - | TRecord of (string * ety) list +and surface_ty = + | Ty_field of mod_expr * string * surface_ty list (* T.Cons *) + | Ty_cons of string * surface_ty list (* Cons x *) + | Ty_var of Ident.ident (* 'var *) + | Ty_arrow of surface_ty * surface_ty + | Ty_tuple of surface_ty list + | Ty_record of (string * surface_ty) list -and ety_def = - | TDAdt of string * ety_paras * evariant list - | TDRecord of string * ety_paras * (string * ety) list - | TDAlias of string * ety +and surface_ty_def = + | Ty_def_adt of string * surface_ty_paras * evariant list + | Ty_def_record of string * surface_ty_paras * (string * surface_ty) list + | Ty_def_alias of string * surface_ty -and ety_paras = Ident.ident list +and surface_ty_paras = Ident.ident list -and emod_ty = - | MTName of string - | MTField of mod_expr * string - | MTSig of ety_comp list - | MTFunctor of string * emod_ty * emod_ty +and surface_mod_ty = + | Mod_ty_name of string + | Mod_ty_field of mod_expr * string + | Mod_ty_sig of surface_spec list + | Mod_ty_functor of string * surface_mod_ty * surface_mod_ty -and evariant = string * ety option [@@deriving sexp] +and evariant = string * surface_ty option [@@deriving sexp] let make_node desc start_loc end_loc = { desc; start_loc; end_loc; attrs = [] } diff --git a/lib/typing/alias.ml b/lib/typing/alias.ml index e9ffce2..7dd7601 100644 --- a/lib/typing/alias.ml +++ b/lib/typing/alias.ml @@ -5,29 +5,29 @@ module I = Types_in let dealias_te (te : I.ty) alias_map = let rec go (t : I.ty) = match t with - | I.TConsI (id, []) -> ( + | I.Ty_cons (id, []) -> ( match List.assoc_opt id alias_map with | Some t' -> ( match t' with - | I.TConsI (id', []) -> I.TConsI (id', []) + | I.Ty_cons (id', []) -> I.Ty_cons (id', []) | _ -> failwith "ill form alias") | None -> t) - | I.TConsI (id, args) -> ( + | I.Ty_cons (id, args) -> ( match List.assoc_opt id alias_map with | Some _t' -> failwith "parameterized type alias is not supported" - | None -> I.TConsI (id, List.map go args)) - | I.TVarI { contents = I.Unbound _ } -> + | None -> I.Ty_cons (id, List.map go args)) + | I.Ty_var { contents = I.Unbound _ } -> (* It's a 'never reach' when local module is not supported(that's the current implementation), because every normalized module type should only capture module level entities, which should have normalized and fully inferenced already. *) failwith "never reach: deliasing a type not fully inferenced" - | I.TVarI { contents = I.Link t' } -> go t' - | I.TQVarI _ -> t - | I.TArrowI (t0, t1) -> I.TArrowI (go t0, go t1) - | I.TTupleI tes -> I.TTupleI (List.map go tes) - | I.TRecordI fields -> - I.TRecordI (List.map (fun (name, te) -> (name, go te)) fields) + | I.Ty_var { contents = I.Link t' } -> go t' + | I.Ty_qvar _ -> t + | I.Ty_arrow (t0, t1) -> I.Ty_arrow (go t0, go t1) + | I.Ty_tuple tes -> I.Ty_tuple (List.map go tes) + | I.Ty_record fields -> + I.Ty_record (List.map (fun (name, te) -> (name, go te)) fields) in go te @@ -35,19 +35,19 @@ let dealias ((qvs, te) : I.bind_ty) alias_map = (qvs, dealias_te te alias_map) let dealias_td (td : I.ty_def) alias_map = match td with - | I.TDOpaqueI (_, _) -> td - | I.TDAdtI (name, paras, bs) -> - I.TDAdtI + | I.Ty_def_opaque (_, _) -> td + | I.Ty_def_adt (name, paras, bs) -> + I.Ty_def_adt ( name, paras, List.map (fun (cname, t) -> (cname, Option.map (fun t' -> dealias_te t' alias_map) t)) bs ) - | I.TDRecordI (name, paras, fields) -> - I.TDRecordI + | I.Ty_def_record (name, paras, fields) -> + I.Ty_def_record ( name, paras, List.map (fun (name, t) -> (name, dealias_te t alias_map)) fields ) - | I.TDAliasI (name, t) -> I.TDAliasI (name, dealias_te t alias_map) + | I.Ty_def_alias (name, t) -> I.Ty_def_alias (name, dealias_te t alias_map) diff --git a/lib/typing/check.ml b/lib/typing/check.ml index a068215..d42264d 100644 --- a/lib/typing/check.ml +++ b/lib/typing/check.ml @@ -35,21 +35,21 @@ let check_subtype = Subtype.check_subtype let rec check_expr (e : T.expr) (env : Env.t) : expr = try match e.desc with - | T.EConst c -> check_const c - | T.EVar x -> check_var x env - | T.ELet (x, e0, e1) -> check_let x e0 e1 env - | T.ELetrec (binds, body) -> check_letrec binds body env - | T.ELam (para, body) -> check_lambda para body env - | T.EIf (c, e0, e1) -> check_if_else c e0 e1 env - | T.ECase (e, bs) -> check_cases e bs env - | T.EApp (e0, e1) -> check_app e0 e1 env - | T.EAnn (e, te) -> check_ann e te env - | T.ETuple es -> check_tuple es env - | T.EField (p, x) -> check_field p x env - | T.ECons c -> check_cons c env - | T.EFieldCons (p, c) -> check_field_cons p c env - | T.ECmp (op, e0, e1) -> check_cmp op e0 e1 env - | T.ESeq (e0, e1) -> check_seq e0 e1 env + | T.Exp_const c -> check_const c + | T.Exp_var x -> check_var x env + | T.Exp_let (x, e0, e1) -> check_let x e0 e1 env + | T.Exp_letrec (binds, body) -> check_letrec binds body env + | T.Exp_lam (para, body) -> check_lambda para body env + | T.Exp_if (c, e0, e1) -> check_if_else c e0 e1 env + | T.Exp_case (e, bs) -> check_cases e bs env + | T.Exp_app (e0, e1) -> check_app e0 e1 env + | T.Exp_ann (e, te) -> check_ann e te env + | T.Exp_tuple es -> check_tuple es env + | T.Exp_field (p, x) -> check_field p x env + | T.Exp_constr c -> check_cons c env + | T.Exp_field_constr (p, c) -> check_field_cons p c env + | T.Exp_cmp (op, e0, e1) -> check_cmp op e0 e1 env + | T.Exp_seq (e0, e1) -> check_seq e0 e1 env with | U.UnificationError (t0, t1) -> Report.unification_error t0 t1 e.start_loc e.end_loc env @@ -58,68 +58,70 @@ let rec check_expr (e : T.expr) (env : Env.t) : expr = and check_const c = match c with - | T.CBool _ -> EConst (c, I.bool_ty) - | T.CInt _ -> EConst (c, I.int_ty) - | T.CString _ -> EConst (c, I.string_ty) - | T.CUnit -> EConst (c, I.unit_ty) + | T.Const_bool _ -> Exp_const (c, I.bool_ty) + | T.Const_int _ -> Exp_const (c, I.int_ty) + | T.Const_string _ -> Exp_const (c, I.string_ty) + | T.Const_unit -> Exp_const (c, I.unit_ty) and check_var x env = (* lookup a binding won't unify anything *) let bind = Env.lookup_var_type x env in let t = P.inst bind in - EVar (x, t) + Exp_var (x, t) (* pattern will create bindings under context's type *) and check_pattern p te env : pattern * (string * I.ty) list = let check_PCons_aux (cons_ty : I.ty) (p (* payload pattern *) : T.pattern) te0 = match cons_ty with - | I.TArrowI (pay_ty (* payload type *), te1) -> + | I.Ty_arrow (pay_ty (* payload type *), te1) -> U.unify te1 te0; let p, vars = check_pattern p pay_ty env in (p, vars) | _ -> failwith "payload constructor is not arrow type" in match (p, te) with - | T.PVar x, te -> (PVar (x, te), [ (x, te) ]) - | T.PCons (c, None), te -> ( + | T.Pat_var x, te -> (Pat_var (x, te), [ (x, te) ]) + | T.Pat_constr (c, None), te -> ( let cons_ty_gen (* type of constructor *), id = Env.lookup_constr_type c env in let cons_ty = P.inst cons_ty_gen in U.unify cons_ty te; match cons_ty with - | I.TConsI _ -> (PCons (c, id, None), []) + | I.Ty_cons _ -> (Pat_constr (c, id, None), []) | _ -> failwith (Printf.sprintf "wrong no-payload constructor pattern %s" c)) - | T.PCons (c, Some p0 (* pattern *)), te -> + | T.Pat_constr (c, Some p0 (* pattern *)), te -> let cons_ty_gen (* type of constructor *), id = Env.lookup_constr_type c env in let p0, binds = check_PCons_aux (P.inst cons_ty_gen) p0 te in - (PCons (c, id, Some p0), binds) - | T.PFieldCons (me, c, None), te -> ( + (Pat_constr (c, id, Some p0), binds) + | T.Pat_field_constr (me, c, None), te -> ( let cons_typed (* constructor *) = check_field_cons me c env in - let[@warning "-8"] (EFieldCons (_, _, id, _)) = cons_typed in + let[@warning "-8"] (Exp_field_constr (_, _, id, _)) = cons_typed in let cons_ty = get_ty cons_typed in U.unify cons_ty te; (* unify cons_ty with te *) match cons_ty with - | I.TConsI (_, _) -> (PCons (c, id, None), [ (* bind nothing *) ]) + | I.Ty_cons (_, _) -> (Pat_constr (c, id, None), [ (* bind nothing *) ]) | _ -> failwith "wrong type") - | T.PFieldCons (p (* path *), c, Some p0), te -> + | T.Pat_field_constr (p (* path *), c, Some p0), te -> let cons_typed (* typed constructor *) = check_field_cons p c env in - let[@warning "-8"] (EFieldCons (_, _, id, cons_ty)) = cons_typed in + let[@warning "-8"] (Exp_field_constr (_, _, id, cons_ty)) = + cons_typed + in let p0, binds = check_PCons_aux cons_ty p0 te in - (PCons (c, id, Some p0), binds) - | T.PVal v, te -> + (Pat_constr (c, id, Some p0), binds) + | T.Pat_val v, te -> let v_typed = check_const v in U.unify (get_ty v_typed) te; - (PVal v, []) - | T.PTuple pats, te -> + (Pat_val v, []) + | T.Pat_tuple pats, te -> let payload_tvs = List.map (fun _ -> P.make_tv ()) pats in - U.unify te (I.TTupleI payload_tvs); + U.unify te (I.Ty_tuple payload_tvs); let pats, vars = List.fold_left2 (fun (pats_acc, vars_acc) pat te -> @@ -127,12 +129,12 @@ and check_pattern p te env : pattern * (string * I.ty) list = (pats_acc @ [ pat ], vars_acc @ vars)) ([], []) pats payload_tvs in - (PTuple pats, vars) + (Pat_tuple pats, vars) and check_let x e0 e1 env = let e0_typed, env = check_let_binding x e0 env in let e1_typed = check_expr e1 env in - ELet (x, e0_typed, e1_typed, get_ty e1_typed) + Exp_let (x, e0_typed, e1_typed, get_ty e1_typed) and check_let_binding x e0 env : expr * Env.t = Poly.enter_level (); @@ -146,7 +148,7 @@ and check_let_binding x e0 env : expr * Env.t = and check_letrec binds body env : expr = let env, vars, lams_typed = check_letrec_binding binds env in let body_typed = check_expr body env in - ELetrec (List.combine vars lams_typed, body_typed, get_ty body_typed) + Exp_letrec (List.combine vars lams_typed, body_typed, get_ty body_typed) and check_letrec_binding binds env = let origin_env = env in @@ -172,7 +174,7 @@ and check_letrec_binding binds env = let lams_typed = List.map (function - | ELam (x, body, ty) -> (x, body, ty) + | Exp_lam (x, body, ty) -> (x, body, ty) | _ -> failwith "neverreach") lams_typed in @@ -186,18 +188,18 @@ and check_letrec_binding binds env = and check_lambda para body env0 : expr = match para with - | T.PAnn (x, t) -> + | T.Para_ann (x, t) -> let ann = normalize_ty t env0 in let env = Env.add_value x ([], ann) env0 in let body0 = check_expr body env in let body_ty0 = get_ty body0 in - ELam (x, body0, I.TArrowI (ann, body_ty0)) - | T.PBare x -> + Exp_lam (x, body0, I.Ty_arrow (ann, body_ty0)) + | T.Para_bare x -> let tv = P.make_tv () in let env = Env.add_value x ([], tv) env0 in let body0 = check_expr body env in let body_ty0 = get_ty body0 in - ELam (x, body0, I.TArrowI (tv, body_ty0)) + Exp_lam (x, body0, I.Ty_arrow (tv, body_ty0)) and check_if_else c e1 e2 env : expr = let c_typed = check_expr c env in @@ -205,7 +207,7 @@ and check_if_else c e1 e2 env : expr = let e1_typed = check_expr e1 env in let e2_typed = check_expr e2 env in U.unify (get_ty e1_typed) (get_ty e2_typed); - EIf (c_typed, e1_typed, e2_typed, get_ty e1_typed) + Exp_if (c_typed, e1_typed, e2_typed, get_ty e1_typed) and check_app op arg env = let op_typed = check_expr op env in @@ -213,21 +215,21 @@ and check_app op arg env = let arg_typed = check_expr arg env in let arg_ty = get_ty arg_typed in let tv = P.make_tv_of "'ret" in - U.unify op_ty (I.TArrowI (arg_ty, tv)); - EApp (op_typed, arg_typed, tv) + U.unify op_ty (I.Ty_arrow (arg_ty, tv)); + Exp_app (op_typed, arg_typed, tv) and check_cmp op e0 e1 env = let e0_typed = check_expr e0 env in let e1_typed = check_expr e1 env in U.unify (get_ty e0_typed) (get_ty e1_typed); - ECmp (op, e0_typed, e1_typed, I.bool_ty) + Exp_cmp (op, e0_typed, e1_typed, I.bool_ty) and check_seq e0 e1 env = let e0_typed = check_expr e0 env in U.unify (get_ty e0_typed) I.unit_ty; let e1_typed = check_expr e1 env in let e1_ty = get_ty e1_typed in - ESeq (e0_typed, e1_typed, e1_ty) + Exp_seq (e0_typed, e1_typed, e1_ty) and check_cases e bs env = let e_typed = check_expr e env in @@ -255,7 +257,7 @@ and check_cases e bs env = bs_typed @ [ (p, res_typed) ]) [] bs in - ECase (e_typed, bs_typed, res_ty) + Exp_case (e_typed, bs_typed, res_ty) and check_tuple es env = let es_typed = @@ -265,27 +267,27 @@ and check_tuple es env = acc @ [ e_typed ]) [] es in - let tu_te = I.TTupleI (List.map get_ty es_typed) in - ETuple (es_typed, tu_te) + let tu_te = I.Ty_tuple (List.map get_ty es_typed) in + Exp_tuple (es_typed, tu_te) and check_cons c env = let t, id = Env.lookup_constr_type c env in - ECons (c, id, P.inst t) + Exp_constr (c, id, P.inst t) and check_field_cons me c env = let me_typed = check_mod me env in match get_mod_ty me_typed with - | I.MTMod { constr_defs; _ } -> + | I.Mod_ty_struct { constr_defs; _ } -> let t, id = List.assoc c constr_defs in - EFieldCons (me_typed, c, id, P.inst t) - | I.MTFun _ -> failwith "try get field from functor" + Exp_field_constr (me_typed, c, id, P.inst t) + | I.Mod_ty_functor _ -> failwith "try get field from functor" and check_field me x env = let me_typed = check_mod me env in match get_mod_ty me_typed with - | I.MTMod { val_defs; _ } -> - EField (me_typed, x, P.inst (List.assoc x val_defs)) - | I.MTFun _ -> failwith "try get field from functor" + | I.Mod_ty_struct { val_defs; _ } -> + Exp_field (me_typed, x, P.inst (List.assoc x val_defs)) + | I.Mod_ty_functor _ -> failwith "try get field from functor" and check_ann e te env = let e_typed = check_expr e env in @@ -299,43 +301,43 @@ and check_top_level (top : T.top_level) env : top_level * Env.t = reset_pool (); let top_typed = match top with - | T.TopLet (x, e) -> + | T.Top_let (x, e) -> let e_typed0, env = check_let_binding x e env in - (TopLet (x, e_typed0), env) - | T.TopLetRec binds -> + (Top_let (x, e_typed0), env) + | T.Top_letrec binds -> let env, vars, lams = check_letrec_binding binds env in let binds = List.combine vars lams in - (TopLetRec binds, env) - | T.TopTypeDef (TDAdt (name, ty_para_names, _) as def_ext) -> + (Top_letrec binds, env) + | T.Top_type_def (Ty_def_adt (name, ty_para_names, _) as def_ext) -> let tid = Env.mk_tid name env in let normalize_env = (* special environment for normalizing type definition, with typed definition pushed as an opaque type *) - Env.add_type_def (I.TDOpaqueI (name, ty_para_names)) env + Env.add_type_def (I.Ty_def_opaque (name, ty_para_names)) env in let def = normalize_def def_ext normalize_env in - let[@warning "-8"] (I.TDAdtI (_, _, bs)) = def in + let[@warning "-8"] (I.Ty_def_adt (_, _, bs)) = def in let env = Env.add_type_def def env in let constructors = analyze_constructors tid ty_para_names bs in let env = Env.add_constrs constructors env in - (TopTypeDef def, env) - | T.TopTypeDef (_ as def_ext) -> + (Top_type_def def, env) + | T.Top_type_def (_ as def_ext) -> let def = normalize_def def_ext env in - (TopTypeDef def, Env.add_type_def def env) - | T.TopMod (name, me) -> + (Top_type_def def, Env.add_type_def def env) + | T.Top_mod (name, me) -> let me_typed = check_mod me env in - ( TopMod (name, me_typed), + ( Top_mod (name, me_typed), Env.add_module name (get_mod_ty me_typed) env ) - | T.TopModSig (name, ext_mt) -> + | T.Top_mod_sig (name, ext_mt) -> let mt = normalize_mt ext_mt env in - (TopModSig (name, mt), Env.add_module_sig name mt env) - | T.TopExternal (name, e_ty, ext_name) -> + (Top_mod_sig (name, mt), Env.add_module_sig name mt env) + | T.Top_external (name, e_ty, ext_name) -> P.enter_level (); let te = normalize e_ty Let env in P.exit_level (); let gen = P.generalize te env in - (TopExternal (name, te, ext_name), Env.add_value name gen env) + (Top_external (name, te, ext_name), Env.add_value name gen env) in tv_pool := old_pool; top_typed @@ -348,16 +350,17 @@ and analyze_constructors (tid : I.ty_id) para_names (bs : I.variant list) : | c, None -> ( c, ( ( para_names, - I.TConsI (tid, List.map (fun id -> I.TQVarI id) para_names) + I.Ty_cons (tid, List.map (fun id -> I.Ty_qvar id) para_names) ), id ) ) | c, Some payload -> ( c, ( ( para_names, - I.TArrowI + I.Ty_arrow ( payload, - TConsI (tid, List.map (fun id -> I.TQVarI id) para_names) - ) ), + Ty_cons + (tid, List.map (fun id -> I.Ty_qvar id) para_names) ) + ), id ) )) bs @@ -382,7 +385,7 @@ and make_mt_by_scope history; hints = _; } = - I.MTMod + I.Mod_ty_struct { id = curr; val_defs = values; @@ -396,36 +399,36 @@ and make_mt_by_scope and check_mod (me : T.mod_expr) (env : Env.t) : mod_expr = let me_typed = match me.desc with - | T.MEName name -> check_mod_name name env - | T.MEStruct body -> check_struct body env - | T.MEFunctor ((name, ext_mt0), me1) -> + | T.Mod_name name -> check_mod_name name env + | T.Mod_struct body -> check_struct body env + | T.Mod_functor ((name, ext_mt0), me1) -> check_functor name ext_mt0 me1 env - | T.MEField (me, name) -> check_mod_field me name env - | T.MEApply (me0, me1) -> check_mod_apply me0 me1 env - | T.MERestrict (me, mt) -> check_mod_restrict me mt env + | T.Mod_field (me, name) -> check_mod_field me name env + | T.Mod_apply (me0, me1) -> check_mod_apply me0 me1 env + | T.Mod_restrict (me, mt) -> check_mod_restrict me mt env in Env.try_record_hint me_typed env; me_typed -and check_mod_name name env = MEName (name, Env.lookup_module_def name env) +and check_mod_name name env = Mod_name (name, Env.lookup_module_def name env) and check_struct body env = let body_typed, env' = check_top_levels body (Env.enter_env env) in let scope = absorb_history env' env in let mt = make_mt_by_scope scope in - MEStruct (body_typed, mt) + Mod_struct (body_typed, mt) and check_functor name ext_mt0 me1 env = let mt0 = normalize_mt ext_mt0 env in let me1_typed = check_mod me1 (Env.add_module name mt0 env) in - MEFunctor ((name, mt0), me1_typed) + Mod_functor ((name, mt0), me1_typed) and check_mod_field me name env = let me_typed = check_mod me env in match get_mod_ty me_typed with - | I.MTMod { mod_defs; _ } -> - MEField (me_typed, name, List.assoc name mod_defs) - | I.MTFun _ -> failwith "try get field from functor" + | I.Mod_ty_struct { mod_defs; _ } -> + Mod_field (me_typed, name, List.assoc name mod_defs) + | I.Mod_ty_functor _ -> failwith "try get field from functor" and check_mod_apply me0 me1 env = let me0_typed = check_mod me0 env in @@ -433,15 +436,15 @@ and check_mod_apply me0 me1 env = let mt0 = get_mod_ty me0_typed in let mt1 = get_mod_ty me1_typed in match mt0 with - | I.MTMod _ -> failwith "try apply a structure" - | I.MTFun (para_mt, body_mt) -> - MEApply (me0_typed, me1_typed, apply_functor para_mt body_mt mt1 env) + | I.Mod_ty_struct _ -> failwith "try apply a structure" + | I.Mod_ty_functor (para_mt, body_mt) -> + Mod_apply (me0_typed, me1_typed, apply_functor para_mt body_mt mt1 env) and check_mod_restrict me mt env = let me_typed = check_mod me env in let mt = normalize_mt mt env in let _subst = check_subtype (get_mod_ty me_typed) mt in - MERestrict (me_typed, mt, shift_mt mt env) + Mod_restrict (me_typed, mt, shift_mt mt env) (* apply a functor, add returned module type's id into environment *) and apply_functor para_mt body_mt arg_mt env = @@ -457,7 +460,7 @@ and shift_mt (mt : I.mod_ty) env : I.mod_ty = let result = ref IntMap.empty in let rec go mt = match (mt : I.mod_ty) with - | I.MTMod + | I.Mod_ty_struct { id; val_defs = _; @@ -475,7 +478,7 @@ and shift_mt (mt : I.mod_ty) env : I.mod_ty = (id :: owned_mods); List.iter (fun (_, mt) -> go mt) mod_defs; List.iter (fun (_, mt) -> go mt) mod_sigs - | I.MTFun (_para_mt, _body_mt) -> + | I.Mod_ty_functor (_para_mt, _body_mt) -> (* It's OK to ignore functor's input and output in shifting, because they are not indicate modules "created" by the functor. They are just module types indicate compatibility. *) @@ -496,11 +499,11 @@ and shift_mt (mt : I.mod_ty) env : I.mod_ty = (* todo: remove this object *) inherit [_] Types_in.map as super - method! visit_MTMod () id val_defs constr_defs ty_defs mod_sigs - mod_defs owned_mods = + method! visit_Mod_ty_struct () id val_defs constr_defs ty_defs + mod_sigs mod_defs owned_mods = let shifted_id = get_id_or_default id in - super#visit_MTMod () shifted_id val_defs constr_defs ty_defs - mod_sigs mod_defs + super#visit_Mod_ty_struct () shifted_id val_defs constr_defs + ty_defs mod_sigs mod_defs (List.map get_id_or_default owned_mods) method! visit_ty_id () (id, name) = (get_id_or_default id, name) @@ -517,10 +520,10 @@ and shift_mt (mt : I.mod_ty) env : I.mod_ty = in mapper mt -and normalize_def (t : T.ety_def) env : I.ty_def = +and normalize_def (t : T.surface_ty_def) env : I.ty_def = let normed = match t with - | T.TDAdt (n, tvs, vs) -> + | T.Ty_def_adt (n, tvs, vs) -> let vs = List.map (function @@ -528,72 +531,74 @@ and normalize_def (t : T.ety_def) env : I.ty_def = | c, Some payload -> (c, Some (normalize payload Type env))) vs in - I.TDAdtI (n, tvs, vs) - | T.TDRecord (n, tvs, fields) -> - I.TDRecordI + I.Ty_def_adt (n, tvs, vs) + | T.Ty_def_record (n, tvs, fields) -> + I.Ty_def_record (n, tvs, List.map (fun (x, t) -> (x, normalize t Type env)) fields) - | T.TDAlias (n, te) -> I.TDAliasI (n, normalize te Type env) + | T.Ty_def_alias (n, te) -> I.Ty_def_alias (n, normalize te Type env) in normed and normalize_ty t env = normalize t Let env -and normalize (t : T.ety) (ctx : norm_ctx) (env : Env.t) : I.ty = +and normalize (t : T.surface_ty) (ctx : norm_ctx) (env : Env.t) : I.ty = match t with - | T.TField (me, n, tes) -> ( + | T.Ty_field (me, n, tes) -> ( let tes = List.map (fun te -> normalize te ctx env) tes in let me_typed = check_mod me env in let mod_ty = get_mod_ty me_typed in match mod_ty with - | I.MTMod { id; ty_defs; _ } -> ( + | I.Mod_ty_struct { id; ty_defs; _ } -> ( match I.get_def n ty_defs with - | I.TDOpaqueI (_, _) - | I.TDAdtI (_, _, _) - | I.TDRecordI (_, _, _) -> - TConsI ((id, n), tes) - | I.TDAliasI (_, te) -> ( + | I.Ty_def_opaque (_, _) + | I.Ty_def_adt (_, _, _) + | I.Ty_def_record (_, _, _) -> + Ty_cons ((id, n), tes) + | I.Ty_def_alias (_, te) -> ( match tes with | [] -> te | _ :: _ -> failwith "try to provide type parameter to a type alias")) - | I.MTFun _ -> failwith "try get a field from functor") - | T.TCons (c, tes) -> ( + | I.Mod_ty_functor _ -> failwith "try get a field from functor") + | T.Ty_cons (c, tes) -> ( let id, def = Env.lookup_type_def c env in match def with - | I.TDOpaqueI (_, _) - | I.TDAdtI (_, _, _) - | I.TDRecordI (_, _, _) -> - TConsI ((id, c), List.map (fun t -> normalize t ctx env) tes) - | I.TDAliasI (_, te) -> ( + | I.Ty_def_opaque (_, _) + | I.Ty_def_adt (_, _, _) + | I.Ty_def_record (_, _, _) -> + Ty_cons ((id, c), List.map (fun t -> normalize t ctx env) tes) + | I.Ty_def_alias (_, te) -> ( match tes with | [] -> te | _ -> failwith "apply type to type alias")) - | T.TVar x -> ( + | T.Ty_var x -> ( match ctx with - | Type -> TQVarI x + | Type -> Ty_qvar x | Let -> pool_make_tv x) - | T.TArrow (t0, t1) -> TArrowI (normalize t0 ctx env, normalize t1 ctx env) - | T.TTuple ts -> TTupleI (List.map (fun t -> normalize t ctx env) ts) - | T.TRecord fields -> - TRecordI (List.map (fun (x, t) -> (x, normalize t ctx env)) fields) + | T.Ty_arrow (t0, t1) -> + Ty_arrow (normalize t0 ctx env, normalize t1 ctx env) + | T.Ty_tuple ts -> Ty_tuple (List.map (fun t -> normalize t ctx env) ts) + | T.Ty_record fields -> + Ty_record (List.map (fun (x, t) -> (x, normalize t ctx env)) fields) -and normalize_mt (me : T.emod_ty) env : I.mod_ty = +and normalize_mt (me : T.surface_mod_ty) env : I.mod_ty = match me with - | T.MTName name -> Env.lookup_module_sig name env - | T.MTField (me, name) -> ( + | T.Mod_ty_name name -> Env.lookup_module_sig name env + | T.Mod_ty_field (me, name) -> ( let me_typed = check_mod me env in let mt = get_mod_ty me_typed in match mt with - | I.MTMod mt -> List.assoc name mt.mod_sigs - | I.MTFun (_mt0, _mt1) -> failwith "try get field from functor") - | T.MTSig comps -> + | I.Mod_ty_struct mt -> List.assoc name mt.mod_sigs + | I.Mod_ty_functor (_mt0, _mt1) -> + failwith "try get field from functor") + | T.Mod_ty_sig comps -> let env' = normalize_msig comps (Env.enter_env env) in let scope = absorb_history env' env in make_mt_by_scope scope - | T.MTFunctor (m0, ext_mt0, m1) -> + | T.Mod_ty_functor (m0, ext_mt0, m1) -> let mt0 = normalize_mt ext_mt0 env in let mt1 = normalize_mt m1 (Env.add_module m0 mt0 env) in - MTFun (mt0, mt1) + Mod_ty_functor (mt0, mt1) and normalize_msig comps env = match comps with @@ -601,18 +606,18 @@ and normalize_msig comps env = | comp :: comps -> let env = match comp with - | T.TValueSpec (name, te) -> + | T.Spec_value (name, te) -> reset_pool (); P.enter_level (); let normalized = normalize_ty te env in P.exit_level (); Env.add_value name (P.generalize normalized env) env - | T.TAbstTySpec (name, paras) -> - Env.add_type_def (TDOpaqueI (name, paras)) env - | T.TManiTySpec def -> - let _, env = check_top_level (T.TopTypeDef def) env in + | T.Spec_abstr (name, paras) -> + Env.add_type_def (Ty_def_opaque (name, paras)) env + | T.Spec_mani_ty def -> + let _, env = check_top_level (T.Top_type_def def) env in env - | T.TModSpec (name, ext_mt) -> + | T.Spec_mod (name, ext_mt) -> let mt = normalize_mt ext_mt env in Env.add_module name mt env in diff --git a/lib/typing/env.ml b/lib/typing/env.ml index 5acb6b7..1fd4f55 100644 --- a/lib/typing/env.ml +++ b/lib/typing/env.ml @@ -80,7 +80,7 @@ let try_record_hint me_typed (env : t) = | s :: _ -> ( let mt = T.get_mod_ty me_typed in match mt with - | I.MTMod { id; _ } -> s.hints := (id, me_typed) :: !(s.hints) + | I.Mod_ty_struct { id; _ } -> s.hints := (id, me_typed) :: !(s.hints) | _ -> ()) let record_all_history ids (env : t) = @@ -107,10 +107,10 @@ let rec lookup_module_sig m (env : t) = let get_root_def tn = ( 0, match tn with - | "int" -> I.TDAdtI ("int", [], []) - | "string" -> I.TDAdtI ("string", [], []) - | "bool" -> I.TDAdtI ("bool", [], []) - | "unit" -> I.TDAdtI ("unit", [], []) + | "int" -> I.Ty_def_adt ("int", [], []) + | "string" -> I.Ty_def_adt ("string", [], []) + | "bool" -> I.Ty_def_adt ("bool", [], []) + | "unit" -> I.Ty_def_adt ("unit", [], []) | tn -> failwith (Printf.sprintf "cant get type `%s`" tn) ) let rec lookup_type_def tn env = @@ -120,10 +120,10 @@ let rec lookup_type_def tn env = match List.find_opt (function - | I.TDOpaqueI (x, _) - | TDAdtI (x, _, _) - | TDRecordI (x, _, _) - | TDAliasI (x, _) -> + | I.Ty_def_opaque (x, _) + | Ty_def_adt (x, _, _) + | Ty_def_record (x, _, _) + | Ty_def_alias (x, _) -> x = tn) s.types with @@ -205,10 +205,10 @@ let dbg (env : t) = s.types |> List.map (fun def -> match def with - | I.TDOpaqueI (name, _) -> (name, def) - | I.TDAdtI (name, _, _) -> (name, def) - | I.TDRecordI (name, _, _) -> (name, def) - | I.TDAliasI (name, _) -> (name, def)) + | I.Ty_def_opaque (name, _) -> (name, def) + | I.Ty_def_adt (name, _, _) -> (name, def) + | I.Ty_def_record (name, _, _) -> (name, def) + | I.Ty_def_alias (name, _) -> (name, def)) |> List.map (fun (name, def) -> ( name, I.sexp_of_ty_def def diff --git a/lib/typing/poly.ml b/lib/typing/poly.ml index 9e32743..96b3606 100644 --- a/lib/typing/poly.ml +++ b/lib/typing/poly.ml @@ -8,24 +8,24 @@ let exit_level () = current_level := !current_level - 1 let make_tv () = let name = "'_t" in - I.TVarI (ref (I.Unbound (Ident.create ~hint:name, !current_level))) + I.Ty_var (ref (I.Unbound (Ident.create ~hint:name, !current_level))) let make_tv_of hint = - I.TVarI (ref (I.Unbound (Ident.create ~hint, !current_level))) + I.Ty_var (ref (I.Unbound (Ident.create ~hint, !current_level))) let inst_with (t : I.bind_ty) tes : I.ty = let qvs, te = t in let dict = List.combine qvs tes in let rec go te = match (te : I.ty) with - | I.TConsI (tid, tes) -> I.TConsI (tid, List.map go tes) - | I.TVarI { contents = I.Unbound _ } -> te - | I.TVarI { contents = I.Link t } -> go t - | I.TQVarI qtv -> List.assoc qtv dict - | I.TArrowI (te0, te1) -> TArrowI (go te0, go te1) - | I.TTupleI tes -> TTupleI (List.map go tes) - | I.TRecordI fields -> - I.TRecordI (List.map (fun (name, te) -> (name, go te)) fields) + | I.Ty_cons (tid, tes) -> I.Ty_cons (tid, List.map go tes) + | I.Ty_var { contents = I.Unbound _ } -> te + | I.Ty_var { contents = I.Link t } -> go t + | I.Ty_qvar qtv -> List.assoc qtv dict + | I.Ty_arrow (te0, te1) -> Ty_arrow (go te0, go te1) + | I.Ty_tuple tes -> Ty_tuple (List.map go tes) + | I.Ty_record fields -> + I.Ty_record (List.map (fun (name, te) -> (name, go te)) fields) in go te @@ -43,7 +43,7 @@ let align_inst (t : I.bind_ty) : I.ty = free type variables *) let qvs, _ = t in let new_tvs = - List.mapi (fun i _id -> I.TQVarI (Ident.mk_ident i "_stable")) qvs + List.mapi (fun i _id -> I.Ty_qvar (Ident.mk_ident i "_stable")) qvs in inst_with t new_tvs @@ -52,21 +52,21 @@ let generalize (t : I.ty) (_env : Env.t) : I.bind_ty = let cons_uniq x xs = if List.mem x xs then xs else x :: xs in let rec gen (t : I.ty) = match t with - | I.TVarI { contents = I.Unbound (x, level) } -> + | I.Ty_var { contents = I.Unbound (x, level) } -> (* if a type variable not captured by environment, we need to generalize it *) if level > !current_level then ( (* if a type variable is created(allocated) in a inner scope(region), quantify(release) it *) qvs := cons_uniq x !qvs; - I.TQVarI x) + I.Ty_qvar x) else t - | I.TVarI { contents = I.Link t } -> gen t - | I.TConsI (c, tes) -> I.TConsI (c, List.map gen tes) - | I.TQVarI _ -> failwith "neverreach" - | I.TArrowI (t1, t2) -> I.TArrowI (gen t1, gen t2) - | I.TTupleI tes -> I.TTupleI (List.map gen tes) - | I.TRecordI fields -> - I.TRecordI (List.map (fun (name, te) -> (name, gen te)) fields) + | I.Ty_var { contents = I.Link t } -> gen t + | I.Ty_cons (c, tes) -> I.Ty_cons (c, List.map gen tes) + | I.Ty_qvar _ -> failwith "neverreach" + | I.Ty_arrow (t1, t2) -> I.Ty_arrow (gen t1, gen t2) + | I.Ty_tuple tes -> I.Ty_tuple (List.map gen tes) + | I.Ty_record fields -> + I.Ty_record (List.map (fun (name, te) -> (name, gen te)) fields) in (!qvs, gen t) diff --git a/lib/typing/render.ml b/lib/typing/render.ml index 3c1dabb..afcacd4 100644 --- a/lib/typing/render.ml +++ b/lib/typing/render.ml @@ -13,27 +13,27 @@ end module MakePP (Config : PPConfig) = struct let rec pp_expr (fmt : Format.formatter) (e : expr) = match e with - | EConst (CBool b, ty) -> + | Exp_const (Const_bool b, ty) -> pp_is_ty fmt Config.show_const_ty (fun _ -> Fmt.pp_print_bool fmt b) ty - | EConst (CInt i, ty) -> + | Exp_const (Const_int i, ty) -> pp_is_ty fmt Config.show_const_ty (fun _ -> Fmt.pp_print_int fmt i) ty - | EConst (CString s, ty) -> + | Exp_const (Const_string s, ty) -> pp_is_ty fmt Config.show_const_ty (fun _ -> Fmt.pp_print_string fmt (Printf.sprintf "\"%s\"" s)) ty - | EConst (CUnit, ty) -> + | Exp_const (Const_unit, ty) -> pp_is_ty fmt Config.show_const_ty (fun _ -> Fmt.pp_print_string fmt "()") ty - | EVar (x, ty) -> + | Exp_var (x, ty) -> pp_is_ty fmt Config.show_bind_ty (fun _ -> Fmt.pp_print_string fmt x) ty - | ELet (x, e0, e1, _) -> + | Exp_let (x, e0, e1, _) -> Fmt.fprintf fmt "@[let %s = " x; pp_expr fmt e0; Fmt.fprintf fmt "@\n"; @@ -43,7 +43,7 @@ module MakePP (Config : PPConfig) = struct pp_expr fmt e1; Fmt.fprintf fmt "@]"; Fmt.fprintf fmt "@]" - | ELetrec (lams, body, _) -> + | Exp_letrec (lams, body, _) -> (match lams with | [] -> failwith "neverreach" | (x, lam) :: tail -> @@ -61,14 +61,14 @@ module MakePP (Config : PPConfig) = struct pp_expr fmt body; Fmt.fprintf fmt "@]"; Fmt.fprintf fmt "@]" - | ELam (x, e, _) -> + | Exp_lam (x, e, _) -> Fmt.fprintf fmt "fun %s ->" x; Fmt.fprintf fmt "@\n"; Fmt.fprintf fmt " "; Fmt.fprintf fmt "@["; pp_expr fmt e; Fmt.fprintf fmt "@]" - | EIf (e0, e1, e2, _) -> + | Exp_if (e0, e1, e2, _) -> Fmt.fprintf fmt "@["; Fmt.fprintf fmt "if@\n"; Fmt.fprintf fmt " @["; @@ -82,7 +82,7 @@ module MakePP (Config : PPConfig) = struct Fmt.fprintf fmt " @["; pp_expr fmt e2; Fmt.fprintf fmt "@]" - | ECase (cond, branches, _) -> + | Exp_case (cond, branches, _) -> Fmt.fprintf fmt "@["; Fmt.fprintf fmt "match "; pp_expr fmt cond; @@ -95,17 +95,17 @@ module MakePP (Config : PPConfig) = struct pp_expr fmt e) branches; Fmt.fprintf fmt "@]" - | EApp (op, arg, _) -> + | Exp_app (op, arg, _) -> pp_expr fmt op; Fmt.fprintf fmt " "; pp_expr fmt arg - | EAnn (e, te) -> + | Exp_ann (e, te) -> Fmt.fprintf fmt "@["; pp_expr fmt e; Fmt.fprintf fmt ":@["; pp_ty fmt te; Fmt.fprintf fmt "@]" - | ETuple (es, _) -> + | Exp_tuple (es, _) -> let size = List.length es in Fmt.fprintf fmt "("; List.iteri @@ -114,7 +114,7 @@ module MakePP (Config : PPConfig) = struct if i = size - 1 then Fmt.fprintf fmt ")" else Fmt.fprintf fmt ", ") es - | EField (me, name, te) -> + | Exp_field (me, name, te) -> pp_is_ty fmt Config.show_bind_ty (fun _ -> Fmt.fprintf fmt "@["; @@ -122,7 +122,7 @@ module MakePP (Config : PPConfig) = struct Fmt.fprintf fmt ".%s" name; Fmt.fprintf fmt "@]") te - | EFieldCons (me, name, id, te) -> + | Exp_field_constr (me, name, id, te) -> pp_is_ty fmt Config.show_bind_ty (fun _ -> Fmt.fprintf fmt "@["; @@ -130,11 +130,11 @@ module MakePP (Config : PPConfig) = struct Fmt.fprintf fmt ".%s[%d]" name id; Fmt.fprintf fmt "@]") te - | ECons (c, id, te) -> + | Exp_constr (c, id, te) -> pp_is_ty fmt Config.show_bind_ty (fun _ -> Fmt.fprintf fmt "%s[%d]" c id) te - | ECmp (op, e0, e1, te) -> + | Exp_cmp (op, e0, e1, te) -> pp_is_ty fmt Config.show_bind_ty (fun _ -> pp_expr fmt e0; @@ -143,7 +143,7 @@ module MakePP (Config : PPConfig) = struct | T.Neq -> Fmt.fprintf fmt " <> "); pp_expr fmt e1) te - | ESeq (e0, e1, _te) -> + | Exp_seq (e0, e1, _te) -> Fmt.fprintf fmt "@["; pp_expr fmt e0; Fmt.fprintf fmt " ;@\n"; @@ -176,8 +176,8 @@ module MakePP (Config : PPConfig) = struct and pp_mod fmt ?(env : Env.t option) me = match me with - | MEName (name, _) -> Fmt.pp_print_string fmt name - | MEStruct (tops, mt) -> + | Mod_name (name, _) -> Fmt.pp_print_string fmt name + | Mod_struct (tops, mt) -> pp_is_mod_ty fmt Config.show_mod_ty (fun _ -> Fmt.fprintf fmt "@[struct"; @@ -188,18 +188,18 @@ module MakePP (Config : PPConfig) = struct tops; Fmt.fprintf fmt "@]@\n@\nend") mt - | MEFunctor ((name, mt), me) -> + | Mod_functor ((name, mt), me) -> Fmt.fprintf fmt "@[functor (%s : " name; pp_mod_ty fmt mt; Fmt.fprintf fmt ")@\n-> @\n"; pp_mod fmt ?env me; Fmt.fprintf fmt "@]" - | MEField (me, name, _) -> + | Mod_field (me, name, _) -> Fmt.fprintf fmt "@["; pp_mod fmt ?env me; Fmt.fprintf fmt ".%s" name; Fmt.fprintf fmt "@]" - | MEApply (me0, me1, mt) -> + | Mod_apply (me0, me1, mt) -> pp_is_mod_ty fmt Config.show_mod_ty (fun _ -> pp_mod fmt ?env me0; @@ -207,7 +207,7 @@ module MakePP (Config : PPConfig) = struct pp_mod fmt ?env me1; Fmt.fprintf fmt ")") mt - | MERestrict (me, mt, mt') -> + | Mod_restrict (me, mt, mt') -> pp_is_mod_ty fmt Config.show_mod_ty (fun _ -> Fmt.fprintf fmt "("; @@ -223,11 +223,11 @@ module MakePP (Config : PPConfig) = struct and pp_top fmt top = match top with - | TopLet (x, e) -> + | Top_let (x, e) -> Fmt.fprintf fmt "@[let %s = " x; pp_expr fmt e; Fmt.fprintf fmt "@]" - | TopLetRec lams -> ( + | Top_letrec lams -> ( match lams with | [] -> failwith "neverreach" | (x, lam) :: tail -> @@ -242,23 +242,23 @@ module MakePP (Config : PPConfig) = struct Fmt.fprintf fmt "@]") tail; Fmt.fprintf fmt "@]") - | TopTypeDef td -> pp_ty_def fmt td - | TopMod (name, me) -> + | Top_type_def td -> pp_ty_def fmt td + | Top_mod (name, me) -> Fmt.fprintf fmt "@[module %s = @\n" name; pp_mod fmt me; Fmt.fprintf fmt "@]" - | TopModSig (name, mt) -> + | Top_mod_sig (name, mt) -> Fmt.fprintf fmt "@[module type %s = @\n" name; pp_mod_ty fmt mt; Fmt.fprintf fmt "@]" - | TopExternal (name, te, ext_name) -> + | Top_external (name, te, ext_name) -> Fmt.fprintf fmt "@[external %s : " name; pp_ty fmt te; Fmt.fprintf fmt "= \"%s\"@]" ext_name and pp_ty_def fmt td = match td with - | I.TDOpaqueI (name, paras) -> + | I.Ty_def_opaque (name, paras) -> Fmt.fprintf fmt "type ("; (match paras with | [] -> () @@ -268,7 +268,7 @@ module MakePP (Config : PPConfig) = struct (fun x -> Fmt.fprintf fmt ", %s" (Ident.show_ident x)) rest); Fmt.fprintf fmt ") %s" name - | TDAdtI (name, tvs, vs (* variants *)) -> + | Ty_def_adt (name, tvs, vs (* variants *)) -> Fmt.fprintf fmt "@[type ("; (match tvs with | [] -> () @@ -286,21 +286,21 @@ module MakePP (Config : PPConfig) = struct pp_ty fmt te) vs; Fmt.fprintf fmt "@]" - | I.TDRecordI (name, tvs, fields) -> + | I.Ty_def_record (name, tvs, fields) -> Fmt.fprintf fmt "@type (%s) %s = " (tvs |> List.map Ident.show_ident |> String.concat ", ") name; Fmt.fprintf fmt "@\n @[{@["; pp_fields fmt fields; Fmt.fprintf fmt "@]@\n}@]" - | I.TDAliasI (name, te) -> + | I.Ty_def_alias (name, te) -> Fmt.fprintf fmt "@[type %s = " name; pp_ty fmt te; Fmt.fprintf fmt "@]" and pp_ty fmt ?env te = match te with - | I.TConsI ((id, name), tes) -> + | I.Ty_cons ((id, name), tes) -> Fmt.fprintf fmt "@["; (match tes with | [] -> Fmt.fprintf fmt "()@ " @@ -321,21 +321,21 @@ module MakePP (Config : PPConfig) = struct | None, _ -> Fmt.fprintf fmt "%d." id); Fmt.fprintf fmt "%s" name; Fmt.fprintf fmt "@]" - | I.TVarI { contents = I.Unbound (tv, _level) } -> + | I.Ty_var { contents = I.Unbound (tv, _level) } -> Fmt.fprintf fmt "{%s}" (Ident.show_ident tv) - | I.TVarI { contents = I.Link te } -> + | I.Ty_var { contents = I.Link te } -> Fmt.fprintf fmt "{"; pp_ty fmt te; Fmt.fprintf fmt "}" - | I.TQVarI tv -> Fmt.fprintf fmt "[%s]" (Ident.show_ident tv) - | I.TArrowI (arg_ty, ret_ty) -> + | I.Ty_qvar tv -> Fmt.fprintf fmt "[%s]" (Ident.show_ident tv) + | I.Ty_arrow (arg_ty, ret_ty) -> Fmt.fprintf fmt "(@["; pp_ty fmt arg_ty; Fmt.fprintf fmt "@\n->"; pp_ty fmt ret_ty; Fmt.fprintf fmt "@])" - | I.TTupleI [] -> failwith "neverreach" - | I.TTupleI (te0 :: tes) -> + | I.Ty_tuple [] -> failwith "neverreach" + | I.Ty_tuple (te0 :: tes) -> Fmt.fprintf fmt "(@["; pp_ty fmt te0; List.iter @@ -344,18 +344,18 @@ module MakePP (Config : PPConfig) = struct pp_ty fmt te) tes; Fmt.fprintf fmt "@])" - | I.TRecordI fields -> + | I.Ty_record fields -> Fmt.fprintf fmt "{@["; pp_fields fmt fields; Fmt.fprintf fmt "@]}@\n" and pp_pattern fmt p = match p with - | PVal (CBool b) -> Fmt.pp_print_bool fmt b - | PVal (CInt i) -> Fmt.pp_print_int fmt i - | PVal (CString s) -> Fmt.fprintf fmt "\"%s\"" s - | PVal CUnit -> Fmt.fprintf fmt "()" - | PCons (cname, id, p) -> ( + | Pat_val (Const_bool b) -> Fmt.pp_print_bool fmt b + | Pat_val (Const_int i) -> Fmt.pp_print_int fmt i + | Pat_val (Const_string s) -> Fmt.fprintf fmt "\"%s\"" s + | Pat_val Const_unit -> Fmt.fprintf fmt "()" + | Pat_constr (cname, id, p) -> ( match p with | None -> Fmt.fprintf fmt "%s" cname | Some p -> @@ -363,12 +363,12 @@ module MakePP (Config : PPConfig) = struct Fmt.fprintf fmt "@ "; pp_pattern fmt p; Fmt.fprintf fmt ")") - | PVar (x, ty) -> + | Pat_var (x, ty) -> pp_is_ty fmt Config.show_const_ty (fun _ -> Fmt.pp_print_string fmt x) ty - | PTuple [] -> failwith "neverreach" - | PTuple (p :: ps) -> + | Pat_tuple [] -> failwith "neverreach" + | Pat_tuple (p :: ps) -> Fmt.fprintf fmt "(@["; pp_pattern fmt p; List.iter @@ -388,7 +388,7 @@ module MakePP (Config : PPConfig) = struct and pp_mod_ty fmt mt = match mt with - | I.MTMod + | I.Mod_ty_struct { id; val_defs; @@ -446,7 +446,7 @@ module MakePP (Config : PPConfig) = struct List.iter (fun i -> Fmt.fprintf fmt "@\n%d ;" i) owned_mods; Fmt.fprintf fmt "@]@\n}"; Fmt.fprintf fmt "@]@\n@\nend" - | I.MTFun (mt0, mt1) -> + | I.Mod_ty_functor (mt0, mt1) -> Fmt.fprintf fmt "@[functor (_ : @["; pp_mod_ty fmt mt0; Fmt.fprintf fmt "@])@\n-> @\n"; diff --git a/lib/typing/report.ml b/lib/typing/report.ml index 619ddb6..b73f777 100644 --- a/lib/typing/report.ml +++ b/lib/typing/report.ml @@ -7,22 +7,22 @@ type err = (* error reportings *) (* todo: support error tolerable type checking *) exception - UnificationError of T.ty * T.ty * Lexing.position * Lexing.position * Env.t + Unification_err of T.ty * T.ty * Lexing.position * Lexing.position * Env.t let unification_error t0 t1 loc1 loc2 env = - raise (UnificationError (t0, t1, loc1, loc2, env)) + raise (Unification_err (t0, t1, loc1, loc2, env)) -exception ComponentInCompatible of string * T.bind_ty * T.bind_ty +exception Component_incompatible of string * T.bind_ty * T.bind_ty let in_compatible_error name t0 t1 = - raise (ComponentInCompatible (name, t0, t1)) + raise (Component_incompatible (name, t0, t1)) -exception OccurError of string * T.ty * Lexing.position * Lexing.position +exception Occur_err of string * T.ty * Lexing.position * Lexing.position let occur_error tv te loc1 loc2 = match !tv with | T.Unbound (v, _lvl) -> - raise (OccurError (Ident.to_string v, te, loc1, loc2)) + raise (Occur_err (Ident.to_string v, te, loc1, loc2)) | T.Link _ -> failwith "neverreach" let print_code_range (start : Lexing.position) (last : Lexing.position) = @@ -35,18 +35,18 @@ let unknown_location () = Printf.printf "At some unknown location: " let wrap_with_error_report f = try Some (f ()) with - | UnificationError (t0, t1, start, last, env) -> + | Unification_err (t0, t1, start, last, env) -> print_code_range start last; Printf.printf "Can't unify `%s` with `%s`" (PP.pp_str_of_ty ~env t0) (PP.pp_str_of_ty ~env t1); None - | OccurError (tv, te, start, last) -> + | Occur_err (tv, te, start, last) -> print_code_range start last; Printf.printf "internal error: occur check error\n"; Printf.printf "type variable %s occured in " tv; PP.pp_ty Format.std_formatter te; None - | ComponentInCompatible (name, (_, t0), (_, t1)) -> + | Component_incompatible (name, (_, t0), (_, t1)) -> unknown_location (); Printf.printf "Value component %s has type `%s`, which is not compatible with `%s`" diff --git a/lib/typing/subtype.ml b/lib/typing/subtype.ml index ba9f940..d959b8f 100644 --- a/lib/typing/subtype.ml +++ b/lib/typing/subtype.ml @@ -6,15 +6,15 @@ let build_mod_correspond mt0 mt1 = let mid_map = ref [] in let rec collect_mid_maping mt0 mt1 = match (mt0, mt1) with - | ( I.MTMod { id = id0; mod_defs = mds0; _ }, - I.MTMod { id = id1; mod_defs = mds1; _ } ) -> + | ( I.Mod_ty_struct { id = id0; mod_defs = mds0; _ }, + I.Mod_ty_struct { id = id1; mod_defs = mds1; _ } ) -> mid_map := (id1, id0) :: !mid_map; List.iter (fun (name, md1) -> let md0 = List.assoc name mds0 in collect_mid_maping md0 md1) mds1 - | I.MTFun (argt0, mt0), I.MTFun (argt1, mt1) -> + | I.Mod_ty_functor (argt0, mt0), I.Mod_ty_functor (argt1, mt1) -> collect_mid_maping argt0 argt1; collect_mid_maping mt0 mt1 | _ -> failwith "subtype check error" @@ -49,7 +49,7 @@ let compatible mt0 mt1 = let alias_map : (I.ty_id * I.ty) list ref = ref [] in let rec compatible_aux mt0 mt1 : unit = match (mt0, mt1) with - | ( I.MTMod + | ( I.Mod_ty_struct { val_defs = vds0; constr_defs = cds0; @@ -59,7 +59,7 @@ let compatible mt0 mt1 = id = id0; _; }, - I.MTMod + I.Mod_ty_struct { val_defs = vds1; constr_defs = cds1; @@ -71,17 +71,17 @@ let compatible mt0 mt1 = List.iter (fun td1 -> match td1 with - | I.TDOpaqueI (name, paras) -> ( + | I.Ty_def_opaque (name, paras) -> ( let td0 = I.get_def name tds0 in match td0 with - | I.TDOpaqueI (_, paras0) - | I.TDAdtI (_, paras0, _) - | I.TDRecordI (_, paras0, _) -> + | I.Ty_def_opaque (_, paras0) + | I.Ty_def_adt (_, paras0, _) + | I.Ty_def_record (_, paras0, _) -> if List.length paras0 <> List.length paras then failwith "number of type parameter not compatible in opaque \ type" - | I.TDAliasI (_, ty0) -> ( + | I.Ty_def_alias (_, ty0) -> ( match paras with | [] -> alias_map := ((id0, name), ty0) :: !alias_map | _ :: _ -> failwith "type alias has parameter")) @@ -115,7 +115,7 @@ let compatible mt0 mt1 = List.iter (fun (name, ms1) -> compatible_aux (List.assoc name mds0) ms1) ms1 - | I.MTFun (argt0, mt0), I.MTFun (argt1, mt1) -> + | I.Mod_ty_functor (argt0, mt0), I.Mod_ty_functor (argt1, mt1) -> compatible_aux argt1 argt0; compatible_aux mt0 mt1 | _ -> failwith "subtype check error" diff --git a/lib/typing/typedtree.ml b/lib/typing/typedtree.ml index 42b8b93..36c40b9 100644 --- a/lib/typing/typedtree.ml +++ b/lib/typing/typedtree.ml @@ -5,28 +5,28 @@ module T = Syntax.Parsetree type constant = T.constant [@@deriving sexp] type expr = - | EConst of constant * ty - | EVar of string * ty - | ELet of string * expr * expr * ty - | ELetrec of (string * lambda_typed) list * expr * ty - | ELam of lambda_typed - | EIf of expr * expr * expr * ty - | ECase of expr * (pattern * expr) list * ty - | EApp of expr * expr * ty - | EAnn of expr * ty - | ETuple of expr list * ty - | EField of mod_expr * string * ty - | ECons of + | Exp_const of constant * ty + | Exp_var of string * ty + | Exp_let of string * expr * expr * ty + | Exp_letrec of (string * lambda_typed) list * expr * ty + | Exp_lam of lambda_typed + | Exp_if of expr * expr * expr * ty + | Exp_case of expr * (pattern * expr) list * ty + | Exp_app of expr * expr * ty + | Exp_ann of expr * ty + | Exp_tuple of expr list * ty + | Exp_field of mod_expr * string * ty + | Exp_constr of (* constructor like Cons *) string * int (* constructor id *) * ty - | EFieldCons of + | Exp_field_constr of (* constructor like M.Cons *) mod_expr * string * int (* constructor id *) * ty - | ECmp of T.cmp_op * expr * expr * ty - | ESeq of expr * expr * ty + | Exp_cmp of T.cmp_op * expr * expr * ty + | Exp_seq of expr * expr * ty and lambda_typed = string * expr * ty @@ -35,55 +35,55 @@ and functor_para = string * mod_ty and mod_body = top_level list and mod_expr = - | MEName of string * mod_ty (* M *) - | MEStruct of mod_body * mod_ty (* struct ... end *) - | MEFunctor of functor_para * mod_expr (* functor (M: MT) -> ... *) - | MEField of mod_expr * string * mod_ty (* M1.M2 *) - | MEApply of mod_expr * mod_expr * mod_ty (* M1(...) *) - | MERestrict of mod_expr * mod_ty * mod_ty + | Mod_name of string * mod_ty (* M *) + | Mod_struct of mod_body * mod_ty (* struct ... end *) + | Mod_functor of functor_para * mod_expr (* functor (M: MT) -> ... *) + | Mod_field of mod_expr * string * mod_ty (* M1.M2 *) + | Mod_apply of mod_expr * mod_expr * mod_ty (* M1(...) *) + | Mod_restrict of mod_expr * mod_ty * mod_ty and top_level = - | TopLet of string * expr - | TopLetRec of (string * lambda_typed) list - | TopTypeDef of ty_def - | TopMod of string * mod_expr - | TopModSig of string * mod_ty - | TopExternal of string * ty * string + | Top_let of string * expr + | Top_letrec of (string * lambda_typed) list + | Top_type_def of ty_def + | Top_mod of string * mod_expr + | Top_mod_sig of string * mod_ty + | Top_external of string * ty * string and program = top_level list and pattern = (* simplest pattern is enough after type info has been filled *) - | PVal of constant - | PCons of string * int * pattern option (* Cons (1, 2) *) - | PVar of string * ty - | PTuple of pattern list (* (x, y, z) *) + | Pat_val of constant + | Pat_constr of string * int * pattern option (* Cons (1, 2) *) + | Pat_var of string * ty + | Pat_tuple of pattern list (* (x, y, z) *) [@@deriving sexp] let get_ty = function - | EConst (_, ty) - | EVar (_, ty) - | ELet (_, _, _, ty) - | ELetrec (_, _, ty) - | ELam (_, _, ty) - | EIf (_, _, _, ty) - | ECase (_, _, ty) - | EApp (_, _, ty) - | EAnn (_, ty) - | ETuple (_, ty) - | EField (_, _, ty) - | ECons (_, _, ty) - | EFieldCons (_, _, _, ty) - | ECmp (_, _, _, ty) - | ESeq (_, _, ty) -> + | Exp_const (_, ty) + | Exp_var (_, ty) + | Exp_let (_, _, _, ty) + | Exp_letrec (_, _, ty) + | Exp_lam (_, _, ty) + | Exp_if (_, _, _, ty) + | Exp_case (_, _, ty) + | Exp_app (_, _, ty) + | Exp_ann (_, ty) + | Exp_tuple (_, ty) + | Exp_field (_, _, ty) + | Exp_constr (_, _, ty) + | Exp_field_constr (_, _, _, ty) + | Exp_cmp (_, _, _, ty) + | Exp_seq (_, _, ty) -> ty let rec get_mod_ty (me : mod_expr) = match me with - | MEName (_, ty) - | MEStruct (_, ty) - | MEField (_, _, ty) - | MERestrict (_, _, ty) - | MEApply (_, _, ty) -> + | Mod_name (_, ty) + | Mod_struct (_, ty) + | Mod_field (_, _, ty) + | Mod_restrict (_, _, ty) + | Mod_apply (_, _, ty) -> ty - | MEFunctor ((_, mt0), me1) -> MTFun (mt0, get_mod_ty me1) + | Mod_functor ((_, mt0), me1) -> Mod_ty_functor (mt0, get_mod_ty me1) diff --git a/lib/typing/types_in.ml b/lib/typing/types_in.ml index ccda687..7bbc95b 100644 --- a/lib/typing/types_in.ml +++ b/lib/typing/types_in.ml @@ -8,12 +8,12 @@ type ty_id = int (* module type id *) * string (* normalized type expression *) and ty = - | TConsI of ty_id * ty list (* x list *) - | TVarI of tv ref (* 'var *) - | TQVarI of Ident.ident - | TArrowI of ty * ty - | TTupleI of ty list - | TRecordI of (string * ty) list + | Ty_cons of ty_id * ty list (* x list *) + | Ty_var of tv ref (* 'var *) + | Ty_qvar of Ident.ident + | Ty_arrow of ty * ty + | Ty_tuple of ty list + | Ty_record of (string * ty) list and tv = | Unbound of Ident.ident * int (* level *) @@ -26,13 +26,13 @@ and type_paras = Ident.ident list and variant = string * ty option and ty_def = - | TDOpaqueI of string * type_paras - | TDAdtI of string * type_paras * variant list - | TDRecordI of string * type_paras * (string * ty) list - | TDAliasI of string * ty + | Ty_def_opaque of string * type_paras + | Ty_def_adt of string * type_paras * variant list + | Ty_def_record of string * type_paras * (string * ty) list + | Ty_def_alias of string * ty and mod_ty = - | MTMod of { + | Mod_ty_struct of { id : int; (* give every module type an identity *) val_defs : (string * bind_ty) list; constr_defs : @@ -42,7 +42,7 @@ and mod_ty = mod_defs : (string * mod_ty) list; owned_mods : int list; } - | MTFun of (mod_ty * mod_ty) + | Mod_ty_functor of (mod_ty * mod_ty) [@@deriving sexp, show, @@ -53,9 +53,9 @@ class virtual ['self] map = object (self : 'self) inherit ['self] ty_map - method! visit_TVarI () tv = + method! visit_Ty_var () tv = match !tv with - | Unbound _ -> TVarI tv + | Unbound _ -> Ty_var tv | Link te -> self#visit_ty () te method visit_ident env id = @@ -79,32 +79,32 @@ let root_id = 0 let mk_root_tid tn = (root_id, tn) -let int_ty = TConsI (mk_root_tid "int", []) +let int_ty = Ty_cons (mk_root_tid "int", []) -let string_ty = TConsI (mk_root_tid "string", []) +let string_ty = Ty_cons (mk_root_tid "string", []) -let bool_ty = TConsI (mk_root_tid "bool", []) +let bool_ty = Ty_cons (mk_root_tid "bool", []) -let unit_ty = TConsI (mk_root_tid "unit", []) +let unit_ty = Ty_cons (mk_root_tid "unit", []) let same_def td0 td1 = td0 = td1 let get_def_name (td : ty_def) = match td with - | TDOpaqueI (name, _) - | TDAdtI (name, _, _) - | TDRecordI (name, _, _) - | TDAliasI (name, _) -> + | Ty_def_opaque (name, _) + | Ty_def_adt (name, _, _) + | Ty_def_record (name, _, _) + | Ty_def_alias (name, _) -> name let get_def name ty_defs = List.find (fun td -> match td with - | TDOpaqueI (name', _) - | TDAdtI (name', _, _) - | TDRecordI (name', _, _) - | TDAliasI (name', _) + | Ty_def_opaque (name', _) + | Ty_def_adt (name', _, _) + | Ty_def_record (name', _, _) + | Ty_def_alias (name', _) when name' = name -> true | _ -> false) diff --git a/lib/typing/unify.ml b/lib/typing/unify.ml index 7151c35..c3db4aa 100644 --- a/lib/typing/unify.ml +++ b/lib/typing/unify.ml @@ -11,27 +11,27 @@ exception IllFormType let occurs (tpv : tv ref) (te : ty) : unit = let rec go te = match te with - | TTupleI tes - | TConsI (_, tes) -> + | Ty_tuple tes + | Ty_cons (_, tes) -> List.iter go tes - | TVarI tpv' when tpv == tpv' -> ( + | Ty_var tpv' when tpv == tpv' -> ( match tpv with | { contents = Unbound _ } -> raise (OccurError (tpv, te)) | { contents = Link _ } -> failwith "illegal occur check value") - | TVarI { contents = Link te } -> go te - | TVarI ({ contents = Unbound (tvn', level') } as tpv') -> + | Ty_var { contents = Link te } -> go te + | Ty_var ({ contents = Unbound (tvn', level') } as tpv') -> let[@warning "-8"] (Unbound (_, level)) = !tpv in let min_level = min level level' in tpv'.contents <- Unbound (tvn', min_level) - | TQVarI _ -> () - | TArrowI (te1, te2) -> + | Ty_qvar _ -> () + | Ty_arrow (te1, te2) -> go te1; go te2 - | TRecordI fields -> List.map snd fields |> List.iter go + | Ty_record fields -> List.map snd fields |> List.iter go in let rec strip te : ty = match te with - | TVarI { contents = Link te } -> strip te + | Ty_var { contents = Link te } -> strip te | _ -> te in go (strip te) @@ -41,17 +41,17 @@ let rec unify (t0 : ty) (t1 : ty) : unit = else match (t0, t1) with (* strip links *) - | TVarI { contents = Link t0 }, t1 -> unify t0 t1 - | t0, TVarI { contents = Link t1 } -> unify t0 t1 - | TVarI ({ contents = Unbound _ } as tv0), t1 - | t1, TVarI ({ contents = Unbound _ } as tv0) -> + | Ty_var { contents = Link t0 }, t1 -> unify t0 t1 + | t0, Ty_var { contents = Link t1 } -> unify t0 t1 + | Ty_var ({ contents = Unbound _ } as tv0), t1 + | t1, Ty_var ({ contents = Unbound _ } as tv0) -> occurs tv0 t1; tv0.contents <- Link t1 - | TConsI (tc0, tes0), TConsI (tc1, tes1) when tc0 = tc1 -> + | Ty_cons (tc0, tes0), Ty_cons (tc1, tes1) when tc0 = tc1 -> unify_lst tes0 tes1 - | TArrowI (op0, arg0), TArrowI (op1, arg1) -> + | Ty_arrow (op0, arg0), Ty_arrow (op1, arg1) -> unify_lst [ op0; arg0 ] [ op1; arg1 ] - | TTupleI tes0, TTupleI tes1 -> unify_lst tes0 tes1 + | Ty_tuple tes0, Ty_tuple tes1 -> unify_lst tes0 tes1 (* by default raise an exception *) | _ -> raise (UnificationError (t0, t1)) diff --git a/tests/cram/test_dirs/simple.t/run.t b/tests/cram/test_dirs/simple.t/run.t index d16a290..8693300 100644 --- a/tests/cram/test_dirs/simple.t/run.t +++ b/tests/cram/test_dirs/simple.t/run.t @@ -98,37 +98,41 @@ main/1 Global C functions: (main/1 () () - (EModObject - ((FSimple x (EConst (CInt 1))) (FSimple y (EConst (CInt 1))) - (FSimple z (EClosure ((y) z/2))) (FSimple w (EClosure (() w/3))) - (FSimple m (EClosure ((w) m/4))))))(m/4 (w) (x) (EApp (EVar w) ((EConst (CInt 1)))))(w/3 () (x) (EConst (CInt 0)))(z/2 (y) (x) (EVar y)) + (Exp_mod_obj + ((Field_simple x (Exp_const (Const_int 1))) + (Field_simple y (Exp_const (Const_int 1))) + (Field_simple z (Exp_closure ((y) z/2))) + (Field_simple w (Exp_closure (() w/3))) + (Field_simple m (Exp_closure ((w) m/4))))))(m/4 (w) (x) (Exp_app (Exp_var w) ((Exp_const (Const_int 1)))))(w/3 () (x) (Exp_const (Const_int 0)))(z/2 (y) (x) (Exp_var y)) $ cat simple1.lambda - (EModObject - ((FSimple x (EConst (CInt 1))) (FSimple y (EConst (CInt 1))) - (FSimple z (ELam ((x) (EVar y) (y)))) - (FSimple w (ELam ((x) (EConst (CInt 0)) ()))) - (FSimple m (ELam ((x) (EApp (EVar w) ((EConst (CInt 1)))) (w)))))) + (Exp_mod_obj + ((Field_simple x (Exp_const (Const_int 1))) + (Field_simple y (Exp_const (Const_int 1))) + (Field_simple z (Exp_lam ((x) (Exp_var y) (y)))) + (Field_simple w (Exp_lam ((x) (Exp_const (Const_int 0)) ()))) + (Field_simple m + (Exp_lam ((x) (Exp_app (Exp_var w) ((Exp_const (Const_int 1)))) (w)))))) $ cat simple1.parsing - ((TopLet x - ((desc (EConst (CInt 1))) + ((Top_let x + ((desc (Exp_const (Const_int 1))) (start_loc ((pos_fname simple.fun) (pos_lnum 1) (pos_bol 0) (pos_cnum 8))) (end_loc ((pos_fname simple.fun) (pos_lnum 1) (pos_bol 0) (pos_cnum 9))) (attrs ()))) - (TopLet y - ((desc (EConst (CInt 1))) + (Top_let y + ((desc (Exp_const (Const_int 1))) (start_loc ((pos_fname simple.fun) (pos_lnum 3) (pos_bol 11) (pos_cnum 19))) (end_loc ((pos_fname simple.fun) (pos_lnum 3) (pos_bol 11) (pos_cnum 20))) (attrs ()))) - (TopLet z + (Top_let z ((desc - (ELam - ((PBare x) - ((desc (EVar y)) + (Exp_lam + ((Para_bare x) + ((desc (Exp_var y)) (start_loc ((pos_fname simple.fun) (pos_lnum 5) (pos_bol 22) (pos_cnum 40))) @@ -141,11 +145,11 @@ (end_loc ((pos_fname simple.fun) (pos_lnum 5) (pos_bol 22) (pos_cnum 41))) (attrs ()))) - (TopLet w + (Top_let w ((desc - (ELam - ((PBare x) - ((desc (EConst (CInt 0))) + (Exp_lam + ((Para_bare x) + ((desc (Exp_const (Const_int 0))) (start_loc ((pos_fname simple.fun) (pos_lnum 7) (pos_bol 44) (pos_cnum 62))) @@ -158,13 +162,13 @@ (end_loc ((pos_fname simple.fun) (pos_lnum 7) (pos_bol 44) (pos_cnum 63))) (attrs ()))) - (TopLet m + (Top_let m ((desc - (ELam - ((PBare x) + (Exp_lam + ((Para_bare x) ((desc - (EApp - ((desc (EVar w)) + (Exp_app + ((desc (Exp_var w)) (start_loc ((pos_fname simple.fun) (pos_lnum 9) (pos_bol 66) (pos_cnum 84))) @@ -172,7 +176,7 @@ ((pos_fname simple.fun) (pos_lnum 9) (pos_bol 66) (pos_cnum 85))) (attrs ())) - ((desc (EConst (CInt 1))) + ((desc (Exp_const (Const_int 1))) (start_loc ((pos_fname simple.fun) (pos_lnum 9) (pos_bol 66) (pos_cnum 86))) diff --git a/tests/regular/lift_test.ml b/tests/regular/lift_test.ml index a88e53f..7639064 100644 --- a/tests/regular/lift_test.ml +++ b/tests/regular/lift_test.ml @@ -29,7 +29,7 @@ let%expect_test "Test: full program lowering" = Main function name: main/1 Global C functions: - (main/1 () () (EModObject ((FSimple x (EConst (CInt 1)))))) + (main/1 () () (Exp_mod_obj ((Field_simple x (Exp_const (Const_int 1)))))) |}]; print_lifted @@ -53,10 +53,13 @@ let%expect_test "Test: full program lowering" = main/1 Global C functions: (main/1 () () - (EModObject - ((FSimple M - (EModObject ((FSimple x (ECons 0)) (FSimple y (EConst (CInt 1)))))) - (FSimple c (EField (EVar M) x)) (FSimple d (EField (EVar M) y))))) + (Exp_mod_obj + ((Field_simple M + (Exp_mod_obj + ((Field_simple x (Exp_constr 0)) + (Field_simple y (Exp_const (Const_int 1)))))) + (Field_simple c (Exp_field (Exp_var M) x)) + (Field_simple d (Exp_field (Exp_var M) y))))) |}]; print_lifted @@ -72,9 +75,9 @@ let%expect_test "Test: full program lowering" = Main function name: main/1 Global C functions: - (main/1 () () (EModObject ((FLetRec (() ((f f/2) (g g/3))))))) - (f/2 (f g) (x) (EVar x)) - (g/3 (f g) (x) (EApp (EVar f) ((EConst (CInt 1))))) + (main/1 () () (Exp_mod_obj ((Field_letrec (() ((f f/2) (g g/3))))))) + (f/2 (f g) (x) (Exp_var x)) + (g/3 (f g) (x) (Exp_app (Exp_var f) ((Exp_const (Const_int 1))))) |}]; print_lifted {| @@ -85,7 +88,7 @@ external add : int -> int -> int = "ff_add" Main function name: main/1 Global C functions: - (main/1 () () (EModObject ((FSimple add (EExt ff_add))))) + (main/1 () () (Exp_mod_obj ((Field_simple add (Exp_external ff_add))))) |}]; print_lifted {| let x = 1 @@ -100,10 +103,11 @@ let z = fun z -> x = y main/1 Global C functions: (main/1 () () - (EModObject - ((FSimple x (EConst (CInt 1))) (FSimple y (EConst (CInt 2))) - (FSimple z (EClosure ((x y) z/2)))))) - (z/2 (x y) (z) (ECmp Eq (EVar x) (EVar y))) + (Exp_mod_obj + ((Field_simple x (Exp_const (Const_int 1))) + (Field_simple y (Exp_const (Const_int 2))) + (Field_simple z (Exp_closure ((x y) z/2)))))) + (z/2 (x y) (z) (Exp_cmp Eq (Exp_var x) (Exp_var y))) |}]; print_lifted @@ -118,8 +122,8 @@ let z = fun z -> x = y Main function name: main/1 Global C functions: - (main/1 () () (EModObject ((FLetRec (() ((sum sum/2))))))) + (main/1 () () (Exp_mod_obj ((Field_letrec (() ((sum sum/2))))))) (sum/2 (sum) (x) - (EIf (ECmp Eq (EVar x) (EConst (CInt 0))) (EConst (CInt 1)) - (EConst (CInt 2)))) + (Exp_if (Exp_cmp Eq (Exp_var x) (Exp_const (Const_int 0))) + (Exp_const (Const_int 1)) (Exp_const (Const_int 2)))) |}] diff --git a/tests/regular/lower_test.ml b/tests/regular/lower_test.ml index 6b351b2..2c59f75 100644 --- a/tests/regular/lower_test.ml +++ b/tests/regular/lower_test.ml @@ -16,7 +16,7 @@ let%expect_test "Test: full program lowering" = in print_lowered {| let x = 1 |}; - [%expect {| (EModObject ((FSimple x (EConst (CInt 1))))) |}]; + [%expect {| (Exp_mod_obj ((Field_simple x (Exp_const (Const_int 1))))) |}]; print_lowered {| @@ -35,10 +35,14 @@ let%expect_test "Test: full program lowering" = |}; [%expect {| - (EModObject - ((FSimple M - (EModObject ((FSimple x (ECons 0)) (FSimple y (EConst (CInt 1)))))) - (FSimple c (EField (EVar M) x)) (FSimple d (EField (EVar M) y)))) |}]; + (Exp_mod_obj + ((Field_simple M + (Exp_mod_obj + ((Field_simple x (Exp_constr 0)) + (Field_simple y (Exp_const (Const_int 1)))))) + (Field_simple c (Exp_field (Exp_var M) x)) + (Field_simple d (Exp_field (Exp_var M) y)))) + |}]; print_lowered {| @@ -101,29 +105,34 @@ module MMM = (M(F).K : I) |}; [%expect {| - (EModObject - ((FSimple MJ - (EModObject - ((FSimple x (EConst (CInt 1))) (FSimple y (EConst (CInt 1))) - (FSimple z (EConst (CInt 1)))))) - (FSimple Simple - (EModObject - ((FSimple x (EConst (CInt 1))) (FSimple y (EConst (CInt 2)))))) - (FSimple M - (ELam - ((MI) (EModObject ((FSimple K (EApp (EVar MI) ((EVar Simple)))))) + (Exp_mod_obj + ((Field_simple MJ + (Exp_mod_obj + ((Field_simple x (Exp_const (Const_int 1))) + (Field_simple y (Exp_const (Const_int 1))) + (Field_simple z (Exp_const (Const_int 1)))))) + (Field_simple Simple + (Exp_mod_obj + ((Field_simple x (Exp_const (Const_int 1))) + (Field_simple y (Exp_const (Const_int 2)))))) + (Field_simple M + (Exp_lam + ((MI) + (Exp_mod_obj + ((Field_simple K (Exp_app (Exp_var MI) ((Exp_var Simple)))))) (Simple)))) - (FSimple F - (ELam + (Field_simple F + (Exp_lam ((MI) - (EModObject - ((FSimple x (EConst (CInt 1))) (FSimple y (EConst (CInt 1))) - (FSimple z (EConst (CInt 1))))) + (Exp_mod_obj + ((Field_simple x (Exp_const (Const_int 1))) + (Field_simple y (Exp_const (Const_int 1))) + (Field_simple z (Exp_const (Const_int 1))))) ()))) - (FSimple MMM (EField (EApp (EVar M) ((EVar F))) K)) - (FLetRec - ((f ((x) (EVar x) ())) - (g ((x) (EApp (EVar f) ((EConst (CInt 1)))) (f))))))) + (Field_simple MMM (Exp_field (Exp_app (Exp_var M) ((Exp_var F))) K)) + (Field_letrec + ((f ((x) (Exp_var x) ())) + (g ((x) (Exp_app (Exp_var f) ((Exp_const (Const_int 1)))) (f))))))) |}]; print_lowered @@ -136,10 +145,10 @@ module MMM = (M(F).K : I) |}; [%expect {| - (EModObject - ((FLetRec - ((f ((x) (EVar x) ())) - (g ((x) (EApp (EVar f) ((EConst (CInt 1)))) (f))))))) + (Exp_mod_obj + ((Field_letrec + ((f ((x) (Exp_var x) ())) + (g ((x) (Exp_app (Exp_var f) ((Exp_const (Const_int 1)))) (f))))))) |}]; print_lowered {| @@ -159,14 +168,16 @@ module MMM = (M(F).K : I) |}; [%expect {| - (EModObject - ((FSimple x (ECons 1)) (FSimple z (EApp (EConsWith 0) ((EConst (CInt 1))))) - (FSimple f - (ELam + (Exp_mod_obj + ((Field_simple x (Exp_constr 1)) + (Field_simple z + (Exp_app (Exp_payload_constr 0) ((Exp_const (Const_int 1))))) + (Field_simple f + (Exp_lam ((p) - (ESwitch (EVar x) - (((PCons 0 ((PVar y))) (EVar y)) - ((PCons 1 ()) (EConst (CInt 0))))) + (Exp_switch (Exp_var x) + (((Pat_constr 0 ((Pat_var y))) (Exp_var y)) + ((Pat_constr 1 ()) (Exp_const (Const_int 0))))) (x)))))) |}]; @@ -187,10 +198,12 @@ module MMM = (M(F).K : I) [%expect {| - (EModObject - ((FSimple M (EModObject ((FSimple x (EConst (CInt 1)))))) - (FSimple F - (ELam ((X) (EModObject ((FSimple y (EField (EVar M) x)))) (M)))))) + (Exp_mod_obj + ((Field_simple M + (Exp_mod_obj ((Field_simple x (Exp_const (Const_int 1)))))) + (Field_simple F + (Exp_lam + ((X) (Exp_mod_obj ((Field_simple y (Exp_field (Exp_var M) x)))) (M)))))) |}]; print_lowered {| @@ -209,11 +222,15 @@ module MMM = (M(F).K : I) |}; [%expect {| - (EModObject - ((FSimple M (EModObject ((FSimple x (EConst (CInt 1)))))) - (FSimple F1 - (ELam - ((X) (ELam ((Y) (EModObject ((FSimple y (EField (EVar M) x)))) (M))) + (Exp_mod_obj + ((Field_simple M + (Exp_mod_obj ((Field_simple x (Exp_const (Const_int 1)))))) + (Field_simple F1 + (Exp_lam + ((X) + (Exp_lam + ((Y) (Exp_mod_obj ((Field_simple y (Exp_field (Exp_var M) x)))) + (M))) (M)))))) |}]; @@ -241,23 +258,28 @@ module MMM = (M(F).K : I) |}; [%expect {| - (EModObject - ((FSimple M (EModObject ((FSimple x (EConst (CInt 1)))))) - (FSimple F2 - (ELam + (Exp_mod_obj + ((Field_simple M + (Exp_mod_obj ((Field_simple x (Exp_const (Const_int 1)))))) + (Field_simple F2 + (Exp_lam ((X) - (EModObject - ((FSimple N (EModObject ((FSimple x (EConst (CInt 2)))))) - (FSimple F3 - (ELam - ((Y) (EModObject ((FSimple y (EField (EVar N) x)))) (N)))))) + (Exp_mod_obj + ((Field_simple N + (Exp_mod_obj ((Field_simple x (Exp_const (Const_int 2)))))) + (Field_simple F3 + (Exp_lam + ((Y) + (Exp_mod_obj + ((Field_simple y (Exp_field (Exp_var N) x)))) + (N)))))) ()))))) |}]; print_lowered {| external add : int -> int -> int = "ff_add" |}; - [%expect {| (EModObject ((FSimple add (EExt ff_add)))) |}]; + [%expect {| (Exp_mod_obj ((Field_simple add (Exp_external ff_add)))) |}]; print_lowered {| let x = 1 @@ -268,9 +290,10 @@ let z = x = y |}; [%expect {| - (EModObject - ((FSimple x (EConst (CInt 1))) (FSimple y (EConst (CInt 2))) - (FSimple z (ECmp Eq (EVar x) (EVar y))))) + (Exp_mod_obj + ((Field_simple x (Exp_const (Const_int 1))) + (Field_simple y (Exp_const (Const_int 2))) + (Field_simple z (Exp_cmp Eq (Exp_var x) (Exp_var y))))) |}]; print_lowered {| @@ -282,10 +305,12 @@ let z = x = y |}; [%expect {| - (EModObject - ((FSimple even - (ELetRec - ((even ((x) (EApp (EVar odd) ((EConst (CInt 1)))) (odd))) - (odd ((x) (EApp (EVar even) ((EConst (CInt 1)))) (even)))) - (EVar even))))) + (Exp_mod_obj + ((Field_simple even + (Exp_letrec + ((even + ((x) (Exp_app (Exp_var odd) ((Exp_const (Const_int 1)))) (odd))) + (odd + ((x) (Exp_app (Exp_var even) ((Exp_const (Const_int 1)))) (even)))) + (Exp_var even))))) |}] diff --git a/tests/regular/parse_test.ml b/tests/regular/parse_test.ml index 5b150d3..4fd3cbc 100644 --- a/tests/regular/parse_test.ml +++ b/tests/regular/parse_test.ml @@ -11,7 +11,7 @@ let print_parsed_mod_expr str = parse_string_mod_expr str |> sexp_of_mod_expr |> print_sexp let print_parsed_type_expr str = - parse_string_type_expr str |> sexp_of_ety |> print_sexp + parse_string_type_expr str |> sexp_of_surface_ty |> print_sexp let%expect_test "Test: expression parsing" = let print_parsed str = @@ -20,7 +20,7 @@ let%expect_test "Test: expression parsing" = print_parsed "x"; [%expect {| - ((desc (EVar x)) + ((desc (Exp_var x)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 0))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 1))) (attrs ())) @@ -28,7 +28,7 @@ let%expect_test "Test: expression parsing" = print_parsed "1"; [%expect {| - ((desc (EConst (CInt 1))) + ((desc (Exp_const (Const_int 1))) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 0))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 1))) (attrs ())) @@ -36,7 +36,7 @@ let%expect_test "Test: expression parsing" = print_parsed {| () |}; [%expect {| - ((desc (EConst CUnit)) + ((desc (Exp_const Const_unit)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 1))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 3))) (attrs ())) @@ -44,7 +44,7 @@ let%expect_test "Test: expression parsing" = print_parsed {| "x \n \t,()*@/"|}; [%expect {| - ((desc (EConst (CString "\"x \\n \\t,()*@/\""))) + ((desc (Exp_const (Const_string "\"x \\n \\t,()*@/\""))) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 1))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 16))) (attrs ())) @@ -54,18 +54,18 @@ let%expect_test "Test: expression parsing" = [%expect {| ((desc - (EApp + (Exp_app ((desc - (EApp + (Exp_app ((desc - (EApp - ((desc (EVar a)) + (Exp_app + ((desc (Exp_var a)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 0))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 1))) (attrs ())) - ((desc (EVar b)) + ((desc (Exp_var b)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 2))) (end_loc @@ -75,7 +75,7 @@ let%expect_test "Test: expression parsing" = ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 0))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 3))) (attrs ())) - ((desc (EVar c)) + ((desc (Exp_var c)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 4))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 5))) @@ -83,14 +83,14 @@ let%expect_test "Test: expression parsing" = (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 0))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 5))) (attrs ())) - ((desc (EVar d)) + ((desc (Exp_var d)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 6))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 7))) (attrs ())))) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 0))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 7))) (attrs ())) - ((desc (EConst (CBool true))) + ((desc (Exp_const (Const_bool true))) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 0))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 4))) (attrs ())) @@ -99,12 +99,12 @@ let%expect_test "Test: expression parsing" = [%expect {| ((desc - (ELet x - ((desc (EConst (CInt 1))) + (Exp_let x + ((desc (Exp_const (Const_int 1))) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 8))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 9))) (attrs ())) - ((desc (EVar y)) + ((desc (Exp_var y)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 13))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 14))) (attrs ())))) @@ -115,7 +115,7 @@ let%expect_test "Test: expression parsing" = print_parsed {| Nil |}; [%expect {| - ((desc (ECons Nil)) + ((desc (Exp_constr Nil)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 1))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 4))) (attrs ())) @@ -124,28 +124,28 @@ let%expect_test "Test: expression parsing" = [%expect {| ((desc - (ETuple - (((desc (EConst (CInt 1))) + (Exp_tuple + (((desc (Exp_const (Const_int 1))) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 0))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 1))) (attrs ())) - ((desc (EConst (CInt 3))) + ((desc (Exp_const (Const_int 3))) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 2))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 3))) (attrs ())) - ((desc (EConst (CInt 4))) + ((desc (Exp_const (Const_int 4))) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 4))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 5))) (attrs ())) ((desc - (ETuple - (((desc (EConst (CInt 5))) + (Exp_tuple + (((desc (Exp_const (Const_int 5))) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 7))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 8))) (attrs ())) - ((desc (EConst (CInt 6))) + ((desc (Exp_const (Const_int 6))) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 9))) (end_loc @@ -154,7 +154,7 @@ let%expect_test "Test: expression parsing" = (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 7))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 10))) (attrs ())) - ((desc (EConst (CInt 7))) + ((desc (Exp_const (Const_int 7))) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 12))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 13))) (attrs ()))))) @@ -166,15 +166,15 @@ let%expect_test "Test: expression parsing" = [%expect {| ((desc - (ETuple + (Exp_tuple (((desc - (EApp - ((desc (EVar f)) + (Exp_app + ((desc (Exp_var f)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 0))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 1))) (attrs ())) - ((desc (EConst (CInt 1))) + ((desc (Exp_const (Const_int 1))) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 2))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 3))) @@ -183,14 +183,14 @@ let%expect_test "Test: expression parsing" = (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 3))) (attrs ())) ((desc - (EApp - ((desc (EVar f)) + (Exp_app + ((desc (Exp_var f)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 5))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 6))) (attrs ())) - ((desc (EConst (CBool true))) + ((desc (Exp_const (Const_bool true))) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 7))) (end_loc @@ -207,12 +207,12 @@ let%expect_test "Test: expression parsing" = [%expect {| ((desc - (EApp - ((desc (ECons Cons)) + (Exp_app + ((desc (Exp_constr Cons)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 0))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 4))) (attrs ())) - ((desc (EConst (CInt 1))) + ((desc (Exp_const (Const_int 1))) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 6))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 7))) (attrs ())))) @@ -230,18 +230,18 @@ let%expect_test "Test: expression parsing" = [%expect {| ((desc - (ELetrec + (Exp_letrec ((odd - ((PBare x) + ((Para_bare x) ((desc - (EApp - ((desc (EVar even)) + (Exp_app + ((desc (Exp_var even)) (start_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 29))) (end_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 33))) (attrs ())) - ((desc (EVar x)) + ((desc (Exp_var x)) (start_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 34))) (end_loc @@ -252,16 +252,16 @@ let%expect_test "Test: expression parsing" = (end_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 35))) (attrs ())))) (even - ((PAnn x (TCons int ())) + ((Para_ann x (Ty_cons int ())) ((desc - (EApp - ((desc (EVar odd)) + (Exp_app + ((desc (Exp_var odd)) (start_loc ((pos_fname "") (pos_lnum 3) (pos_bol 36) (pos_cnum 67))) (end_loc ((pos_fname "") (pos_lnum 3) (pos_bol 36) (pos_cnum 70))) (attrs ())) - ((desc (EVar x)) + ((desc (Exp_var x)) (start_loc ((pos_fname "") (pos_lnum 3) (pos_bol 36) (pos_cnum 71))) (end_loc @@ -273,14 +273,14 @@ let%expect_test "Test: expression parsing" = ((pos_fname "") (pos_lnum 3) (pos_bol 36) (pos_cnum 72))) (attrs ()))))) ((desc - (EApp - ((desc (EVar odd)) + (Exp_app + ((desc (Exp_var odd)) (start_loc ((pos_fname "") (pos_lnum 5) (pos_bol 81) (pos_cnum 86))) (end_loc ((pos_fname "") (pos_lnum 5) (pos_bol 81) (pos_cnum 89))) (attrs ())) - ((desc (EConst (CInt 1))) + ((desc (Exp_const (Const_int 1))) (start_loc ((pos_fname "") (pos_lnum 5) (pos_bol 81) (pos_cnum 90))) (end_loc @@ -297,10 +297,10 @@ let%expect_test "Test: expression parsing" = [%expect {| ((desc - (EApp + (Exp_app ((desc - (EField - ((desc (MEName E)) + (Exp_field + ((desc (Mod_name E)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 0))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 1))) @@ -309,7 +309,7 @@ let%expect_test "Test: expression parsing" = (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 0))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 3))) (attrs ())) - ((desc (EVar y)) + ((desc (Exp_var y)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 4))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 5))) (attrs ())))) @@ -321,12 +321,12 @@ let%expect_test "Test: expression parsing" = [%expect {| ((desc - (EApp - ((desc (ECons Cons)) + (Exp_app + ((desc (Exp_constr Cons)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 0))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 4))) (attrs ())) - ((desc (EConst (CInt 1))) + ((desc (Exp_const (Const_int 1))) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 5))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 6))) (attrs ())))) @@ -338,19 +338,19 @@ let%expect_test "Test: expression parsing" = [%expect {| ((desc - (EApp - ((desc (ECons Cons)) + (Exp_app + ((desc (Exp_constr Cons)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 0))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 4))) (attrs ())) ((desc - (ETuple - (((desc (EVar x)) + (Exp_tuple + (((desc (Exp_var x)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 6))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 7))) (attrs ())) - ((desc (EVar y)) + ((desc (Exp_var y)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 9))) (end_loc @@ -367,10 +367,10 @@ let%expect_test "Test: expression parsing" = [%expect {| ((desc - (EApp + (Exp_app ((desc - (EFieldCons - ((desc (MEName L)) + (Exp_field_constr + ((desc (Mod_name L)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 0))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 1))) @@ -380,13 +380,13 @@ let%expect_test "Test: expression parsing" = (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 6))) (attrs ())) ((desc - (ETuple - (((desc (EVar x)) + (Exp_tuple + (((desc (Exp_var x)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 8))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 9))) (attrs ())) - ((desc (EVar y)) + ((desc (Exp_var y)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 11))) (end_loc @@ -403,9 +403,9 @@ let%expect_test "Test: expression parsing" = [%expect {| ((desc - (ELam - ((PBare x) - ((desc (EVar x)) + (Exp_lam + ((Para_bare x) + ((desc (Exp_var x)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 9))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 10))) (attrs ()))))) @@ -417,12 +417,12 @@ let%expect_test "Test: expression parsing" = [%expect {| ((desc - (EApp - ((desc (EVar f)) + (Exp_app + ((desc (Exp_var f)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 0))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 1))) (attrs ())) - ((desc (EConst (CInt 1))) + ((desc (Exp_const (Const_int 1))) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 2))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 3))) (attrs ())))) @@ -439,19 +439,19 @@ let%expect_test "Test: expression parsing" = [%expect {| ((desc - (ECase - ((desc (EVar c)) + (Exp_case + ((desc (Exp_var c)) (start_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 16))) (end_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 17))) (attrs ())) - (((PCons Cons ((PVar x))) - ((desc (EVar x)) + (((Pat_constr Cons ((Pat_var x))) + ((desc (Exp_var x)) (start_loc ((pos_fname "") (pos_lnum 3) (pos_bol 23) (pos_cnum 44))) (end_loc ((pos_fname "") (pos_lnum 3) (pos_bol 23) (pos_cnum 45))) (attrs ()))) - ((PCons Nil ()) - ((desc (EConst (CInt 0))) + ((Pat_constr Nil ()) + ((desc (Exp_const (Const_int 0))) (start_loc ((pos_fname "") (pos_lnum 4) (pos_bol 46) (pos_cnum 67))) (end_loc ((pos_fname "") (pos_lnum 4) (pos_bol 46) (pos_cnum 68))) @@ -464,12 +464,12 @@ let%expect_test "Test: expression parsing" = [%expect {| ((desc - (ECmp Eq - ((desc (EVar x)) + (Exp_cmp Eq + ((desc (Exp_var x)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 1))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 2))) (attrs ())) - ((desc (EVar y)) + ((desc (Exp_var y)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 5))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 6))) (attrs ())))) @@ -481,12 +481,12 @@ let%expect_test "Test: expression parsing" = [%expect {| ((desc - (ECmp Neq - ((desc (EVar x)) + (Exp_cmp Neq + ((desc (Exp_var x)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 1))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 2))) (attrs ())) - ((desc (EVar y)) + ((desc (Exp_var y)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 6))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 7))) (attrs ())))) @@ -500,15 +500,15 @@ let%expect_test "Test: expression parsing" = [%expect {| ((desc - (ESeq + (Exp_seq ((desc - (EApp - ((desc (EVar f)) + (Exp_app + ((desc (Exp_var f)) (start_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 4))) (end_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 5))) (attrs ())) - ((desc (EConst (CInt 1))) + ((desc (Exp_const (Const_int 1))) (start_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 6))) (end_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 7))) @@ -517,16 +517,16 @@ let%expect_test "Test: expression parsing" = (end_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 7))) (attrs ())) ((desc - (ESeq + (Exp_seq ((desc - (EApp - ((desc (EVar f)) + (Exp_app + ((desc (Exp_var f)) (start_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 10))) (end_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 11))) (attrs ())) - ((desc (EConst (CInt 2))) + ((desc (Exp_const (Const_int 2))) (start_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 12))) (end_loc @@ -537,10 +537,10 @@ let%expect_test "Test: expression parsing" = (end_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 13))) (attrs ())) ((desc - (ECmp Eq + (Exp_cmp Eq ((desc - (EApp - ((desc (EVar f)) + (Exp_app + ((desc (Exp_var f)) (start_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 16))) @@ -548,7 +548,7 @@ let%expect_test "Test: expression parsing" = ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 17))) (attrs ())) - ((desc (EConst (CInt 2))) + ((desc (Exp_const (Const_int 2))) (start_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 18))) @@ -561,7 +561,7 @@ let%expect_test "Test: expression parsing" = (end_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 19))) (attrs ())) - ((desc (EConst (CInt 3))) + ((desc (Exp_const (Const_int 3))) (start_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 22))) (end_loc @@ -582,15 +582,15 @@ let%expect_test "Test: expression parsing" = [%expect {| ((desc - (EApp + (Exp_app ((desc - (EApp - ((desc (EVar add)) + (Exp_app + ((desc (Exp_var add)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 0))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 3))) (attrs ())) - ((desc (EVar x)) + ((desc (Exp_var x)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 4))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 5))) @@ -599,16 +599,16 @@ let%expect_test "Test: expression parsing" = (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 5))) (attrs ())) ((desc - (EApp + (Exp_app ((desc - (EApp - ((desc (EVar minus)) + (Exp_app + ((desc (Exp_var minus)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 7))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 12))) (attrs ())) - ((desc (EVar x)) + ((desc (Exp_var x)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 13))) (end_loc @@ -618,7 +618,7 @@ let%expect_test "Test: expression parsing" = ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 7))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 14))) (attrs ())) - ((desc (EConst (CInt 1))) + ((desc (Exp_const (Const_int 1))) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 15))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 16))) @@ -634,15 +634,15 @@ let%expect_test "Test: expression parsing" = [%expect {| ((desc - (EApp + (Exp_app ((desc - (EApp - ((desc (EVar a)) + (Exp_app + ((desc (Exp_var a)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 0))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 1))) (attrs ())) - ((desc (EVar b)) + ((desc (Exp_var b)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 2))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 3))) @@ -650,7 +650,7 @@ let%expect_test "Test: expression parsing" = (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 0))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 3))) (attrs ())) - ((desc (ECons Nil)) + ((desc (Exp_constr Nil)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 4))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 7))) (attrs ())))) @@ -664,17 +664,18 @@ let%expect_test "Test: pattern parsing" = parse_string_pattern str |> sexp_of_pattern |> print_sexp in print_parsed {| x |}; - [%expect {| (PVar x) |}]; + [%expect {| (Pat_var x) |}]; print_parsed {| 1 |}; - [%expect {| (PVal (CInt 1)) |}]; + [%expect {| (Pat_val (Const_int 1)) |}]; print_parsed {| Nil |}; - [%expect {| (PCons Nil ()) |}]; + [%expect {| (Pat_constr Nil ()) |}]; print_parsed {| Cons 1 |}; - [%expect {| (PCons Cons ((PVal (CInt 1)))) |}]; + [%expect {| (Pat_constr Cons ((Pat_val (Const_int 1)))) |}]; print_parsed {| Cons x |}; - [%expect {| (PCons Cons ((PVar x))) |}]; + [%expect {| (Pat_constr Cons ((Pat_var x))) |}]; print_parsed {| Cons (x, y, z) |}; - [%expect {| (PCons Cons ((PTuple ((PVar x) (PVar y) (PVar z))))) |}] + [%expect + {| (Pat_constr Cons ((Pat_tuple ((Pat_var x) (Pat_var y) (Pat_var z))))) |}] let%expect_test "Test: full program parsing" = print_parsed_program @@ -684,13 +685,13 @@ let%expect_test "Test: full program parsing" = print_parsed_program {|let x = 1|}; [%expect {| - ((TopLet x - ((desc (EConst (CInt 1))) + ((Top_let x + ((desc (Exp_const (Const_int 1))) (start_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 70))) (end_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 71))) (attrs ())))) - ((TopLet x - ((desc (EConst (CInt 1))) + ((Top_let x + ((desc (Exp_const (Const_int 1))) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 8))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 9))) (attrs ())))) @@ -703,28 +704,28 @@ let%expect_test "Test: full program parsing" = |}; [%expect {| - ((TopLet x - ((desc (EConst (CInt 1))) + ((Top_let x + ((desc (Exp_const (Const_int 1))) (start_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 14))) (end_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 15))) (attrs ()))) - (TopLet y - ((desc (EConst (CInt 2))) + (Top_let y + ((desc (Exp_const (Const_int 2))) (start_loc ((pos_fname "") (pos_lnum 3) (pos_bol 16) (pos_cnum 29))) (end_loc ((pos_fname "") (pos_lnum 3) (pos_bol 16) (pos_cnum 30))) (attrs ()))) - (TopLetRec + (Top_letrec ((foo - ((PBare x) + ((Para_bare x) ((desc - (EApp - ((desc (EVar foo)) + (Exp_app + ((desc (Exp_var foo)) (start_loc ((pos_fname "") (pos_lnum 4) (pos_bol 31) (pos_cnum 59))) (end_loc ((pos_fname "") (pos_lnum 4) (pos_bol 31) (pos_cnum 62))) (attrs ())) - ((desc (EVar x)) + ((desc (Exp_var x)) (start_loc ((pos_fname "") (pos_lnum 4) (pos_bol 31) (pos_cnum 63))) (end_loc @@ -738,10 +739,10 @@ let%expect_test "Test: full program parsing" = print_parsed_program {|let rec f = fun (x:int) -> 1|}; [%expect {| - ((TopLetRec + ((Top_letrec ((f - ((PAnn x (TCons int ())) - ((desc (EConst (CInt 1))) + ((Para_ann x (Ty_cons int ())) + ((desc (Exp_const (Const_int 1))) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 27))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 28))) (attrs ()))))))) @@ -753,18 +754,18 @@ let%expect_test "Test: full program parsing" = |}; [%expect {| - ((TopLetRec + ((Top_letrec ((odd - ((PBare x) + ((Para_bare x) ((desc - (EApp - ((desc (EVar even)) + (Exp_app + ((desc (Exp_var even)) (start_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 28))) (end_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 32))) (attrs ())) - ((desc (EVar x)) + ((desc (Exp_var x)) (start_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 33))) (end_loc @@ -774,16 +775,16 @@ let%expect_test "Test: full program parsing" = (end_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 34))) (attrs ())))) (even - ((PBare x) + ((Para_bare x) ((desc - (EApp - ((desc (EVar odd)) + (Exp_app + ((desc (Exp_var odd)) (start_loc ((pos_fname "") (pos_lnum 3) (pos_bol 35) (pos_cnum 59))) (end_loc ((pos_fname "") (pos_lnum 3) (pos_bol 35) (pos_cnum 62))) (attrs ())) - ((desc (EVar x)) + ((desc (Exp_var x)) (start_loc ((pos_fname "") (pos_lnum 3) (pos_bol 35) (pos_cnum 63))) (end_loc @@ -810,14 +811,14 @@ let%expect_test "Test: full program parsing" = |}; [%expect {| - ((TopMod M + ((Top_mod M ((desc - (MERestrict + (Mod_restrict ((desc - (MEStruct - ((TopTypeDef (TDAdt t () ((Nil ())))) - (TopLet x - ((desc (ECons Nil)) + (Mod_struct + ((Top_type_def (Ty_def_adt t () ((Nil ())))) + (Top_let x + ((desc (Exp_constr Nil)) (start_loc ((pos_fname "") (pos_lnum 6) (pos_bol 55) (pos_cnum 70))) (end_loc @@ -827,7 +828,7 @@ let%expect_test "Test: full program parsing" = ((pos_fname "") (pos_lnum 3) (pos_bol 18) (pos_cnum 23))) (end_loc ((pos_fname "") (pos_lnum 7) (pos_bol 74) (pos_cnum 82))) (attrs ())) - (MTSig ((TAbstTySpec t ()) (TValueSpec x (TCons t ())))))) + (Mod_ty_sig ((Spec_abstr t ()) (Spec_value x (Ty_cons t ())))))) (start_loc ((pos_fname "") (pos_lnum 3) (pos_bol 18) (pos_cnum 23))) (end_loc ((pos_fname "") (pos_lnum 11) (pos_bol 128) (pos_cnum 136))) (attrs ())))) @@ -844,9 +845,10 @@ let%expect_test "Test: full program parsing" = |}; [%expect {| - ((TopModSig MIntf - (MTSig - ((TManiTySpec (TDAdt t () ((Nil ())))) (TValueSpec x (TCons t ())))))) + ((Top_mod_sig MIntf + (Mod_ty_sig + ((Spec_mani_ty (Ty_def_adt t () ((Nil ())))) + (Spec_value x (Ty_cons t ())))))) |}]; print_parsed_program @@ -867,16 +869,16 @@ functor |}; [%expect {| - ((TopMod F + ((Top_mod F ((desc - (MEFunctor - ((MI (MTName I)) + (Mod_functor + ((MI (Mod_ty_name I)) ((desc - (MERestrict + (Mod_restrict ((desc - (MEStruct - ((TopLet x - ((desc (EConst (CInt 1))) + (Mod_struct + ((Top_let x + ((desc (Exp_const (Const_int 1))) (start_loc ((pos_fname "") (pos_lnum 8) (pos_bol 51) (pos_cnum 65))) @@ -884,8 +886,8 @@ functor ((pos_fname "") (pos_lnum 8) (pos_bol 51) (pos_cnum 66))) (attrs ()))) - (TopLet y - ((desc (EConst (CInt 1))) + (Top_let y + ((desc (Exp_const (Const_int 1))) (start_loc ((pos_fname "") (pos_lnum 10) (pos_bol 68) (pos_cnum 82))) @@ -893,8 +895,8 @@ functor ((pos_fname "") (pos_lnum 10) (pos_bol 68) (pos_cnum 83))) (attrs ()))) - (TopLet z - ((desc (EConst (CInt 1))) + (Top_let z + ((desc (Exp_const (Const_int 1))) (start_loc ((pos_fname "") (pos_lnum 12) (pos_bol 85) (pos_cnum 99))) @@ -908,7 +910,7 @@ functor ((pos_fname "") (pos_lnum 13) (pos_bol 101) (pos_cnum 108))) (attrs ())) - (MTName J))) + (Mod_ty_name J))) (start_loc ((pos_fname "") (pos_lnum 7) (pos_bol 40) (pos_cnum 44))) (end_loc @@ -926,22 +928,22 @@ functor |}; [%expect {| - ((TopLet co + ((Top_let co ((desc - (EApp - ((desc (ECons Cons)) + (Exp_app + ((desc (Exp_constr Cons)) (start_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 14))) (end_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 18))) (attrs ())) - ((desc (EConst (CInt 1))) + ((desc (Exp_const (Const_int 1))) (start_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 19))) (end_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 20))) (attrs ())))) (start_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 14))) (end_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 20))) (attrs ()))) - (TopLet f - ((desc (EConst (CInt 1))) + (Top_let f + ((desc (Exp_const (Const_int 1))) (start_loc ((pos_fname "") (pos_lnum 4) (pos_bol 22) (pos_cnum 34))) (end_loc ((pos_fname "") (pos_lnum 4) (pos_bol 22) (pos_cnum 35))) (attrs ())))) @@ -951,15 +953,19 @@ functor type t = a list -> b |}; [%expect - {| ((TopTypeDef (TDAlias t (TArrow (TCons list ((TCons a ()))) (TCons b ()))))) |}]; + {| + ((Top_type_def + (Ty_def_alias t (Ty_arrow (Ty_cons list ((Ty_cons a ()))) (Ty_cons b ()))))) + |}]; print_parsed_program {| external x : int -> int -> int = "ff_add" |}; [%expect {| - ((TopExternal x - (TArrow (TCons int ()) (TArrow (TCons int ()) (TCons int ()))) ff_add)) + ((Top_external x + (Ty_arrow (Ty_cons int ()) (Ty_arrow (Ty_cons int ()) (Ty_cons int ()))) + ff_add)) |}]; print_parsed_program @@ -971,15 +977,15 @@ let y = 2 |}; [%expect {| - ((TopLet x + ((Top_let x ((desc - (ECase - ((desc (EVar a)) + (Exp_case + ((desc (Exp_var a)) (start_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 15))) (end_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 16))) (attrs ())) - (((PCons Cons ()) - ((desc (EConst (CInt 0))) + (((Pat_constr Cons ()) + ((desc (Exp_const (Const_int 0))) (start_loc ((pos_fname "") (pos_lnum 3) (pos_bol 22) (pos_cnum 38))) (end_loc @@ -988,8 +994,8 @@ let y = 2 (start_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 9))) (end_loc ((pos_fname "") (pos_lnum 3) (pos_bol 22) (pos_cnum 39))) (attrs ()))) - (TopLet y - ((desc (EConst (CInt 2))) + (Top_let y + ((desc (Exp_const (Const_int 2))) (start_loc ((pos_fname "") (pos_lnum 5) (pos_bol 41) (pos_cnum 49))) (end_loc ((pos_fname "") (pos_lnum 5) (pos_bol 41) (pos_cnum 50))) (attrs ())))) @@ -1002,11 +1008,11 @@ let y = 2 |}; [%expect {| - ((TopLet x + ((Top_let x ((desc - (ELam - ((PBare x) - ((desc (EVar y)) + (Exp_lam + ((Para_bare x) + ((desc (Exp_var y)) (start_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 18))) (end_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 19))) @@ -1014,8 +1020,8 @@ let y = 2 (start_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 9))) (end_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 19))) (attrs ()))) - (TopLet y - ((desc (EConst (CInt 2))) + (Top_let y + ((desc (Exp_const (Const_int 2))) (start_loc ((pos_fname "") (pos_lnum 4) (pos_bol 21) (pos_cnum 29))) (end_loc ((pos_fname "") (pos_lnum 4) (pos_bol 21) (pos_cnum 30))) (attrs ())))) @@ -1037,15 +1043,15 @@ let y = 2 |}; [%expect {| - ((TopLet x + ((Top_let x ((desc - (ETuple - (((desc (EConst (CInt 1))) + (Exp_tuple + (((desc (Exp_const (Const_int 1))) (start_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 15))) (end_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 16))) (attrs ())) - ((desc (EConst (CInt 2))) + ((desc (Exp_const (Const_int 2))) (start_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 17))) (end_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 18))) @@ -1053,16 +1059,16 @@ let y = 2 (start_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 15))) (end_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 18))) (attrs ()))) - (TopLet y + (Top_let y ((desc - (ETuple - (((desc (EConst (CInt 1))) + (Exp_tuple + (((desc (Exp_const (Const_int 1))) (start_loc ((pos_fname "") (pos_lnum 4) (pos_bol 21) (pos_cnum 35))) (end_loc ((pos_fname "") (pos_lnum 4) (pos_bol 21) (pos_cnum 36))) (attrs ())) - ((desc (EConst (CInt 2))) + ((desc (Exp_const (Const_int 2))) (start_loc ((pos_fname "") (pos_lnum 4) (pos_bol 21) (pos_cnum 38))) (end_loc @@ -1071,16 +1077,16 @@ let y = 2 (start_loc ((pos_fname "") (pos_lnum 4) (pos_bol 21) (pos_cnum 35))) (end_loc ((pos_fname "") (pos_lnum 4) (pos_bol 21) (pos_cnum 39))) (attrs ()))) - (TopLet z + (Top_let z ((desc - (ECase - ((desc (EVar y)) + (Exp_case + ((desc (Exp_var y)) (start_loc ((pos_fname "") (pos_lnum 6) (pos_bol 42) (pos_cnum 61))) (end_loc ((pos_fname "") (pos_lnum 6) (pos_bol 42) (pos_cnum 62))) (attrs ())) - (((PTuple ((PVar x) (PVar y))) - ((desc (EVar x)) + (((Pat_tuple ((Pat_var x) (Pat_var y))) + ((desc (Exp_var x)) (start_loc ((pos_fname "") (pos_lnum 7) (pos_bol 69) (pos_cnum 94))) (end_loc @@ -1089,20 +1095,20 @@ let y = 2 (start_loc ((pos_fname "") (pos_lnum 6) (pos_bol 42) (pos_cnum 55))) (end_loc ((pos_fname "") (pos_lnum 7) (pos_bol 69) (pos_cnum 95))) (attrs ()))) - (TopLet n + (Top_let n ((desc - (ELam - ((PBare y) + (Exp_lam + ((Para_bare y) ((desc - (ECase - ((desc (EVar y)) + (Exp_case + ((desc (Exp_var y)) (start_loc ((pos_fname "") (pos_lnum 9) (pos_bol 97) (pos_cnum 125))) (end_loc ((pos_fname "") (pos_lnum 9) (pos_bol 97) (pos_cnum 126))) (attrs ())) - (((PTuple ((PVar x) (PVar y))) - ((desc (EVar y)) + (((Pat_tuple ((Pat_var x) (Pat_var y))) + ((desc (Exp_var y)) (start_loc ((pos_fname "") (pos_lnum 10) (pos_bol 133) (pos_cnum 152))) @@ -1118,8 +1124,8 @@ let y = 2 (start_loc ((pos_fname "") (pos_lnum 9) (pos_bol 97) (pos_cnum 110))) (end_loc ((pos_fname "") (pos_lnum 10) (pos_bol 133) (pos_cnum 153))) (attrs ()))) - (TopLet w - ((desc (EConst (CInt 1))) + (Top_let w + ((desc (Exp_const (Const_int 1))) (start_loc ((pos_fname "") (pos_lnum 12) (pos_bol 155) (pos_cnum 168))) (end_loc ((pos_fname "") (pos_lnum 12) (pos_bol 155) (pos_cnum 169))) (attrs ())))) @@ -1136,14 +1142,14 @@ let result = print_int (sum 4) |}; [%expect {| - ((TopLetRec + ((Top_letrec ((sum - ((PBare x) + ((Para_bare x) ((desc - (EIf + (Exp_if ((desc - (ECmp Eq - ((desc (EVar x)) + (Exp_cmp Eq + ((desc (Exp_var x)) (start_loc ((pos_fname "") (pos_lnum 3) (pos_bol 24) (pos_cnum 32))) @@ -1151,7 +1157,7 @@ let result = print_int (sum 4) ((pos_fname "") (pos_lnum 3) (pos_bol 24) (pos_cnum 33))) (attrs ())) - ((desc (EConst (CInt 0))) + ((desc (Exp_const (Const_int 0))) (start_loc ((pos_fname "") (pos_lnum 3) (pos_bol 24) (pos_cnum 36))) @@ -1164,13 +1170,13 @@ let result = print_int (sum 4) (end_loc ((pos_fname "") (pos_lnum 3) (pos_bol 24) (pos_cnum 37))) (attrs ())) - ((desc (EConst (CInt 0))) + ((desc (Exp_const (Const_int 0))) (start_loc ((pos_fname "") (pos_lnum 4) (pos_bol 38) (pos_cnum 47))) (end_loc ((pos_fname "") (pos_lnum 4) (pos_bol 38) (pos_cnum 48))) (attrs ())) - ((desc (EConst (CInt 1))) + ((desc (Exp_const (Const_int 1))) (start_loc ((pos_fname "") (pos_lnum 5) (pos_bol 49) (pos_cnum 58))) (end_loc @@ -1180,23 +1186,23 @@ let result = print_int (sum 4) ((pos_fname "") (pos_lnum 3) (pos_bol 24) (pos_cnum 29))) (end_loc ((pos_fname "") (pos_lnum 5) (pos_bol 49) (pos_cnum 59))) (attrs ())))))) - (TopLet result + (Top_let result ((desc - (EApp - ((desc (EVar print_int)) + (Exp_app + ((desc (Exp_var print_int)) (start_loc ((pos_fname "") (pos_lnum 7) (pos_bol 62) (pos_cnum 75))) (end_loc ((pos_fname "") (pos_lnum 7) (pos_bol 62) (pos_cnum 84))) (attrs ())) ((desc - (EApp - ((desc (EVar sum)) + (Exp_app + ((desc (Exp_var sum)) (start_loc ((pos_fname "") (pos_lnum 7) (pos_bol 62) (pos_cnum 86))) (end_loc ((pos_fname "") (pos_lnum 7) (pos_bol 62) (pos_cnum 89))) (attrs ())) - ((desc (EConst (CInt 4))) + ((desc (Exp_const (Const_int 4))) (start_loc ((pos_fname "") (pos_lnum 7) (pos_bol 62) (pos_cnum 90))) (end_loc @@ -1214,12 +1220,12 @@ let result = print_int (sum 4) {| type 'a t = Nil |}; - [%expect {| ((TopTypeDef (TDAdt t ('a/0) ((Nil ()))))) |}]; + [%expect {| ((Top_type_def (Ty_def_adt t ('a/0) ((Nil ()))))) |}]; print_parsed_program {| type t = | Nil |}; - [%expect {| ((TopTypeDef (TDAdt t () ((Nil ()))))) |}]; + [%expect {| ((Top_type_def (Ty_def_adt t () ((Nil ()))))) |}]; print_parsed_program {| let x = let rec f = fun x -> 1 @@ -1230,26 +1236,26 @@ let result = print_int (sum 4) |}; [%expect {| - ((TopLet x + ((Top_let x ((desc - (ELetrec + (Exp_letrec ((f - ((PBare x) - ((desc (EConst (CInt 1))) + ((Para_bare x) + ((desc (Exp_const (Const_int 1))) (start_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 35))) (end_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 36))) (attrs ())))) (g - ((PBare y) - ((desc (EConst (CInt 2))) + ((Para_bare y) + ((desc (Exp_const (Const_int 2))) (start_loc ((pos_fname "") (pos_lnum 3) (pos_bol 37) (pos_cnum 67))) (end_loc ((pos_fname "") (pos_lnum 3) (pos_bol 37) (pos_cnum 68))) (attrs ()))))) - ((desc (EVar f)) + ((desc (Exp_var f)) (start_loc ((pos_fname "") (pos_lnum 4) (pos_bol 72) (pos_cnum 85))) (end_loc ((pos_fname "") (pos_lnum 4) (pos_bol 72) (pos_cnum 86))) @@ -1257,8 +1263,8 @@ let result = print_int (sum 4) (start_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 14))) (end_loc ((pos_fname "") (pos_lnum 4) (pos_bol 72) (pos_cnum 86))) (attrs ()))) - (TopLet _ - ((desc (EConst (CInt 1))) + (Top_let _ + ((desc (Exp_const (Const_int 1))) (start_loc ((pos_fname "") (pos_lnum 5) (pos_bol 87) (pos_cnum 100))) (end_loc ((pos_fname "") (pos_lnum 5) (pos_bol 87) (pos_cnum 101))) (attrs ())))) @@ -1268,7 +1274,7 @@ let%expect_test "Test: path parsing" = print_parsed_mod_expr {|X|}; [%expect {| - ((desc (MEName X)) + ((desc (Mod_name X)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 0))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 1))) (attrs ())) @@ -1277,8 +1283,8 @@ let%expect_test "Test: path parsing" = [%expect {| ((desc - (MEField - ((desc (MEName X)) + (Mod_field + ((desc (Mod_name X)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 0))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 1))) (attrs ())) @@ -1291,12 +1297,12 @@ let%expect_test "Test: path parsing" = [%expect {| ((desc - (MEApply - ((desc (MEName X)) + (Mod_apply + ((desc (Mod_name X)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 0))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 1))) (attrs ())) - ((desc (MEName Y)) + ((desc (Mod_name Y)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 2))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 3))) (attrs ())))) @@ -1308,12 +1314,12 @@ let%expect_test "Test: path parsing" = [%expect {| ((desc - (MEApply + (Mod_apply ((desc - (MEApply + (Mod_apply ((desc - (MEField - ((desc (MEName X)) + (Mod_field + ((desc (Mod_name X)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 0))) (end_loc @@ -1325,14 +1331,14 @@ let%expect_test "Test: path parsing" = (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 3))) (attrs ())) ((desc - (MEApply - ((desc (MEName Z)) + (Mod_apply + ((desc (Mod_name Z)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 4))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 5))) (attrs ())) - ((desc (MEName N)) + ((desc (Mod_name N)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 6))) (end_loc @@ -1346,10 +1352,10 @@ let%expect_test "Test: path parsing" = (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 9))) (attrs ())) ((desc - (MEField + (Mod_field ((desc - (MEField - ((desc (MEName W)) + (Mod_field + ((desc (Mod_name W)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 10))) (end_loc @@ -1371,68 +1377,71 @@ let%expect_test "Test: path parsing" = let%expect_test "Test: type expression parsing" = print_parsed_type_expr "string"; - [%expect {| (TCons string ()) |}]; + [%expect {| (Ty_cons string ()) |}]; print_parsed_type_expr "(string) list"; - [%expect {| (TCons list ((TCons string ()))) |}]; + [%expect {| (Ty_cons list ((Ty_cons string ()))) |}]; print_parsed_type_expr "string list"; - [%expect {| (TCons list ((TCons string ()))) |}]; + [%expect {| (Ty_cons list ((Ty_cons string ()))) |}]; print_parsed_type_expr "'x"; - [%expect {| (TVar 'x/0) |}]; + [%expect {| (Ty_var 'x/0) |}]; print_parsed_type_expr "(string, 'x, 'y) list"; - [%expect {| (TCons list ((TCons string ()) (TVar 'x/0) (TVar 'y/0))) |}]; + [%expect + {| (Ty_cons list ((Ty_cons string ()) (Ty_var 'x/0) (Ty_var 'y/0))) |}]; print_parsed_type_expr "int * int"; - [%expect {| (TTuple ((TCons int ()) (TCons int ()))) |}]; + [%expect {| (Ty_tuple ((Ty_cons int ()) (Ty_cons int ()))) |}]; print_parsed_type_expr "int * i list * (x * y) list * (t1 * t2)"; [%expect {| - (TTuple - ((TCons int ()) (TCons list ((TCons i ()))) - (TCons list ((TTuple ((TCons x ()) (TCons y ()))))) - (TTuple ((TCons t1 ()) (TCons t2 ()))))) |}]; + (Ty_tuple + ((Ty_cons int ()) (Ty_cons list ((Ty_cons i ()))) + (Ty_cons list ((Ty_tuple ((Ty_cons x ()) (Ty_cons y ()))))) + (Ty_tuple ((Ty_cons t1 ()) (Ty_cons t2 ()))))) + |}]; print_parsed_type_expr "{x: int; y: float; z: int -> float }"; [%expect {| - (TRecord - ((x (TCons int ())) (y (TCons float ())) - (z (TArrow (TCons int ()) (TCons float ()))))) |}]; + (Ty_record + ((x (Ty_cons int ())) (y (Ty_cons float ())) + (z (Ty_arrow (Ty_cons int ()) (Ty_cons float ()))))) + |}]; print_parsed_type_expr "(int, float) T.t"; [%expect {| - (TField - ((desc (MEName T)) + (Ty_field + ((desc (Mod_name T)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 13))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 14))) (attrs ())) - t ((TCons int ()) (TCons float ()))) + t ((Ty_cons int ()) (Ty_cons float ()))) |}]; print_parsed_type_expr "int T(M).t"; [%expect {| - (TField + (Ty_field ((desc - (MEApply - ((desc (MEName T)) + (Mod_apply + ((desc (Mod_name T)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 4))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 5))) (attrs ())) - ((desc (MEName M)) + ((desc (Mod_name M)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 6))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 7))) (attrs ())))) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 4))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 8))) (attrs ())) - t ((TCons int ()))) + t ((Ty_cons int ()))) |}]; print_parsed_type_expr "(int) T.t"; [%expect {| - (TField - ((desc (MEName T)) + (Ty_field + ((desc (Mod_name T)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 6))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 7))) (attrs ())) - t ((TCons int ()))) + t ((Ty_cons int ()))) |}] let%expect_test "Test: top level module" = @@ -1442,8 +1451,8 @@ let%expect_test "Test: top level module" = |}; [%expect {| - ((TopMod X - ((desc (MEStruct ())) + ((Top_mod X + ((desc (Mod_struct ())) (start_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 17))) (end_loc ((pos_fname "") (pos_lnum 3) (pos_bol 24) (pos_cnum 32))) (attrs ())))) @@ -1460,27 +1469,27 @@ let%expect_test "Test: top level module" = |}; [%expect {| - ((TopMod X + ((Top_mod X ((desc - (MEStruct - ((TopLet x - ((desc (EConst (CInt 1))) + (Mod_struct + ((Top_let x + ((desc (Exp_const (Const_int 1))) (start_loc ((pos_fname "") (pos_lnum 3) (pos_bol 24) (pos_cnum 39))) (end_loc ((pos_fname "") (pos_lnum 3) (pos_bol 24) (pos_cnum 40))) (attrs ()))) - (TopLetRec + (Top_letrec ((y - ((PBare x) - ((desc (EConst (CInt 3))) + ((Para_bare x) + ((desc (Exp_const (Const_int 3))) (start_loc ((pos_fname "") (pos_lnum 4) (pos_bol 41) (pos_cnum 69))) (end_loc ((pos_fname "") (pos_lnum 4) (pos_bol 41) (pos_cnum 70))) (attrs ())))))) - (TopMod Y - ((desc (MEStruct ())) + (Top_mod Y + ((desc (Mod_struct ())) (start_loc ((pos_fname "") (pos_lnum 5) (pos_bol 71) (pos_cnum 89))) (end_loc @@ -1508,14 +1517,14 @@ let%expect_test "Test: module expression" = [%expect {| ((desc - (MEStruct - ((TopLet x - ((desc (EConst (CInt 1))) + (Mod_struct + ((Top_let x + ((desc (Exp_const (Const_int 1))) (start_loc ((pos_fname "") (pos_lnum 3) (pos_bol 14) (pos_cnum 29))) (end_loc ((pos_fname "") (pos_lnum 3) (pos_bol 14) (pos_cnum 30))) (attrs ()))) - (TopTypeDef (TDAdt a () ((Cons ((TCons int ()))) (Nil ()))))))) + (Top_type_def (Ty_def_adt a () ((Cons ((Ty_cons int ()))) (Nil ()))))))) (start_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 6))) (end_loc ((pos_fname "") (pos_lnum 8) (pos_bol 91) (pos_cnum 99))) (attrs ())) @@ -1524,9 +1533,9 @@ let%expect_test "Test: module expression" = [%expect {| ((desc - (MEFunctor - ((X (MTName M)) - ((desc (MEStruct ())) + (Mod_functor + ((X (Mod_ty_name M)) + ((desc (Mod_struct ())) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 18))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 28))) (attrs ()))))) @@ -1537,19 +1546,19 @@ let%expect_test "Test: module expression" = let%expect_test "Test: module type" = let print_parsed str = - parse_string_mod_type str |> sexp_of_emod_ty |> print_sexp + parse_string_mod_type str |> sexp_of_surface_mod_ty |> print_sexp in print_parsed {|M|}; - [%expect {| (MTName M) |}]; + [%expect {| (Mod_ty_name M) |}]; print_parsed {|M.X(M).E|}; [%expect {| - (MTField + (Mod_ty_field ((desc - (MEApply + (Mod_apply ((desc - (MEField - ((desc (MEName M)) + (Mod_field + ((desc (Mod_name M)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 0))) (end_loc @@ -1559,7 +1568,7 @@ let%expect_test "Test: module type" = (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 0))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 3))) (attrs ())) - ((desc (MEName M)) + ((desc (Mod_name M)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 4))) (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 5))) (attrs ())))) @@ -1569,15 +1578,21 @@ let%expect_test "Test: module type" = E) |}]; print_parsed {|sig val x : int end|}; - [%expect {| (MTSig ((TValueSpec x (TCons int ())))) |}]; + [%expect {| (Mod_ty_sig ((Spec_value x (Ty_cons int ())))) |}]; print_parsed {|functor (M:M) -> sig val x: int end|}; [%expect - {| (MTFunctor M (MTName M) (MTSig ((TValueSpec x (TCons int ()))))) |}]; + {| + (Mod_ty_functor M (Mod_ty_name M) + (Mod_ty_sig ((Spec_value x (Ty_cons int ()))))) + |}]; print_parsed {|functor (M:M) -> M1|}; - [%expect {| (MTFunctor M (MTName M) (MTName M1)) |}]; + [%expect {| (Mod_ty_functor M (Mod_ty_name M) (Mod_ty_name M1)) |}]; print_parsed {|functor (M:functor (X:M)->M) -> M1|}; [%expect - {| (MTFunctor M (MTFunctor X (MTName M) (MTName M)) (MTName M1)) |}]; + {| + (Mod_ty_functor M (Mod_ty_functor X (Mod_ty_name M) (Mod_ty_name M)) + (Mod_ty_name M1)) + |}]; print_parsed {| sig @@ -1592,7 +1607,9 @@ let%expect_test "Test: module type" = |}; [%expect {| - (MTSig - ((TValueSpec x (TCons int ())) (TAbstTySpec t ()) - (TValueSpec m (TArrow (TCons t ()) (TCons t ()))) - (TManiTySpec (TDAdt i_list () ((Cons ((TCons int ()))) (Nil ())))))) |}] + (Mod_ty_sig + ((Spec_value x (Ty_cons int ())) (Spec_abstr t ()) + (Spec_value m (Ty_arrow (Ty_cons t ()) (Ty_cons t ()))) + (Spec_mani_ty + (Ty_def_adt i_list () ((Cons ((Ty_cons int ()))) (Nil ())))))) + |}] diff --git a/tests/regular/typing_test.ml b/tests/regular/typing_test.ml index e417a8b..f99b702 100644 --- a/tests/regular/typing_test.ml +++ b/tests/regular/typing_test.ml @@ -28,83 +28,87 @@ let%expect_test "Test: expression typing" = typed |> T.get_ty |> Typing.Types_in.sexp_of_ty |> print_sexp in print_typed "1"; - [%expect {| (EConst (CInt 1) (TConsI (0 int) ())) |}]; + [%expect {| (Exp_const (Const_int 1) (Ty_cons (0 int) ())) |}]; print_type "1"; - [%expect {| (TConsI (0 int) ()) |}]; + [%expect {| (Ty_cons (0 int) ()) |}]; print_typed "let x = 1 in x"; [%expect {| - (ELet x (EConst (CInt 1) (TConsI (0 int) ())) (EVar x (TConsI (0 int) ())) - (TConsI (0 int) ())) |}]; + (Exp_let x (Exp_const (Const_int 1) (Ty_cons (0 int) ())) + (Exp_var x (Ty_cons (0 int) ())) (Ty_cons (0 int) ())) + |}]; print_type "let x = 1 in x"; - [%expect {| (TConsI (0 int) ()) |}]; + [%expect {| (Ty_cons (0 int) ()) |}]; print_typed "let f = (fun x -> x) in f"; [%expect {| - (ELet f - (ELam - (x (EVar x (TVarI (Unbound '_t/1 1))) - (TArrowI (TVarI (Unbound '_t/1 1)) (TVarI (Unbound '_t/1 1))))) - (EVar f (TArrowI (TVarI (Unbound '_t/2 0)) (TVarI (Unbound '_t/2 0)))) - (TArrowI (TVarI (Unbound '_t/2 0)) (TVarI (Unbound '_t/2 0)))) + (Exp_let f + (Exp_lam + (x (Exp_var x (Ty_var (Unbound '_t/1 1))) + (Ty_arrow (Ty_var (Unbound '_t/1 1)) (Ty_var (Unbound '_t/1 1))))) + (Exp_var f + (Ty_arrow (Ty_var (Unbound '_t/2 0)) (Ty_var (Unbound '_t/2 0)))) + (Ty_arrow (Ty_var (Unbound '_t/2 0)) (Ty_var (Unbound '_t/2 0)))) |}]; print_typed "let f = (fun x -> x) in f 1"; [%expect {| - (ELet f - (ELam - (x (EVar x (TVarI (Unbound '_t/1 1))) - (TArrowI (TVarI (Unbound '_t/1 1)) (TVarI (Unbound '_t/1 1))))) - (EApp - (EVar f - (TArrowI (TVarI (Link (TConsI (0 int) ()))) - (TVarI (Link (TConsI (0 int) ()))))) - (EConst (CInt 1) (TConsI (0 int) ())) (TVarI (Link (TConsI (0 int) ())))) - (TVarI (Link (TConsI (0 int) ())))) + (Exp_let f + (Exp_lam + (x (Exp_var x (Ty_var (Unbound '_t/1 1))) + (Ty_arrow (Ty_var (Unbound '_t/1 1)) (Ty_var (Unbound '_t/1 1))))) + (Exp_app + (Exp_var f + (Ty_arrow (Ty_var (Link (Ty_cons (0 int) ()))) + (Ty_var (Link (Ty_cons (0 int) ()))))) + (Exp_const (Const_int 1) (Ty_cons (0 int) ())) + (Ty_var (Link (Ty_cons (0 int) ())))) + (Ty_var (Link (Ty_cons (0 int) ())))) |}]; print_type "let f = (fun x -> x) in f 1"; [%expect {| - (TVarI (Link (TConsI (0 int) ()))) |}]; + (Ty_var (Link (Ty_cons (0 int) ()))) |}]; print_typed "1, true"; [%expect {| - (ETuple - ((EConst (CInt 1) (TConsI (0 int) ())) - (EConst (CBool true) (TConsI (0 bool) ()))) - (TTupleI ((TConsI (0 int) ()) (TConsI (0 bool) ())))) |}]; + (Exp_tuple + ((Exp_const (Const_int 1) (Ty_cons (0 int) ())) + (Exp_const (Const_bool true) (Ty_cons (0 bool) ()))) + (Ty_tuple ((Ty_cons (0 int) ()) (Ty_cons (0 bool) ())))) |}]; print_typed "let f = (fun x -> x) in (f 1, f true)"; [%expect {| - (ELet f - (ELam - (x (EVar x (TVarI (Unbound '_t/1 1))) - (TArrowI (TVarI (Unbound '_t/1 1)) (TVarI (Unbound '_t/1 1))))) - (ETuple - ((EApp - (EVar f - (TArrowI (TVarI (Link (TConsI (0 int) ()))) - (TVarI (Link (TConsI (0 int) ()))))) - (EConst (CInt 1) (TConsI (0 int) ())) - (TVarI (Link (TConsI (0 int) ())))) - (EApp - (EVar f - (TArrowI (TVarI (Link (TConsI (0 bool) ()))) - (TVarI (Link (TConsI (0 bool) ()))))) - (EConst (CBool true) (TConsI (0 bool) ())) - (TVarI (Link (TConsI (0 bool) ()))))) - (TTupleI - ((TVarI (Link (TConsI (0 int) ()))) - (TVarI (Link (TConsI (0 bool) ())))))) - (TTupleI - ((TVarI (Link (TConsI (0 int) ()))) (TVarI (Link (TConsI (0 bool) ())))))) + (Exp_let f + (Exp_lam + (x (Exp_var x (Ty_var (Unbound '_t/1 1))) + (Ty_arrow (Ty_var (Unbound '_t/1 1)) (Ty_var (Unbound '_t/1 1))))) + (Exp_tuple + ((Exp_app + (Exp_var f + (Ty_arrow (Ty_var (Link (Ty_cons (0 int) ()))) + (Ty_var (Link (Ty_cons (0 int) ()))))) + (Exp_const (Const_int 1) (Ty_cons (0 int) ())) + (Ty_var (Link (Ty_cons (0 int) ())))) + (Exp_app + (Exp_var f + (Ty_arrow (Ty_var (Link (Ty_cons (0 bool) ()))) + (Ty_var (Link (Ty_cons (0 bool) ()))))) + (Exp_const (Const_bool true) (Ty_cons (0 bool) ())) + (Ty_var (Link (Ty_cons (0 bool) ()))))) + (Ty_tuple + ((Ty_var (Link (Ty_cons (0 int) ()))) + (Ty_var (Link (Ty_cons (0 bool) ())))))) + (Ty_tuple + ((Ty_var (Link (Ty_cons (0 int) ()))) + (Ty_var (Link (Ty_cons (0 bool) ())))))) |}]; print_typed {| @@ -116,28 +120,28 @@ let%expect_test "Test: expression typing" = |}; [%expect {| - (ELetrec + (Exp_letrec ((f (x - (EApp - (EVar g - (TVarI + (Exp_app + (Exp_var g + (Ty_var (Link - (TArrowI (TVarI (Link (TVarI (Unbound '_t/5 1)))) - (TVarI (Link (TVarI (Unbound 'ret/6 1)))))))) - (EVar x (TVarI (Link (TVarI (Unbound '_t/5 1))))) - (TVarI (Link (TVarI (Unbound 'ret/6 1))))) - (TArrowI (TVarI (Link (TVarI (Unbound '_t/5 1)))) - (TVarI (Link (TVarI (Unbound 'ret/6 1))))))) + (Ty_arrow (Ty_var (Link (Ty_var (Unbound '_t/5 1)))) + (Ty_var (Link (Ty_var (Unbound 'ret/6 1)))))))) + (Exp_var x (Ty_var (Link (Ty_var (Unbound '_t/5 1))))) + (Ty_var (Link (Ty_var (Unbound 'ret/6 1))))) + (Ty_arrow (Ty_var (Link (Ty_var (Unbound '_t/5 1)))) + (Ty_var (Link (Ty_var (Unbound 'ret/6 1))))))) (g (x - (EApp - (EVar f - (TArrowI (TVarI (Link (TVarI (Unbound '_t/5 1)))) - (TVarI (Link (TVarI (Unbound 'ret/6 1)))))) - (EVar x (TVarI (Unbound '_t/5 1))) (TVarI (Unbound 'ret/6 1))) - (TArrowI (TVarI (Unbound '_t/5 1)) (TVarI (Unbound 'ret/6 1)))))) - (EConst (CInt 1) (TConsI (0 int) ())) (TConsI (0 int) ())) + (Exp_app + (Exp_var f + (Ty_arrow (Ty_var (Link (Ty_var (Unbound '_t/5 1)))) + (Ty_var (Link (Ty_var (Unbound 'ret/6 1)))))) + (Exp_var x (Ty_var (Unbound '_t/5 1))) (Ty_var (Unbound 'ret/6 1))) + (Ty_arrow (Ty_var (Unbound '_t/5 1)) (Ty_var (Unbound 'ret/6 1)))))) + (Exp_const (Const_int 1) (Ty_cons (0 int) ())) (Ty_cons (0 int) ())) |}]; print_typed @@ -150,22 +154,22 @@ let%expect_test "Test: expression typing" = |}; [%expect {| - (ELetrec + (Exp_letrec ((f - (x (EVar x (TVarI (Link (TConsI (0 int) ())))) - (TArrowI (TVarI (Link (TConsI (0 int) ()))) - (TVarI (Link (TConsI (0 int) ())))))) + (x (Exp_var x (Ty_var (Link (Ty_cons (0 int) ())))) + (Ty_arrow (Ty_var (Link (Ty_cons (0 int) ()))) + (Ty_var (Link (Ty_cons (0 int) ())))))) (g (x - (EApp - (EVar f - (TArrowI (TVarI (Link (TConsI (0 int) ()))) - (TVarI (Link (TConsI (0 int) ()))))) - (EConst (CInt 1) (TConsI (0 int) ())) - (TVarI (Link (TConsI (0 int) ())))) - (TArrowI (TVarI (Unbound '_t/4 1)) - (TVarI (Link (TConsI (0 int) ()))))))) - (EConst (CInt 1) (TConsI (0 int) ())) (TConsI (0 int) ())) + (Exp_app + (Exp_var f + (Ty_arrow (Ty_var (Link (Ty_cons (0 int) ()))) + (Ty_var (Link (Ty_cons (0 int) ()))))) + (Exp_const (Const_int 1) (Ty_cons (0 int) ())) + (Ty_var (Link (Ty_cons (0 int) ())))) + (Ty_arrow (Ty_var (Unbound '_t/4 1)) + (Ty_var (Link (Ty_cons (0 int) ()))))))) + (Exp_const (Const_int 1) (Ty_cons (0 int) ())) (Ty_cons (0 int) ())) |}] (* todo: test pattern matching *) @@ -185,7 +189,8 @@ let%expect_test "Test: program toplevel typing" = print_typed {| let x = 1 |}; - [%expect {| ((TopLet x (EConst (CInt 1) (TConsI (0 int) ())))) |}]; + [%expect + {| ((Top_let x (Exp_const (Const_int 1) (Ty_cons (0 int) ())))) |}]; print_typed {| let rec f = fun x -> x @@ -194,21 +199,21 @@ let%expect_test "Test: program toplevel typing" = |}; [%expect {| - ((TopLetRec + ((Top_letrec ((f - (x (EVar x (TVarI (Link (TConsI (0 int) ())))) - (TArrowI (TVarI (Link (TConsI (0 int) ()))) - (TVarI (Link (TConsI (0 int) ())))))) + (x (Exp_var x (Ty_var (Link (Ty_cons (0 int) ())))) + (Ty_arrow (Ty_var (Link (Ty_cons (0 int) ()))) + (Ty_var (Link (Ty_cons (0 int) ())))))) (g (x - (EApp - (EVar f - (TArrowI (TVarI (Link (TConsI (0 int) ()))) - (TVarI (Link (TConsI (0 int) ()))))) - (EConst (CInt 1) (TConsI (0 int) ())) - (TVarI (Link (TConsI (0 int) ())))) - (TArrowI (TVarI (Unbound '_t/4 1)) - (TVarI (Link (TConsI (0 int) ()))))))))) + (Exp_app + (Exp_var f + (Ty_arrow (Ty_var (Link (Ty_cons (0 int) ()))) + (Ty_var (Link (Ty_cons (0 int) ()))))) + (Exp_const (Const_int 1) (Ty_cons (0 int) ())) + (Ty_var (Link (Ty_cons (0 int) ())))) + (Ty_arrow (Ty_var (Unbound '_t/4 1)) + (Ty_var (Link (Ty_cons (0 int) ()))))))))) |}]; print_effect {| type () a @@ -223,7 +228,7 @@ let%expect_test "Test: program toplevel typing" = Value Bindings: Type Definitions: - a |-> (TDAdtI a () ((Cons ((TConsI (0 int) ()))) (Nil ()))) + a |-> (Ty_def_adt a () ((Cons ((Ty_cons (0 int) ()))) (Nil ()))) Module Definitions: Module Types: @@ -245,12 +250,16 @@ let%expect_test "Test: program toplevel typing" = |}; [%expect {| - ((TopTypeDef (TDAdtI int_l () ((Cons ((TConsI (0 int) ()))) (Nil ())))) - (TopLet c (ECons Nil 1 (TConsI (0 int_l) ()))) - (TopLet co - (EApp (ECons Cons 0 (TArrowI (TConsI (0 int) ()) (TConsI (0 int_l) ()))) - (EConst (CInt 1) (TConsI (0 int) ())) - (TVarI (Link (TConsI (0 int_l) ())))))) |}]; + ((Top_type_def + (Ty_def_adt int_l () ((Cons ((Ty_cons (0 int) ()))) (Nil ())))) + (Top_let c (Exp_constr Nil 1 (Ty_cons (0 int_l) ()))) + (Top_let co + (Exp_app + (Exp_constr Cons 0 + (Ty_arrow (Ty_cons (0 int) ()) (Ty_cons (0 int_l) ()))) + (Exp_const (Const_int 1) (Ty_cons (0 int) ())) + (Ty_var (Link (Ty_cons (0 int_l) ())))))) + |}]; print_effect {| type () int_l @@ -266,10 +275,10 @@ let%expect_test "Test: program toplevel typing" = ++++++++++++++++++Scope Debug Info Begin++++++++++++++++++ Value Bindings: - co |-> forall . (TConsI (0 int_l) ()); - c |-> forall . (TConsI (0 int_l) ()) + co |-> forall . (Ty_cons (0 int_l) ()); + c |-> forall . (Ty_cons (0 int_l) ()) Type Definitions: - int_l |-> (TDAdtI int_l () ((Cons ((TConsI (0 int) ()))) (Nil ()))) + int_l |-> (Ty_def_adt int_l () ((Cons ((Ty_cons (0 int) ()))) (Nil ()))) Module Definitions: Module Types: @@ -295,14 +304,17 @@ let%expect_test "Test: program toplevel typing" = |}; [%expect {| - ((TopTypeDef (TDAdtI int_l () ((Cons ((TConsI (0 int) ()))) (Nil ())))) - (TopLet x (ECons Nil 1 (TConsI (0 int_l) ()))) - (TopLet f - (ECase (EVar x (TConsI (0 int_l) ())) - (((PCons Cons 0 ((PVar x (TConsI (0 int) ())))) - (EVar x (TConsI (0 int) ()))) - ((PCons Nil 1 ()) (EConst (CInt 0) (TConsI (0 int) ())))) - (TVarI (Link (TConsI (0 int) ())))))) |}]; + ((Top_type_def + (Ty_def_adt int_l () ((Cons ((Ty_cons (0 int) ()))) (Nil ())))) + (Top_let x (Exp_constr Nil 1 (Ty_cons (0 int_l) ()))) + (Top_let f + (Exp_case (Exp_var x (Ty_cons (0 int_l) ())) + (((Pat_constr Cons 0 ((Pat_var x (Ty_cons (0 int) ())))) + (Exp_var x (Ty_cons (0 int) ()))) + ((Pat_constr Nil 1 ()) + (Exp_const (Const_int 0) (Ty_cons (0 int) ())))) + (Ty_var (Link (Ty_cons (0 int) ())))))) + |}]; print_typed {| @@ -317,29 +329,30 @@ let%expect_test "Test: program toplevel typing" = |}; [%expect {| - ((TopTypeDef - (TDAdtI int_l ('a/0 'b/0) - ((Cons ((TTupleI ((TQVarI 'a/0) (TQVarI 'b/0))))) (Nil ())))) - (TopLet x - (ECons Nil 1 - (TConsI (0 int_l) ((TVarI (Unbound 'a/1 1)) (TVarI (Unbound 'b/2 1)))))) - (TopLet f - (ECase - (EVar x - (TConsI (0 int_l) - ((TVarI (Link (TVarI (Unbound '_t/8 1)))) - (TVarI (Link (TVarI (Unbound '_t/9 1))))))) - (((PCons Cons 0 - ((PTuple - ((PVar a (TVarI (Unbound '_t/8 1))) - (PVar b (TVarI (Unbound '_t/9 1))))))) - (ETuple - ((EVar b (TVarI (Unbound '_t/9 1))) - (EVar a (TVarI (Unbound '_t/8 1)))) - (TTupleI ((TVarI (Unbound '_t/9 1)) (TVarI (Unbound '_t/8 1))))))) - (TVarI + ((Top_type_def + (Ty_def_adt int_l ('a/0 'b/0) + ((Cons ((Ty_tuple ((Ty_qvar 'a/0) (Ty_qvar 'b/0))))) (Nil ())))) + (Top_let x + (Exp_constr Nil 1 + (Ty_cons (0 int_l) + ((Ty_var (Unbound 'a/1 1)) (Ty_var (Unbound 'b/2 1)))))) + (Top_let f + (Exp_case + (Exp_var x + (Ty_cons (0 int_l) + ((Ty_var (Link (Ty_var (Unbound '_t/8 1)))) + (Ty_var (Link (Ty_var (Unbound '_t/9 1))))))) + (((Pat_constr Cons 0 + ((Pat_tuple + ((Pat_var a (Ty_var (Unbound '_t/8 1))) + (Pat_var b (Ty_var (Unbound '_t/9 1))))))) + (Exp_tuple + ((Exp_var b (Ty_var (Unbound '_t/9 1))) + (Exp_var a (Ty_var (Unbound '_t/8 1)))) + (Ty_tuple ((Ty_var (Unbound '_t/9 1)) (Ty_var (Unbound '_t/8 1))))))) + (Ty_var (Link - (TTupleI ((TVarI (Unbound '_t/9 1)) (TVarI (Unbound '_t/8 1))))))))) + (Ty_tuple ((Ty_var (Unbound '_t/9 1)) (Ty_var (Unbound '_t/8 1))))))))) |}]; print_effect {| @@ -358,11 +371,11 @@ let%expect_test "Test: program toplevel typing" = ++++++++++++++++++Scope Debug Info Begin++++++++++++++++++ Value Bindings: - f |-> forall '_t/8;'_t/9 . (TTupleI ((TQVarI '_t/9) (TQVarI '_t/8))); - x |-> forall 'b/2;'a/1 . (TConsI (0 int_l) ((TQVarI 'a/1) (TQVarI 'b/2))) + f |-> forall '_t/8;'_t/9 . (Ty_tuple ((Ty_qvar '_t/9) (Ty_qvar '_t/8))); + x |-> forall 'b/2;'a/1 . (Ty_cons (0 int_l) ((Ty_qvar 'a/1) (Ty_qvar 'b/2))) Type Definitions: - int_l |-> (TDAdtI int_l ('a/0 'b/0) - ((Cons ((TTupleI ((TQVarI 'a/0) (TQVarI 'b/0))))) (Nil ()))) + int_l |-> (Ty_def_adt int_l ('a/0 'b/0) + ((Cons ((Ty_tuple ((Ty_qvar 'a/0) (Ty_qvar 'b/0))))) (Nil ()))) Module Definitions: Module Types: @@ -391,14 +404,17 @@ let%expect_test "Test: full program typing" = in print_typed {| let x = 1 |}; - [%expect {| ((TopLet x (EConst (CInt 1) (TConsI (0 int) ())))) |}]; + [%expect + {| ((Top_let x (Exp_const (Const_int 1) (Ty_cons (0 int) ())))) |}]; print_typed {| module M = struct let x = 1 end |}; [%expect {| - ((TopMod M - (MEStruct ((TopLet x (EConst (CInt 1) (TConsI (0 int) ())))) - (MTMod (id 1) (val_defs ((x (() (TConsI (0 int) ()))))) (constr_defs ()) - (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) |}]; + ((Top_mod M + (Mod_struct ((Top_let x (Exp_const (Const_int 1) (Ty_cons (0 int) ())))) + (Mod_ty_struct (id 1) (val_defs ((x (() (Ty_cons (0 int) ()))))) + (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) + (owned_mods ()))))) + |}]; print_typed {| module M = struct let x = 1 end @@ -406,17 +422,19 @@ let%expect_test "Test: full program typing" = |}; [%expect {| - ((TopMod M - (MEStruct ((TopLet x (EConst (CInt 1) (TConsI (0 int) ())))) - (MTMod (id 1) (val_defs ((x (() (TConsI (0 int) ()))))) (constr_defs ()) - (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())))) - (TopLet c - (EField - (MEName M - (MTMod (id 1) (val_defs ((x (() (TConsI (0 int) ()))))) + ((Top_mod M + (Mod_struct ((Top_let x (Exp_const (Const_int 1) (Ty_cons (0 int) ())))) + (Mod_ty_struct (id 1) (val_defs ((x (() (Ty_cons (0 int) ()))))) + (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) + (owned_mods ())))) + (Top_let c + (Exp_field + (Mod_name M + (Mod_ty_struct (id 1) (val_defs ((x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - x (TConsI (0 int) ())))) |}]; + x (Ty_cons (0 int) ())))) + |}]; print_typed {| module M = @@ -430,22 +448,23 @@ let%expect_test "Test: full program typing" = |}; [%expect {| - ((TopMod M - (MEStruct - ((TopTypeDef (TDAdtI t () ((Nil ())))) - (TopLet x (ECons Nil 0 (TConsI (1 t) ())))) - (MTMod (id 1) (val_defs ((x (() (TConsI (1 t) ()))))) - (constr_defs ((Nil ((() (TConsI (1 t) ())) 0)))) - (ty_defs ((TDAdtI t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) + ((Top_mod M + (Mod_struct + ((Top_type_def (Ty_def_adt t () ((Nil ())))) + (Top_let x (Exp_constr Nil 0 (Ty_cons (1 t) ())))) + (Mod_ty_struct (id 1) (val_defs ((x (() (Ty_cons (1 t) ()))))) + (constr_defs ((Nil ((() (Ty_cons (1 t) ())) 0)))) + (ty_defs ((Ty_def_adt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) (owned_mods ())))) - (TopLet c - (EField - (MEName M - (MTMod (id 1) (val_defs ((x (() (TConsI (1 t) ()))))) - (constr_defs ((Nil ((() (TConsI (1 t) ())) 0)))) - (ty_defs ((TDAdtI t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) - (owned_mods ()))) - x (TConsI (1 t) ())))) |}]; + (Top_let c + (Exp_field + (Mod_name M + (Mod_ty_struct (id 1) (val_defs ((x (() (Ty_cons (1 t) ()))))) + (constr_defs ((Nil ((() (Ty_cons (1 t) ())) 0)))) + (ty_defs ((Ty_def_adt t () ((Nil ()))))) (mod_sigs ()) + (mod_defs ()) (owned_mods ()))) + x (Ty_cons (1 t) ())))) + |}]; print_typed {| @@ -468,87 +487,90 @@ let%expect_test "Test: full program typing" = |}; [%expect {| - ((TopMod M - (MEStruct - ((TopTypeDef (TDAdtI t () ((Nil ())))) - (TopLet x (ECons Nil 0 (TConsI (1 t) ()))) - (TopMod N - (MEStruct ((TopTypeDef (TDAdtI t () ((Nil ()))))) - (MTMod (id 2) (val_defs ()) - (constr_defs ((Nil ((() (TConsI (2 t) ())) 0)))) - (ty_defs ((TDAdtI t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) - (owned_mods ())))) - (TopLet z - (EFieldCons - (MEName N - (MTMod (id 2) (val_defs ()) - (constr_defs ((Nil ((() (TConsI (2 t) ())) 0)))) - (ty_defs ((TDAdtI t () ((Nil ()))))) (mod_sigs ()) + ((Top_mod M + (Mod_struct + ((Top_type_def (Ty_def_adt t () ((Nil ())))) + (Top_let x (Exp_constr Nil 0 (Ty_cons (1 t) ()))) + (Top_mod N + (Mod_struct ((Top_type_def (Ty_def_adt t () ((Nil ()))))) + (Mod_ty_struct (id 2) (val_defs ()) + (constr_defs ((Nil ((() (Ty_cons (2 t) ())) 0)))) + (ty_defs ((Ty_def_adt t () ((Nil ()))))) (mod_sigs ()) + (mod_defs ()) (owned_mods ())))) + (Top_let z + (Exp_field_constr + (Mod_name N + (Mod_ty_struct (id 2) (val_defs ()) + (constr_defs ((Nil ((() (Ty_cons (2 t) ())) 0)))) + (ty_defs ((Ty_def_adt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - Nil 0 (TConsI (2 t) ())))) - (MTMod (id 1) - (val_defs ((z (() (TConsI (2 t) ()))) (x (() (TConsI (1 t) ()))))) - (constr_defs ((Nil ((() (TConsI (1 t) ())) 0)))) - (ty_defs ((TDAdtI t () ((Nil ()))))) (mod_sigs ()) + Nil 0 (Ty_cons (2 t) ())))) + (Mod_ty_struct (id 1) + (val_defs ((z (() (Ty_cons (2 t) ()))) (x (() (Ty_cons (1 t) ()))))) + (constr_defs ((Nil ((() (Ty_cons (1 t) ())) 0)))) + (ty_defs ((Ty_def_adt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ((N - (MTMod (id 2) (val_defs ()) - (constr_defs ((Nil ((() (TConsI (2 t) ())) 0)))) - (ty_defs ((TDAdtI t () ((Nil ()))))) (mod_sigs ()) + (Mod_ty_struct (id 2) (val_defs ()) + (constr_defs ((Nil ((() (Ty_cons (2 t) ())) 0)))) + (ty_defs ((Ty_def_adt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) (owned_mods (2))))) - (TopLet c - (EField - (MEName M - (MTMod (id 1) - (val_defs ((z (() (TConsI (2 t) ()))) (x (() (TConsI (1 t) ()))))) - (constr_defs ((Nil ((() (TConsI (1 t) ())) 0)))) - (ty_defs ((TDAdtI t () ((Nil ()))))) (mod_sigs ()) + (Top_let c + (Exp_field + (Mod_name M + (Mod_ty_struct (id 1) + (val_defs + ((z (() (Ty_cons (2 t) ()))) (x (() (Ty_cons (1 t) ()))))) + (constr_defs ((Nil ((() (Ty_cons (1 t) ())) 0)))) + (ty_defs ((Ty_def_adt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ((N - (MTMod (id 2) (val_defs ()) - (constr_defs ((Nil ((() (TConsI (2 t) ())) 0)))) - (ty_defs ((TDAdtI t () ((Nil ()))))) (mod_sigs ()) + (Mod_ty_struct (id 2) (val_defs ()) + (constr_defs ((Nil ((() (Ty_cons (2 t) ())) 0)))) + (ty_defs ((Ty_def_adt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) (owned_mods (2)))) - x (TConsI (1 t) ()))) - (TopLet x - (EFieldCons - (MEField - (MEName M - (MTMod (id 1) + x (Ty_cons (1 t) ()))) + (Top_let x + (Exp_field_constr + (Mod_field + (Mod_name M + (Mod_ty_struct (id 1) (val_defs - ((z (() (TConsI (2 t) ()))) (x (() (TConsI (1 t) ()))))) - (constr_defs ((Nil ((() (TConsI (1 t) ())) 0)))) - (ty_defs ((TDAdtI t () ((Nil ()))))) (mod_sigs ()) + ((z (() (Ty_cons (2 t) ()))) (x (() (Ty_cons (1 t) ()))))) + (constr_defs ((Nil ((() (Ty_cons (1 t) ())) 0)))) + (ty_defs ((Ty_def_adt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ((N - (MTMod (id 2) (val_defs ()) - (constr_defs ((Nil ((() (TConsI (2 t) ())) 0)))) - (ty_defs ((TDAdtI t () ((Nil ()))))) (mod_sigs ()) + (Mod_ty_struct (id 2) (val_defs ()) + (constr_defs ((Nil ((() (Ty_cons (2 t) ())) 0)))) + (ty_defs ((Ty_def_adt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) (owned_mods (2)))) N - (MTMod (id 2) (val_defs ()) - (constr_defs ((Nil ((() (TConsI (2 t) ())) 0)))) - (ty_defs ((TDAdtI t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) - (owned_mods ()))) - Nil 0 (TConsI (2 t) ()))) - (TopLet y - (EField - (MEName M - (MTMod (id 1) - (val_defs ((z (() (TConsI (2 t) ()))) (x (() (TConsI (1 t) ()))))) - (constr_defs ((Nil ((() (TConsI (1 t) ())) 0)))) - (ty_defs ((TDAdtI t () ((Nil ()))))) (mod_sigs ()) + (Mod_ty_struct (id 2) (val_defs ()) + (constr_defs ((Nil ((() (Ty_cons (2 t) ())) 0)))) + (ty_defs ((Ty_def_adt t () ((Nil ()))))) (mod_sigs ()) + (mod_defs ()) (owned_mods ()))) + Nil 0 (Ty_cons (2 t) ()))) + (Top_let y + (Exp_field + (Mod_name M + (Mod_ty_struct (id 1) + (val_defs + ((z (() (Ty_cons (2 t) ()))) (x (() (Ty_cons (1 t) ()))))) + (constr_defs ((Nil ((() (Ty_cons (1 t) ())) 0)))) + (ty_defs ((Ty_def_adt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ((N - (MTMod (id 2) (val_defs ()) - (constr_defs ((Nil ((() (TConsI (2 t) ())) 0)))) - (ty_defs ((TDAdtI t () ((Nil ()))))) (mod_sigs ()) + (Mod_ty_struct (id 2) (val_defs ()) + (constr_defs ((Nil ((() (Ty_cons (2 t) ())) 0)))) + (ty_defs ((Ty_def_adt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) (owned_mods (2)))) - z (TConsI (2 t) ())))) |}]; + z (Ty_cons (2 t) ())))) + |}]; print_typed {| @@ -565,21 +587,21 @@ let%expect_test "Test: full program typing" = |}; [%expect {| - ((TopMod M - (MERestrict - (MEStruct - ((TopTypeDef (TDAdtI t () ((Nil ())))) - (TopLet x (ECons Nil 0 (TConsI (1 t) ())))) - (MTMod (id 1) (val_defs ((x (() (TConsI (1 t) ()))))) - (constr_defs ((Nil ((() (TConsI (1 t) ())) 0)))) - (ty_defs ((TDAdtI t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) + ((Top_mod M + (Mod_restrict + (Mod_struct + ((Top_type_def (Ty_def_adt t () ((Nil ())))) + (Top_let x (Exp_constr Nil 0 (Ty_cons (1 t) ())))) + (Mod_ty_struct (id 1) (val_defs ((x (() (Ty_cons (1 t) ()))))) + (constr_defs ((Nil ((() (Ty_cons (1 t) ())) 0)))) + (ty_defs ((Ty_def_adt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - (MTMod (id 2) (val_defs ((x (() (TConsI (2 t) ()))))) (constr_defs ()) - (ty_defs ((TDOpaqueI t ()))) (mod_sigs ()) (mod_defs ()) - (owned_mods ())) - (MTMod (id 3) (val_defs ((x (() (TConsI (3 t) ()))))) (constr_defs ()) - (ty_defs ((TDOpaqueI t ()))) (mod_sigs ()) (mod_defs ()) - (owned_mods ()))))) + (Mod_ty_struct (id 2) (val_defs ((x (() (Ty_cons (2 t) ()))))) + (constr_defs ()) (ty_defs ((Ty_def_opaque t ()))) (mod_sigs ()) + (mod_defs ()) (owned_mods ())) + (Mod_ty_struct (id 3) (val_defs ((x (() (Ty_cons (3 t) ()))))) + (constr_defs ()) (ty_defs ((Ty_def_opaque t ()))) (mod_sigs ()) + (mod_defs ()) (owned_mods ()))))) |}]; print_typed @@ -593,10 +615,10 @@ let%expect_test "Test: full program typing" = |}; [%expect {| - ((TopModSig MIntf - (MTMod (id 1) (val_defs ((x (() (TConsI (1 t) ()))))) - (constr_defs ((Nil ((() (TConsI (1 t) ())) 0)))) - (ty_defs ((TDAdtI t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) + ((Top_mod_sig MIntf + (Mod_ty_struct (id 1) (val_defs ((x (() (Ty_cons (1 t) ()))))) + (constr_defs ((Nil ((() (Ty_cons (1 t) ())) 0)))) + (ty_defs ((Ty_def_adt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) (owned_mods ())))) |}]; @@ -621,9 +643,9 @@ let%expect_test "Test: full program typing" = Module Definitions: Module Types: - MIntf |-> (MTMod (id 1) (val_defs ((x (() (TConsI (1 t) ()))))) - (constr_defs ((Nil ((() (TConsI (1 t) ())) 0)))) - (ty_defs ((TDAdtI t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) + MIntf |-> (Mod_ty_struct (id 1) (val_defs ((x (() (Ty_cons (1 t) ()))))) + (constr_defs ((Nil ((() (Ty_cons (1 t) ())) 0)))) + (ty_defs ((Ty_def_adt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) (owned_mods ())) Module Creation History: 1 @@ -645,10 +667,11 @@ let%expect_test "Test: full program typing" = |}; [%expect {| - ((TopModSig MIntf - (MTMod (id 1) (val_defs ((x (() (TConsI (1 t) ()))))) (constr_defs ()) - (ty_defs ((TDOpaqueI t ()))) (mod_sigs ()) (mod_defs ()) - (owned_mods ())))) |}]; + ((Top_mod_sig MIntf + (Mod_ty_struct (id 1) (val_defs ((x (() (Ty_cons (1 t) ()))))) + (constr_defs ()) (ty_defs ((Ty_def_opaque t ()))) (mod_sigs ()) + (mod_defs ()) (owned_mods ())))) + |}]; print_typed {| @@ -671,28 +694,28 @@ let%expect_test "Test: full program typing" = |}; [%expect {| - ((TopModSig MIntf - (MTMod (id 1) (val_defs ((x (() (TConsI (1 t) ()))))) (constr_defs ()) - (ty_defs ((TDOpaqueI t ()))) (mod_sigs ()) (mod_defs ()) - (owned_mods ()))) - (TopMod MImpl - (MERestrict - (MEStruct - ((TopTypeDef (TDAdtI t () ((Nil ())))) - (TopLet z (EConst (CInt 1) (TConsI (0 int) ()))) - (TopLet x (ECons Nil 0 (TConsI (2 t) ())))) - (MTMod (id 2) + ((Top_mod_sig MIntf + (Mod_ty_struct (id 1) (val_defs ((x (() (Ty_cons (1 t) ()))))) + (constr_defs ()) (ty_defs ((Ty_def_opaque t ()))) (mod_sigs ()) + (mod_defs ()) (owned_mods ()))) + (Top_mod MImpl + (Mod_restrict + (Mod_struct + ((Top_type_def (Ty_def_adt t () ((Nil ())))) + (Top_let z (Exp_const (Const_int 1) (Ty_cons (0 int) ()))) + (Top_let x (Exp_constr Nil 0 (Ty_cons (2 t) ())))) + (Mod_ty_struct (id 2) (val_defs - ((x (() (TConsI (2 t) ()))) (z (() (TConsI (0 int) ()))))) - (constr_defs ((Nil ((() (TConsI (2 t) ())) 0)))) - (ty_defs ((TDAdtI t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) - (owned_mods ()))) - (MTMod (id 1) (val_defs ((x (() (TConsI (1 t) ()))))) (constr_defs ()) - (ty_defs ((TDOpaqueI t ()))) (mod_sigs ()) (mod_defs ()) - (owned_mods ())) - (MTMod (id 3) (val_defs ((x (() (TConsI (3 t) ()))))) (constr_defs ()) - (ty_defs ((TDOpaqueI t ()))) (mod_sigs ()) (mod_defs ()) - (owned_mods ()))))) + ((x (() (Ty_cons (2 t) ()))) (z (() (Ty_cons (0 int) ()))))) + (constr_defs ((Nil ((() (Ty_cons (2 t) ())) 0)))) + (ty_defs ((Ty_def_adt t () ((Nil ()))))) (mod_sigs ()) + (mod_defs ()) (owned_mods ()))) + (Mod_ty_struct (id 1) (val_defs ((x (() (Ty_cons (1 t) ()))))) + (constr_defs ()) (ty_defs ((Ty_def_opaque t ()))) (mod_sigs ()) + (mod_defs ()) (owned_mods ())) + (Mod_ty_struct (id 3) (val_defs ((x (() (Ty_cons (3 t) ()))))) + (constr_defs ()) (ty_defs ((Ty_def_opaque t ()))) (mod_sigs ()) + (mod_defs ()) (owned_mods ()))))) |}]; print_typed @@ -751,193 +774,194 @@ module MMM = (M(F).K : I) |}; [%expect {| - ((TopModSig I - (MTMod (id 1) - (val_defs ((y (() (TConsI (0 int) ()))) (x (() (TConsI (0 int) ()))))) + ((Top_mod_sig I + (Mod_ty_struct (id 1) + (val_defs ((y (() (Ty_cons (0 int) ()))) (x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - (TopModSig J - (MTMod (id 2) + (Top_mod_sig J + (Mod_ty_struct (id 2) (val_defs - ((z (() (TConsI (0 int) ()))) (y (() (TConsI (0 int) ()))) - (x (() (TConsI (0 int) ()))))) + ((z (() (Ty_cons (0 int) ()))) (y (() (Ty_cons (0 int) ()))) + (x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - (TopMod MJ - (MEStruct - ((TopLet x (EConst (CInt 1) (TConsI (0 int) ()))) - (TopLet y (EConst (CInt 1) (TConsI (0 int) ()))) - (TopLet z (EConst (CInt 1) (TConsI (0 int) ())))) - (MTMod (id 3) + (Top_mod MJ + (Mod_struct + ((Top_let x (Exp_const (Const_int 1) (Ty_cons (0 int) ()))) + (Top_let y (Exp_const (Const_int 1) (Ty_cons (0 int) ()))) + (Top_let z (Exp_const (Const_int 1) (Ty_cons (0 int) ())))) + (Mod_ty_struct (id 3) (val_defs - ((z (() (TConsI (0 int) ()))) (y (() (TConsI (0 int) ()))) - (x (() (TConsI (0 int) ()))))) + ((z (() (Ty_cons (0 int) ()))) (y (() (Ty_cons (0 int) ()))) + (x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())))) - (TopMod Simple - (MEStruct - ((TopLet x (EConst (CInt 1) (TConsI (0 int) ()))) - (TopLet y (EConst (CInt 2) (TConsI (0 int) ())))) - (MTMod (id 4) + (Top_mod Simple + (Mod_struct + ((Top_let x (Exp_const (Const_int 1) (Ty_cons (0 int) ()))) + (Top_let y (Exp_const (Const_int 2) (Ty_cons (0 int) ())))) + (Mod_ty_struct (id 4) (val_defs - ((y (() (TConsI (0 int) ()))) (x (() (TConsI (0 int) ()))))) + ((y (() (Ty_cons (0 int) ()))) (x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())))) - (TopMod M - (MEFunctor + (Top_mod M + (Mod_functor (MI - (MTFun - ((MTMod (id 1) + (Mod_ty_functor + ((Mod_ty_struct (id 1) (val_defs - ((y (() (TConsI (0 int) ()))) (x (() (TConsI (0 int) ()))))) + ((y (() (Ty_cons (0 int) ()))) (x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())) - (MTMod (id 1) + (Mod_ty_struct (id 1) (val_defs - ((y (() (TConsI (0 int) ()))) (x (() (TConsI (0 int) ()))))) + ((y (() (Ty_cons (0 int) ()))) (x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) - (MEStruct - ((TopMod K - (MEApply - (MEName MI - (MTFun - ((MTMod (id 1) + (Mod_struct + ((Top_mod K + (Mod_apply + (Mod_name MI + (Mod_ty_functor + ((Mod_ty_struct (id 1) (val_defs - ((y (() (TConsI (0 int) ()))) - (x (() (TConsI (0 int) ()))))) + ((y (() (Ty_cons (0 int) ()))) + (x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())) - (MTMod (id 1) + (Mod_ty_struct (id 1) (val_defs - ((y (() (TConsI (0 int) ()))) - (x (() (TConsI (0 int) ()))))) + ((y (() (Ty_cons (0 int) ()))) + (x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) - (MEName Simple - (MTMod (id 4) + (Mod_name Simple + (Mod_ty_struct (id 4) (val_defs - ((y (() (TConsI (0 int) ()))) - (x (() (TConsI (0 int) ()))))) + ((y (() (Ty_cons (0 int) ()))) + (x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - (MTMod (id 6) + (Mod_ty_struct (id 6) (val_defs - ((y (() (TConsI (0 int) ()))) (x (() (TConsI (0 int) ()))))) + ((y (() (Ty_cons (0 int) ()))) + (x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) - (MTMod (id 5) (val_defs ()) (constr_defs ()) (ty_defs ()) + (Mod_ty_struct (id 5) (val_defs ()) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ((K - (MTMod (id 6) + (Mod_ty_struct (id 6) (val_defs - ((y (() (TConsI (0 int) ()))) - (x (() (TConsI (0 int) ()))))) + ((y (() (Ty_cons (0 int) ()))) + (x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) (owned_mods (6)))))) - (TopMod F - (MEFunctor + (Top_mod F + (Mod_functor (MI - (MTMod (id 1) + (Mod_ty_struct (id 1) (val_defs - ((y (() (TConsI (0 int) ()))) (x (() (TConsI (0 int) ()))))) + ((y (() (Ty_cons (0 int) ()))) (x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - (MERestrict - (MEStruct - ((TopLet x (EConst (CInt 1) (TConsI (0 int) ()))) - (TopLet y (EConst (CInt 1) (TConsI (0 int) ()))) - (TopLet z (EConst (CInt 1) (TConsI (0 int) ())))) - (MTMod (id 7) + (Mod_restrict + (Mod_struct + ((Top_let x (Exp_const (Const_int 1) (Ty_cons (0 int) ()))) + (Top_let y (Exp_const (Const_int 1) (Ty_cons (0 int) ()))) + (Top_let z (Exp_const (Const_int 1) (Ty_cons (0 int) ())))) + (Mod_ty_struct (id 7) (val_defs - ((z (() (TConsI (0 int) ()))) (y (() (TConsI (0 int) ()))) - (x (() (TConsI (0 int) ()))))) + ((z (() (Ty_cons (0 int) ()))) (y (() (Ty_cons (0 int) ()))) + (x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - (MTMod (id 2) + (Mod_ty_struct (id 2) (val_defs - ((z (() (TConsI (0 int) ()))) (y (() (TConsI (0 int) ()))) - (x (() (TConsI (0 int) ()))))) + ((z (() (Ty_cons (0 int) ()))) (y (() (Ty_cons (0 int) ()))) + (x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())) - (MTMod (id 8) + (Mod_ty_struct (id 8) (val_defs - ((z (() (TConsI (0 int) ()))) (y (() (TConsI (0 int) ()))) - (x (() (TConsI (0 int) ()))))) + ((z (() (Ty_cons (0 int) ()))) (y (() (Ty_cons (0 int) ()))) + (x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) - (TopMod MMM - (MERestrict - (MEField - (MEApply - (MEName M - (MTFun - ((MTFun - ((MTMod (id 1) + (Top_mod MMM + (Mod_restrict + (Mod_field + (Mod_apply + (Mod_name M + (Mod_ty_functor + ((Mod_ty_functor + ((Mod_ty_struct (id 1) (val_defs - ((y (() (TConsI (0 int) ()))) - (x (() (TConsI (0 int) ()))))) + ((y (() (Ty_cons (0 int) ()))) + (x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())) - (MTMod (id 1) + (Mod_ty_struct (id 1) (val_defs - ((y (() (TConsI (0 int) ()))) - (x (() (TConsI (0 int) ()))))) + ((y (() (Ty_cons (0 int) ()))) + (x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())))) - (MTMod (id 5) (val_defs ()) (constr_defs ()) (ty_defs ()) - (mod_sigs ()) + (Mod_ty_struct (id 5) (val_defs ()) (constr_defs ()) + (ty_defs ()) (mod_sigs ()) (mod_defs ((K - (MTMod (id 6) + (Mod_ty_struct (id 6) (val_defs - ((y (() (TConsI (0 int) ()))) - (x (() (TConsI (0 int) ()))))) + ((y (() (Ty_cons (0 int) ()))) + (x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) (owned_mods (6)))))) - (MEName F - (MTFun - ((MTMod (id 1) + (Mod_name F + (Mod_ty_functor + ((Mod_ty_struct (id 1) (val_defs - ((y (() (TConsI (0 int) ()))) - (x (() (TConsI (0 int) ()))))) + ((y (() (Ty_cons (0 int) ()))) + (x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())) - (MTMod (id 8) + (Mod_ty_struct (id 8) (val_defs - ((z (() (TConsI (0 int) ()))) - (y (() (TConsI (0 int) ()))) - (x (() (TConsI (0 int) ()))))) + ((z (() (Ty_cons (0 int) ()))) + (y (() (Ty_cons (0 int) ()))) + (x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) - (MTMod (id 9) (val_defs ()) (constr_defs ()) (ty_defs ()) + (Mod_ty_struct (id 9) (val_defs ()) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ((K - (MTMod (id 10) + (Mod_ty_struct (id 10) (val_defs - ((y (() (TConsI (0 int) ()))) - (x (() (TConsI (0 int) ()))))) + ((y (() (Ty_cons (0 int) ()))) + (x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) (owned_mods (10)))) K - (MTMod (id 10) + (Mod_ty_struct (id 10) (val_defs - ((y (() (TConsI (0 int) ()))) (x (() (TConsI (0 int) ()))))) + ((y (() (Ty_cons (0 int) ()))) (x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - (MTMod (id 1) + (Mod_ty_struct (id 1) (val_defs - ((y (() (TConsI (0 int) ()))) (x (() (TConsI (0 int) ()))))) + ((y (() (Ty_cons (0 int) ()))) (x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())) - (MTMod (id 11) + (Mod_ty_struct (id 11) (val_defs - ((y (() (TConsI (0 int) ()))) (x (() (TConsI (0 int) ()))))) + ((y (() (Ty_cons (0 int) ()))) (x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) |}]; @@ -1007,63 +1031,64 @@ module MMM = (M(F).K : I) Type Definitions: Module Definitions: - MMM |-> (MTMod (id 13) - (val_defs ((y (() (TConsI (0 int) ()))) (x (() (TConsI (0 int) ()))))) + MMM |-> (Mod_ty_struct (id 13) + (val_defs ((y (() (Ty_cons (0 int) ()))) (x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())); - F |-> (MTFun - ((MTMod (id 1) - (val_defs ((y (() (TConsI (0 int) ()))) (x (() (TConsI (0 int) ()))))) + F |-> (Mod_ty_functor + ((Mod_ty_struct (id 1) + (val_defs ((y (() (Ty_cons (0 int) ()))) (x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())) - (MTMod (id 9) + (Mod_ty_struct (id 9) (val_defs - ((z (() (TConsI (0 int) ()))) (y (() (TConsI (0 int) ()))) - (x (() (TConsI (0 int) ()))))) + ((z (() (Ty_cons (0 int) ()))) (y (() (Ty_cons (0 int) ()))) + (x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())))); - M |-> (MTFun - ((MTFun - ((MTMod (id 1) + M |-> (Mod_ty_functor + ((Mod_ty_functor + ((Mod_ty_struct (id 1) (val_defs - ((y (() (TConsI (0 int) ()))) (x (() (TConsI (0 int) ()))))) + ((y (() (Ty_cons (0 int) ()))) (x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())) - (MTMod (id 1) + (Mod_ty_struct (id 1) (val_defs - ((y (() (TConsI (0 int) ()))) (x (() (TConsI (0 int) ()))))) + ((y (() (Ty_cons (0 int) ()))) (x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())))) - (MTMod (id 5) (val_defs ()) (constr_defs ()) (ty_defs ()) (mod_sigs ()) + (Mod_ty_struct (id 5) (val_defs ()) (constr_defs ()) (ty_defs ()) + (mod_sigs ()) (mod_defs ((K2 - (MTMod (id 7) + (Mod_ty_struct (id 7) (val_defs - ((y (() (TConsI (0 int) ()))) (x (() (TConsI (0 int) ()))))) + ((y (() (Ty_cons (0 int) ()))) (x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) (K - (MTMod (id 6) + (Mod_ty_struct (id 6) (val_defs - ((y (() (TConsI (0 int) ()))) (x (() (TConsI (0 int) ()))))) + ((y (() (Ty_cons (0 int) ()))) (x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) (owned_mods (7 6))))); - Simple |-> (MTMod (id 4) - (val_defs ((y (() (TConsI (0 int) ()))) (x (() (TConsI (0 int) ()))))) + Simple |-> (Mod_ty_struct (id 4) + (val_defs ((y (() (Ty_cons (0 int) ()))) (x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())); - MJ |-> (MTMod (id 3) + MJ |-> (Mod_ty_struct (id 3) (val_defs - ((z (() (TConsI (0 int) ()))) (y (() (TConsI (0 int) ()))) - (x (() (TConsI (0 int) ()))))) + ((z (() (Ty_cons (0 int) ()))) (y (() (Ty_cons (0 int) ()))) + (x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())) Module Types: - J |-> (MTMod (id 2) + J |-> (Mod_ty_struct (id 2) (val_defs - ((z (() (TConsI (0 int) ()))) (y (() (TConsI (0 int) ()))) - (x (() (TConsI (0 int) ()))))) + ((z (() (Ty_cons (0 int) ()))) (y (() (Ty_cons (0 int) ()))) + (x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())); - I |-> (MTMod (id 1) - (val_defs ((y (() (TConsI (0 int) ()))) (x (() (TConsI (0 int) ()))))) + I |-> (Mod_ty_struct (id 1) + (val_defs ((y (() (Ty_cons (0 int) ()))) (x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())) Module Creation History: 13; @@ -1094,11 +1119,12 @@ external print_int : int -> int = "ff_builtin_print_int" |}; [%expect {| - ((TopExternal add - (TArrowI (TConsI (0 int) ()) - (TArrowI (TConsI (0 int) ()) (TConsI (0 int) ()))) + ((Top_external add + (Ty_arrow (Ty_cons (0 int) ()) + (Ty_arrow (Ty_cons (0 int) ()) (Ty_cons (0 int) ()))) ff_add) - (TopExternal print_int (TArrowI (TConsI (0 int) ()) (TConsI (0 int) ())) + (Top_external print_int + (Ty_arrow (Ty_cons (0 int) ()) (Ty_cons (0 int) ())) ff_builtin_print_int)) |}]; @@ -1108,10 +1134,10 @@ external print_int : int -> int = "ff_builtin_print_int" |}; [%expect {| - ((TopLet x (EConst (CInt 1) (TConsI (0 int) ()))) - (TopLet n - (ECmp Eq (EVar x (TConsI (0 int) ())) - (EConst (CInt 1) (TConsI (0 int) ())) (TConsI (0 bool) ())))) + ((Top_let x (Exp_const (Const_int 1) (Ty_cons (0 int) ()))) + (Top_let n + (Exp_cmp Eq (Exp_var x (Ty_cons (0 int) ())) + (Exp_const (Const_int 1) (Ty_cons (0 int) ())) (Ty_cons (0 bool) ())))) |}]; print_effect {| @@ -1123,7 +1149,7 @@ external print_int : int -> int = "ff_builtin_print_int" ++++++++++++++++++Scope Debug Info Begin++++++++++++++++++ Value Bindings: - id |-> forall '_t/2 . (TArrowI (TQVarI '_t/2) (TQVarI '_t/2)) + id |-> forall '_t/2 . (Ty_arrow (Ty_qvar '_t/2) (Ty_qvar '_t/2)) Type Definitions: Module Definitions: @@ -1149,24 +1175,24 @@ external print_int : int -> int = "ff_builtin_print_int" |}; [%expect {| - ((TopMod M - (MEStruct - ((TopModSig N - (MTMod (id 2) (val_defs ()) (constr_defs ()) (ty_defs ()) + ((Top_mod M + (Mod_struct + ((Top_mod_sig N + (Mod_ty_struct (id 2) (val_defs ()) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())))) - (MTMod (id 1) (val_defs ()) (constr_defs ()) (ty_defs ()) + (Mod_ty_struct (id 1) (val_defs ()) (constr_defs ()) (ty_defs ()) (mod_sigs ((N - (MTMod (id 2) (val_defs ()) (constr_defs ()) (ty_defs ()) + (Mod_ty_struct (id 2) (val_defs ()) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) (mod_defs ()) (owned_mods (2))))) - (TopMod F - (MEFunctor + (Top_mod F + (Mod_functor (X - (MTMod (id 2) (val_defs ()) (constr_defs ()) (ty_defs ()) + (Mod_ty_struct (id 2) (val_defs ()) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - (MEStruct () - (MTMod (id 3) (val_defs ()) (constr_defs ()) (ty_defs ()) + (Mod_struct () + (Mod_ty_struct (id 3) (val_defs ()) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())))))) |}]; print_typed @@ -1181,24 +1207,24 @@ external print_int : int -> int = "ff_builtin_print_int" |}; [%expect {| - ((TopMod F - (MERestrict - (MERestrict - (MEStruct ((TopTypeDef (TDAliasI t (TConsI (0 int) ())))) - (MTMod (id 1) (val_defs ()) (constr_defs ()) - (ty_defs ((TDAliasI t (TConsI (0 int) ())))) (mod_sigs ()) + ((Top_mod F + (Mod_restrict + (Mod_restrict + (Mod_struct ((Top_type_def (Ty_def_alias t (Ty_cons (0 int) ())))) + (Mod_ty_struct (id 1) (val_defs ()) (constr_defs ()) + (ty_defs ((Ty_def_alias t (Ty_cons (0 int) ())))) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - (MTMod (id 2) (val_defs ()) (constr_defs ()) - (ty_defs ((TDOpaqueI t ()))) (mod_sigs ()) (mod_defs ()) + (Mod_ty_struct (id 2) (val_defs ()) (constr_defs ()) + (ty_defs ((Ty_def_opaque t ()))) (mod_sigs ()) (mod_defs ()) (owned_mods ())) - (MTMod (id 3) (val_defs ()) (constr_defs ()) - (ty_defs ((TDOpaqueI t ()))) (mod_sigs ()) (mod_defs ()) + (Mod_ty_struct (id 3) (val_defs ()) (constr_defs ()) + (ty_defs ((Ty_def_opaque t ()))) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - (MTMod (id 4) (val_defs ()) (constr_defs ()) - (ty_defs ((TDOpaqueI t ()))) (mod_sigs ()) (mod_defs ()) + (Mod_ty_struct (id 4) (val_defs ()) (constr_defs ()) + (ty_defs ((Ty_def_opaque t ()))) (mod_sigs ()) (mod_defs ()) (owned_mods ())) - (MTMod (id 5) (val_defs ()) (constr_defs ()) - (ty_defs ((TDOpaqueI t ()))) (mod_sigs ()) (mod_defs ()) + (Mod_ty_struct (id 5) (val_defs ()) (constr_defs ()) + (ty_defs ((Ty_def_opaque t ()))) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) |}] @@ -1257,50 +1283,54 @@ let%expect_test "Error reporting test" = |}; [%expect {| - ((TopModSig I - (MTMod (id 1) (val_defs ((x (() (TConsI (0 int) ()))))) (constr_defs ()) - (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - (TopMod F - (MERestrict - (MEStruct - ((TopTypeDef (TDAliasI t (TConsI (0 int) ()))) - (TopLet y (EConst (CInt 1) (TConsI (0 int) ())))) - (MTMod (id 2) (val_defs ((y (() (TConsI (0 int) ()))))) - (constr_defs ()) (ty_defs ((TDAliasI t (TConsI (0 int) ())))) + ((Top_mod_sig I + (Mod_ty_struct (id 1) (val_defs ((x (() (Ty_cons (0 int) ()))))) + (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) + (owned_mods ()))) + (Top_mod F + (Mod_restrict + (Mod_struct + ((Top_type_def (Ty_def_alias t (Ty_cons (0 int) ()))) + (Top_let y (Exp_const (Const_int 1) (Ty_cons (0 int) ())))) + (Mod_ty_struct (id 2) (val_defs ((y (() (Ty_cons (0 int) ()))))) + (constr_defs ()) (ty_defs ((Ty_def_alias t (Ty_cons (0 int) ())))) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - (MTMod (id 3) (val_defs ((y (() (TConsI (3 t) ()))))) (constr_defs ()) - (ty_defs ((TDOpaqueI t ()))) (mod_sigs ()) (mod_defs ()) - (owned_mods ())) - (MTMod (id 4) (val_defs ((y (() (TConsI (4 t) ()))))) (constr_defs ()) - (ty_defs ((TDOpaqueI t ()))) (mod_sigs ()) (mod_defs ()) - (owned_mods ()))))) - ((TopModSig I - (MTMod (id 1) (val_defs ((x (() (TConsI (0 int) ()))))) (constr_defs ()) - (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - (TopMod F - (MEFunctor + (Mod_ty_struct (id 3) (val_defs ((y (() (Ty_cons (3 t) ()))))) + (constr_defs ()) (ty_defs ((Ty_def_opaque t ()))) (mod_sigs ()) + (mod_defs ()) (owned_mods ())) + (Mod_ty_struct (id 4) (val_defs ((y (() (Ty_cons (4 t) ()))))) + (constr_defs ()) (ty_defs ((Ty_def_opaque t ()))) (mod_sigs ()) + (mod_defs ()) (owned_mods ()))))) + ((Top_mod_sig I + (Mod_ty_struct (id 1) (val_defs ((x (() (Ty_cons (0 int) ()))))) + (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) + (owned_mods ()))) + (Top_mod F + (Mod_functor (X - (MTMod (id 1) (val_defs ((x (() (TConsI (0 int) ()))))) + (Mod_ty_struct (id 1) (val_defs ((x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - (MERestrict - (MEStruct - ((TopTypeDef (TDAliasI t (TConsI (0 int) ()))) - (TopLet y - (EField - (MEName X - (MTMod (id 1) (val_defs ((x (() (TConsI (0 int) ()))))) + (Mod_restrict + (Mod_struct + ((Top_type_def (Ty_def_alias t (Ty_cons (0 int) ()))) + (Top_let y + (Exp_field + (Mod_name X + (Mod_ty_struct (id 1) + (val_defs ((x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - x (TConsI (0 int) ())))) - (MTMod (id 2) (val_defs ((y (() (TConsI (0 int) ()))))) - (constr_defs ()) (ty_defs ((TDAliasI t (TConsI (0 int) ())))) - (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - (MTMod (id 3) (val_defs ((y (() (TConsI (3 t) ()))))) - (constr_defs ()) (ty_defs ((TDOpaqueI t ()))) (mod_sigs ()) + x (Ty_cons (0 int) ())))) + (Mod_ty_struct (id 2) (val_defs ((y (() (Ty_cons (0 int) ()))))) + (constr_defs ()) + (ty_defs ((Ty_def_alias t (Ty_cons (0 int) ())))) (mod_sigs ()) + (mod_defs ()) (owned_mods ()))) + (Mod_ty_struct (id 3) (val_defs ((y (() (Ty_cons (3 t) ()))))) + (constr_defs ()) (ty_defs ((Ty_def_opaque t ()))) (mod_sigs ()) (mod_defs ()) (owned_mods ())) - (MTMod (id 4) (val_defs ((y (() (TConsI (4 t) ()))))) - (constr_defs ()) (ty_defs ((TDOpaqueI t ()))) (mod_sigs ()) + (Mod_ty_struct (id 4) (val_defs ((y (() (Ty_cons (4 t) ()))))) + (constr_defs ()) (ty_defs ((Ty_def_opaque t ()))) (mod_sigs ()) (mod_defs ()) (owned_mods ())))))) |}]; @@ -1354,32 +1384,35 @@ let%expect_test "Error reporting test" = |}; [%expect {| - ((TopModSig I - (MTMod (id 1) (val_defs ((x (() (TConsI (0 int) ()))))) (constr_defs ()) - (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - (TopMod F - (MEFunctor + ((Top_mod_sig I + (Mod_ty_struct (id 1) (val_defs ((x (() (Ty_cons (0 int) ()))))) + (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) + (owned_mods ()))) + (Top_mod F + (Mod_functor (X - (MTMod (id 1) (val_defs ((x (() (TConsI (0 int) ()))))) + (Mod_ty_struct (id 1) (val_defs ((x (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - (MERestrict - (MEStruct - ((TopTypeDef (TDAliasI t (TConsI (0 int) ()))) - (TopTypeDef (TDAliasI n (TConsI (0 int) ()))) - (TopLet y (EConst (CInt 3) (TConsI (0 int) ())))) - (MTMod (id 2) (val_defs ((y (() (TConsI (0 int) ()))))) + (Mod_restrict + (Mod_struct + ((Top_type_def (Ty_def_alias t (Ty_cons (0 int) ()))) + (Top_type_def (Ty_def_alias n (Ty_cons (0 int) ()))) + (Top_let y (Exp_const (Const_int 3) (Ty_cons (0 int) ())))) + (Mod_ty_struct (id 2) (val_defs ((y (() (Ty_cons (0 int) ()))))) (constr_defs ()) (ty_defs - ((TDAliasI n (TConsI (0 int) ())) - (TDAliasI t (TConsI (0 int) ())))) + ((Ty_def_alias n (Ty_cons (0 int) ())) + (Ty_def_alias t (Ty_cons (0 int) ())))) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - (MTMod (id 3) (val_defs ((y (() (TConsI (3 t) ()))))) - (constr_defs ()) (ty_defs ((TDOpaqueI t ()) (TDOpaqueI n ()))) - (mod_sigs ()) (mod_defs ()) (owned_mods ())) - (MTMod (id 4) (val_defs ((y (() (TConsI (4 t) ()))))) - (constr_defs ()) (ty_defs ((TDOpaqueI t ()) (TDOpaqueI n ()))) - (mod_sigs ()) (mod_defs ()) (owned_mods ())))))) + (Mod_ty_struct (id 3) (val_defs ((y (() (Ty_cons (3 t) ()))))) + (constr_defs ()) + (ty_defs ((Ty_def_opaque t ()) (Ty_def_opaque n ()))) (mod_sigs ()) + (mod_defs ()) (owned_mods ())) + (Mod_ty_struct (id 4) (val_defs ((y (() (Ty_cons (4 t) ()))))) + (constr_defs ()) + (ty_defs ((Ty_def_opaque t ()) (Ty_def_opaque n ()))) (mod_sigs ()) + (mod_defs ()) (owned_mods ())))))) |}]; print_typed @@ -1391,29 +1424,29 @@ let%expect_test "Error reporting test" = |}; [%expect {| - ((TopLet x - (ELet y - (ETuple - ((EConst (CInt 1) (TConsI (0 int) ())) - (EConst (CInt 1) (TConsI (0 int) ()))) - (TTupleI ((TConsI (0 int) ()) (TConsI (0 int) ())))) - (ELet z - (ETuple - ((EConst (CInt 2) (TConsI (0 int) ())) - (EConst (CInt 1) (TConsI (0 int) ()))) - (TTupleI ((TConsI (0 int) ()) (TConsI (0 int) ())))) - (ETuple - ((EVar y (TTupleI ((TConsI (0 int) ()) (TConsI (0 int) ())))) - (EVar z (TTupleI ((TConsI (0 int) ()) (TConsI (0 int) ()))))) - (TTupleI - ((TTupleI ((TConsI (0 int) ()) (TConsI (0 int) ()))) - (TTupleI ((TConsI (0 int) ()) (TConsI (0 int) ())))))) - (TTupleI - ((TTupleI ((TConsI (0 int) ()) (TConsI (0 int) ()))) - (TTupleI ((TConsI (0 int) ()) (TConsI (0 int) ())))))) - (TTupleI - ((TTupleI ((TConsI (0 int) ()) (TConsI (0 int) ()))) - (TTupleI ((TConsI (0 int) ()) (TConsI (0 int) ())))))))) + ((Top_let x + (Exp_let y + (Exp_tuple + ((Exp_const (Const_int 1) (Ty_cons (0 int) ())) + (Exp_const (Const_int 1) (Ty_cons (0 int) ()))) + (Ty_tuple ((Ty_cons (0 int) ()) (Ty_cons (0 int) ())))) + (Exp_let z + (Exp_tuple + ((Exp_const (Const_int 2) (Ty_cons (0 int) ())) + (Exp_const (Const_int 1) (Ty_cons (0 int) ()))) + (Ty_tuple ((Ty_cons (0 int) ()) (Ty_cons (0 int) ())))) + (Exp_tuple + ((Exp_var y (Ty_tuple ((Ty_cons (0 int) ()) (Ty_cons (0 int) ())))) + (Exp_var z (Ty_tuple ((Ty_cons (0 int) ()) (Ty_cons (0 int) ()))))) + (Ty_tuple + ((Ty_tuple ((Ty_cons (0 int) ()) (Ty_cons (0 int) ()))) + (Ty_tuple ((Ty_cons (0 int) ()) (Ty_cons (0 int) ())))))) + (Ty_tuple + ((Ty_tuple ((Ty_cons (0 int) ()) (Ty_cons (0 int) ()))) + (Ty_tuple ((Ty_cons (0 int) ()) (Ty_cons (0 int) ())))))) + (Ty_tuple + ((Ty_tuple ((Ty_cons (0 int) ()) (Ty_cons (0 int) ()))) + (Ty_tuple ((Ty_cons (0 int) ()) (Ty_cons (0 int) ())))))))) |}]; print_typed @@ -1447,87 +1480,93 @@ module L2 = (K: M) |}; [%expect {| - ((TopModSig M - (MTMod (id 1) (val_defs ()) (constr_defs ()) (ty_defs ()) (mod_sigs ()) + ((Top_mod_sig M + (Mod_ty_struct (id 1) (val_defs ()) (constr_defs ()) (ty_defs ()) + (mod_sigs ()) (mod_defs ((N - (MTMod (id 2) (val_defs ()) (constr_defs ()) - (ty_defs ((TDOpaqueI s ()) (TDOpaqueI t ()))) (mod_sigs ()) - (mod_defs ()) (owned_mods ()))))) + (Mod_ty_struct (id 2) (val_defs ()) (constr_defs ()) + (ty_defs ((Ty_def_opaque s ()) (Ty_def_opaque t ()))) + (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) (owned_mods (2)))) - (TopMod K - (MEStruct - ((TopMod N - (MEStruct - ((TopTypeDef (TDAliasI t (TConsI (0 int) ()))) - (TopTypeDef (TDAliasI s (TConsI (0 int) ())))) - (MTMod (id 4) (val_defs ()) (constr_defs ()) + (Top_mod K + (Mod_struct + ((Top_mod N + (Mod_struct + ((Top_type_def (Ty_def_alias t (Ty_cons (0 int) ()))) + (Top_type_def (Ty_def_alias s (Ty_cons (0 int) ())))) + (Mod_ty_struct (id 4) (val_defs ()) (constr_defs ()) (ty_defs - ((TDAliasI s (TConsI (0 int) ())) - (TDAliasI t (TConsI (0 int) ())))) + ((Ty_def_alias s (Ty_cons (0 int) ())) + (Ty_def_alias t (Ty_cons (0 int) ())))) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) - (MTMod (id 3) (val_defs ()) (constr_defs ()) (ty_defs ()) (mod_sigs ()) + (Mod_ty_struct (id 3) (val_defs ()) (constr_defs ()) (ty_defs ()) + (mod_sigs ()) (mod_defs ((N - (MTMod (id 4) (val_defs ()) (constr_defs ()) + (Mod_ty_struct (id 4) (val_defs ()) (constr_defs ()) (ty_defs - ((TDAliasI s (TConsI (0 int) ())) - (TDAliasI t (TConsI (0 int) ())))) + ((Ty_def_alias s (Ty_cons (0 int) ())) + (Ty_def_alias t (Ty_cons (0 int) ())))) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) (owned_mods (4))))) - (TopMod L1 - (MERestrict - (MEName K - (MTMod (id 3) (val_defs ()) (constr_defs ()) (ty_defs ()) + (Top_mod L1 + (Mod_restrict + (Mod_name K + (Mod_ty_struct (id 3) (val_defs ()) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ((N - (MTMod (id 4) (val_defs ()) (constr_defs ()) + (Mod_ty_struct (id 4) (val_defs ()) (constr_defs ()) (ty_defs - ((TDAliasI s (TConsI (0 int) ())) - (TDAliasI t (TConsI (0 int) ())))) + ((Ty_def_alias s (Ty_cons (0 int) ())) + (Ty_def_alias t (Ty_cons (0 int) ())))) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) (owned_mods (4)))) - (MTMod (id 1) (val_defs ()) (constr_defs ()) (ty_defs ()) (mod_sigs ()) + (Mod_ty_struct (id 1) (val_defs ()) (constr_defs ()) (ty_defs ()) + (mod_sigs ()) (mod_defs ((N - (MTMod (id 2) (val_defs ()) (constr_defs ()) - (ty_defs ((TDOpaqueI s ()) (TDOpaqueI t ()))) (mod_sigs ()) - (mod_defs ()) (owned_mods ()))))) + (Mod_ty_struct (id 2) (val_defs ()) (constr_defs ()) + (ty_defs ((Ty_def_opaque s ()) (Ty_def_opaque t ()))) + (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) (owned_mods (2))) - (MTMod (id 5) (val_defs ()) (constr_defs ()) (ty_defs ()) (mod_sigs ()) + (Mod_ty_struct (id 5) (val_defs ()) (constr_defs ()) (ty_defs ()) + (mod_sigs ()) (mod_defs ((N - (MTMod (id 6) (val_defs ()) (constr_defs ()) - (ty_defs ((TDOpaqueI s ()) (TDOpaqueI t ()))) (mod_sigs ()) - (mod_defs ()) (owned_mods ()))))) + (Mod_ty_struct (id 6) (val_defs ()) (constr_defs ()) + (ty_defs ((Ty_def_opaque s ()) (Ty_def_opaque t ()))) + (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) (owned_mods (6))))) - (TopMod L2 - (MERestrict - (MEName K - (MTMod (id 3) (val_defs ()) (constr_defs ()) (ty_defs ()) + (Top_mod L2 + (Mod_restrict + (Mod_name K + (Mod_ty_struct (id 3) (val_defs ()) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ((N - (MTMod (id 4) (val_defs ()) (constr_defs ()) + (Mod_ty_struct (id 4) (val_defs ()) (constr_defs ()) (ty_defs - ((TDAliasI s (TConsI (0 int) ())) - (TDAliasI t (TConsI (0 int) ())))) + ((Ty_def_alias s (Ty_cons (0 int) ())) + (Ty_def_alias t (Ty_cons (0 int) ())))) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) (owned_mods (4)))) - (MTMod (id 1) (val_defs ()) (constr_defs ()) (ty_defs ()) (mod_sigs ()) + (Mod_ty_struct (id 1) (val_defs ()) (constr_defs ()) (ty_defs ()) + (mod_sigs ()) (mod_defs ((N - (MTMod (id 2) (val_defs ()) (constr_defs ()) - (ty_defs ((TDOpaqueI s ()) (TDOpaqueI t ()))) (mod_sigs ()) - (mod_defs ()) (owned_mods ()))))) + (Mod_ty_struct (id 2) (val_defs ()) (constr_defs ()) + (ty_defs ((Ty_def_opaque s ()) (Ty_def_opaque t ()))) + (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) (owned_mods (2))) - (MTMod (id 7) (val_defs ()) (constr_defs ()) (ty_defs ()) (mod_sigs ()) + (Mod_ty_struct (id 7) (val_defs ()) (constr_defs ()) (ty_defs ()) + (mod_sigs ()) (mod_defs ((N - (MTMod (id 8) (val_defs ()) (constr_defs ()) - (ty_defs ((TDOpaqueI s ()) (TDOpaqueI t ()))) (mod_sigs ()) - (mod_defs ()) (owned_mods ()))))) + (Mod_ty_struct (id 8) (val_defs ()) (constr_defs ()) + (ty_defs ((Ty_def_opaque s ()) (Ty_def_opaque t ()))) + (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) (owned_mods (8)))))) |}]; @@ -1539,30 +1578,30 @@ module L2 = (K: M) |}; [%expect {| - ((TopLet result - (ELet id - (ELam - (x (EVar x (TVarI (Unbound '_t/1 4))) - (TArrowI (TVarI (Unbound '_t/1 4)) (TVarI (Unbound '_t/1 4))))) - (ETuple - ((EApp - (EVar id - (TArrowI (TVarI (Link (TConsI (0 int) ()))) - (TVarI (Link (TConsI (0 int) ()))))) - (EConst (CInt 1) (TConsI (0 int) ())) - (TVarI (Link (TConsI (0 int) ())))) - (EApp - (EVar id - (TArrowI (TVarI (Link (TConsI (0 string) ()))) - (TVarI (Link (TConsI (0 string) ()))))) - (EConst (CString "\"xx\"") (TConsI (0 string) ())) - (TVarI (Link (TConsI (0 string) ()))))) - (TTupleI - ((TVarI (Link (TConsI (0 int) ()))) - (TVarI (Link (TConsI (0 string) ())))))) - (TTupleI - ((TVarI (Link (TConsI (0 int) ()))) - (TVarI (Link (TConsI (0 string) ())))))))) + ((Top_let result + (Exp_let id + (Exp_lam + (x (Exp_var x (Ty_var (Unbound '_t/1 4))) + (Ty_arrow (Ty_var (Unbound '_t/1 4)) (Ty_var (Unbound '_t/1 4))))) + (Exp_tuple + ((Exp_app + (Exp_var id + (Ty_arrow (Ty_var (Link (Ty_cons (0 int) ()))) + (Ty_var (Link (Ty_cons (0 int) ()))))) + (Exp_const (Const_int 1) (Ty_cons (0 int) ())) + (Ty_var (Link (Ty_cons (0 int) ())))) + (Exp_app + (Exp_var id + (Ty_arrow (Ty_var (Link (Ty_cons (0 string) ()))) + (Ty_var (Link (Ty_cons (0 string) ()))))) + (Exp_const (Const_string "\"xx\"") (Ty_cons (0 string) ())) + (Ty_var (Link (Ty_cons (0 string) ()))))) + (Ty_tuple + ((Ty_var (Link (Ty_cons (0 int) ()))) + (Ty_var (Link (Ty_cons (0 string) ())))))) + (Ty_tuple + ((Ty_var (Link (Ty_cons (0 int) ()))) + (Ty_var (Link (Ty_cons (0 string) ())))))))) |}]; print_typed {| @@ -1606,24 +1645,24 @@ module L2 = (K: M) |}; [%expect {| - ((TopModSig MT - (MTMod (id 1) (val_defs ()) - (constr_defs ((Nil ((() (TConsI (1 t) ())) 0)))) - (ty_defs ((TDAdtI t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) + ((Top_mod_sig MT + (Mod_ty_struct (id 1) (val_defs ()) + (constr_defs ((Nil ((() (Ty_cons (1 t) ())) 0)))) + (ty_defs ((Ty_def_adt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - (TopMod M - (MERestrict - (MEStruct ((TopTypeDef (TDAdtI t () ((Nil ()))))) - (MTMod (id 2) (val_defs ()) - (constr_defs ((Nil ((() (TConsI (2 t) ())) 0)))) - (ty_defs ((TDAdtI t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) - (owned_mods ()))) - (MTMod (id 1) (val_defs ()) - (constr_defs ((Nil ((() (TConsI (1 t) ())) 0)))) - (ty_defs ((TDAdtI t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) + (Top_mod M + (Mod_restrict + (Mod_struct ((Top_type_def (Ty_def_adt t () ((Nil ()))))) + (Mod_ty_struct (id 2) (val_defs ()) + (constr_defs ((Nil ((() (Ty_cons (2 t) ())) 0)))) + (ty_defs ((Ty_def_adt t () ((Nil ()))))) (mod_sigs ()) + (mod_defs ()) (owned_mods ()))) + (Mod_ty_struct (id 1) (val_defs ()) + (constr_defs ((Nil ((() (Ty_cons (1 t) ())) 0)))) + (ty_defs ((Ty_def_adt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) (owned_mods ())) - (MTMod (id 3) (val_defs ()) - (constr_defs ((Nil ((() (TConsI (3 t) ())) 0)))) - (ty_defs ((TDAdtI t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) + (Mod_ty_struct (id 3) (val_defs ()) + (constr_defs ((Nil ((() (Ty_cons (3 t) ())) 0)))) + (ty_defs ((Ty_def_adt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) |}] diff --git a/tests/regular/unify_test.ml b/tests/regular/unify_test.ml index 2d358d2..aba59d6 100644 --- a/tests/regular/unify_test.ml +++ b/tests/regular/unify_test.ml @@ -9,30 +9,30 @@ let print_sexp s = let%expect_test "Test: unify typing" = let print_type ty = ty |> sexp_of_ty |> print_sexp in - let type_of x = TVarI { contents = Unbound (Ident.mk_ident 0 x, 0) } in + let type_of x = Ty_var { contents = Unbound (Ident.mk_ident 0 x, 0) } in let ret_ty = type_of "'ret" in let tv = type_of "'t" in unify tv int_ty; print_type tv; - [%expect {| (TVarI (Link (TConsI (0 int) ()))) |}]; - unify (TArrowI (tv, tv)) (TArrowI (int_ty, ret_ty)); + [%expect {| (Ty_var (Link (Ty_cons (0 int) ()))) |}]; + unify (Ty_arrow (tv, tv)) (Ty_arrow (int_ty, ret_ty)); print_type tv; - [%expect {| (TVarI (Link (TConsI (0 int) ()))) |}]; - let t1 = TVarI { contents = Unbound (Ident.mk_ident 0 "'t", 1) } in - let t2 = TVarI { contents = Unbound (Ident.mk_ident 1 "'t", 33) } in + [%expect {| (Ty_var (Link (Ty_cons (0 int) ()))) |}]; + let t1 = Ty_var { contents = Unbound (Ident.mk_ident 0 "'t", 1) } in + let t2 = Ty_var { contents = Unbound (Ident.mk_ident 1 "'t", 33) } in print_type t1; print_type t2; [%expect {| - (TVarI (Unbound 't/0 1)) - (TVarI (Unbound 't/1 33)) + (Ty_var (Unbound 't/0 1)) + (Ty_var (Unbound 't/1 33)) |}]; unify t1 t2; print_type t1; print_type t2; [%expect {| - (TVarI (Link (TVarI (Unbound 't/1 1)))) - (TVarI (Unbound 't/1 1)) + (Ty_var (Link (Ty_var (Unbound 't/1 1)))) + (Ty_var (Unbound 't/1 1)) |}]