diff --git a/lib/back/closure_translator.ml b/lib/back/closure_translator.ml index 9cbe161..f157dba 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 - | Field_simple (x, _) -> [ x ] - | Field_letrec (_, binds) -> fst (List.split binds)) + | FSimple (x, _) -> [ x ] + | FLetRec (_, 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 - | Exp_var x -> (List.assoc x ctx.dict, []) - | Exp_external ff_name -> + | EVar x -> (List.assoc x ctx.dict, []) + | EExt ff_name -> ( ff_name (* assume we can access an ff object by its external name*), [] ) - | Exp_let (x, e0, e1) -> + | ELet (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) - | Exp_const c -> + | EConst c -> let ret_v = create_decl "temp" ctx in (ret_v, [ make_assign (VARIABLE ret_v) (trans_const c) ]) - | Exp_tuple es -> + | ETuple 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) - | Exp_if (e0, e1, e2) -> + | EIf (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) ]) )); ] ) - | Exp_app (e0, e1s) -> + | EApp (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 )); ] ) - | Exp_constr i -> + | ECons 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)) ])); ] ) - | Exp_payload_constr i -> + | EConsWith 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)) ])); ] ) - | Exp_field (e, name) -> + | EField (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) ])); ] ) - | Exp_closure (fvs, cfunc) -> + | EClosure (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); ] )); ] ) - | Exp_letrec ((fvs, binds), body) -> + | ELetRec ((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) - | Exp_mod_obj members -> + | EModObject members -> let stmts, mems_c, ctx = List.fold_left (fun (stmts_acc, mems_c_acc, ctx) mem -> match mem with - | Field_simple (x, e) -> + | FSimple (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 ) - | Field_letrec (fvs, binds) -> + | FLetRec (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); ] )); ] ) - | Exp_switch (e, bs) -> + | ESwitch (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)); ] ) - | Exp_cmp (op, e0, e1) -> + | ECmp (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,19 +328,18 @@ and trans_expr ctx e = make_assign (VARIABLE is_eq_v) (CALL (eq_fn, [ VARIABLE e0_v; VARIABLE e1_v ])); ] ) - | Exp_seq (e0, e1) -> + | ESeq (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) - | Exp_struct _ -> ("todo", []) + | EStruct _ -> ("todo", []) and trans_const (c : S.constant) = match c with - | Const_bool b -> + | CBool b -> C.CALL (ff_make_bool, [ CONSTANT (CONST_INT (if b then "1" else "0")) ]) - | Const_int i -> - C.CALL (ff_make_int, [ CONSTANT (CONST_INT (string_of_int i)) ]) - | Const_string s -> + | CInt i -> C.CALL (ff_make_int, [ CONSTANT (CONST_INT (string_of_int i)) ]) + | CString s -> C.CALL ( ff_make_str, [ @@ -348,8 +347,7 @@ and trans_const (c : S.constant) = (CONST_STRING (Scanf.unescaped (String.sub s 1 (String.length s - 2)))); ] ) - | Const_unit -> - C.CALL (ff_make_int, [ CONSTANT (CONST_INT (string_of_int 0)) ]) + | CUnit -> 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 @@ -368,16 +366,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 - | Pat_var x -> + | PVar x -> let x, ctx = create_var ~need_decl:true x ctx in ([ Bind C.(BINARY (ASSIGN, VARIABLE x, VARIABLE cond_var)) ], ctx) - | Pat_val c -> + | PVal c -> ( [ CheckPat (C.CALL (ff_is_equal_aux, [ VARIABLE cond_var; trans_const c ])); ], ctx ) - | Pat_constr (id, None) -> + | PCons (id, None) -> ( [ CheckPat (C.CALL @@ -387,7 +385,7 @@ and analyze_match_sequence (cond_var : string) (p : pattern) ctx : ] )); ], ctx ) - | Pat_constr (id, Some p) -> + | PCons (id, Some p) -> let pat_var = create_decl "pat_var" ctx in let check = CheckPat @@ -401,7 +399,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) - | Pat_tuple ps -> + | PTuple 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 cae68bd..5f6d8c1 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 = - | Exp_tuple of expr list - | Exp_mod_obj of object_field list + | ETuple of expr list + | EModObject 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. *) - | 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 + | 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 and pattern = L.pattern and object_field = - | Field_simple of string * expr - | Field_letrec of closure_rec + | FSimple of string * expr + | FLetRec of closure_rec and closure = string list * Ident.ident diff --git a/lib/clos/lift.ml b/lib/clos/lift.ml index 39cf125..b4ace56 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.Exp_tuple es -> + | L.ETuple es -> es |> List.map (fun e -> lift e vars ~hint) |> List.split - |> fun (es, fns) -> (C.Exp_tuple es, List.flatten fns) - | L.Exp_mod_obj mems -> + |> fun (es, fns) -> (C.ETuple es, List.flatten fns) + | L.EModObject mems -> let _, mems, fns = List.fold_left (fun (vars, mem_acc, fn_acc) mem -> match mem with - | L.Field_simple (x, e) -> + | L.FSimple (x, e) -> let e, fns = lift ~hint:x e vars in - (x :: vars, C.Field_simple (x, e) :: mem_acc, fns @ fn_acc) - | L.Field_letrec binds -> + (x :: vars, C.FSimple (x, e) :: mem_acc, fns @ fn_acc) + | L.FLetRec binds -> let xs, _ = List.split binds in let binds, fns = lift_letrec binds vars in - (xs @ vars, C.Field_letrec binds :: mem_acc, fns @ fn_acc)) + (xs @ vars, C.FLetRec binds :: mem_acc, fns @ fn_acc)) (vars, [], []) mems in - (C.Exp_mod_obj (List.rev mems), fns) - | L.Exp_struct mems -> + (C.EModObject (List.rev mems), fns) + | L.EStruct 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.Exp_struct mems, fns) - | L.Exp_var x -> + (C.EStruct mems, fns) + | L.EVar x -> assert (List.mem x vars); - (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) -> + (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) -> 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.Exp_app (e0, e1s), fns0 @ fns1) - | L.Exp_cmp (op, e0, e1) -> + (C.EApp (e0, e1s), fns0 @ fns1) + | L.ECmp (op, e0, e1) -> let e0, fns0 = lift e0 vars in let e1, fns1 = lift e1 vars in - (C.Exp_cmp (op, e0, e1), fns0 @ fns1) - | L.Exp_seq (e0, e1) -> + (C.ECmp (op, e0, e1), fns0 @ fns1) + | L.ESeq (e0, e1) -> let e0, fns0 = lift e0 vars in let e1, fns1 = lift e1 vars in - (C.Exp_seq (e0, e1), fns0 @ fns1) - | L.Exp_switch (e0, bs) -> + (C.ESeq (e0, e1), fns0 @ fns1) + | L.ESwitch (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.Exp_switch (e0, List.combine ps es), fns0 @ fns1) - | L.Exp_let (x, e0, e1) -> + (C.ESwitch (e0, List.combine ps es), fns0 @ fns1) + | L.ELet (x, e0, e1) -> let e0, fns0 = lift ~hint:x e0 vars in let e1, fns1 = lift e1 (x :: vars) ~hint in - (C.Exp_let (x, e0, e1), fns0 @ fns1) - | L.Exp_if (e0, e1, e2) -> + (C.ELet (x, e0, e1), fns0 @ fns1) + | L.EIf (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.Exp_if (e0, e1, e2), fns0 @ fns1 @ fns2) - | L.Exp_lam (xs, e, fvs) -> + (C.EIf (e0, e1, e2), fns0 @ fns1 @ fns2) + | L.ELam (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.Exp_closure (!fvs, fn_id), new_fn :: fns) - | L.Exp_letrec (binds, e) -> + (C.EClosure (!fvs, fn_id), new_fn :: fns) + | L.ELetRec (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.Exp_letrec (cls, e), fns' @ fns) - | L.Exp_field (e, name) -> + (C.ELetRec (cls, e), fns' @ fns) + | L.EField (e, name) -> let e', fns = lift e vars ~hint in - (C.Exp_field (e', name), fns) + (C.EField (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 919910e..330da41 100644 --- a/lib/lam/compile.ml +++ b/lib/lam/compile.ml @@ -3,31 +3,27 @@ module L = Tree let rec compile_expr (e : T.expr) = match e with - | 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 + | 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 (List.map (fun (x, lam) -> (x, compile_lam lam)) lams, compile_expr e) - | 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) + | 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.TArrow (_, _)) -> L.EConsWith id + | T.ECons (_, id, _) -> L.ECons id + | T.EFieldCons (_, _, id, Typing.Types_in.TArrow (_, _)) -> 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) and compile_lam (x, e, _) = ([ x ], compile_expr e, ref []) @@ -35,11 +31,11 @@ and compile_branch (p, e) : L.branch = let compile_pattern p = let rec go p = match p with - | 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) + | 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) in go p in @@ -47,31 +43,30 @@ and compile_branch (p, e) : L.branch = and compile_mod_expr me = match me with - | 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' + | 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' and compile_top_levels tops = - L.Exp_mod_obj + L.EModObject (List.filter_map (fun (top : T.top_level) -> match top with - | T.Top_let (x, e) -> Some (L.Field_simple (x, compile_expr e)) - | T.Top_letrec binds -> + | T.TopLet (x, e) -> Some (L.FSimple (x, compile_expr e)) + | T.TopLetRec binds -> Some - (L.Field_letrec + (L.FLetRec (List.map (fun (x, lam) -> (x, compile_lam lam)) binds)) - | 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))) + | 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))) tops) let capture fvs vars = List.filter (fun x -> not (List.mem x vars)) fvs @@ -80,33 +75,32 @@ let get_pat_vars (p : L.pattern) = let all = ref [] in let rec go p = match p with - | 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 + | L.PVar x -> all := x :: !all + | L.PVal _ -> () + | L.PCons (_, None) -> () + | L.PCons (_, Some p) -> go p + | L.PTuple ps -> List.iter go ps in go p; !all let rec fva_expr e vars = match e with - | L.Exp_tuple es -> - List.fold_left (fun acc e -> fva_expr e vars @ acc) [] es - | L.Exp_mod_obj mems -> + | L.ETuple es -> List.fold_left (fun acc e -> fva_expr e vars @ acc) [] es + | L.EModObject mems -> let capture_vars = ref [] in let vars = ref vars in List.fold_left (fun acc mem -> match mem with - | L.Field_simple (name, e) -> + | L.FSimple (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.Field_letrec binds -> + | L.FLetRec binds -> let xs, _ = List.split binds in capture_vars := xs @ !capture_vars; let fvs_in_binds = fva_letrec binds !vars in @@ -114,39 +108,39 @@ let rec fva_expr e vars = vars := xs @ !vars; fvs @ acc) [] mems - | L.Exp_struct fields -> + | L.EStruct fields -> List.fold_left (fun acc (_, e) -> acc @ fva_expr e vars) [] fields - | L.Exp_var x' -> + | L.EVar x' -> assert (List.mem x' vars); [ x' ] - | L.Exp_external _x' -> [] - | L.Exp_constr _ -> [] - | L.Exp_payload_constr _ -> [] - | L.Exp_const _ -> [] - | L.Exp_app (e0, e1s) -> + | L.EExt _x' -> [] + | L.ECons _ -> [] + | L.EConsWith _ -> [] + | L.EConst _ -> [] + | L.EApp (e0, e1s) -> fva_expr e0 vars @ List.concat_map (fun e1 -> fva_expr e1 vars) e1s - | 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) -> + | 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) -> 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.Exp_let (x', e0, e1) -> + | L.ELet (x', e0, e1) -> fva_expr e0 vars @ capture (fva_expr e1 (x' :: vars)) [ x' ] - | L.Exp_if (e0, e1, e2) -> + | L.EIf (e0, e1, e2) -> fva_expr e0 vars @ fva_expr e1 vars @ fva_expr e2 vars - | L.Exp_lam (para, e, fvs) -> + | L.ELam (para, e, fvs) -> let fvs' = fva_lambda para e vars in fvs := List_utils.remove_from_left fvs'; fvs' - | L.Exp_letrec (binds, e) -> + | L.ELetRec (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.Exp_field (e, _) -> fva_expr e vars + | L.EField (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 920e191..cd908df 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 = - | 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 + | 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 and pattern = - | Pat_var of string - | Pat_val of constant - | Pat_constr of int * pattern option - | Pat_tuple of pattern list + | PVar of string + | PVal of constant + | PCons of int * pattern option + | PTuple of pattern list and object_field = - | Field_simple of string * expr - | Field_letrec of (string * lambda) list + | FSimple of string * expr + | FLetRec of (string * lambda) list and lambda = string list (* lambda parameters *) diff --git a/lib/syntax/parser.mly b/lib/syntax/parser.mly index bd253d7..aeff2e3 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 -> Ty_field (p, n, t_args) - | None, n -> Ty_cons (n, t_args) + | Some p, n -> TField(p, n, t_args) + | None, n -> TCons(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 { - Top_type_def td :: rest } + TopTypeDef td :: rest } | LET x=IDENT EQ e=expr rest=top_levels { - Top_let (x, e) + TopLet (x, e) :: rest } | LET REC funcs=separated_list(AND, function_bind) rest=top_levels { - Top_letrec funcs + TopLetRec funcs :: rest } | EXTERNAL x=IDENT COLON te=type_expr EQ s=STRING rest=top_levels { - Top_external (x, te, String.(sub s 1 (length s - 2))) + TopExternal (x, te, String.(sub s 1 (length s - 2))) :: rest } | MODULE m_name=MIDENT EQ m_body=mod_expr rest=top_levels { - Top_mod (m_name, m_body) + TopMod (m_name, m_body) :: rest } | MODULE TYPE m_name=MIDENT EQ mt=mod_type rest=top_levels { - Top_mod_sig (m_name, mt) + TopModSig (m_name, mt) :: rest } ; @@ -127,17 +127,17 @@ mod_expr: | LPAREN me=mod_expr RPAREN { me } | m_name=MIDENT - { make_node (Mod_name m_name) $startpos $endpos } + { make_node (MEName m_name) $startpos $endpos } | STRUCT m_body=top_levels END - { make_node (Mod_struct m_body) $startpos $endpos } + { make_node (MEStruct m_body) $startpos $endpos } | FUNCTOR LPAREN mp=mod_para RPAREN ARROW f_body=mod_expr - { make_node (Mod_functor (mp, f_body)) $startpos $endpos } + { make_node (MEFunctor (mp, f_body)) $startpos $endpos } | m = mod_expr DOT n = MIDENT - { make_node (Mod_field (m, n)) $startpos $endpos } + { make_node (MEField (m, n)) $startpos $endpos } | m1 = mod_expr LPAREN m2 = mod_expr RPAREN - { make_node (Mod_apply (m1, m2)) $startpos $endpos } + { make_node (MEApply (m1, m2)) $startpos $endpos } | m1 = mod_expr COLON mt1 = mod_type - { make_node (Mod_restrict (m1, mt1)) $startpos $endpos } + { make_node (MERestrict (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 - { Ty_def_adt (n, (List.map Ident.from tvs), vs) } + { TDAdt (n, (List.map Ident.from tvs), vs) } | TYPE UNIT n=IDENT EQ OR? vs=separated_list(OR, variant) %prec over_TOP - { Ty_def_adt (n, [], vs) } + { TDAdt (n, [], vs) } | TYPE tv=TYPEVAR n=IDENT EQ OR? vs=separated_list(OR, variant) %prec over_TOP - { Ty_def_adt (n, [ Ident.from tv ], vs) } + { TDAdt (n, [ Ident.from tv ], vs) } | TYPE n=IDENT EQ OR? vs=separated_list(OR, variant) %prec over_TOP - { Ty_def_adt (n, [], vs) } + { TDAdt (n, [], vs) } | TYPE n=IDENT EQ te=type_expr %prec over_TOP - { Ty_def_alias (n, te) } + { TDAlias (n, te) } pattern: - | 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) } + | 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) } | LPAREN pats=separated_nontrivial_llist(COMMA, pattern) RPAREN - { Pat_tuple (pats) } + { PTuple (pats) } ; parameter: - | n=IDENT { Para_bare n } - | LPAREN n=IDENT COLON t=type_expr RPAREN { Para_ann (n, t) } + | n=IDENT { PBare n } + | LPAREN n=IDENT COLON t=type_expr RPAREN { PAnn (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) { Ty_tuple ts } + | ts=separated_nontrivial_llist(STAR, type_expr) { TTuple 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 { 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 } + | 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 } path: - | m_name=MIDENT { make_node (Mod_name m_name) $startpos $endpos } - | m = path DOT n = MIDENT { make_node (Mod_field (m, n)) $startpos $endpos } + | m_name=MIDENT { make_node (MEName m_name) $startpos $endpos } + | m = path DOT n = MIDENT { make_node (MEField (m, n)) $startpos $endpos } expr: | c=constant %prec over_TOP - { make_node (Exp_const c) $startpos $endpos } + { make_node (EConst c) $startpos $endpos } | func=expr arg=expr %prec below_APP - { make_node (Exp_app (func, arg)) $startpos $endpos } + { make_node (EApp (func, arg)) $startpos $endpos } | LPAREN e=expr RPAREN { e } | c=MIDENT - { make_node (Exp_constr c) $startpos $endpos } + { make_node (ECons c) $startpos $endpos } | p=path DOT v=IDENT - { make_node (Exp_field (p, v)) $startpos $endpos } + { make_node (EField (p, v)) $startpos $endpos } | p=path DOT v=MIDENT - { make_node (Exp_field_constr (p, v)) $startpos $endpos } + { make_node (EFieldCons (p, v)) $startpos $endpos } | v=IDENT %prec over_TOP - { make_node (Exp_var v) $startpos $endpos } + { make_node (EVar v) $startpos $endpos } | LET x=IDENT EQ e1=expr IN e2=expr - { make_node (Exp_let (x, e1, e2)) $startpos $endpos } + { make_node (ELet (x, e1, e2)) $startpos $endpos } | LET REC binds=separated_nonempty_list(AND, function_bind) IN body=expr %prec over_TOP - { make_node (Exp_letrec (binds, body)) $startpos $endpos } + { make_node (ELetrec (binds, body)) $startpos $endpos } | IF e0=expr THEN e1=expr ELSE e2=expr - { make_node (Exp_if (e0, e1, e2)) $startpos $endpos } + { make_node (EIf (e0, e1, e2)) $startpos $endpos } | tu=tuple_expr { tu } | FUN para=parameter ARROW body=expr %prec over_TOP { - make_node (Exp_lam (para, body)) $startpos $endpos + make_node (ELam (para, body)) $startpos $endpos } | MATCH e=expr WITH OR? branches=separated_nonempty_list(OR, branch) %prec over_TOP { - make_node (Exp_case (e, branches)) $startpos $endpos + make_node (ECase (e, branches)) $startpos $endpos } | e=bin_expr { e } - | e=expr COLON te=type_expr { make_node (Exp_ann (e, te)) $startpos $endpos } + | e=expr COLON te=type_expr { make_node (EAnn (e, te)) $startpos $endpos } ; bin_expr: | e0=expr EQ e1=expr %prec EQ { - make_node (Exp_cmp (Eq, e0, e1)) $startpos $endpos + make_node (ECmp (Eq, e0, e1)) $startpos $endpos } | e0=expr NEQ e1=expr %prec EQ { - make_node (Exp_cmp (Neq, e0, e1)) $startpos $endpos + make_node (ECmp (Neq, e0, e1)) $startpos $endpos } | e0=expr SEMI e1=expr %prec below_SEMI { - make_node (Exp_seq (e0, e1)) $startpos $endpos + make_node (ESeq (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 (Exp_tuple es) $startpos $endpos } + { make_node (ETuple es) $startpos $endpos } mod_type: - | 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 } + | m=MIDENT { MTName m } + | p=mod_expr DOT m=MIDENT { MTField (p, m) } + | SIG comps=list(sig_comp) END { MTSig comps } | FUNCTOR LPAREN p=MIDENT COLON p_ty=mod_type RPAREN - ARROW body=mod_type { Mod_ty_functor (p, p_ty, body) } + ARROW body=mod_type { MTFunctor (p, p_ty, body) } sig_comp: - | VAL v=IDENT COLON ty=type_expr { Spec_value (v, ty) } + | VAL v=IDENT COLON ty=type_expr { SpecVal (v, ty) } | TYPE LPAREN tvs=separated_list(COMMA, TYPEVAR) RPAREN t=IDENT - { Spec_abstr (t, (List.map Ident.from tvs)) } + { SpecAbstTy (t, (List.map Ident.from tvs)) } | TYPE UNIT t=IDENT - { Spec_abstr (t, []) } - | def=type_def { Spec_mani_ty def } - | MODULE m_name=MIDENT COLON mt=mod_type { Spec_mod (m_name, mt) } + { SpecAbstTy (t, []) } + | def=type_def { SpecManiTy def } + | MODULE m_name=MIDENT COLON mt=mod_type { SpecMod (m_name, mt) } ; constant: - | i = INT { Const_int i } - | b = BOOL { Const_bool b } - | s = STRING { Const_string s } - | UNIT { Const_unit } ; + | i = INT { CInt i } + | b = BOOL { CBool b } + | s = STRING { CString s } + | UNIT { CUnit } ; (* 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 0dbdc51..0b0352d 100644 --- a/lib/syntax/parsetree.ml +++ b/lib/syntax/parsetree.ml @@ -1,10 +1,10 @@ open Sexplib.Conv type constant = - | Const_bool of bool - | Const_int of int - | Const_string of string - | Const_unit + | CBool of bool + | CInt of int + | CString of string + | CUnit [@@deriving sexp] type position = Lexing.position = { @@ -25,16 +25,16 @@ type 'a node = { and program = top_level list and top_level = - | 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 + | TopLet of string * expr + | TopLetRec of (string * lambda) list + | TopTypeDef of ty_def + | TopMod of string * mod_expr + | TopModSig of string * mod_ty + | TopExternal of string * ty * string and para = - | Para_ann of string * surface_ty - | Para_bare of string + | PAnn of string * ty + | PBare of string and paras = para list @@ -45,29 +45,28 @@ and cmp_op = and expr = expr_desc node and expr_desc = - | 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 + | 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 * ty + | ETuple of expr list + | EField of mod_expr * string + | EFieldCons of mod_expr * string + | ECmp of cmp_op * expr * expr + | ESeq of expr * expr and pattern = - | 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) *) + | 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) *) and lambda = para * expr @@ -76,47 +75,47 @@ and mod_body = top_level list and mod_expr = mod_expr_desc node and mod_expr_desc = - | 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 *) + | 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 * mod_ty (* M: M_ty *) -and functor_para = string * surface_mod_ty +and functor_para = string * mod_ty and functor_expr = functor_para * mod_expr -and adt_def = string * surface_ty_paras * evariant list +and adt_def = string * ty_paras * evariant list -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 spec = + | SpecVal of string * ty + | SpecAbstTy of string * ty_paras + | SpecManiTy of ty_def + | SpecMod of (string * mod_ty) -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 ty = + | TField of mod_expr * string * ty list (* T.Cons *) + | TCons of string * ty list (* Cons x *) + | TVar of Ident.ident (* 'var *) + | TArrow of ty * ty + | TTuple of ty list + | TRecord of (string * ty) list -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 ty_def = + | TDAdt of string * ty_paras * evariant list + | TDRecord of string * ty_paras * (string * ty) list + | TDAlias of string * ty -and surface_ty_paras = Ident.ident list +and ty_paras = Ident.ident list -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 mod_ty = + | MTName of string + | MTField of mod_expr * string + | MTSig of spec list + | MTFunctor of string * mod_ty * mod_ty -and evariant = string * surface_ty option [@@deriving sexp] +and evariant = string * 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 7dd7601..77612d2 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.Ty_cons (id, []) -> ( + | I.TCons (id, []) -> ( match List.assoc_opt id alias_map with | Some t' -> ( match t' with - | I.Ty_cons (id', []) -> I.Ty_cons (id', []) + | I.TCons (id', []) -> I.TCons (id', []) | _ -> failwith "ill form alias") | None -> t) - | I.Ty_cons (id, args) -> ( + | I.TCons (id, args) -> ( match List.assoc_opt id alias_map with | Some _t' -> failwith "parameterized type alias is not supported" - | None -> I.Ty_cons (id, List.map go args)) - | I.Ty_var { contents = I.Unbound _ } -> + | None -> I.TCons (id, List.map go args)) + | I.TVar { 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.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) + | I.TVar { contents = I.Link t' } -> go t' + | I.TQVar _ -> t + | I.TArrow (t0, t1) -> I.TArrow (go t0, go t1) + | I.TTuple tes -> I.TTuple (List.map go tes) + | I.TRecord fields -> + I.TRecord (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.Ty_def_opaque (_, _) -> td - | I.Ty_def_adt (name, paras, bs) -> - I.Ty_def_adt + | I.TDOpaque (_, _) -> td + | I.TDAdt (name, paras, bs) -> + I.TDAdt ( name, paras, List.map (fun (cname, t) -> (cname, Option.map (fun t' -> dealias_te t' alias_map) t)) bs ) - | I.Ty_def_record (name, paras, fields) -> - I.Ty_def_record + | I.TDRecord (name, paras, fields) -> + I.TDRecord ( name, paras, List.map (fun (name, t) -> (name, dealias_te t alias_map)) fields ) - | I.Ty_def_alias (name, t) -> I.Ty_def_alias (name, dealias_te t alias_map) + | I.TDAlias (name, t) -> I.TDAlias (name, dealias_te t alias_map) diff --git a/lib/typing/check.ml b/lib/typing/check.ml index d42264d..c45acce 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.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 + | 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 with | U.UnificationError (t0, t1) -> Report.unification_error t0 t1 e.start_loc e.end_loc env @@ -58,70 +58,68 @@ let rec check_expr (e : T.expr) (env : Env.t) : expr = and check_const c = match c with - | 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) + | 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) 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 - Exp_var (x, t) + EVar (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.Ty_arrow (pay_ty (* payload type *), te1) -> + | I.TArrow (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.Pat_var x, te -> (Pat_var (x, te), [ (x, te) ]) - | T.Pat_constr (c, None), te -> ( + | T.PVar x, te -> (PVar (x, te), [ (x, te) ]) + | T.PCons (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.Ty_cons _ -> (Pat_constr (c, id, None), []) + | I.TCons _ -> (PCons (c, id, None), []) | _ -> failwith (Printf.sprintf "wrong no-payload constructor pattern %s" c)) - | T.Pat_constr (c, Some p0 (* pattern *)), te -> + | T.PCons (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 - (Pat_constr (c, id, Some p0), binds) - | T.Pat_field_constr (me, c, None), te -> ( + (PCons (c, id, Some p0), binds) + | T.PFieldCons (me, c, None), te -> ( let cons_typed (* constructor *) = check_field_cons me c env in - let[@warning "-8"] (Exp_field_constr (_, _, id, _)) = cons_typed in + let[@warning "-8"] (EFieldCons (_, _, 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.Ty_cons (_, _) -> (Pat_constr (c, id, None), [ (* bind nothing *) ]) + | I.TCons (_, _) -> (PCons (c, id, None), [ (* bind nothing *) ]) | _ -> failwith "wrong type") - | T.Pat_field_constr (p (* path *), c, Some p0), te -> + | T.PFieldCons (p (* path *), c, Some p0), te -> let cons_typed (* typed constructor *) = check_field_cons p c env in - let[@warning "-8"] (Exp_field_constr (_, _, id, cons_ty)) = - cons_typed - in + let[@warning "-8"] (EFieldCons (_, _, id, cons_ty)) = cons_typed in let p0, binds = check_PCons_aux cons_ty p0 te in - (Pat_constr (c, id, Some p0), binds) - | T.Pat_val v, te -> + (PCons (c, id, Some p0), binds) + | T.PVal v, te -> let v_typed = check_const v in U.unify (get_ty v_typed) te; - (Pat_val v, []) - | T.Pat_tuple pats, te -> + (PVal v, []) + | T.PTuple pats, te -> let payload_tvs = List.map (fun _ -> P.make_tv ()) pats in - U.unify te (I.Ty_tuple payload_tvs); + U.unify te (I.TTuple payload_tvs); let pats, vars = List.fold_left2 (fun (pats_acc, vars_acc) pat te -> @@ -129,12 +127,12 @@ and check_pattern p te env : pattern * (string * I.ty) list = (pats_acc @ [ pat ], vars_acc @ vars)) ([], []) pats payload_tvs in - (Pat_tuple pats, vars) + (PTuple 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 - Exp_let (x, e0_typed, e1_typed, get_ty e1_typed) + ELet (x, e0_typed, e1_typed, get_ty e1_typed) and check_let_binding x e0 env : expr * Env.t = Poly.enter_level (); @@ -148,7 +146,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 - Exp_letrec (List.combine vars lams_typed, body_typed, get_ty body_typed) + ELetrec (List.combine vars lams_typed, body_typed, get_ty body_typed) and check_letrec_binding binds env = let origin_env = env in @@ -174,7 +172,7 @@ and check_letrec_binding binds env = let lams_typed = List.map (function - | Exp_lam (x, body, ty) -> (x, body, ty) + | ELam (x, body, ty) -> (x, body, ty) | _ -> failwith "neverreach") lams_typed in @@ -188,18 +186,18 @@ and check_letrec_binding binds env = and check_lambda para body env0 : expr = match para with - | T.Para_ann (x, t) -> + | T.PAnn (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 - Exp_lam (x, body0, I.Ty_arrow (ann, body_ty0)) - | T.Para_bare x -> + ELam (x, body0, I.TArrow (ann, body_ty0)) + | T.PBare 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 - Exp_lam (x, body0, I.Ty_arrow (tv, body_ty0)) + ELam (x, body0, I.TArrow (tv, body_ty0)) and check_if_else c e1 e2 env : expr = let c_typed = check_expr c env in @@ -207,7 +205,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); - Exp_if (c_typed, e1_typed, e2_typed, get_ty e1_typed) + EIf (c_typed, e1_typed, e2_typed, get_ty e1_typed) and check_app op arg env = let op_typed = check_expr op env in @@ -215,21 +213,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.Ty_arrow (arg_ty, tv)); - Exp_app (op_typed, arg_typed, tv) + U.unify op_ty (I.TArrow (arg_ty, tv)); + EApp (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); - Exp_cmp (op, e0_typed, e1_typed, I.bool_ty) + ECmp (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 - Exp_seq (e0_typed, e1_typed, e1_ty) + ESeq (e0_typed, e1_typed, e1_ty) and check_cases e bs env = let e_typed = check_expr e env in @@ -257,7 +255,7 @@ and check_cases e bs env = bs_typed @ [ (p, res_typed) ]) [] bs in - Exp_case (e_typed, bs_typed, res_ty) + ECase (e_typed, bs_typed, res_ty) and check_tuple es env = let es_typed = @@ -267,27 +265,27 @@ and check_tuple es env = acc @ [ e_typed ]) [] es in - let tu_te = I.Ty_tuple (List.map get_ty es_typed) in - Exp_tuple (es_typed, tu_te) + let tu_te = I.TTuple (List.map get_ty es_typed) in + ETuple (es_typed, tu_te) and check_cons c env = let t, id = Env.lookup_constr_type c env in - Exp_constr (c, id, P.inst t) + ECons (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.Mod_ty_struct { constr_defs; _ } -> + | I.MTMod { constr_defs; _ } -> let t, id = List.assoc c constr_defs in - Exp_field_constr (me_typed, c, id, P.inst t) - | I.Mod_ty_functor _ -> failwith "try get field from functor" + EFieldCons (me_typed, c, id, P.inst t) + | I.MTFun _ -> 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.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" + | I.MTMod { val_defs; _ } -> + EField (me_typed, x, P.inst (List.assoc x val_defs)) + | I.MTFun _ -> failwith "try get field from functor" and check_ann e te env = let e_typed = check_expr e env in @@ -301,43 +299,43 @@ and check_top_level (top : T.top_level) env : top_level * Env.t = reset_pool (); let top_typed = match top with - | T.Top_let (x, e) -> + | T.TopLet (x, e) -> let e_typed0, env = check_let_binding x e env in - (Top_let (x, e_typed0), env) - | T.Top_letrec binds -> + (TopLet (x, e_typed0), env) + | T.TopLetRec binds -> let env, vars, lams = check_letrec_binding binds env in let binds = List.combine vars lams in - (Top_letrec binds, env) - | T.Top_type_def (Ty_def_adt (name, ty_para_names, _) as def_ext) -> + (TopLetRec binds, env) + | T.TopTypeDef (TDAdt (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.Ty_def_opaque (name, ty_para_names)) env + Env.add_type_def (I.TDOpaque (name, ty_para_names)) env in let def = normalize_def def_ext normalize_env in - let[@warning "-8"] (I.Ty_def_adt (_, _, bs)) = def in + let[@warning "-8"] (I.TDAdt (_, _, 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 - (Top_type_def def, env) - | T.Top_type_def (_ as def_ext) -> + (TopTypeDef def, env) + | T.TopTypeDef (_ as def_ext) -> let def = normalize_def def_ext env in - (Top_type_def def, Env.add_type_def def env) - | T.Top_mod (name, me) -> + (TopTypeDef def, Env.add_type_def def env) + | T.TopMod (name, me) -> let me_typed = check_mod me env in - ( Top_mod (name, me_typed), + ( TopMod (name, me_typed), Env.add_module name (get_mod_ty me_typed) env ) - | T.Top_mod_sig (name, ext_mt) -> + | T.TopModSig (name, ext_mt) -> let mt = normalize_mt ext_mt env in - (Top_mod_sig (name, mt), Env.add_module_sig name mt env) - | T.Top_external (name, e_ty, ext_name) -> + (TopModSig (name, mt), Env.add_module_sig name mt env) + | T.TopExternal (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 - (Top_external (name, te, ext_name), Env.add_value name gen env) + (TopExternal (name, te, ext_name), Env.add_value name gen env) in tv_pool := old_pool; top_typed @@ -350,17 +348,15 @@ and analyze_constructors (tid : I.ty_id) para_names (bs : I.variant list) : | c, None -> ( c, ( ( para_names, - I.Ty_cons (tid, List.map (fun id -> I.Ty_qvar id) para_names) - ), + I.TCons (tid, List.map (fun id -> I.TQVar id) para_names) ), id ) ) | c, Some payload -> ( c, ( ( para_names, - I.Ty_arrow + I.TArrow ( payload, - Ty_cons - (tid, List.map (fun id -> I.Ty_qvar id) para_names) ) - ), + TCons (tid, List.map (fun id -> I.TQVar id) para_names) + ) ), id ) )) bs @@ -385,7 +381,7 @@ and make_mt_by_scope history; hints = _; } = - I.Mod_ty_struct + I.MTMod { id = curr; val_defs = values; @@ -399,36 +395,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.Mod_name name -> check_mod_name name env - | T.Mod_struct body -> check_struct body env - | T.Mod_functor ((name, ext_mt0), me1) -> + | T.MEName name -> check_mod_name name env + | T.MEStruct body -> check_struct body env + | T.MEFunctor ((name, ext_mt0), me1) -> check_functor name ext_mt0 me1 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 + | 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 in Env.try_record_hint me_typed env; me_typed -and check_mod_name name env = Mod_name (name, Env.lookup_module_def name env) +and check_mod_name name env = MEName (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 - Mod_struct (body_typed, mt) + MEStruct (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 - Mod_functor ((name, mt0), me1_typed) + MEFunctor ((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.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" + | I.MTMod { mod_defs; _ } -> + MEField (me_typed, name, List.assoc name mod_defs) + | I.MTFun _ -> failwith "try get field from functor" and check_mod_apply me0 me1 env = let me0_typed = check_mod me0 env in @@ -436,15 +432,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.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) + | 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) 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 - Mod_restrict (me_typed, mt, shift_mt mt env) + MERestrict (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 = @@ -460,7 +456,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.Mod_ty_struct + | I.MTMod { id; val_defs = _; @@ -478,7 +474,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.Mod_ty_functor (_para_mt, _body_mt) -> + | I.MTFun (_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. *) @@ -499,11 +495,11 @@ and shift_mt (mt : I.mod_ty) env : I.mod_ty = (* todo: remove this object *) inherit [_] Types_in.map as super - method! visit_Mod_ty_struct () id val_defs constr_defs ty_defs - mod_sigs mod_defs owned_mods = + method! visit_MTMod () id val_defs constr_defs ty_defs mod_sigs + mod_defs owned_mods = let shifted_id = get_id_or_default id in - super#visit_Mod_ty_struct () shifted_id val_defs constr_defs - ty_defs mod_sigs mod_defs + super#visit_MTMod () 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) @@ -520,10 +516,10 @@ and shift_mt (mt : I.mod_ty) env : I.mod_ty = in mapper mt -and normalize_def (t : T.surface_ty_def) env : I.ty_def = +and normalize_def (t : T.ty_def) env : I.ty_def = let normed = match t with - | T.Ty_def_adt (n, tvs, vs) -> + | T.TDAdt (n, tvs, vs) -> let vs = List.map (function @@ -531,74 +527,72 @@ and normalize_def (t : T.surface_ty_def) env : I.ty_def = | c, Some payload -> (c, Some (normalize payload Type env))) vs in - I.Ty_def_adt (n, tvs, vs) - | T.Ty_def_record (n, tvs, fields) -> - I.Ty_def_record + I.TDAdt (n, tvs, vs) + | T.TDRecord (n, tvs, fields) -> + I.TDRecord (n, tvs, List.map (fun (x, t) -> (x, normalize t Type env)) fields) - | T.Ty_def_alias (n, te) -> I.Ty_def_alias (n, normalize te Type env) + | T.TDAlias (n, te) -> I.TDAlias (n, normalize te Type env) in normed and normalize_ty t env = normalize t Let env -and normalize (t : T.surface_ty) (ctx : norm_ctx) (env : Env.t) : I.ty = +and normalize (t : T.ty) (ctx : norm_ctx) (env : Env.t) : I.ty = match t with - | T.Ty_field (me, n, tes) -> ( + | T.TField (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.Mod_ty_struct { id; ty_defs; _ } -> ( + | I.MTMod { id; ty_defs; _ } -> ( match I.get_def n ty_defs with - | I.Ty_def_opaque (_, _) - | I.Ty_def_adt (_, _, _) - | I.Ty_def_record (_, _, _) -> - Ty_cons ((id, n), tes) - | I.Ty_def_alias (_, te) -> ( + | I.TDOpaque (_, _) + | I.TDAdt (_, _, _) + | I.TDRecord (_, _, _) -> + TCons ((id, n), tes) + | I.TDAlias (_, te) -> ( match tes with | [] -> te | _ :: _ -> failwith "try to provide type parameter to a type alias")) - | I.Mod_ty_functor _ -> failwith "try get a field from functor") - | T.Ty_cons (c, tes) -> ( + | I.MTFun _ -> failwith "try get a field from functor") + | T.TCons (c, tes) -> ( let id, def = Env.lookup_type_def c env in match def with - | 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) -> ( + | I.TDOpaque (_, _) + | I.TDAdt (_, _, _) + | I.TDRecord (_, _, _) -> + TCons ((id, c), List.map (fun t -> normalize t ctx env) tes) + | I.TDAlias (_, te) -> ( match tes with | [] -> te | _ -> failwith "apply type to type alias")) - | T.Ty_var x -> ( + | T.TVar x -> ( match ctx with - | Type -> Ty_qvar x + | Type -> TQVar x | Let -> pool_make_tv x) - | 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) + | T.TArrow (t0, t1) -> TArrow (normalize t0 ctx env, normalize t1 ctx env) + | T.TTuple ts -> TTuple (List.map (fun t -> normalize t ctx env) ts) + | T.TRecord fields -> + TRecord (List.map (fun (x, t) -> (x, normalize t ctx env)) fields) -and normalize_mt (me : T.surface_mod_ty) env : I.mod_ty = +and normalize_mt (me : T.mod_ty) env : I.mod_ty = match me with - | T.Mod_ty_name name -> Env.lookup_module_sig name env - | T.Mod_ty_field (me, name) -> ( + | T.MTName name -> Env.lookup_module_sig name env + | T.MTField (me, name) -> ( let me_typed = check_mod me env in let mt = get_mod_ty me_typed in match mt with - | 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 -> + | I.MTMod mt -> List.assoc name mt.mod_sigs + | I.MTFun (_mt0, _mt1) -> failwith "try get field from functor") + | T.MTSig comps -> let env' = normalize_msig comps (Env.enter_env env) in let scope = absorb_history env' env in make_mt_by_scope scope - | T.Mod_ty_functor (m0, ext_mt0, m1) -> + | T.MTFunctor (m0, ext_mt0, m1) -> let mt0 = normalize_mt ext_mt0 env in let mt1 = normalize_mt m1 (Env.add_module m0 mt0 env) in - Mod_ty_functor (mt0, mt1) + MTFun (mt0, mt1) and normalize_msig comps env = match comps with @@ -606,18 +600,18 @@ and normalize_msig comps env = | comp :: comps -> let env = match comp with - | T.Spec_value (name, te) -> + | T.SpecVal (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.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 + | T.SpecAbstTy (name, paras) -> + Env.add_type_def (TDOpaque (name, paras)) env + | T.SpecManiTy def -> + let _, env = check_top_level (T.TopTypeDef def) env in env - | T.Spec_mod (name, ext_mt) -> + | T.SpecMod (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 1fd4f55..2c96908 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.Mod_ty_struct { id; _ } -> s.hints := (id, me_typed) :: !(s.hints) + | I.MTMod { 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.Ty_def_adt ("int", [], []) - | "string" -> I.Ty_def_adt ("string", [], []) - | "bool" -> I.Ty_def_adt ("bool", [], []) - | "unit" -> I.Ty_def_adt ("unit", [], []) + | "int" -> I.TDAdt ("int", [], []) + | "string" -> I.TDAdt ("string", [], []) + | "bool" -> I.TDAdt ("bool", [], []) + | "unit" -> I.TDAdt ("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.Ty_def_opaque (x, _) - | Ty_def_adt (x, _, _) - | Ty_def_record (x, _, _) - | Ty_def_alias (x, _) -> + | I.TDOpaque (x, _) + | TDAdt (x, _, _) + | TDRecord (x, _, _) + | TDAlias (x, _) -> x = tn) s.types with @@ -205,10 +205,10 @@ let dbg (env : t) = s.types |> List.map (fun def -> match def with - | 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)) + | I.TDOpaque (name, _) -> (name, def) + | I.TDAdt (name, _, _) -> (name, def) + | I.TDRecord (name, _, _) -> (name, def) + | I.TDAlias (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 96b3606..7927f9d 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.Ty_var (ref (I.Unbound (Ident.create ~hint:name, !current_level))) + I.TVar (ref (I.Unbound (Ident.create ~hint:name, !current_level))) let make_tv_of hint = - I.Ty_var (ref (I.Unbound (Ident.create ~hint, !current_level))) + I.TVar (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.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) + | I.TCons (tid, tes) -> I.TCons (tid, List.map go tes) + | I.TVar { contents = I.Unbound _ } -> te + | I.TVar { contents = I.Link t } -> go t + | I.TQVar qtv -> List.assoc qtv dict + | I.TArrow (te0, te1) -> TArrow (go te0, go te1) + | I.TTuple tes -> TTuple (List.map go tes) + | I.TRecord fields -> + I.TRecord (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.Ty_qvar (Ident.mk_ident i "_stable")) qvs + List.mapi (fun i _id -> I.TQVar (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.Ty_var { contents = I.Unbound (x, level) } -> + | I.TVar { 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.Ty_qvar x) + I.TQVar x) else t - | 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) + | I.TVar { contents = I.Link t } -> gen t + | I.TCons (c, tes) -> I.TCons (c, List.map gen tes) + | I.TQVar _ -> failwith "neverreach" + | I.TArrow (t1, t2) -> I.TArrow (gen t1, gen t2) + | I.TTuple tes -> I.TTuple (List.map gen tes) + | I.TRecord fields -> + I.TRecord (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 afcacd4..e818c79 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 - | Exp_const (Const_bool b, ty) -> + | EConst (CBool b, ty) -> pp_is_ty fmt Config.show_const_ty (fun _ -> Fmt.pp_print_bool fmt b) ty - | Exp_const (Const_int i, ty) -> + | EConst (CInt i, ty) -> pp_is_ty fmt Config.show_const_ty (fun _ -> Fmt.pp_print_int fmt i) ty - | Exp_const (Const_string s, ty) -> + | EConst (CString s, ty) -> pp_is_ty fmt Config.show_const_ty (fun _ -> Fmt.pp_print_string fmt (Printf.sprintf "\"%s\"" s)) ty - | Exp_const (Const_unit, ty) -> + | EConst (CUnit, ty) -> pp_is_ty fmt Config.show_const_ty (fun _ -> Fmt.pp_print_string fmt "()") ty - | Exp_var (x, ty) -> + | EVar (x, ty) -> pp_is_ty fmt Config.show_bind_ty (fun _ -> Fmt.pp_print_string fmt x) ty - | Exp_let (x, e0, e1, _) -> + | ELet (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 "@]" - | Exp_letrec (lams, body, _) -> + | ELetrec (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 "@]" - | Exp_lam (x, e, _) -> + | ELam (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 "@]" - | Exp_if (e0, e1, e2, _) -> + | EIf (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 "@]" - | Exp_case (cond, branches, _) -> + | ECase (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 "@]" - | Exp_app (op, arg, _) -> + | EApp (op, arg, _) -> pp_expr fmt op; Fmt.fprintf fmt " "; pp_expr fmt arg - | Exp_ann (e, te) -> + | EAnn (e, te) -> Fmt.fprintf fmt "@["; pp_expr fmt e; Fmt.fprintf fmt ":@["; pp_ty fmt te; Fmt.fprintf fmt "@]" - | Exp_tuple (es, _) -> + | ETuple (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 - | Exp_field (me, name, te) -> + | EField (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 - | Exp_field_constr (me, name, id, te) -> + | EFieldCons (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 - | Exp_constr (c, id, te) -> + | ECons (c, id, te) -> pp_is_ty fmt Config.show_bind_ty (fun _ -> Fmt.fprintf fmt "%s[%d]" c id) te - | Exp_cmp (op, e0, e1, te) -> + | ECmp (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 - | Exp_seq (e0, e1, _te) -> + | ESeq (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 - | Mod_name (name, _) -> Fmt.pp_print_string fmt name - | Mod_struct (tops, mt) -> + | MEName (name, _) -> Fmt.pp_print_string fmt name + | MEStruct (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 - | Mod_functor ((name, mt), me) -> + | MEFunctor ((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 "@]" - | Mod_field (me, name, _) -> + | MEField (me, name, _) -> Fmt.fprintf fmt "@["; pp_mod fmt ?env me; Fmt.fprintf fmt ".%s" name; Fmt.fprintf fmt "@]" - | Mod_apply (me0, me1, mt) -> + | MEApply (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 - | Mod_restrict (me, mt, mt') -> + | MERestrict (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 - | Top_let (x, e) -> + | TopLet (x, e) -> Fmt.fprintf fmt "@[let %s = " x; pp_expr fmt e; Fmt.fprintf fmt "@]" - | Top_letrec lams -> ( + | TopLetRec 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 "@]") - | Top_type_def td -> pp_ty_def fmt td - | Top_mod (name, me) -> + | TopTypeDef td -> pp_ty_def fmt td + | TopMod (name, me) -> Fmt.fprintf fmt "@[module %s = @\n" name; pp_mod fmt me; Fmt.fprintf fmt "@]" - | Top_mod_sig (name, mt) -> + | TopModSig (name, mt) -> Fmt.fprintf fmt "@[module type %s = @\n" name; pp_mod_ty fmt mt; Fmt.fprintf fmt "@]" - | Top_external (name, te, ext_name) -> + | TopExternal (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.Ty_def_opaque (name, paras) -> + | I.TDOpaque (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 - | Ty_def_adt (name, tvs, vs (* variants *)) -> + | TDAdt (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.Ty_def_record (name, tvs, fields) -> + | I.TDRecord (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.Ty_def_alias (name, te) -> + | I.TDAlias (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.Ty_cons ((id, name), tes) -> + | I.TCons ((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.Ty_var { contents = I.Unbound (tv, _level) } -> + | I.TVar { contents = I.Unbound (tv, _level) } -> Fmt.fprintf fmt "{%s}" (Ident.show_ident tv) - | I.Ty_var { contents = I.Link te } -> + | I.TVar { contents = I.Link te } -> Fmt.fprintf fmt "{"; pp_ty fmt te; Fmt.fprintf fmt "}" - | I.Ty_qvar tv -> Fmt.fprintf fmt "[%s]" (Ident.show_ident tv) - | I.Ty_arrow (arg_ty, ret_ty) -> + | I.TQVar tv -> Fmt.fprintf fmt "[%s]" (Ident.show_ident tv) + | I.TArrow (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.Ty_tuple [] -> failwith "neverreach" - | I.Ty_tuple (te0 :: tes) -> + | I.TTuple [] -> failwith "neverreach" + | I.TTuple (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.Ty_record fields -> + | I.TRecord fields -> Fmt.fprintf fmt "{@["; pp_fields fmt fields; Fmt.fprintf fmt "@]}@\n" and pp_pattern fmt p = match p with - | 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) -> ( + | 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) -> ( 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 ")") - | Pat_var (x, ty) -> + | PVar (x, ty) -> pp_is_ty fmt Config.show_const_ty (fun _ -> Fmt.pp_print_string fmt x) ty - | Pat_tuple [] -> failwith "neverreach" - | Pat_tuple (p :: ps) -> + | PTuple [] -> failwith "neverreach" + | PTuple (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.Mod_ty_struct + | I.MTMod { 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.Mod_ty_functor (mt0, mt1) -> + | I.MTFun (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 b73f777..619ddb6 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 - Unification_err of T.ty * T.ty * Lexing.position * Lexing.position * Env.t + UnificationError of T.ty * T.ty * Lexing.position * Lexing.position * Env.t let unification_error t0 t1 loc1 loc2 env = - raise (Unification_err (t0, t1, loc1, loc2, env)) + raise (UnificationError (t0, t1, loc1, loc2, env)) -exception Component_incompatible of string * T.bind_ty * T.bind_ty +exception ComponentInCompatible of string * T.bind_ty * T.bind_ty let in_compatible_error name t0 t1 = - raise (Component_incompatible (name, t0, t1)) + raise (ComponentInCompatible (name, t0, t1)) -exception Occur_err of string * T.ty * Lexing.position * Lexing.position +exception OccurError of string * T.ty * Lexing.position * Lexing.position let occur_error tv te loc1 loc2 = match !tv with | T.Unbound (v, _lvl) -> - raise (Occur_err (Ident.to_string v, te, loc1, loc2)) + raise (OccurError (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 - | Unification_err (t0, t1, start, last, env) -> + | UnificationError (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 - | Occur_err (tv, te, start, last) -> + | OccurError (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 - | Component_incompatible (name, (_, t0), (_, t1)) -> + | ComponentInCompatible (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 d959b8f..9ee8b24 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.Mod_ty_struct { id = id0; mod_defs = mds0; _ }, - I.Mod_ty_struct { id = id1; mod_defs = mds1; _ } ) -> + | ( I.MTMod { id = id0; mod_defs = mds0; _ }, + I.MTMod { 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.Mod_ty_functor (argt0, mt0), I.Mod_ty_functor (argt1, mt1) -> + | I.MTFun (argt0, mt0), I.MTFun (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.Mod_ty_struct + | ( I.MTMod { val_defs = vds0; constr_defs = cds0; @@ -59,7 +59,7 @@ let compatible mt0 mt1 = id = id0; _; }, - I.Mod_ty_struct + I.MTMod { val_defs = vds1; constr_defs = cds1; @@ -71,17 +71,17 @@ let compatible mt0 mt1 = List.iter (fun td1 -> match td1 with - | I.Ty_def_opaque (name, paras) -> ( + | I.TDOpaque (name, paras) -> ( let td0 = I.get_def name tds0 in match td0 with - | I.Ty_def_opaque (_, paras0) - | I.Ty_def_adt (_, paras0, _) - | I.Ty_def_record (_, paras0, _) -> + | I.TDOpaque (_, paras0) + | I.TDAdt (_, paras0, _) + | I.TDRecord (_, paras0, _) -> if List.length paras0 <> List.length paras then failwith "number of type parameter not compatible in opaque \ type" - | I.Ty_def_alias (_, ty0) -> ( + | I.TDAlias (_, 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.Mod_ty_functor (argt0, mt0), I.Mod_ty_functor (argt1, mt1) -> + | I.MTFun (argt0, mt0), I.MTFun (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 36c40b9..42b8b93 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 = - | 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 + | 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 (* constructor like Cons *) string * int (* constructor id *) * ty - | Exp_field_constr of + | EFieldCons of (* constructor like M.Cons *) mod_expr * string * int (* constructor id *) * ty - | Exp_cmp of T.cmp_op * expr * expr * ty - | Exp_seq of expr * expr * ty + | ECmp of T.cmp_op * expr * expr * ty + | ESeq 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 = - | 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 + | 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 and top_level = - | 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 + | 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 and program = top_level list and pattern = (* simplest pattern is enough after type info has been filled *) - | 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) *) + | PVal of constant + | PCons of string * int * pattern option (* Cons (1, 2) *) + | PVar of string * ty + | PTuple of pattern list (* (x, y, z) *) [@@deriving sexp] let get_ty = function - | 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) -> + | 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) -> ty let rec get_mod_ty (me : mod_expr) = match me with - | Mod_name (_, ty) - | Mod_struct (_, ty) - | Mod_field (_, _, ty) - | Mod_restrict (_, _, ty) - | Mod_apply (_, _, ty) -> + | MEName (_, ty) + | MEStruct (_, ty) + | MEField (_, _, ty) + | MERestrict (_, _, ty) + | MEApply (_, _, ty) -> ty - | Mod_functor ((_, mt0), me1) -> Mod_ty_functor (mt0, get_mod_ty me1) + | MEFunctor ((_, mt0), me1) -> MTFun (mt0, get_mod_ty me1) diff --git a/lib/typing/types_in.ml b/lib/typing/types_in.ml index 7bbc95b..5a38678 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 = - | 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 + | TCons of ty_id * ty list (* x list *) + | TVar of tv ref (* 'var *) + | TQVar of Ident.ident + | TArrow of ty * ty + | TTuple of ty list + | TRecord 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 = - | 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 + | TDOpaque of string * type_paras + | TDAdt of string * type_paras * variant list + | TDRecord of string * type_paras * (string * ty) list + | TDAlias of string * ty and mod_ty = - | Mod_ty_struct of { + | MTMod 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; } - | Mod_ty_functor of (mod_ty * mod_ty) + | MTFun 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_Ty_var () tv = + method! visit_TVar () tv = match !tv with - | Unbound _ -> Ty_var tv + | Unbound _ -> TVar 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 = Ty_cons (mk_root_tid "int", []) +let int_ty = TCons (mk_root_tid "int", []) -let string_ty = Ty_cons (mk_root_tid "string", []) +let string_ty = TCons (mk_root_tid "string", []) -let bool_ty = Ty_cons (mk_root_tid "bool", []) +let bool_ty = TCons (mk_root_tid "bool", []) -let unit_ty = Ty_cons (mk_root_tid "unit", []) +let unit_ty = TCons (mk_root_tid "unit", []) let same_def td0 td1 = td0 = td1 let get_def_name (td : ty_def) = match td with - | Ty_def_opaque (name, _) - | Ty_def_adt (name, _, _) - | Ty_def_record (name, _, _) - | Ty_def_alias (name, _) -> + | TDOpaque (name, _) + | TDAdt (name, _, _) + | TDRecord (name, _, _) + | TDAlias (name, _) -> name let get_def name ty_defs = List.find (fun td -> match td with - | Ty_def_opaque (name', _) - | Ty_def_adt (name', _, _) - | Ty_def_record (name', _, _) - | Ty_def_alias (name', _) + | TDOpaque (name', _) + | TDAdt (name', _, _) + | TDRecord (name', _, _) + | TDAlias (name', _) when name' = name -> true | _ -> false) diff --git a/lib/typing/unify.ml b/lib/typing/unify.ml index c494fd9..82e31f8 100644 --- a/lib/typing/unify.ml +++ b/lib/typing/unify.ml @@ -11,28 +11,27 @@ exception IllFormType let occurs (tpv : tv ref) (te : ty) : unit = let rec go te = match te with - | Ty_tuple tes - | Ty_cons (_, tes) -> + | TTuple tes + | TCons (_, tes) -> List.iter go tes - | Ty_var tpv' when tpv == tpv' -> ( + | TVar tpv' when tpv == tpv' -> ( match tpv with | { contents = Unbound _ } -> raise (OccurError (tpv, te)) | { contents = Link _ } -> failwith "illegal occur check value") - | Ty_var { contents = Link te } -> go te - | Ty_var ({ contents = Unbound (tvn', level') } as tpv') -> + | TVar { contents = Link te } -> go te + | TVar ({ 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) - | Ty_qvar _ -> - failwith "internal error: unify with quantified type variable" - | Ty_arrow (te1, te2) -> + | TQVar _ -> () + | TArrow (te1, te2) -> go te1; go te2 - | Ty_record fields -> List.map snd fields |> List.iter go + | TRecord fields -> List.map snd fields |> List.iter go in let rec strip te : ty = match te with - | Ty_var { contents = Link te } -> strip te + | TVar { contents = Link te } -> strip te | _ -> te in go (strip te) @@ -42,17 +41,17 @@ let rec unify (t0 : ty) (t1 : ty) : unit = else match (t0, t1) with (* strip links *) - | 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) -> + | TVar { contents = Link t0 }, t1 -> unify t0 t1 + | t0, TVar { contents = Link t1 } -> unify t0 t1 + | TVar ({ contents = Unbound _ } as tv0), t1 + | t1, TVar ({ contents = Unbound _ } as tv0) -> occurs tv0 t1; tv0.contents <- Link t1 - | Ty_cons (tc0, tes0), Ty_cons (tc1, tes1) when tc0 = tc1 -> + | TCons (tc0, tes0), TCons (tc1, tes1) when tc0 = tc1 -> unify_lst tes0 tes1 - | Ty_arrow (op0, arg0), Ty_arrow (op1, arg1) -> + | TArrow (op0, arg0), TArrow (op1, arg1) -> unify_lst [ op0; arg0 ] [ op1; arg1 ] - | Ty_tuple tes0, Ty_tuple tes1 -> unify_lst tes0 tes1 + | TTuple tes0, TTuple 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 8693300..d16a290 100644 --- a/tests/cram/test_dirs/simple.t/run.t +++ b/tests/cram/test_dirs/simple.t/run.t @@ -98,41 +98,37 @@ main/1 Global C functions: (main/1 () () - (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)) + (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)) $ cat simple1.lambda - (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)))))) + (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)))))) $ cat simple1.parsing - ((Top_let x - ((desc (Exp_const (Const_int 1))) + ((TopLet x + ((desc (EConst (CInt 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 ()))) - (Top_let y - ((desc (Exp_const (Const_int 1))) + (TopLet y + ((desc (EConst (CInt 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 ()))) - (Top_let z + (TopLet z ((desc - (Exp_lam - ((Para_bare x) - ((desc (Exp_var y)) + (ELam + ((PBare x) + ((desc (EVar y)) (start_loc ((pos_fname simple.fun) (pos_lnum 5) (pos_bol 22) (pos_cnum 40))) @@ -145,11 +141,11 @@ (end_loc ((pos_fname simple.fun) (pos_lnum 5) (pos_bol 22) (pos_cnum 41))) (attrs ()))) - (Top_let w + (TopLet w ((desc - (Exp_lam - ((Para_bare x) - ((desc (Exp_const (Const_int 0))) + (ELam + ((PBare x) + ((desc (EConst (CInt 0))) (start_loc ((pos_fname simple.fun) (pos_lnum 7) (pos_bol 44) (pos_cnum 62))) @@ -162,13 +158,13 @@ (end_loc ((pos_fname simple.fun) (pos_lnum 7) (pos_bol 44) (pos_cnum 63))) (attrs ()))) - (Top_let m + (TopLet m ((desc - (Exp_lam - ((Para_bare x) + (ELam + ((PBare x) ((desc - (Exp_app - ((desc (Exp_var w)) + (EApp + ((desc (EVar w)) (start_loc ((pos_fname simple.fun) (pos_lnum 9) (pos_bol 66) (pos_cnum 84))) @@ -176,7 +172,7 @@ ((pos_fname simple.fun) (pos_lnum 9) (pos_bol 66) (pos_cnum 85))) (attrs ())) - ((desc (Exp_const (Const_int 1))) + ((desc (EConst (CInt 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 7639064..a88e53f 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 () () (Exp_mod_obj ((Field_simple x (Exp_const (Const_int 1)))))) + (main/1 () () (EModObject ((FSimple x (EConst (CInt 1)))))) |}]; print_lifted @@ -53,13 +53,10 @@ let%expect_test "Test: full program lowering" = main/1 Global C functions: (main/1 () () - (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))))) + (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))))) |}]; print_lifted @@ -75,9 +72,9 @@ let%expect_test "Test: full program lowering" = Main function name: main/1 Global C functions: - (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))))) + (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))))) |}]; print_lifted {| @@ -88,7 +85,7 @@ external add : int -> int -> int = "ff_add" Main function name: main/1 Global C functions: - (main/1 () () (Exp_mod_obj ((Field_simple add (Exp_external ff_add))))) + (main/1 () () (EModObject ((FSimple add (EExt ff_add))))) |}]; print_lifted {| let x = 1 @@ -103,11 +100,10 @@ let z = fun z -> x = y main/1 Global C functions: (main/1 () () - (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))) + (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))) |}]; print_lifted @@ -122,8 +118,8 @@ let z = fun z -> x = y Main function name: main/1 Global C functions: - (main/1 () () (Exp_mod_obj ((Field_letrec (() ((sum sum/2))))))) + (main/1 () () (EModObject ((FLetRec (() ((sum sum/2))))))) (sum/2 (sum) (x) - (Exp_if (Exp_cmp Eq (Exp_var x) (Exp_const (Const_int 0))) - (Exp_const (Const_int 1)) (Exp_const (Const_int 2)))) + (EIf (ECmp Eq (EVar x) (EConst (CInt 0))) (EConst (CInt 1)) + (EConst (CInt 2)))) |}] diff --git a/tests/regular/lower_test.ml b/tests/regular/lower_test.ml index 2c59f75..6b351b2 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 {| (Exp_mod_obj ((Field_simple x (Exp_const (Const_int 1))))) |}]; + [%expect {| (EModObject ((FSimple x (EConst (CInt 1))))) |}]; print_lowered {| @@ -35,14 +35,10 @@ let%expect_test "Test: full program lowering" = |}; [%expect {| - (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)))) - |}]; + (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)))) |}]; print_lowered {| @@ -105,34 +101,29 @@ module MMM = (M(F).K : I) |}; [%expect {| - (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)))))) + (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)))))) (Simple)))) - (Field_simple F - (Exp_lam + (FSimple F + (ELam ((MI) - (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))))) + (EModObject + ((FSimple x (EConst (CInt 1))) (FSimple y (EConst (CInt 1))) + (FSimple z (EConst (CInt 1))))) ()))) - (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))))))) + (FSimple MMM (EField (EApp (EVar M) ((EVar F))) K)) + (FLetRec + ((f ((x) (EVar x) ())) + (g ((x) (EApp (EVar f) ((EConst (CInt 1)))) (f))))))) |}]; print_lowered @@ -145,10 +136,10 @@ module MMM = (M(F).K : I) |}; [%expect {| - (Exp_mod_obj - ((Field_letrec - ((f ((x) (Exp_var x) ())) - (g ((x) (Exp_app (Exp_var f) ((Exp_const (Const_int 1)))) (f))))))) + (EModObject + ((FLetRec + ((f ((x) (EVar x) ())) + (g ((x) (EApp (EVar f) ((EConst (CInt 1)))) (f))))))) |}]; print_lowered {| @@ -168,16 +159,14 @@ module MMM = (M(F).K : I) |}; [%expect {| - (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 + (EModObject + ((FSimple x (ECons 1)) (FSimple z (EApp (EConsWith 0) ((EConst (CInt 1))))) + (FSimple f + (ELam ((p) - (Exp_switch (Exp_var x) - (((Pat_constr 0 ((Pat_var y))) (Exp_var y)) - ((Pat_constr 1 ()) (Exp_const (Const_int 0))))) + (ESwitch (EVar x) + (((PCons 0 ((PVar y))) (EVar y)) + ((PCons 1 ()) (EConst (CInt 0))))) (x)))))) |}]; @@ -198,12 +187,10 @@ module MMM = (M(F).K : I) [%expect {| - (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)))))) + (EModObject + ((FSimple M (EModObject ((FSimple x (EConst (CInt 1)))))) + (FSimple F + (ELam ((X) (EModObject ((FSimple y (EField (EVar M) x)))) (M)))))) |}]; print_lowered {| @@ -222,15 +209,11 @@ module MMM = (M(F).K : I) |}; [%expect {| - (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))) + (EModObject + ((FSimple M (EModObject ((FSimple x (EConst (CInt 1)))))) + (FSimple F1 + (ELam + ((X) (ELam ((Y) (EModObject ((FSimple y (EField (EVar M) x)))) (M))) (M)))))) |}]; @@ -258,28 +241,23 @@ module MMM = (M(F).K : I) |}; [%expect {| - (Exp_mod_obj - ((Field_simple M - (Exp_mod_obj ((Field_simple x (Exp_const (Const_int 1)))))) - (Field_simple F2 - (Exp_lam + (EModObject + ((FSimple M (EModObject ((FSimple x (EConst (CInt 1)))))) + (FSimple F2 + (ELam ((X) - (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)))))) + (EModObject + ((FSimple N (EModObject ((FSimple x (EConst (CInt 2)))))) + (FSimple F3 + (ELam + ((Y) (EModObject ((FSimple y (EField (EVar N) x)))) (N)))))) ()))))) |}]; print_lowered {| external add : int -> int -> int = "ff_add" |}; - [%expect {| (Exp_mod_obj ((Field_simple add (Exp_external ff_add)))) |}]; + [%expect {| (EModObject ((FSimple add (EExt ff_add)))) |}]; print_lowered {| let x = 1 @@ -290,10 +268,9 @@ let z = x = y |}; [%expect {| - (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))))) + (EModObject + ((FSimple x (EConst (CInt 1))) (FSimple y (EConst (CInt 2))) + (FSimple z (ECmp Eq (EVar x) (EVar y))))) |}]; print_lowered {| @@ -305,12 +282,10 @@ let z = x = y |}; [%expect {| - (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))))) + (EModObject + ((FSimple even + (ELetRec + ((even ((x) (EApp (EVar odd) ((EConst (CInt 1)))) (odd))) + (odd ((x) (EApp (EVar even) ((EConst (CInt 1)))) (even)))) + (EVar even))))) |}] diff --git a/tests/regular/parse_test.ml b/tests/regular/parse_test.ml index 4fd3cbc..0bc3609 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_surface_ty |> print_sexp + parse_string_type_expr str |> sexp_of_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 (Exp_var x)) + ((desc (EVar 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 (Exp_const (Const_int 1))) + ((desc (EConst (CInt 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 (Exp_const Const_unit)) + ((desc (EConst CUnit)) (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 (Exp_const (Const_string "\"x \\n \\t,()*@/\""))) + ((desc (EConst (CString "\"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 - (Exp_app + (EApp ((desc - (Exp_app + (EApp ((desc - (Exp_app - ((desc (Exp_var a)) + (EApp + ((desc (EVar 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 (Exp_var b)) + ((desc (EVar 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 (Exp_var c)) + ((desc (EVar 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 (Exp_var d)) + ((desc (EVar 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 (Exp_const (Const_bool true))) + ((desc (EConst (CBool 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 - (Exp_let x - ((desc (Exp_const (Const_int 1))) + (ELet x + ((desc (EConst (CInt 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 (Exp_var y)) + ((desc (EVar 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 (Exp_constr Nil)) + ((desc (ECons 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 - (Exp_tuple - (((desc (Exp_const (Const_int 1))) + (ETuple + (((desc (EConst (CInt 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 (Exp_const (Const_int 3))) + ((desc (EConst (CInt 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 (Exp_const (Const_int 4))) + ((desc (EConst (CInt 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 - (Exp_tuple - (((desc (Exp_const (Const_int 5))) + (ETuple + (((desc (EConst (CInt 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 (Exp_const (Const_int 6))) + ((desc (EConst (CInt 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 (Exp_const (Const_int 7))) + ((desc (EConst (CInt 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 - (Exp_tuple + (ETuple (((desc - (Exp_app - ((desc (Exp_var f)) + (EApp + ((desc (EVar 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 (Exp_const (Const_int 1))) + ((desc (EConst (CInt 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 - (Exp_app - ((desc (Exp_var f)) + (EApp + ((desc (EVar 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 (Exp_const (Const_bool true))) + ((desc (EConst (CBool 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 - (Exp_app - ((desc (Exp_constr Cons)) + (EApp + ((desc (ECons 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 (Exp_const (Const_int 1))) + ((desc (EConst (CInt 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 - (Exp_letrec + (ELetrec ((odd - ((Para_bare x) + ((PBare x) ((desc - (Exp_app - ((desc (Exp_var even)) + (EApp + ((desc (EVar 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 (Exp_var x)) + ((desc (EVar 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 - ((Para_ann x (Ty_cons int ())) + ((PAnn x (TCons int ())) ((desc - (Exp_app - ((desc (Exp_var odd)) + (EApp + ((desc (EVar 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 (Exp_var x)) + ((desc (EVar 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 - (Exp_app - ((desc (Exp_var odd)) + (EApp + ((desc (EVar 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 (Exp_const (Const_int 1))) + ((desc (EConst (CInt 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 - (Exp_app + (EApp ((desc - (Exp_field - ((desc (Mod_name E)) + (EField + ((desc (MEName 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 (Exp_var y)) + ((desc (EVar 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 - (Exp_app - ((desc (Exp_constr Cons)) + (EApp + ((desc (ECons 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 (Exp_const (Const_int 1))) + ((desc (EConst (CInt 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 - (Exp_app - ((desc (Exp_constr Cons)) + (EApp + ((desc (ECons 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 - (Exp_tuple - (((desc (Exp_var x)) + (ETuple + (((desc (EVar 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 (Exp_var y)) + ((desc (EVar 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 - (Exp_app + (EApp ((desc - (Exp_field_constr - ((desc (Mod_name L)) + (EFieldCons + ((desc (MEName 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 - (Exp_tuple - (((desc (Exp_var x)) + (ETuple + (((desc (EVar 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 (Exp_var y)) + ((desc (EVar 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 - (Exp_lam - ((Para_bare x) - ((desc (Exp_var x)) + (ELam + ((PBare x) + ((desc (EVar 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 - (Exp_app - ((desc (Exp_var f)) + (EApp + ((desc (EVar 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 (Exp_const (Const_int 1))) + ((desc (EConst (CInt 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 - (Exp_case - ((desc (Exp_var c)) + (ECase + ((desc (EVar 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 ())) - (((Pat_constr Cons ((Pat_var x))) - ((desc (Exp_var x)) + (((PCons Cons ((PVar x))) + ((desc (EVar 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 ()))) - ((Pat_constr Nil ()) - ((desc (Exp_const (Const_int 0))) + ((PCons Nil ()) + ((desc (EConst (CInt 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 - (Exp_cmp Eq - ((desc (Exp_var x)) + (ECmp Eq + ((desc (EVar 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 (Exp_var y)) + ((desc (EVar 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 - (Exp_cmp Neq - ((desc (Exp_var x)) + (ECmp Neq + ((desc (EVar 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 (Exp_var y)) + ((desc (EVar 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 - (Exp_seq + (ESeq ((desc - (Exp_app - ((desc (Exp_var f)) + (EApp + ((desc (EVar 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 (Exp_const (Const_int 1))) + ((desc (EConst (CInt 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 - (Exp_seq + (ESeq ((desc - (Exp_app - ((desc (Exp_var f)) + (EApp + ((desc (EVar 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 (Exp_const (Const_int 2))) + ((desc (EConst (CInt 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 - (Exp_cmp Eq + (ECmp Eq ((desc - (Exp_app - ((desc (Exp_var f)) + (EApp + ((desc (EVar 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 (Exp_const (Const_int 2))) + ((desc (EConst (CInt 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 (Exp_const (Const_int 3))) + ((desc (EConst (CInt 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 - (Exp_app + (EApp ((desc - (Exp_app - ((desc (Exp_var add)) + (EApp + ((desc (EVar 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 (Exp_var x)) + ((desc (EVar 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 - (Exp_app + (EApp ((desc - (Exp_app - ((desc (Exp_var minus)) + (EApp + ((desc (EVar 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 (Exp_var x)) + ((desc (EVar 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 (Exp_const (Const_int 1))) + ((desc (EConst (CInt 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 - (Exp_app + (EApp ((desc - (Exp_app - ((desc (Exp_var a)) + (EApp + ((desc (EVar 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 (Exp_var b)) + ((desc (EVar 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 (Exp_constr Nil)) + ((desc (ECons 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,18 +664,17 @@ let%expect_test "Test: pattern parsing" = parse_string_pattern str |> sexp_of_pattern |> print_sexp in print_parsed {| x |}; - [%expect {| (Pat_var x) |}]; + [%expect {| (PVar x) |}]; print_parsed {| 1 |}; - [%expect {| (Pat_val (Const_int 1)) |}]; + [%expect {| (PVal (CInt 1)) |}]; print_parsed {| Nil |}; - [%expect {| (Pat_constr Nil ()) |}]; + [%expect {| (PCons Nil ()) |}]; print_parsed {| Cons 1 |}; - [%expect {| (Pat_constr Cons ((Pat_val (Const_int 1)))) |}]; + [%expect {| (PCons Cons ((PVal (CInt 1)))) |}]; print_parsed {| Cons x |}; - [%expect {| (Pat_constr Cons ((Pat_var x))) |}]; + [%expect {| (PCons Cons ((PVar x))) |}]; print_parsed {| Cons (x, y, z) |}; - [%expect - {| (Pat_constr Cons ((Pat_tuple ((Pat_var x) (Pat_var y) (Pat_var z))))) |}] + [%expect {| (PCons Cons ((PTuple ((PVar x) (PVar y) (PVar z))))) |}] let%expect_test "Test: full program parsing" = print_parsed_program @@ -685,13 +684,13 @@ let%expect_test "Test: full program parsing" = print_parsed_program {|let x = 1|}; [%expect {| - ((Top_let x - ((desc (Exp_const (Const_int 1))) + ((TopLet x + ((desc (EConst (CInt 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 ())))) - ((Top_let x - ((desc (Exp_const (Const_int 1))) + ((TopLet x + ((desc (EConst (CInt 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 ())))) @@ -704,28 +703,28 @@ let%expect_test "Test: full program parsing" = |}; [%expect {| - ((Top_let x - ((desc (Exp_const (Const_int 1))) + ((TopLet x + ((desc (EConst (CInt 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 ()))) - (Top_let y - ((desc (Exp_const (Const_int 2))) + (TopLet y + ((desc (EConst (CInt 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 ()))) - (Top_letrec + (TopLetRec ((foo - ((Para_bare x) + ((PBare x) ((desc - (Exp_app - ((desc (Exp_var foo)) + (EApp + ((desc (EVar 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 (Exp_var x)) + ((desc (EVar x)) (start_loc ((pos_fname "") (pos_lnum 4) (pos_bol 31) (pos_cnum 63))) (end_loc @@ -739,10 +738,10 @@ let%expect_test "Test: full program parsing" = print_parsed_program {|let rec f = fun (x:int) -> 1|}; [%expect {| - ((Top_letrec + ((TopLetRec ((f - ((Para_ann x (Ty_cons int ())) - ((desc (Exp_const (Const_int 1))) + ((PAnn x (TCons int ())) + ((desc (EConst (CInt 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 ()))))))) @@ -754,18 +753,18 @@ let%expect_test "Test: full program parsing" = |}; [%expect {| - ((Top_letrec + ((TopLetRec ((odd - ((Para_bare x) + ((PBare x) ((desc - (Exp_app - ((desc (Exp_var even)) + (EApp + ((desc (EVar 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 (Exp_var x)) + ((desc (EVar x)) (start_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 33))) (end_loc @@ -775,16 +774,16 @@ let%expect_test "Test: full program parsing" = (end_loc ((pos_fname "") (pos_lnum 2) (pos_bol 1) (pos_cnum 34))) (attrs ())))) (even - ((Para_bare x) + ((PBare x) ((desc - (Exp_app - ((desc (Exp_var odd)) + (EApp + ((desc (EVar 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 (Exp_var x)) + ((desc (EVar x)) (start_loc ((pos_fname "") (pos_lnum 3) (pos_bol 35) (pos_cnum 63))) (end_loc @@ -811,14 +810,14 @@ let%expect_test "Test: full program parsing" = |}; [%expect {| - ((Top_mod M + ((TopMod M ((desc - (Mod_restrict + (MERestrict ((desc - (Mod_struct - ((Top_type_def (Ty_def_adt t () ((Nil ())))) - (Top_let x - ((desc (Exp_constr Nil)) + (MEStruct + ((TopTypeDef (TDAdt t () ((Nil ())))) + (TopLet x + ((desc (ECons Nil)) (start_loc ((pos_fname "") (pos_lnum 6) (pos_bol 55) (pos_cnum 70))) (end_loc @@ -828,7 +827,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 ())) - (Mod_ty_sig ((Spec_abstr t ()) (Spec_value x (Ty_cons t ())))))) + (MTSig ((SpecAbstTy t ()) (SpecVal x (TCons 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 ())))) @@ -845,10 +844,8 @@ let%expect_test "Test: full program parsing" = |}; [%expect {| - ((Top_mod_sig MIntf - (Mod_ty_sig - ((Spec_mani_ty (Ty_def_adt t () ((Nil ())))) - (Spec_value x (Ty_cons t ())))))) + ((TopModSig MIntf + (MTSig ((SpecManiTy (TDAdt t () ((Nil ())))) (SpecVal x (TCons t ())))))) |}]; print_parsed_program @@ -869,16 +866,16 @@ functor |}; [%expect {| - ((Top_mod F + ((TopMod F ((desc - (Mod_functor - ((MI (Mod_ty_name I)) + (MEFunctor + ((MI (MTName I)) ((desc - (Mod_restrict + (MERestrict ((desc - (Mod_struct - ((Top_let x - ((desc (Exp_const (Const_int 1))) + (MEStruct + ((TopLet x + ((desc (EConst (CInt 1))) (start_loc ((pos_fname "") (pos_lnum 8) (pos_bol 51) (pos_cnum 65))) @@ -886,8 +883,8 @@ functor ((pos_fname "") (pos_lnum 8) (pos_bol 51) (pos_cnum 66))) (attrs ()))) - (Top_let y - ((desc (Exp_const (Const_int 1))) + (TopLet y + ((desc (EConst (CInt 1))) (start_loc ((pos_fname "") (pos_lnum 10) (pos_bol 68) (pos_cnum 82))) @@ -895,8 +892,8 @@ functor ((pos_fname "") (pos_lnum 10) (pos_bol 68) (pos_cnum 83))) (attrs ()))) - (Top_let z - ((desc (Exp_const (Const_int 1))) + (TopLet z + ((desc (EConst (CInt 1))) (start_loc ((pos_fname "") (pos_lnum 12) (pos_bol 85) (pos_cnum 99))) @@ -910,7 +907,7 @@ functor ((pos_fname "") (pos_lnum 13) (pos_bol 101) (pos_cnum 108))) (attrs ())) - (Mod_ty_name J))) + (MTName J))) (start_loc ((pos_fname "") (pos_lnum 7) (pos_bol 40) (pos_cnum 44))) (end_loc @@ -928,22 +925,22 @@ functor |}; [%expect {| - ((Top_let co + ((TopLet co ((desc - (Exp_app - ((desc (Exp_constr Cons)) + (EApp + ((desc (ECons 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 (Exp_const (Const_int 1))) + ((desc (EConst (CInt 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 ()))) - (Top_let f - ((desc (Exp_const (Const_int 1))) + (TopLet f + ((desc (EConst (CInt 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 ())))) @@ -953,19 +950,15 @@ functor type t = a list -> b |}; [%expect - {| - ((Top_type_def - (Ty_def_alias t (Ty_arrow (Ty_cons list ((Ty_cons a ()))) (Ty_cons b ()))))) - |}]; + {| ((TopTypeDef (TDAlias t (TArrow (TCons list ((TCons a ()))) (TCons b ()))))) |}]; print_parsed_program {| external x : int -> int -> int = "ff_add" |}; [%expect {| - ((Top_external x - (Ty_arrow (Ty_cons int ()) (Ty_arrow (Ty_cons int ()) (Ty_cons int ()))) - ff_add)) + ((TopExternal x + (TArrow (TCons int ()) (TArrow (TCons int ()) (TCons int ()))) ff_add)) |}]; print_parsed_program @@ -977,15 +970,15 @@ let y = 2 |}; [%expect {| - ((Top_let x + ((TopLet x ((desc - (Exp_case - ((desc (Exp_var a)) + (ECase + ((desc (EVar 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 ())) - (((Pat_constr Cons ()) - ((desc (Exp_const (Const_int 0))) + (((PCons Cons ()) + ((desc (EConst (CInt 0))) (start_loc ((pos_fname "") (pos_lnum 3) (pos_bol 22) (pos_cnum 38))) (end_loc @@ -994,8 +987,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 ()))) - (Top_let y - ((desc (Exp_const (Const_int 2))) + (TopLet y + ((desc (EConst (CInt 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 ())))) @@ -1008,11 +1001,11 @@ let y = 2 |}; [%expect {| - ((Top_let x + ((TopLet x ((desc - (Exp_lam - ((Para_bare x) - ((desc (Exp_var y)) + (ELam + ((PBare x) + ((desc (EVar 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))) @@ -1020,8 +1013,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 ()))) - (Top_let y - ((desc (Exp_const (Const_int 2))) + (TopLet y + ((desc (EConst (CInt 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 ())))) @@ -1043,15 +1036,15 @@ let y = 2 |}; [%expect {| - ((Top_let x + ((TopLet x ((desc - (Exp_tuple - (((desc (Exp_const (Const_int 1))) + (ETuple + (((desc (EConst (CInt 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 (Exp_const (Const_int 2))) + ((desc (EConst (CInt 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))) @@ -1059,16 +1052,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 ()))) - (Top_let y + (TopLet y ((desc - (Exp_tuple - (((desc (Exp_const (Const_int 1))) + (ETuple + (((desc (EConst (CInt 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 (Exp_const (Const_int 2))) + ((desc (EConst (CInt 2))) (start_loc ((pos_fname "") (pos_lnum 4) (pos_bol 21) (pos_cnum 38))) (end_loc @@ -1077,16 +1070,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 ()))) - (Top_let z + (TopLet z ((desc - (Exp_case - ((desc (Exp_var y)) + (ECase + ((desc (EVar 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 ())) - (((Pat_tuple ((Pat_var x) (Pat_var y))) - ((desc (Exp_var x)) + (((PTuple ((PVar x) (PVar y))) + ((desc (EVar x)) (start_loc ((pos_fname "") (pos_lnum 7) (pos_bol 69) (pos_cnum 94))) (end_loc @@ -1095,20 +1088,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 ()))) - (Top_let n + (TopLet n ((desc - (Exp_lam - ((Para_bare y) + (ELam + ((PBare y) ((desc - (Exp_case - ((desc (Exp_var y)) + (ECase + ((desc (EVar 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 ())) - (((Pat_tuple ((Pat_var x) (Pat_var y))) - ((desc (Exp_var y)) + (((PTuple ((PVar x) (PVar y))) + ((desc (EVar y)) (start_loc ((pos_fname "") (pos_lnum 10) (pos_bol 133) (pos_cnum 152))) @@ -1124,8 +1117,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 ()))) - (Top_let w - ((desc (Exp_const (Const_int 1))) + (TopLet w + ((desc (EConst (CInt 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 ())))) @@ -1142,14 +1135,14 @@ let result = print_int (sum 4) |}; [%expect {| - ((Top_letrec + ((TopLetRec ((sum - ((Para_bare x) + ((PBare x) ((desc - (Exp_if + (EIf ((desc - (Exp_cmp Eq - ((desc (Exp_var x)) + (ECmp Eq + ((desc (EVar x)) (start_loc ((pos_fname "") (pos_lnum 3) (pos_bol 24) (pos_cnum 32))) @@ -1157,7 +1150,7 @@ let result = print_int (sum 4) ((pos_fname "") (pos_lnum 3) (pos_bol 24) (pos_cnum 33))) (attrs ())) - ((desc (Exp_const (Const_int 0))) + ((desc (EConst (CInt 0))) (start_loc ((pos_fname "") (pos_lnum 3) (pos_bol 24) (pos_cnum 36))) @@ -1170,13 +1163,13 @@ let result = print_int (sum 4) (end_loc ((pos_fname "") (pos_lnum 3) (pos_bol 24) (pos_cnum 37))) (attrs ())) - ((desc (Exp_const (Const_int 0))) + ((desc (EConst (CInt 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 (Exp_const (Const_int 1))) + ((desc (EConst (CInt 1))) (start_loc ((pos_fname "") (pos_lnum 5) (pos_bol 49) (pos_cnum 58))) (end_loc @@ -1186,23 +1179,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 ())))))) - (Top_let result + (TopLet result ((desc - (Exp_app - ((desc (Exp_var print_int)) + (EApp + ((desc (EVar 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 - (Exp_app - ((desc (Exp_var sum)) + (EApp + ((desc (EVar 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 (Exp_const (Const_int 4))) + ((desc (EConst (CInt 4))) (start_loc ((pos_fname "") (pos_lnum 7) (pos_bol 62) (pos_cnum 90))) (end_loc @@ -1220,12 +1213,12 @@ let result = print_int (sum 4) {| type 'a t = Nil |}; - [%expect {| ((Top_type_def (Ty_def_adt t ('a/0) ((Nil ()))))) |}]; + [%expect {| ((TopTypeDef (TDAdt t ('a/0) ((Nil ()))))) |}]; print_parsed_program {| type t = | Nil |}; - [%expect {| ((Top_type_def (Ty_def_adt t () ((Nil ()))))) |}]; + [%expect {| ((TopTypeDef (TDAdt t () ((Nil ()))))) |}]; print_parsed_program {| let x = let rec f = fun x -> 1 @@ -1236,26 +1229,26 @@ let result = print_int (sum 4) |}; [%expect {| - ((Top_let x + ((TopLet x ((desc - (Exp_letrec + (ELetrec ((f - ((Para_bare x) - ((desc (Exp_const (Const_int 1))) + ((PBare x) + ((desc (EConst (CInt 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 - ((Para_bare y) - ((desc (Exp_const (Const_int 2))) + ((PBare y) + ((desc (EConst (CInt 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 (Exp_var f)) + ((desc (EVar 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))) @@ -1263,8 +1256,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 ()))) - (Top_let _ - ((desc (Exp_const (Const_int 1))) + (TopLet _ + ((desc (EConst (CInt 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 ())))) @@ -1274,7 +1267,7 @@ let%expect_test "Test: path parsing" = print_parsed_mod_expr {|X|}; [%expect {| - ((desc (Mod_name X)) + ((desc (MEName 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 ())) @@ -1283,8 +1276,8 @@ let%expect_test "Test: path parsing" = [%expect {| ((desc - (Mod_field - ((desc (Mod_name X)) + (MEField + ((desc (MEName 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 ())) @@ -1297,12 +1290,12 @@ let%expect_test "Test: path parsing" = [%expect {| ((desc - (Mod_apply - ((desc (Mod_name X)) + (MEApply + ((desc (MEName 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 (Mod_name Y)) + ((desc (MEName 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 ())))) @@ -1314,12 +1307,12 @@ let%expect_test "Test: path parsing" = [%expect {| ((desc - (Mod_apply + (MEApply ((desc - (Mod_apply + (MEApply ((desc - (Mod_field - ((desc (Mod_name X)) + (MEField + ((desc (MEName X)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 0))) (end_loc @@ -1331,14 +1324,14 @@ let%expect_test "Test: path parsing" = (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 3))) (attrs ())) ((desc - (Mod_apply - ((desc (Mod_name Z)) + (MEApply + ((desc (MEName 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 (Mod_name N)) + ((desc (MEName N)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 6))) (end_loc @@ -1352,10 +1345,10 @@ let%expect_test "Test: path parsing" = (end_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 9))) (attrs ())) ((desc - (Mod_field + (MEField ((desc - (Mod_field - ((desc (Mod_name W)) + (MEField + ((desc (MEName W)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 10))) (end_loc @@ -1377,71 +1370,68 @@ let%expect_test "Test: path parsing" = let%expect_test "Test: type expression parsing" = print_parsed_type_expr "string"; - [%expect {| (Ty_cons string ()) |}]; + [%expect {| (TCons string ()) |}]; print_parsed_type_expr "(string) list"; - [%expect {| (Ty_cons list ((Ty_cons string ()))) |}]; + [%expect {| (TCons list ((TCons string ()))) |}]; print_parsed_type_expr "string list"; - [%expect {| (Ty_cons list ((Ty_cons string ()))) |}]; + [%expect {| (TCons list ((TCons string ()))) |}]; print_parsed_type_expr "'x"; - [%expect {| (Ty_var 'x/0) |}]; + [%expect {| (TVar 'x/0) |}]; print_parsed_type_expr "(string, 'x, 'y) list"; - [%expect - {| (Ty_cons list ((Ty_cons string ()) (Ty_var 'x/0) (Ty_var 'y/0))) |}]; + [%expect {| (TCons list ((TCons string ()) (TVar 'x/0) (TVar 'y/0))) |}]; print_parsed_type_expr "int * int"; - [%expect {| (Ty_tuple ((Ty_cons int ()) (Ty_cons int ()))) |}]; + [%expect {| (TTuple ((TCons int ()) (TCons int ()))) |}]; print_parsed_type_expr "int * i list * (x * y) list * (t1 * t2)"; [%expect {| - (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 ()))))) - |}]; + (TTuple + ((TCons int ()) (TCons list ((TCons i ()))) + (TCons list ((TTuple ((TCons x ()) (TCons y ()))))) + (TTuple ((TCons t1 ()) (TCons t2 ()))))) |}]; print_parsed_type_expr "{x: int; y: float; z: int -> float }"; [%expect {| - (Ty_record - ((x (Ty_cons int ())) (y (Ty_cons float ())) - (z (Ty_arrow (Ty_cons int ()) (Ty_cons float ()))))) - |}]; + (TRecord + ((x (TCons int ())) (y (TCons float ())) + (z (TArrow (TCons int ()) (TCons float ()))))) |}]; print_parsed_type_expr "(int, float) T.t"; [%expect {| - (Ty_field - ((desc (Mod_name T)) + (TField + ((desc (MEName 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 ((Ty_cons int ()) (Ty_cons float ()))) + t ((TCons int ()) (TCons float ()))) |}]; print_parsed_type_expr "int T(M).t"; [%expect {| - (Ty_field + (TField ((desc - (Mod_apply - ((desc (Mod_name T)) + (MEApply + ((desc (MEName 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 (Mod_name M)) + ((desc (MEName 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 ((Ty_cons int ()))) + t ((TCons int ()))) |}]; print_parsed_type_expr "(int) T.t"; [%expect {| - (Ty_field - ((desc (Mod_name T)) + (TField + ((desc (MEName 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 ((Ty_cons int ()))) + t ((TCons int ()))) |}] let%expect_test "Test: top level module" = @@ -1451,8 +1441,8 @@ let%expect_test "Test: top level module" = |}; [%expect {| - ((Top_mod X - ((desc (Mod_struct ())) + ((TopMod X + ((desc (MEStruct ())) (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 ())))) @@ -1469,27 +1459,27 @@ let%expect_test "Test: top level module" = |}; [%expect {| - ((Top_mod X + ((TopMod X ((desc - (Mod_struct - ((Top_let x - ((desc (Exp_const (Const_int 1))) + (MEStruct + ((TopLet x + ((desc (EConst (CInt 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 ()))) - (Top_letrec + (TopLetRec ((y - ((Para_bare x) - ((desc (Exp_const (Const_int 3))) + ((PBare x) + ((desc (EConst (CInt 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 ())))))) - (Top_mod Y - ((desc (Mod_struct ())) + (TopMod Y + ((desc (MEStruct ())) (start_loc ((pos_fname "") (pos_lnum 5) (pos_bol 71) (pos_cnum 89))) (end_loc @@ -1517,14 +1507,14 @@ let%expect_test "Test: module expression" = [%expect {| ((desc - (Mod_struct - ((Top_let x - ((desc (Exp_const (Const_int 1))) + (MEStruct + ((TopLet x + ((desc (EConst (CInt 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 ()))) - (Top_type_def (Ty_def_adt a () ((Cons ((Ty_cons int ()))) (Nil ()))))))) + (TopTypeDef (TDAdt a () ((Cons ((TCons 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 ())) @@ -1533,9 +1523,9 @@ let%expect_test "Test: module expression" = [%expect {| ((desc - (Mod_functor - ((X (Mod_ty_name M)) - ((desc (Mod_struct ())) + (MEFunctor + ((X (MTName M)) + ((desc (MEStruct ())) (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 ()))))) @@ -1546,19 +1536,19 @@ let%expect_test "Test: module expression" = let%expect_test "Test: module type" = let print_parsed str = - parse_string_mod_type str |> sexp_of_surface_mod_ty |> print_sexp + parse_string_mod_type str |> sexp_of_mod_ty |> print_sexp in print_parsed {|M|}; - [%expect {| (Mod_ty_name M) |}]; + [%expect {| (MTName M) |}]; print_parsed {|M.X(M).E|}; [%expect {| - (Mod_ty_field + (MTField ((desc - (Mod_apply + (MEApply ((desc - (Mod_field - ((desc (Mod_name M)) + (MEField + ((desc (MEName M)) (start_loc ((pos_fname "") (pos_lnum 1) (pos_bol 0) (pos_cnum 0))) (end_loc @@ -1568,7 +1558,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 (Mod_name M)) + ((desc (MEName 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 ())))) @@ -1578,21 +1568,15 @@ let%expect_test "Test: module type" = E) |}]; print_parsed {|sig val x : int end|}; - [%expect {| (Mod_ty_sig ((Spec_value x (Ty_cons int ())))) |}]; + [%expect {| (MTSig ((SpecVal x (TCons int ())))) |}]; print_parsed {|functor (M:M) -> sig val x: int end|}; [%expect - {| - (Mod_ty_functor M (Mod_ty_name M) - (Mod_ty_sig ((Spec_value x (Ty_cons int ()))))) - |}]; + {| (MTFunctor M (MTName M) (MTSig ((SpecVal x (TCons int ()))))) |}]; print_parsed {|functor (M:M) -> M1|}; - [%expect {| (Mod_ty_functor M (Mod_ty_name M) (Mod_ty_name M1)) |}]; + [%expect {| (MTFunctor M (MTName M) (MTName M1)) |}]; print_parsed {|functor (M:functor (X:M)->M) -> M1|}; [%expect - {| - (Mod_ty_functor M (Mod_ty_functor X (Mod_ty_name M) (Mod_ty_name M)) - (Mod_ty_name M1)) - |}]; + {| (MTFunctor M (MTFunctor X (MTName M) (MTName M)) (MTName M1)) |}]; print_parsed {| sig @@ -1607,9 +1591,8 @@ let%expect_test "Test: module type" = |}; [%expect {| - (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 ())))))) + (MTSig + ((SpecVal x (TCons int ())) (SpecAbstTy t ()) + (SpecVal m (TArrow (TCons t ()) (TCons t ()))) + (SpecManiTy (TDAdt i_list () ((Cons ((TCons int ()))) (Nil ())))))) |}] diff --git a/tests/regular/typing_test.ml b/tests/regular/typing_test.ml index f99b702..0900b25 100644 --- a/tests/regular/typing_test.ml +++ b/tests/regular/typing_test.ml @@ -28,87 +28,81 @@ let%expect_test "Test: expression typing" = typed |> T.get_ty |> Typing.Types_in.sexp_of_ty |> print_sexp in print_typed "1"; - [%expect {| (Exp_const (Const_int 1) (Ty_cons (0 int) ())) |}]; + [%expect {| (EConst (CInt 1) (TCons (0 int) ())) |}]; print_type "1"; - [%expect {| (Ty_cons (0 int) ()) |}]; + [%expect {| (TCons (0 int) ()) |}]; print_typed "let x = 1 in x"; [%expect {| - (Exp_let x (Exp_const (Const_int 1) (Ty_cons (0 int) ())) - (Exp_var x (Ty_cons (0 int) ())) (Ty_cons (0 int) ())) - |}]; + (ELet x (EConst (CInt 1) (TCons (0 int) ())) (EVar x (TCons (0 int) ())) + (TCons (0 int) ())) |}]; print_type "let x = 1 in x"; - [%expect {| (Ty_cons (0 int) ()) |}]; + [%expect {| (TCons (0 int) ()) |}]; print_typed "let f = (fun x -> x) in f"; [%expect {| - (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)))) + (ELet f + (ELam + (x (EVar x (TVar (Unbound '_t/1 1))) + (TArrow (TVar (Unbound '_t/1 1)) (TVar (Unbound '_t/1 1))))) + (EVar f (TArrow (TVar (Unbound '_t/2 0)) (TVar (Unbound '_t/2 0)))) + (TArrow (TVar (Unbound '_t/2 0)) (TVar (Unbound '_t/2 0)))) |}]; print_typed "let f = (fun x -> x) in f 1"; [%expect {| - (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) ())))) + (ELet f + (ELam + (x (EVar x (TVar (Unbound '_t/1 1))) + (TArrow (TVar (Unbound '_t/1 1)) (TVar (Unbound '_t/1 1))))) + (EApp + (EVar f + (TArrow (TVar (Link (TCons (0 int) ()))) + (TVar (Link (TCons (0 int) ()))))) + (EConst (CInt 1) (TCons (0 int) ())) (TVar (Link (TCons (0 int) ())))) + (TVar (Link (TCons (0 int) ())))) |}]; print_type "let f = (fun x -> x) in f 1"; [%expect {| - (Ty_var (Link (Ty_cons (0 int) ()))) |}]; + (TVar (Link (TCons (0 int) ()))) |}]; print_typed "1, true"; [%expect {| - (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) ())))) |}]; + (ETuple + ((EConst (CInt 1) (TCons (0 int) ())) + (EConst (CBool true) (TCons (0 bool) ()))) + (TTuple ((TCons (0 int) ()) (TCons (0 bool) ())))) |}]; print_typed "let f = (fun x -> x) in (f 1, f true)"; [%expect {| - (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) ())))))) + (ELet f + (ELam + (x (EVar x (TVar (Unbound '_t/1 1))) + (TArrow (TVar (Unbound '_t/1 1)) (TVar (Unbound '_t/1 1))))) + (ETuple + ((EApp + (EVar f + (TArrow (TVar (Link (TCons (0 int) ()))) + (TVar (Link (TCons (0 int) ()))))) + (EConst (CInt 1) (TCons (0 int) ())) (TVar (Link (TCons (0 int) ())))) + (EApp + (EVar f + (TArrow (TVar (Link (TCons (0 bool) ()))) + (TVar (Link (TCons (0 bool) ()))))) + (EConst (CBool true) (TCons (0 bool) ())) + (TVar (Link (TCons (0 bool) ()))))) + (TTuple + ((TVar (Link (TCons (0 int) ()))) (TVar (Link (TCons (0 bool) ())))))) + (TTuple + ((TVar (Link (TCons (0 int) ()))) (TVar (Link (TCons (0 bool) ())))))) |}]; print_typed {| @@ -120,28 +114,28 @@ let%expect_test "Test: expression typing" = |}; [%expect {| - (Exp_letrec + (ELetrec ((f (x - (Exp_app - (Exp_var g - (Ty_var + (EApp + (EVar g + (TVar (Link - (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))))))) + (TArrow (TVar (Link (TVar (Unbound '_t/5 1)))) + (TVar (Link (TVar (Unbound 'ret/6 1)))))))) + (EVar x (TVar (Link (TVar (Unbound '_t/5 1))))) + (TVar (Link (TVar (Unbound 'ret/6 1))))) + (TArrow (TVar (Link (TVar (Unbound '_t/5 1)))) + (TVar (Link (TVar (Unbound 'ret/6 1))))))) (g (x - (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) ())) + (EApp + (EVar f + (TArrow (TVar (Link (TVar (Unbound '_t/5 1)))) + (TVar (Link (TVar (Unbound 'ret/6 1)))))) + (EVar x (TVar (Unbound '_t/5 1))) (TVar (Unbound 'ret/6 1))) + (TArrow (TVar (Unbound '_t/5 1)) (TVar (Unbound 'ret/6 1)))))) + (EConst (CInt 1) (TCons (0 int) ())) (TCons (0 int) ())) |}]; print_typed @@ -154,22 +148,21 @@ let%expect_test "Test: expression typing" = |}; [%expect {| - (Exp_letrec + (ELetrec ((f - (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) ())))))) + (x (EVar x (TVar (Link (TCons (0 int) ())))) + (TArrow (TVar (Link (TCons (0 int) ()))) + (TVar (Link (TCons (0 int) ())))))) (g (x - (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) ())) + (EApp + (EVar f + (TArrow (TVar (Link (TCons (0 int) ()))) + (TVar (Link (TCons (0 int) ()))))) + (EConst (CInt 1) (TCons (0 int) ())) + (TVar (Link (TCons (0 int) ())))) + (TArrow (TVar (Unbound '_t/4 1)) (TVar (Link (TCons (0 int) ()))))))) + (EConst (CInt 1) (TCons (0 int) ())) (TCons (0 int) ())) |}] (* todo: test pattern matching *) @@ -189,8 +182,7 @@ let%expect_test "Test: program toplevel typing" = print_typed {| let x = 1 |}; - [%expect - {| ((Top_let x (Exp_const (Const_int 1) (Ty_cons (0 int) ())))) |}]; + [%expect {| ((TopLet x (EConst (CInt 1) (TCons (0 int) ())))) |}]; print_typed {| let rec f = fun x -> x @@ -199,21 +191,20 @@ let%expect_test "Test: program toplevel typing" = |}; [%expect {| - ((Top_letrec + ((TopLetRec ((f - (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) ())))))) + (x (EVar x (TVar (Link (TCons (0 int) ())))) + (TArrow (TVar (Link (TCons (0 int) ()))) + (TVar (Link (TCons (0 int) ())))))) (g (x - (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) ()))))))))) + (EApp + (EVar f + (TArrow (TVar (Link (TCons (0 int) ()))) + (TVar (Link (TCons (0 int) ()))))) + (EConst (CInt 1) (TCons (0 int) ())) + (TVar (Link (TCons (0 int) ())))) + (TArrow (TVar (Unbound '_t/4 1)) (TVar (Link (TCons (0 int) ()))))))))) |}]; print_effect {| type () a @@ -228,7 +219,7 @@ let%expect_test "Test: program toplevel typing" = Value Bindings: Type Definitions: - a |-> (Ty_def_adt a () ((Cons ((Ty_cons (0 int) ()))) (Nil ()))) + a |-> (TDAdt a () ((Cons ((TCons (0 int) ()))) (Nil ()))) Module Definitions: Module Types: @@ -250,16 +241,12 @@ let%expect_test "Test: program toplevel typing" = |}; [%expect {| - ((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) ())))))) - |}]; + ((TopTypeDef (TDAdt int_l () ((Cons ((TCons (0 int) ()))) (Nil ())))) + (TopLet c (ECons Nil 1 (TCons (0 int_l) ()))) + (TopLet co + (EApp (ECons Cons 0 (TArrow (TCons (0 int) ()) (TCons (0 int_l) ()))) + (EConst (CInt 1) (TCons (0 int) ())) + (TVar (Link (TCons (0 int_l) ())))))) |}]; print_effect {| type () int_l @@ -275,10 +262,10 @@ let%expect_test "Test: program toplevel typing" = ++++++++++++++++++Scope Debug Info Begin++++++++++++++++++ Value Bindings: - co |-> forall . (Ty_cons (0 int_l) ()); - c |-> forall . (Ty_cons (0 int_l) ()) + co |-> forall . (TCons (0 int_l) ()); + c |-> forall . (TCons (0 int_l) ()) Type Definitions: - int_l |-> (Ty_def_adt int_l () ((Cons ((Ty_cons (0 int) ()))) (Nil ()))) + int_l |-> (TDAdt int_l () ((Cons ((TCons (0 int) ()))) (Nil ()))) Module Definitions: Module Types: @@ -304,17 +291,14 @@ let%expect_test "Test: program toplevel typing" = |}; [%expect {| - ((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) ())))))) - |}]; + ((TopTypeDef (TDAdt int_l () ((Cons ((TCons (0 int) ()))) (Nil ())))) + (TopLet x (ECons Nil 1 (TCons (0 int_l) ()))) + (TopLet f + (ECase (EVar x (TCons (0 int_l) ())) + (((PCons Cons 0 ((PVar x (TCons (0 int) ())))) + (EVar x (TCons (0 int) ()))) + ((PCons Nil 1 ()) (EConst (CInt 0) (TCons (0 int) ())))) + (TVar (Link (TCons (0 int) ())))))) |}]; print_typed {| @@ -329,30 +313,28 @@ let%expect_test "Test: program toplevel typing" = |}; [%expect {| - ((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 - (Ty_tuple ((Ty_var (Unbound '_t/9 1)) (Ty_var (Unbound '_t/8 1))))))))) + ((TopTypeDef + (TDAdt int_l ('a/0 'b/0) + ((Cons ((TTuple ((TQVar 'a/0) (TQVar 'b/0))))) (Nil ())))) + (TopLet x + (ECons Nil 1 + (TCons (0 int_l) ((TVar (Unbound 'a/1 1)) (TVar (Unbound 'b/2 1)))))) + (TopLet f + (ECase + (EVar x + (TCons (0 int_l) + ((TVar (Link (TVar (Unbound '_t/8 1)))) + (TVar (Link (TVar (Unbound '_t/9 1))))))) + (((PCons Cons 0 + ((PTuple + ((PVar a (TVar (Unbound '_t/8 1))) + (PVar b (TVar (Unbound '_t/9 1))))))) + (ETuple + ((EVar b (TVar (Unbound '_t/9 1))) + (EVar a (TVar (Unbound '_t/8 1)))) + (TTuple ((TVar (Unbound '_t/9 1)) (TVar (Unbound '_t/8 1))))))) + (TVar + (Link (TTuple ((TVar (Unbound '_t/9 1)) (TVar (Unbound '_t/8 1))))))))) |}]; print_effect {| @@ -371,11 +353,11 @@ let%expect_test "Test: program toplevel typing" = ++++++++++++++++++Scope Debug Info Begin++++++++++++++++++ Value Bindings: - 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))) + f |-> forall '_t/8;'_t/9 . (TTuple ((TQVar '_t/9) (TQVar '_t/8))); + x |-> forall 'b/2;'a/1 . (TCons (0 int_l) ((TQVar 'a/1) (TQVar 'b/2))) Type Definitions: - int_l |-> (Ty_def_adt int_l ('a/0 'b/0) - ((Cons ((Ty_tuple ((Ty_qvar 'a/0) (Ty_qvar 'b/0))))) (Nil ()))) + int_l |-> (TDAdt int_l ('a/0 'b/0) + ((Cons ((TTuple ((TQVar 'a/0) (TQVar 'b/0))))) (Nil ()))) Module Definitions: Module Types: @@ -404,17 +386,14 @@ let%expect_test "Test: full program typing" = in print_typed {| let x = 1 |}; - [%expect - {| ((Top_let x (Exp_const (Const_int 1) (Ty_cons (0 int) ())))) |}]; + [%expect {| ((TopLet x (EConst (CInt 1) (TCons (0 int) ())))) |}]; print_typed {| module M = struct let x = 1 end |}; [%expect {| - ((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 ()))))) - |}]; + ((TopMod M + (MEStruct ((TopLet x (EConst (CInt 1) (TCons (0 int) ())))) + (MTMod (id 1) (val_defs ((x (() (TCons (0 int) ()))))) (constr_defs ()) + (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) |}]; print_typed {| module M = struct let x = 1 end @@ -422,19 +401,17 @@ let%expect_test "Test: full program typing" = |}; [%expect {| - ((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) ()))))) + ((TopMod M + (MEStruct ((TopLet x (EConst (CInt 1) (TCons (0 int) ())))) + (MTMod (id 1) (val_defs ((x (() (TCons (0 int) ()))))) (constr_defs ()) + (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())))) + (TopLet c + (EField + (MEName M + (MTMod (id 1) (val_defs ((x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - x (Ty_cons (0 int) ())))) - |}]; + x (TCons (0 int) ())))) |}]; print_typed {| module M = @@ -448,23 +425,22 @@ let%expect_test "Test: full program typing" = |}; [%expect {| - ((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 ()) + ((TopMod M + (MEStruct + ((TopTypeDef (TDAdt t () ((Nil ())))) + (TopLet x (ECons Nil 0 (TCons (1 t) ())))) + (MTMod (id 1) (val_defs ((x (() (TCons (1 t) ()))))) + (constr_defs ((Nil ((() (TCons (1 t) ())) 0)))) + (ty_defs ((TDAdt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) (owned_mods ())))) - (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) ())))) - |}]; + (TopLet c + (EField + (MEName M + (MTMod (id 1) (val_defs ((x (() (TCons (1 t) ()))))) + (constr_defs ((Nil ((() (TCons (1 t) ())) 0)))) + (ty_defs ((TDAdt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) + (owned_mods ()))) + x (TCons (1 t) ())))) |}]; print_typed {| @@ -487,89 +463,86 @@ let%expect_test "Test: full program typing" = |}; [%expect {| - ((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 ()) + ((TopMod M + (MEStruct + ((TopTypeDef (TDAdt t () ((Nil ())))) + (TopLet x (ECons Nil 0 (TCons (1 t) ()))) + (TopMod N + (MEStruct ((TopTypeDef (TDAdt t () ((Nil ()))))) + (MTMod (id 2) (val_defs ()) + (constr_defs ((Nil ((() (TCons (2 t) ())) 0)))) + (ty_defs ((TDAdt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) + (owned_mods ())))) + (TopLet z + (EFieldCons + (MEName N + (MTMod (id 2) (val_defs ()) + (constr_defs ((Nil ((() (TCons (2 t) ())) 0)))) + (ty_defs ((TDAdt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - 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 ()) + Nil 0 (TCons (2 t) ())))) + (MTMod (id 1) + (val_defs ((z (() (TCons (2 t) ()))) (x (() (TCons (1 t) ()))))) + (constr_defs ((Nil ((() (TCons (1 t) ())) 0)))) + (ty_defs ((TDAdt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ((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 ()))))) + (MTMod (id 2) (val_defs ()) + (constr_defs ((Nil ((() (TCons (2 t) ())) 0)))) + (ty_defs ((TDAdt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) + (owned_mods ()))))) (owned_mods (2))))) - (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 ()) + (TopLet c + (EField + (MEName M + (MTMod (id 1) + (val_defs ((z (() (TCons (2 t) ()))) (x (() (TCons (1 t) ()))))) + (constr_defs ((Nil ((() (TCons (1 t) ())) 0)))) + (ty_defs ((TDAdt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ((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 ()) + (MTMod (id 2) (val_defs ()) + (constr_defs ((Nil ((() (TCons (2 t) ())) 0)))) + (ty_defs ((TDAdt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) (owned_mods (2)))) - x (Ty_cons (1 t) ()))) - (Top_let x - (Exp_field_constr - (Mod_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 ()) + x (TCons (1 t) ()))) + (TopLet x + (EFieldCons + (MEField + (MEName M + (MTMod (id 1) + (val_defs ((z (() (TCons (2 t) ()))) (x (() (TCons (1 t) ()))))) + (constr_defs ((Nil ((() (TCons (1 t) ())) 0)))) + (ty_defs ((TDAdt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ((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 ()) + (MTMod (id 2) (val_defs ()) + (constr_defs ((Nil ((() (TCons (2 t) ())) 0)))) + (ty_defs ((TDAdt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) (owned_mods (2)))) 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 (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 ()) + (MTMod (id 2) (val_defs ()) + (constr_defs ((Nil ((() (TCons (2 t) ())) 0)))) + (ty_defs ((TDAdt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) + (owned_mods ()))) + Nil 0 (TCons (2 t) ()))) + (TopLet y + (EField + (MEName M + (MTMod (id 1) + (val_defs ((z (() (TCons (2 t) ()))) (x (() (TCons (1 t) ()))))) + (constr_defs ((Nil ((() (TCons (1 t) ())) 0)))) + (ty_defs ((TDAdt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ((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 ()) + (MTMod (id 2) (val_defs ()) + (constr_defs ((Nil ((() (TCons (2 t) ())) 0)))) + (ty_defs ((TDAdt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) (owned_mods (2)))) - z (Ty_cons (2 t) ())))) + z (TCons (2 t) ())))) |}]; print_typed @@ -587,21 +560,21 @@ let%expect_test "Test: full program typing" = |}; [%expect {| - ((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 ()) + ((TopMod M + (MERestrict + (MEStruct + ((TopTypeDef (TDAdt t () ((Nil ())))) + (TopLet x (ECons Nil 0 (TCons (1 t) ())))) + (MTMod (id 1) (val_defs ((x (() (TCons (1 t) ()))))) + (constr_defs ((Nil ((() (TCons (1 t) ())) 0)))) + (ty_defs ((TDAdt t () ((Nil ()))))) (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 ()))))) + (MTMod (id 2) (val_defs ((x (() (TCons (2 t) ()))))) (constr_defs ()) + (ty_defs ((TDOpaque t ()))) (mod_sigs ()) (mod_defs ()) + (owned_mods ())) + (MTMod (id 3) (val_defs ((x (() (TCons (3 t) ()))))) (constr_defs ()) + (ty_defs ((TDOpaque t ()))) (mod_sigs ()) (mod_defs ()) + (owned_mods ()))))) |}]; print_typed @@ -615,10 +588,10 @@ let%expect_test "Test: full program typing" = |}; [%expect {| - ((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 ()) + ((TopModSig MIntf + (MTMod (id 1) (val_defs ((x (() (TCons (1 t) ()))))) + (constr_defs ((Nil ((() (TCons (1 t) ())) 0)))) + (ty_defs ((TDAdt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) (owned_mods ())))) |}]; @@ -643,9 +616,9 @@ let%expect_test "Test: full program typing" = Module Definitions: Module Types: - 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 ()) + MIntf |-> (MTMod (id 1) (val_defs ((x (() (TCons (1 t) ()))))) + (constr_defs ((Nil ((() (TCons (1 t) ())) 0)))) + (ty_defs ((TDAdt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) (owned_mods ())) Module Creation History: 1 @@ -667,10 +640,9 @@ let%expect_test "Test: full program typing" = |}; [%expect {| - ((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 ())))) + ((TopModSig MIntf + (MTMod (id 1) (val_defs ((x (() (TCons (1 t) ()))))) (constr_defs ()) + (ty_defs ((TDOpaque t ()))) (mod_sigs ()) (mod_defs ()) (owned_mods ())))) |}]; print_typed @@ -694,28 +666,26 @@ let%expect_test "Test: full program typing" = |}; [%expect {| - ((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 (() (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 ()))))) + ((TopModSig MIntf + (MTMod (id 1) (val_defs ((x (() (TCons (1 t) ()))))) (constr_defs ()) + (ty_defs ((TDOpaque t ()))) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) + (TopMod MImpl + (MERestrict + (MEStruct + ((TopTypeDef (TDAdt t () ((Nil ())))) + (TopLet z (EConst (CInt 1) (TCons (0 int) ()))) + (TopLet x (ECons Nil 0 (TCons (2 t) ())))) + (MTMod (id 2) + (val_defs ((x (() (TCons (2 t) ()))) (z (() (TCons (0 int) ()))))) + (constr_defs ((Nil ((() (TCons (2 t) ())) 0)))) + (ty_defs ((TDAdt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) + (owned_mods ()))) + (MTMod (id 1) (val_defs ((x (() (TCons (1 t) ()))))) (constr_defs ()) + (ty_defs ((TDOpaque t ()))) (mod_sigs ()) (mod_defs ()) + (owned_mods ())) + (MTMod (id 3) (val_defs ((x (() (TCons (3 t) ()))))) (constr_defs ()) + (ty_defs ((TDOpaque t ()))) (mod_sigs ()) (mod_defs ()) + (owned_mods ()))))) |}]; print_typed @@ -774,194 +744,186 @@ module MMM = (M(F).K : I) |}; [%expect {| - ((Top_mod_sig I - (Mod_ty_struct (id 1) - (val_defs ((y (() (Ty_cons (0 int) ()))) (x (() (Ty_cons (0 int) ()))))) + ((TopModSig I + (MTMod (id 1) + (val_defs ((y (() (TCons (0 int) ()))) (x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - (Top_mod_sig J - (Mod_ty_struct (id 2) + (TopModSig J + (MTMod (id 2) (val_defs - ((z (() (Ty_cons (0 int) ()))) (y (() (Ty_cons (0 int) ()))) - (x (() (Ty_cons (0 int) ()))))) + ((z (() (TCons (0 int) ()))) (y (() (TCons (0 int) ()))) + (x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - (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) + (TopMod MJ + (MEStruct + ((TopLet x (EConst (CInt 1) (TCons (0 int) ()))) + (TopLet y (EConst (CInt 1) (TCons (0 int) ()))) + (TopLet z (EConst (CInt 1) (TCons (0 int) ())))) + (MTMod (id 3) (val_defs - ((z (() (Ty_cons (0 int) ()))) (y (() (Ty_cons (0 int) ()))) - (x (() (Ty_cons (0 int) ()))))) + ((z (() (TCons (0 int) ()))) (y (() (TCons (0 int) ()))) + (x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())))) - (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 (() (Ty_cons (0 int) ()))) (x (() (Ty_cons (0 int) ()))))) + (TopMod Simple + (MEStruct + ((TopLet x (EConst (CInt 1) (TCons (0 int) ()))) + (TopLet y (EConst (CInt 2) (TCons (0 int) ())))) + (MTMod (id 4) + (val_defs ((y (() (TCons (0 int) ()))) (x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())))) - (Top_mod M - (Mod_functor + (TopMod M + (MEFunctor (MI - (Mod_ty_functor - ((Mod_ty_struct (id 1) + (MTFun + ((MTMod (id 1) (val_defs - ((y (() (Ty_cons (0 int) ()))) (x (() (Ty_cons (0 int) ()))))) + ((y (() (TCons (0 int) ()))) (x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())) - (Mod_ty_struct (id 1) + (MTMod (id 1) (val_defs - ((y (() (Ty_cons (0 int) ()))) (x (() (Ty_cons (0 int) ()))))) + ((y (() (TCons (0 int) ()))) (x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) - (Mod_struct - ((Top_mod K - (Mod_apply - (Mod_name MI - (Mod_ty_functor - ((Mod_ty_struct (id 1) + (MEStruct + ((TopMod K + (MEApply + (MEName MI + (MTFun + ((MTMod (id 1) (val_defs - ((y (() (Ty_cons (0 int) ()))) - (x (() (Ty_cons (0 int) ()))))) + ((y (() (TCons (0 int) ()))) + (x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())) - (Mod_ty_struct (id 1) + (MTMod (id 1) (val_defs - ((y (() (Ty_cons (0 int) ()))) - (x (() (Ty_cons (0 int) ()))))) + ((y (() (TCons (0 int) ()))) + (x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) - (Mod_name Simple - (Mod_ty_struct (id 4) + (MEName Simple + (MTMod (id 4) (val_defs - ((y (() (Ty_cons (0 int) ()))) - (x (() (Ty_cons (0 int) ()))))) + ((y (() (TCons (0 int) ()))) (x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - (Mod_ty_struct (id 6) + (MTMod (id 6) (val_defs - ((y (() (Ty_cons (0 int) ()))) - (x (() (Ty_cons (0 int) ()))))) + ((y (() (TCons (0 int) ()))) (x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) - (Mod_ty_struct (id 5) (val_defs ()) (constr_defs ()) (ty_defs ()) + (MTMod (id 5) (val_defs ()) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ((K - (Mod_ty_struct (id 6) + (MTMod (id 6) (val_defs - ((y (() (Ty_cons (0 int) ()))) - (x (() (Ty_cons (0 int) ()))))) + ((y (() (TCons (0 int) ()))) (x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) (owned_mods (6)))))) - (Top_mod F - (Mod_functor + (TopMod F + (MEFunctor (MI - (Mod_ty_struct (id 1) + (MTMod (id 1) (val_defs - ((y (() (Ty_cons (0 int) ()))) (x (() (Ty_cons (0 int) ()))))) + ((y (() (TCons (0 int) ()))) (x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - (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) + (MERestrict + (MEStruct + ((TopLet x (EConst (CInt 1) (TCons (0 int) ()))) + (TopLet y (EConst (CInt 1) (TCons (0 int) ()))) + (TopLet z (EConst (CInt 1) (TCons (0 int) ())))) + (MTMod (id 7) (val_defs - ((z (() (Ty_cons (0 int) ()))) (y (() (Ty_cons (0 int) ()))) - (x (() (Ty_cons (0 int) ()))))) + ((z (() (TCons (0 int) ()))) (y (() (TCons (0 int) ()))) + (x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - (Mod_ty_struct (id 2) + (MTMod (id 2) (val_defs - ((z (() (Ty_cons (0 int) ()))) (y (() (Ty_cons (0 int) ()))) - (x (() (Ty_cons (0 int) ()))))) + ((z (() (TCons (0 int) ()))) (y (() (TCons (0 int) ()))) + (x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())) - (Mod_ty_struct (id 8) + (MTMod (id 8) (val_defs - ((z (() (Ty_cons (0 int) ()))) (y (() (Ty_cons (0 int) ()))) - (x (() (Ty_cons (0 int) ()))))) + ((z (() (TCons (0 int) ()))) (y (() (TCons (0 int) ()))) + (x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) - (Top_mod MMM - (Mod_restrict - (Mod_field - (Mod_apply - (Mod_name M - (Mod_ty_functor - ((Mod_ty_functor - ((Mod_ty_struct (id 1) + (TopMod MMM + (MERestrict + (MEField + (MEApply + (MEName M + (MTFun + ((MTFun + ((MTMod (id 1) (val_defs - ((y (() (Ty_cons (0 int) ()))) - (x (() (Ty_cons (0 int) ()))))) + ((y (() (TCons (0 int) ()))) + (x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())) - (Mod_ty_struct (id 1) + (MTMod (id 1) (val_defs - ((y (() (Ty_cons (0 int) ()))) - (x (() (Ty_cons (0 int) ()))))) + ((y (() (TCons (0 int) ()))) + (x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())))) - (Mod_ty_struct (id 5) (val_defs ()) (constr_defs ()) - (ty_defs ()) (mod_sigs ()) + (MTMod (id 5) (val_defs ()) (constr_defs ()) (ty_defs ()) + (mod_sigs ()) (mod_defs ((K - (Mod_ty_struct (id 6) + (MTMod (id 6) (val_defs - ((y (() (Ty_cons (0 int) ()))) - (x (() (Ty_cons (0 int) ()))))) + ((y (() (TCons (0 int) ()))) + (x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) (owned_mods (6)))))) - (Mod_name F - (Mod_ty_functor - ((Mod_ty_struct (id 1) + (MEName F + (MTFun + ((MTMod (id 1) (val_defs - ((y (() (Ty_cons (0 int) ()))) - (x (() (Ty_cons (0 int) ()))))) + ((y (() (TCons (0 int) ()))) (x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())) - (Mod_ty_struct (id 8) + (MTMod (id 8) (val_defs - ((z (() (Ty_cons (0 int) ()))) - (y (() (Ty_cons (0 int) ()))) - (x (() (Ty_cons (0 int) ()))))) + ((z (() (TCons (0 int) ()))) (y (() (TCons (0 int) ()))) + (x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) - (Mod_ty_struct (id 9) (val_defs ()) (constr_defs ()) (ty_defs ()) + (MTMod (id 9) (val_defs ()) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ((K - (Mod_ty_struct (id 10) + (MTMod (id 10) (val_defs - ((y (() (Ty_cons (0 int) ()))) - (x (() (Ty_cons (0 int) ()))))) + ((y (() (TCons (0 int) ()))) + (x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) (owned_mods (10)))) K - (Mod_ty_struct (id 10) + (MTMod (id 10) (val_defs - ((y (() (Ty_cons (0 int) ()))) (x (() (Ty_cons (0 int) ()))))) + ((y (() (TCons (0 int) ()))) (x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - (Mod_ty_struct (id 1) - (val_defs - ((y (() (Ty_cons (0 int) ()))) (x (() (Ty_cons (0 int) ()))))) + (MTMod (id 1) + (val_defs ((y (() (TCons (0 int) ()))) (x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())) - (Mod_ty_struct (id 11) - (val_defs - ((y (() (Ty_cons (0 int) ()))) (x (() (Ty_cons (0 int) ()))))) + (MTMod (id 11) + (val_defs ((y (() (TCons (0 int) ()))) (x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) |}]; @@ -1031,64 +993,61 @@ module MMM = (M(F).K : I) Type Definitions: Module Definitions: - MMM |-> (Mod_ty_struct (id 13) - (val_defs ((y (() (Ty_cons (0 int) ()))) (x (() (Ty_cons (0 int) ()))))) + MMM |-> (MTMod (id 13) + (val_defs ((y (() (TCons (0 int) ()))) (x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())); - F |-> (Mod_ty_functor - ((Mod_ty_struct (id 1) - (val_defs ((y (() (Ty_cons (0 int) ()))) (x (() (Ty_cons (0 int) ()))))) + F |-> (MTFun + ((MTMod (id 1) + (val_defs ((y (() (TCons (0 int) ()))) (x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())) - (Mod_ty_struct (id 9) + (MTMod (id 9) (val_defs - ((z (() (Ty_cons (0 int) ()))) (y (() (Ty_cons (0 int) ()))) - (x (() (Ty_cons (0 int) ()))))) + ((z (() (TCons (0 int) ()))) (y (() (TCons (0 int) ()))) + (x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())))); - M |-> (Mod_ty_functor - ((Mod_ty_functor - ((Mod_ty_struct (id 1) - (val_defs - ((y (() (Ty_cons (0 int) ()))) (x (() (Ty_cons (0 int) ()))))) + M |-> (MTFun + ((MTFun + ((MTMod (id 1) + (val_defs ((y (() (TCons (0 int) ()))) (x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())) - (Mod_ty_struct (id 1) - (val_defs - ((y (() (Ty_cons (0 int) ()))) (x (() (Ty_cons (0 int) ()))))) + (MTMod (id 1) + (val_defs ((y (() (TCons (0 int) ()))) (x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())))) - (Mod_ty_struct (id 5) (val_defs ()) (constr_defs ()) (ty_defs ()) - (mod_sigs ()) + (MTMod (id 5) (val_defs ()) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ((K2 - (Mod_ty_struct (id 7) + (MTMod (id 7) (val_defs - ((y (() (Ty_cons (0 int) ()))) (x (() (Ty_cons (0 int) ()))))) + ((y (() (TCons (0 int) ()))) (x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) (K - (Mod_ty_struct (id 6) + (MTMod (id 6) (val_defs - ((y (() (Ty_cons (0 int) ()))) (x (() (Ty_cons (0 int) ()))))) + ((y (() (TCons (0 int) ()))) (x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) (owned_mods (7 6))))); - Simple |-> (Mod_ty_struct (id 4) - (val_defs ((y (() (Ty_cons (0 int) ()))) (x (() (Ty_cons (0 int) ()))))) + Simple |-> (MTMod (id 4) + (val_defs ((y (() (TCons (0 int) ()))) (x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())); - MJ |-> (Mod_ty_struct (id 3) + MJ |-> (MTMod (id 3) (val_defs - ((z (() (Ty_cons (0 int) ()))) (y (() (Ty_cons (0 int) ()))) - (x (() (Ty_cons (0 int) ()))))) + ((z (() (TCons (0 int) ()))) (y (() (TCons (0 int) ()))) + (x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())) Module Types: - J |-> (Mod_ty_struct (id 2) + J |-> (MTMod (id 2) (val_defs - ((z (() (Ty_cons (0 int) ()))) (y (() (Ty_cons (0 int) ()))) - (x (() (Ty_cons (0 int) ()))))) + ((z (() (TCons (0 int) ()))) (y (() (TCons (0 int) ()))) + (x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())); - I |-> (Mod_ty_struct (id 1) - (val_defs ((y (() (Ty_cons (0 int) ()))) (x (() (Ty_cons (0 int) ()))))) + I |-> (MTMod (id 1) + (val_defs ((y (() (TCons (0 int) ()))) (x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())) Module Creation History: 13; @@ -1119,12 +1078,10 @@ external print_int : int -> int = "ff_builtin_print_int" |}; [%expect {| - ((Top_external add - (Ty_arrow (Ty_cons (0 int) ()) - (Ty_arrow (Ty_cons (0 int) ()) (Ty_cons (0 int) ()))) + ((TopExternal add + (TArrow (TCons (0 int) ()) (TArrow (TCons (0 int) ()) (TCons (0 int) ()))) ff_add) - (Top_external print_int - (Ty_arrow (Ty_cons (0 int) ()) (Ty_cons (0 int) ())) + (TopExternal print_int (TArrow (TCons (0 int) ()) (TCons (0 int) ())) ff_builtin_print_int)) |}]; @@ -1134,10 +1091,10 @@ external print_int : int -> int = "ff_builtin_print_int" |}; [%expect {| - ((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) ())))) + ((TopLet x (EConst (CInt 1) (TCons (0 int) ()))) + (TopLet n + (ECmp Eq (EVar x (TCons (0 int) ())) (EConst (CInt 1) (TCons (0 int) ())) + (TCons (0 bool) ())))) |}]; print_effect {| @@ -1149,7 +1106,7 @@ external print_int : int -> int = "ff_builtin_print_int" ++++++++++++++++++Scope Debug Info Begin++++++++++++++++++ Value Bindings: - id |-> forall '_t/2 . (Ty_arrow (Ty_qvar '_t/2) (Ty_qvar '_t/2)) + id |-> forall '_t/2 . (TArrow (TQVar '_t/2) (TQVar '_t/2)) Type Definitions: Module Definitions: @@ -1175,24 +1132,24 @@ external print_int : int -> int = "ff_builtin_print_int" |}; [%expect {| - ((Top_mod M - (Mod_struct - ((Top_mod_sig N - (Mod_ty_struct (id 2) (val_defs ()) (constr_defs ()) (ty_defs ()) + ((TopMod M + (MEStruct + ((TopModSig N + (MTMod (id 2) (val_defs ()) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())))) - (Mod_ty_struct (id 1) (val_defs ()) (constr_defs ()) (ty_defs ()) + (MTMod (id 1) (val_defs ()) (constr_defs ()) (ty_defs ()) (mod_sigs ((N - (Mod_ty_struct (id 2) (val_defs ()) (constr_defs ()) (ty_defs ()) + (MTMod (id 2) (val_defs ()) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) (mod_defs ()) (owned_mods (2))))) - (Top_mod F - (Mod_functor + (TopMod F + (MEFunctor (X - (Mod_ty_struct (id 2) (val_defs ()) (constr_defs ()) (ty_defs ()) + (MTMod (id 2) (val_defs ()) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - (Mod_struct () - (Mod_ty_struct (id 3) (val_defs ()) (constr_defs ()) (ty_defs ()) + (MEStruct () + (MTMod (id 3) (val_defs ()) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ())))))) |}]; print_typed @@ -1207,25 +1164,23 @@ external print_int : int -> int = "ff_builtin_print_int" |}; [%expect {| - ((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 ()) + ((TopMod F + (MERestrict + (MERestrict + (MEStruct ((TopTypeDef (TDAlias t (TCons (0 int) ())))) + (MTMod (id 1) (val_defs ()) (constr_defs ()) + (ty_defs ((TDAlias t (TCons (0 int) ())))) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - (Mod_ty_struct (id 2) (val_defs ()) (constr_defs ()) - (ty_defs ((Ty_def_opaque t ()))) (mod_sigs ()) (mod_defs ()) + (MTMod (id 2) (val_defs ()) (constr_defs ()) + (ty_defs ((TDOpaque t ()))) (mod_sigs ()) (mod_defs ()) (owned_mods ())) - (Mod_ty_struct (id 3) (val_defs ()) (constr_defs ()) - (ty_defs ((Ty_def_opaque t ()))) (mod_sigs ()) (mod_defs ()) + (MTMod (id 3) (val_defs ()) (constr_defs ()) + (ty_defs ((TDOpaque t ()))) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - (Mod_ty_struct (id 4) (val_defs ()) (constr_defs ()) - (ty_defs ((Ty_def_opaque t ()))) (mod_sigs ()) (mod_defs ()) - (owned_mods ())) - (Mod_ty_struct (id 5) (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 ((TDOpaque t ()))) + (mod_sigs ()) (mod_defs ()) (owned_mods ())) + (MTMod (id 5) (val_defs ()) (constr_defs ()) (ty_defs ((TDOpaque t ()))) + (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) |}] let%expect_test "Error reporting test" = @@ -1283,55 +1238,51 @@ let%expect_test "Error reporting test" = |}; [%expect {| - ((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) ())))) + ((TopModSig I + (MTMod (id 1) (val_defs ((x (() (TCons (0 int) ()))))) (constr_defs ()) + (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) + (TopMod F + (MERestrict + (MEStruct + ((TopTypeDef (TDAlias t (TCons (0 int) ()))) + (TopLet y (EConst (CInt 1) (TCons (0 int) ())))) + (MTMod (id 2) (val_defs ((y (() (TCons (0 int) ()))))) + (constr_defs ()) (ty_defs ((TDAlias t (TCons (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 ())) - (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 + (MTMod (id 3) (val_defs ((y (() (TCons (3 t) ()))))) (constr_defs ()) + (ty_defs ((TDOpaque t ()))) (mod_sigs ()) (mod_defs ()) + (owned_mods ())) + (MTMod (id 4) (val_defs ((y (() (TCons (4 t) ()))))) (constr_defs ()) + (ty_defs ((TDOpaque t ()))) (mod_sigs ()) (mod_defs ()) + (owned_mods ()))))) + ((TopModSig I + (MTMod (id 1) (val_defs ((x (() (TCons (0 int) ()))))) (constr_defs ()) + (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) + (TopMod F + (MEFunctor (X - (Mod_ty_struct (id 1) (val_defs ((x (() (Ty_cons (0 int) ()))))) + (MTMod (id 1) (val_defs ((x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - (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) ()))))) + (MERestrict + (MEStruct + ((TopTypeDef (TDAlias t (TCons (0 int) ()))) + (TopLet y + (EField + (MEName X + (MTMod (id 1) (val_defs ((x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - 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 ())) - (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 ())))))) + x (TCons (0 int) ())))) + (MTMod (id 2) (val_defs ((y (() (TCons (0 int) ()))))) + (constr_defs ()) (ty_defs ((TDAlias t (TCons (0 int) ())))) + (mod_sigs ()) (mod_defs ()) (owned_mods ()))) + (MTMod (id 3) (val_defs ((y (() (TCons (3 t) ()))))) (constr_defs ()) + (ty_defs ((TDOpaque t ()))) (mod_sigs ()) (mod_defs ()) + (owned_mods ())) + (MTMod (id 4) (val_defs ((y (() (TCons (4 t) ()))))) (constr_defs ()) + (ty_defs ((TDOpaque t ()))) (mod_sigs ()) (mod_defs ()) + (owned_mods ())))))) |}]; print_typed @@ -1384,34 +1335,30 @@ let%expect_test "Error reporting test" = |}; [%expect {| - ((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 + ((TopModSig I + (MTMod (id 1) (val_defs ((x (() (TCons (0 int) ()))))) (constr_defs ()) + (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) + (TopMod F + (MEFunctor (X - (Mod_ty_struct (id 1) (val_defs ((x (() (Ty_cons (0 int) ()))))) + (MTMod (id 1) (val_defs ((x (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - (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) ()))))) + (MERestrict + (MEStruct + ((TopTypeDef (TDAlias t (TCons (0 int) ()))) + (TopTypeDef (TDAlias n (TCons (0 int) ()))) + (TopLet y (EConst (CInt 3) (TCons (0 int) ())))) + (MTMod (id 2) (val_defs ((y (() (TCons (0 int) ()))))) (constr_defs ()) (ty_defs - ((Ty_def_alias n (Ty_cons (0 int) ())) - (Ty_def_alias t (Ty_cons (0 int) ())))) + ((TDAlias n (TCons (0 int) ())) (TDAlias t (TCons (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 ()) (Ty_def_opaque n ()))) (mod_sigs ()) + (MTMod (id 3) (val_defs ((y (() (TCons (3 t) ()))))) (constr_defs ()) + (ty_defs ((TDOpaque t ()) (TDOpaque 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 ()) + (MTMod (id 4) (val_defs ((y (() (TCons (4 t) ()))))) (constr_defs ()) + (ty_defs ((TDOpaque t ()) (TDOpaque n ()))) (mod_sigs ()) (mod_defs ()) (owned_mods ())))))) |}]; @@ -1424,29 +1371,29 @@ let%expect_test "Error reporting test" = |}; [%expect {| - ((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) ())))))))) + ((TopLet x + (ELet y + (ETuple + ((EConst (CInt 1) (TCons (0 int) ())) + (EConst (CInt 1) (TCons (0 int) ()))) + (TTuple ((TCons (0 int) ()) (TCons (0 int) ())))) + (ELet z + (ETuple + ((EConst (CInt 2) (TCons (0 int) ())) + (EConst (CInt 1) (TCons (0 int) ()))) + (TTuple ((TCons (0 int) ()) (TCons (0 int) ())))) + (ETuple + ((EVar y (TTuple ((TCons (0 int) ()) (TCons (0 int) ())))) + (EVar z (TTuple ((TCons (0 int) ()) (TCons (0 int) ()))))) + (TTuple + ((TTuple ((TCons (0 int) ()) (TCons (0 int) ()))) + (TTuple ((TCons (0 int) ()) (TCons (0 int) ())))))) + (TTuple + ((TTuple ((TCons (0 int) ()) (TCons (0 int) ()))) + (TTuple ((TCons (0 int) ()) (TCons (0 int) ())))))) + (TTuple + ((TTuple ((TCons (0 int) ()) (TCons (0 int) ()))) + (TTuple ((TCons (0 int) ()) (TCons (0 int) ())))))))) |}]; print_typed @@ -1480,93 +1427,87 @@ module L2 = (K: M) |}; [%expect {| - ((Top_mod_sig M - (Mod_ty_struct (id 1) (val_defs ()) (constr_defs ()) (ty_defs ()) - (mod_sigs ()) + ((TopModSig M + (MTMod (id 1) (val_defs ()) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ((N - (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 ()))))) + (MTMod (id 2) (val_defs ()) (constr_defs ()) + (ty_defs ((TDOpaque s ()) (TDOpaque t ()))) (mod_sigs ()) + (mod_defs ()) (owned_mods ()))))) (owned_mods (2)))) - (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 ()) + (TopMod K + (MEStruct + ((TopMod N + (MEStruct + ((TopTypeDef (TDAlias t (TCons (0 int) ()))) + (TopTypeDef (TDAlias s (TCons (0 int) ())))) + (MTMod (id 4) (val_defs ()) (constr_defs ()) (ty_defs - ((Ty_def_alias s (Ty_cons (0 int) ())) - (Ty_def_alias t (Ty_cons (0 int) ())))) + ((TDAlias s (TCons (0 int) ())) + (TDAlias t (TCons (0 int) ())))) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) - (Mod_ty_struct (id 3) (val_defs ()) (constr_defs ()) (ty_defs ()) - (mod_sigs ()) + (MTMod (id 3) (val_defs ()) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ((N - (Mod_ty_struct (id 4) (val_defs ()) (constr_defs ()) + (MTMod (id 4) (val_defs ()) (constr_defs ()) (ty_defs - ((Ty_def_alias s (Ty_cons (0 int) ())) - (Ty_def_alias t (Ty_cons (0 int) ())))) + ((TDAlias s (TCons (0 int) ())) + (TDAlias t (TCons (0 int) ())))) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) (owned_mods (4))))) - (Top_mod L1 - (Mod_restrict - (Mod_name K - (Mod_ty_struct (id 3) (val_defs ()) (constr_defs ()) (ty_defs ()) + (TopMod L1 + (MERestrict + (MEName K + (MTMod (id 3) (val_defs ()) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ((N - (Mod_ty_struct (id 4) (val_defs ()) (constr_defs ()) + (MTMod (id 4) (val_defs ()) (constr_defs ()) (ty_defs - ((Ty_def_alias s (Ty_cons (0 int) ())) - (Ty_def_alias t (Ty_cons (0 int) ())))) + ((TDAlias s (TCons (0 int) ())) + (TDAlias t (TCons (0 int) ())))) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) (owned_mods (4)))) - (Mod_ty_struct (id 1) (val_defs ()) (constr_defs ()) (ty_defs ()) - (mod_sigs ()) + (MTMod (id 1) (val_defs ()) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ((N - (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 ()))))) + (MTMod (id 2) (val_defs ()) (constr_defs ()) + (ty_defs ((TDOpaque s ()) (TDOpaque t ()))) (mod_sigs ()) + (mod_defs ()) (owned_mods ()))))) (owned_mods (2))) - (Mod_ty_struct (id 5) (val_defs ()) (constr_defs ()) (ty_defs ()) - (mod_sigs ()) + (MTMod (id 5) (val_defs ()) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ((N - (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 ()))))) + (MTMod (id 6) (val_defs ()) (constr_defs ()) + (ty_defs ((TDOpaque s ()) (TDOpaque t ()))) (mod_sigs ()) + (mod_defs ()) (owned_mods ()))))) (owned_mods (6))))) - (Top_mod L2 - (Mod_restrict - (Mod_name K - (Mod_ty_struct (id 3) (val_defs ()) (constr_defs ()) (ty_defs ()) + (TopMod L2 + (MERestrict + (MEName K + (MTMod (id 3) (val_defs ()) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ((N - (Mod_ty_struct (id 4) (val_defs ()) (constr_defs ()) + (MTMod (id 4) (val_defs ()) (constr_defs ()) (ty_defs - ((Ty_def_alias s (Ty_cons (0 int) ())) - (Ty_def_alias t (Ty_cons (0 int) ())))) + ((TDAlias s (TCons (0 int) ())) + (TDAlias t (TCons (0 int) ())))) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) (owned_mods (4)))) - (Mod_ty_struct (id 1) (val_defs ()) (constr_defs ()) (ty_defs ()) - (mod_sigs ()) + (MTMod (id 1) (val_defs ()) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ((N - (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 ()))))) + (MTMod (id 2) (val_defs ()) (constr_defs ()) + (ty_defs ((TDOpaque s ()) (TDOpaque t ()))) (mod_sigs ()) + (mod_defs ()) (owned_mods ()))))) (owned_mods (2))) - (Mod_ty_struct (id 7) (val_defs ()) (constr_defs ()) (ty_defs ()) - (mod_sigs ()) + (MTMod (id 7) (val_defs ()) (constr_defs ()) (ty_defs ()) (mod_sigs ()) (mod_defs ((N - (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 ()))))) + (MTMod (id 8) (val_defs ()) (constr_defs ()) + (ty_defs ((TDOpaque s ()) (TDOpaque t ()))) (mod_sigs ()) + (mod_defs ()) (owned_mods ()))))) (owned_mods (8)))))) |}]; @@ -1578,30 +1519,29 @@ module L2 = (K: M) |}; [%expect {| - ((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) ())))))))) + ((TopLet result + (ELet id + (ELam + (x (EVar x (TVar (Unbound '_t/1 4))) + (TArrow (TVar (Unbound '_t/1 4)) (TVar (Unbound '_t/1 4))))) + (ETuple + ((EApp + (EVar id + (TArrow (TVar (Link (TCons (0 int) ()))) + (TVar (Link (TCons (0 int) ()))))) + (EConst (CInt 1) (TCons (0 int) ())) + (TVar (Link (TCons (0 int) ())))) + (EApp + (EVar id + (TArrow (TVar (Link (TCons (0 string) ()))) + (TVar (Link (TCons (0 string) ()))))) + (EConst (CString "\"xx\"") (TCons (0 string) ())) + (TVar (Link (TCons (0 string) ()))))) + (TTuple + ((TVar (Link (TCons (0 int) ()))) + (TVar (Link (TCons (0 string) ())))))) + (TTuple + ((TVar (Link (TCons (0 int) ()))) (TVar (Link (TCons (0 string) ())))))))) |}]; print_typed {| @@ -1645,24 +1585,24 @@ module L2 = (K: M) |}; [%expect {| - ((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 ()) + ((TopModSig MT + (MTMod (id 1) (val_defs ()) + (constr_defs ((Nil ((() (TCons (1 t) ())) 0)))) + (ty_defs ((TDAdt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) (owned_mods ()))) - (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 ()) + (TopMod M + (MERestrict + (MEStruct ((TopTypeDef (TDAdt t () ((Nil ()))))) + (MTMod (id 2) (val_defs ()) + (constr_defs ((Nil ((() (TCons (2 t) ())) 0)))) + (ty_defs ((TDAdt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) + (owned_mods ()))) + (MTMod (id 1) (val_defs ()) + (constr_defs ((Nil ((() (TCons (1 t) ())) 0)))) + (ty_defs ((TDAdt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) (owned_mods ())) - (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 ()) + (MTMod (id 3) (val_defs ()) + (constr_defs ((Nil ((() (TCons (3 t) ())) 0)))) + (ty_defs ((TDAdt t () ((Nil ()))))) (mod_sigs ()) (mod_defs ()) (owned_mods ()))))) |}] diff --git a/tests/regular/unify_test.ml b/tests/regular/unify_test.ml index aba59d6..3a30063 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 = Ty_var { contents = Unbound (Ident.mk_ident 0 x, 0) } in + let type_of x = TVar { 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 {| (Ty_var (Link (Ty_cons (0 int) ()))) |}]; - unify (Ty_arrow (tv, tv)) (Ty_arrow (int_ty, ret_ty)); + [%expect {| (TVar (Link (TCons (0 int) ()))) |}]; + unify (TArrow (tv, tv)) (TArrow (int_ty, ret_ty)); print_type tv; - [%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 + [%expect {| (TVar (Link (TCons (0 int) ()))) |}]; + let t1 = TVar { contents = Unbound (Ident.mk_ident 0 "'t", 1) } in + let t2 = TVar { contents = Unbound (Ident.mk_ident 1 "'t", 33) } in print_type t1; print_type t2; [%expect {| - (Ty_var (Unbound 't/0 1)) - (Ty_var (Unbound 't/1 33)) + (TVar (Unbound 't/0 1)) + (TVar (Unbound 't/1 33)) |}]; unify t1 t2; print_type t1; print_type t2; [%expect {| - (Ty_var (Link (Ty_var (Unbound 't/1 1)))) - (Ty_var (Unbound 't/1 1)) + (TVar (Link (TVar (Unbound 't/1 1)))) + (TVar (Unbound 't/1 1)) |}]