From b1969a3755f7119b4d30754c59308fa5869ba1fe Mon Sep 17 00:00:00 2001 From: RJ Date: Fri, 13 May 2022 14:55:44 +0100 Subject: [PATCH 01/63] effectalias init --- bin/repl.ml | 23 ++- core/desugarDatatypes.ml | 185 ++++++++++++++++++++++-- core/desugarEffects.ml | 1 + core/desugarTypeVariables.ml | 22 +++ core/instantiate.ml | 26 ++++ core/instantiate.mli | 1 + core/lexer.mll | 1 + core/lib.ml | 1 + core/parser.mly | 56 +++++-- core/sugarTraversals.ml | 85 +++++++++++ core/sugarTraversals.mli | 9 ++ core/sugartoir.ml | 1 + core/sugartypes.ml | 10 +- core/transformSugar.ml | 20 ++- core/transformSugar.mli | 6 +- core/typeSugar.ml | 22 ++- core/types.ml | 92 +++++++++++- core/types.mli | 16 ++ tests/effectname.tests | 56 +++++++ tests/effectname/effect-same-name.links | 8 + tests/effectname/handler.links | 38 +++++ tests/effectname/mutual.links | 7 + tests/effectname/nested-decl.links | 8 + tests/effectname/one.links | 6 + tests/effectname/recursive.links | 10 ++ tests/effectname/simple-decl.links | 16 ++ tests/effectname/two-nested.links | 9 ++ tests/effectname/two.links | 7 + tests/effectname/typenames.links | 12 ++ tests/effectname/zero.links | 6 + 30 files changed, 717 insertions(+), 43 deletions(-) create mode 100644 tests/effectname.tests create mode 100755 tests/effectname/effect-same-name.links create mode 100755 tests/effectname/handler.links create mode 100755 tests/effectname/mutual.links create mode 100755 tests/effectname/nested-decl.links create mode 100644 tests/effectname/one.links create mode 100755 tests/effectname/recursive.links create mode 100755 tests/effectname/simple-decl.links create mode 100755 tests/effectname/two-nested.links create mode 100755 tests/effectname/two.links create mode 100755 tests/effectname/typenames.links create mode 100644 tests/effectname/zero.links diff --git a/bin/repl.ml b/bin/repl.ml index 708750355..d019774e7 100644 --- a/bin/repl.ml +++ b/bin/repl.ml @@ -265,19 +265,26 @@ let execute_directive context (name, args) = let handle previous_context current_context = function | `Definitions _defs -> - let tycon_env' = + let tycon_env', effect_env' = let tenv = Context.typing_environment previous_context in let tenv' = Context.typing_environment current_context in - let tycon_env, tycon_env' = - Types.(tenv.tycon_env, tenv'.tycon_env) + let tycon_env, tycon_env', effect_env, effect_env' = + Types.(tenv.tycon_env, tenv'.tycon_env, tenv.effect_env, tenv'.effect_env) in - Env.String.fold + ( Env.String.fold (fun name def new_tycons -> (* This is a bit of a hack, but it will have to do until names become hygienic. *) if not (Env.String.has name tycon_env) || not (Env.String.find name tycon_env == def) then Env.String.bind name def new_tycons else new_tycons) - tycon_env' Env.String.empty + tycon_env' Env.String.empty , + Env.String.fold + (fun name def new_effects -> + (* This is a bit of a hack, but it will have to do until names become hygienic. *) + if not (Env.String.has name effect_env) || not (Env.String.find name effect_env == def) + then Env.String.bind name def new_effects + else new_effects) + effect_env' Env.String.empty ) in Env.String.fold (fun name spec () -> @@ -285,6 +292,12 @@ let handle previous_context current_context = function (Module_hacks.Name.prettify name) (Types.string_of_tycon_spec spec)) tycon_env' (); + Env.String.fold + (fun name spec () -> + Printf.printf "%s = %s\n%!" + (Module_hacks.Name.prettify name) + (Types.string_of_effect_spec spec)) + effect_env' (); let diff previous_context current_context = let new_vars = let nenv, nenv' = diff --git a/core/desugarDatatypes.ml b/core/desugarDatatypes.ml index cc89e2fbd..24fbe72a0 100644 --- a/core/desugarDatatypes.ml +++ b/core/desugarDatatypes.ml @@ -45,6 +45,10 @@ object (self) (_, None) -> {< all_desugared = false >} | _ -> self + method! row' = function + (_, None) -> {< all_desugared = false >} + | _ -> self + method! type_arg' = function (_, None) -> {< all_desugared = false >} | _ -> self @@ -68,7 +72,7 @@ module Desugar = struct let desugar_quantifiers (sqs: SugarQuantifier.t list) : Quantifier.t list = List.map SugarQuantifier.get_resolved_exn sqs - let rec datatype (alias_env : Types.tycon_environment) t' = + let rec datatype (alias_env : Types.alias_environment) t' = let datatype t' = datatype alias_env t' in match t' with | { node = t; pos } -> @@ -148,11 +152,11 @@ module Desugar = struct else raise (TypeApplicationArityMismatch { pos; name = tycon; expected = qn; provided = tn }) in - begin match SEnv.find_opt tycon alias_env with + begin match SEnv.find_opt tycon alias_env.tycon with | None -> raise (UnboundTyCon (pos, tycon)) | Some (`Alias (qs, _dt)) -> let ts = match_quantifiers snd qs in - Instantiate.alias tycon ts alias_env + Instantiate.alias tycon ts alias_env.tycon | Some (`Abstract abstype) -> let ts = match_quantifiers identity (Abstype.arity abstype) in Application (abstype, ts) @@ -209,6 +213,70 @@ module Desugar = struct let seed = let open Datatype in match rv with + | EffectApplication (name, ts) -> + let match_quantifiers : type a. (a -> Kind.t) -> a list -> Types.type_arg list = fun proj qs -> + let match_kinds i (q, t) = + let primary_kind_of_type_arg : Datatype.type_arg -> PrimaryKind.t = function + | Type _ -> PrimaryKind.Type + | Row _ -> PrimaryKind.Row + | Presence _ -> PrimaryKind.Presence + in + let q_kind, _ = proj q in + let t_kind = primary_kind_of_type_arg t in + if q_kind <> t_kind then + raise + (TypeApplicationKindMismatch + { pos = node.pos; + name = name; + tyarg_number = i; + expected = PrimaryKind.to_string q_kind; + provided = PrimaryKind.to_string t_kind + }) + else t + in + let type_args qs ts = + List.combine qs ts + |> List.mapi + (fun i (q,t) -> + let t = match_kinds i (q, t) in + type_arg alias_env t node) + in + + let qn = List.length qs and tn = List.length ts in + if qn = tn then + type_args qs ts + else + raise (TypeApplicationArityMismatch { pos = node.pos; name = name; expected = qn; provided = tn }) + in + begin match SEnv.find_opt name alias_env.effectname with + | None -> raise (UnboundTyCon (node.pos, name)) + | Some (`Alias (qs, _r)) -> + let ts = match_quantifiers snd qs in + (* let Alias(_,body) = Instantiate.effectalias name ts alias_env.effectname in *) + (* body *) + Instantiate.effectalias name ts alias_env.effectname + | Some (`Abstract abstype) -> + let ts = match_quantifiers identity (Abstype.arity abstype) in + Application (abstype, ts) + | Some (`Mutual (qs, tygroup_ref)) -> + (* Check that the quantifiers / kinds match up, then generate + * a `RecursiveApplication. *) + let r_args = match_quantifiers snd qs in + let r_unwind args dual = + let _, body = StringMap.find name !tygroup_ref.type_map in + let body = Instantiate.recursive_application name qs args body in + if dual then dual_type body else body + in + let r_unique_name = name ^ string_of_int !tygroup_ref.id in + let r_linear () = StringMap.lookup name !tygroup_ref.linearity_map in + RecursiveApplication + { r_name = name; + r_dual = false; + r_unique_name; + r_quantifiers = List.map snd qs; + r_args; r_unwind; r_linear + } + end | Closed -> Types.make_empty_closed_row () | Open srv -> let rv = SugarTypeVar.get_resolved_row_exn srv in @@ -241,6 +309,9 @@ module Desugar = struct let datatype' alias_env ((dt, _) : datatype') = (dt, Some (datatype alias_env dt)) + let row' alias_env ((r, _) :row') = + (r, Some (row alias_env r (WithPos.make (Datatype.Effect r)))) (* TODO(rj) should keep the pos *) + let type_arg' alias_env ((ta, _) : type_arg') : type_arg' = let unlocated = WithPos.make Datatype.Unit in (ta, Some (type_arg alias_env ta unlocated)) @@ -288,6 +359,8 @@ object (self) method! datatype' node = (self, Desugar.datatype' alias_env node) + method! row' node = (self, Desugar.row' alias_env node) + method! type_arg' node = (self, Desugar.type_arg' alias_env node) method! phrasenode = function @@ -340,10 +413,11 @@ object (self) (* Add all type declarations in the group to the alias * environment, as mutuals. Quantifiers need to be desugared. *) - let ((mutual_env : tycon_spec SEnv.t), ts) = + let ((mutual_env : Types.alias_environment), ts) = List.fold_left (fun (alias_env, ts) {node=(t, args, (d, _)); pos} -> let qs = Desugar.desugar_quantifiers args in - let alias_env = SEnv.bind t (`Mutual (qs, tygroup_ref)) alias_env in + let alias_env = { tycon = SEnv.bind t (`Mutual (qs, tygroup_ref)) alias_env.tycon ; + effectname = alias_env.effectname } in (alias_env, WithPos.make ~pos (t, args, (d, None)) :: ts)) (alias_env, []) ts in @@ -403,8 +477,8 @@ object (self) List.fold_left (fun alias_env {node=(t, args, (_, dt')); _} -> let dt = OptionUtils.val_of dt' in let semantic_qs = List.map SugarQuantifier.get_resolved_exn args in - let alias_env = - SEnv.bind t (`Alias (semantic_qs, dt)) alias_env in + let alias_env = { tycon = SEnv.bind t (`Alias (semantic_qs, dt)) alias_env.tycon ; + effectname = alias_env.effectname } in tygroup_ref := { !tygroup_ref with type_map = (StringMap.add t (semantic_qs, dt) !tygroup_ref.type_map); @@ -413,6 +487,95 @@ object (self) ) alias_env desugared_mutuals in ({< alias_env = alias_env >}, Typenames desugared_mutuals) + | Effectnames rs -> + (* Maps syntactic types in the recursive group to semantic types. *) + (* This must be empty to start off with, because there's a cycle + * in calculating the semantic types: we need the alias environment + * populated with all types in the group in order to calculate a + * semantic type. We populate the reference in a later pass. *) + let tygroup_ref = ref { + id = fresh_tygroup_id (); + type_map = StringMap.empty; + linearity_map = StringMap.empty + } in + + + (* Add all type declarations in the group to the alias + * environment, as mutuals. Quantifiers need to be desugared. *) + let ((mutual_env : Types.alias_environment), rs) = + List.fold_left (fun (alias_env, rs) {node=(t, args, (r, _)); pos} -> + let qs = Desugar.desugar_quantifiers args in + let alias_env = { tycon = alias_env.tycon ; + effectname = SEnv.bind t (`Mutual (qs, tygroup_ref)) alias_env.effectname } in + (alias_env, WithPos.make ~pos (t, args, (r, None)) :: rs)) + (alias_env, []) rs in + + (* Desugar all DTs, given the temporary new alias environment. *) + let desugared_mutuals = + List.map (fun {node=(name, args, r); pos} -> + (* Desugar the datatype *) + let r' = Desugar.row' mutual_env r in + (* Check if the datatype has actually been desugared *) + let (t, r) = + match r' with + | (t, Some r) -> (t, r) + | _ -> assert false in + WithPos.make ~pos (name, args, (t, Some r)) + ) rs in + + (* Given the desugared datatypes, we now need to handle linearity. + First, calculate linearity up to recursive application *) + let (linearity_env, dep_graph) = + List.fold_left (fun (lin_map, dep_graph) mutual -> + let (name, _, (_, r)) = SourceCode.WithPos.node mutual in + let r = OptionUtils.val_of r in + let lin_map = StringMap.add name (not @@ Unl.type_satisfies r) lin_map in + let deps = recursive_applications r in + let dep_graph = (name, deps) :: dep_graph in + (lin_map, dep_graph) + ) (StringMap.empty, []) desugared_mutuals in + (* Next, use the toposorted dependency graph from above. We need to + reverse since we propagate linearity information downwards from the + SCCs which everything depends on, rather than upwards. *) + let sorted_graph = Graph.topo_sort_sccs dep_graph |> List.rev in + (* Next, propagate the linearity information through the graph, + in order to construct the final linearity map. + * Given the topo-sorted dependency graph, we propagate linearity based + * on the following rules: + * 1. If any type in a SCC is linear, then all types in that SCC must + * also be linear. + * 2. If a type depends on a linear type, then it must also be linear. + * 3. Otherwise, the type is unrestricted. + * + * Given that we have a topo-sorted graph, as soon as we come across a + * linear SCC, we know that the remaining types are also linear. *) + let (linearity_map, _) = + List.fold_right (fun scc (acc, lin_found) -> + let scc_linear = + lin_found || List.exists (fun x -> StringMap.find x linearity_env) scc in + let acc = + List.fold_left (fun acc x -> StringMap.add x scc_linear acc) acc scc in + (acc, scc_linear)) sorted_graph (StringMap.empty, false) in + + (* Finally, construct a new alias environment, and populate the map from + * strings to the desugared datatypes which in turn allows recursive type + * unwinding in unification. *) + (* NB: type aliases are scoped; we allow shadowing. + We also allow type aliases to shadow abstract types. *) + let alias_env = + List.fold_left (fun alias_env {node=(t, args, (_, r')); _} -> + let r = OptionUtils.val_of r' in + let semantic_qs = List.map SugarQuantifier.get_resolved_exn args in + let alias_env = { tycon = alias_env.tycon ; + effectname = SEnv.bind t (`Alias (semantic_qs, r)) alias_env.effectname } in + tygroup_ref := + { !tygroup_ref with + type_map = (StringMap.add t (semantic_qs, r) !tygroup_ref.type_map); + linearity_map }; + alias_env + ) alias_env desugared_mutuals in + + ({< alias_env = alias_env >}, Effectnames desugared_mutuals) | Foreign alien -> let binder, datatype = Alien.declaration alien in let _, binder = self#binder binder in @@ -468,7 +631,7 @@ let toplevel_bindings alias_env bs = let program typing_env (bindings, p : Sugartypes.program) : Sugartypes.program = - let alias_env = typing_env.tycon_env in + let alias_env = Types.typing_to_alias typing_env in let alias_env, bindings = toplevel_bindings alias_env bindings in (* let typing_env = { typing_env with tycon_env = alias_env } in *) @@ -476,9 +639,9 @@ let program typing_env (bindings, p : Sugartypes.program) : let sentence typing_env = function | Definitions bs -> - let _alias_env, bs' = toplevel_bindings typing_env.tycon_env bs in + let _alias_env, bs' = toplevel_bindings (Types.typing_to_alias typing_env) bs in Definitions bs' - | Expression p -> let _o, p = phrase typing_env.tycon_env p in + | Expression p -> let _o, p = phrase (Types.typing_to_alias typing_env) p in Expression p | Directive d -> Directive d @@ -486,7 +649,7 @@ let read ~aliases s = let dt, _ = parse_string ~in_context:(LinksLexer.fresh_context ()) datatype s in let dt = DesugarTypeVariables.standalone_signature dt in let dt = DesugarEffects.standalone_signature aliases dt in - let _, ty = Generalise.generalise Env.String.empty (Desugar.datatype aliases dt) in + let _, ty = Generalise.generalise Env.String.empty (Desugar.datatype {tycon = aliases ; effectname = SEnv.empty} dt) in ty module Untyped = struct diff --git a/core/desugarEffects.ml b/core/desugarEffects.ml index 063d9e1cc..cfe28eb9e 100644 --- a/core/desugarEffects.ml +++ b/core/desugarEffects.ml @@ -978,6 +978,7 @@ class main_traversal simple_tycon_env = let module D = Datatype in let o, rv = match rv with + | D.EffectApplication (name, ts) -> (o, rv) (* TODO(rj) i may need to do something there *) | D.Closed -> (o, rv) | D.Open stv when (not (SugarTypeVar.is_resolved stv)) diff --git a/core/desugarTypeVariables.ml b/core/desugarTypeVariables.ml index dc51fb2bb..5e50f4ef3 100644 --- a/core/desugarTypeVariables.ml +++ b/core/desugarTypeVariables.ml @@ -415,6 +415,8 @@ object (o : 'self) method! row_var = let open Datatype in function + | EffectApplication _ as ea -> + super#row_var ea | Closed -> o, Closed | Open srv as orig when is_anonymous srv -> (* This transformation pass does not check whether anonymous row variables @@ -540,6 +542,26 @@ object (o : 'self) o, (name, resolved_qs, body) + method! effectnamenode (name, unresolved_qs, body) = + + (* Don't allow unbound named type variables in type definitions. + We do allow unbound *anoynmous* variables, because those may be + effect variables that the effect sugar handling will generalize the + type binding over. + Hence, we must re-check the free variables in the type definiton later on. *) + + let o = o#set_allow_implictly_bound_vars false in + (* Typenames must never use type variables from an outer scope *) + let o = o#reset_vars in + + let o, resolved_qs, body = o#quantified ~rigidify:true unresolved_qs (fun o' -> o'#row' body) in + + let o = o#set_allow_implictly_bound_vars allow_implictly_bound_vars in + let o = o#set_vars tyvar_map in + + o, (name, resolved_qs, body) + + method super_bindingnode = super#bindingnode diff --git a/core/instantiate.ml b/core/instantiate.ml index c2196b220..405c596a4 100644 --- a/core/instantiate.ml +++ b/core/instantiate.ml @@ -169,6 +169,7 @@ let instantiates : instantiation_maps -> (datatype -> datatype) * (row -> row) * match t with | Row _ -> t | Meta row_var -> Row (StringMap.empty, row_var, false) + | Alias (_,row) -> row | _ -> assert false in let instr = inst_row inst_map rec_env in let dual_if = if dual then dual_row else fun x -> x in @@ -449,3 +450,28 @@ let alias name tyargs env : Types.typ = top-level quantifiers *) let (_, body) = typ (instantiate_datatype inst_map body) in Alias ((name, List.map snd vars, tyargs, false), body) + +let effectalias name tyargs env : Types.typ = + (* This is just type application. + + (\Lambda x1 ... xn . t) (t1 ... tn) ~> t[ti/xi] + *) + let open Types in + match (SEnv.find_opt name env : Types.effectalias_spec option) with + | None -> + raise (internal_error (Printf.sprintf "Unrecognised type constructor: %s" name)) + | Some (`Abstract _) + (* | Some (`Mutual _) *)-> + raise (internal_error (Printf.sprintf "The type constructor: %s is not an alias" name)) + | Some (`Alias (vars, _)) when List.length vars <> List.length tyargs -> + raise (internal_error + (Printf.sprintf + "Type alias %s applied with incorrect arity (%d instead of %d). This should have been checked prior to instantiation." + name (List.length tyargs) (List.length vars))) + | Some (`Alias (vars, body)) -> + let inst_map = populate_instantiation_map ~name vars tyargs in + (* instantiate the type variables bound by the alias + definition with the type arguments *and* instantiate any + top-level quantifiers *) + let (_, body) = typ (instantiate_datatype inst_map body) in + Alias ((name, List.map snd vars, tyargs, false), body) diff --git a/core/instantiate.mli b/core/instantiate.mli index 512fa9f9e..b828d0f7a 100644 --- a/core/instantiate.mli +++ b/core/instantiate.mli @@ -16,6 +16,7 @@ val datatype : instantiation_maps -> Types.datatype -> Types.datatype val row : instantiation_maps -> Types.row -> Types.row val presence : instantiation_maps -> Types.field_spec -> Types.field_spec val alias : string -> Types.type_arg list -> Types.tycon_environment -> Types.datatype +val effectalias : string -> Types.type_arg list -> Types.effect_environment -> Types.datatype val recursive_application : string -> Quantifier.t list -> Types.type_arg list -> Types.datatype -> Types.datatype (* Given a quantified type and a list of type arguments, create the corresponding instantiation map *) diff --git a/core/lexer.mll b/core/lexer.mll index 73a15ed8e..dc52081b6 100644 --- a/core/lexer.mll +++ b/core/lexer.mll @@ -72,6 +72,7 @@ let keywords = [ "delete_left", DELETE_LEFT; "determined", DETERMINED; "do" , DOOP; + "effectname", EFFECTNAME; "else" , ELSE; "escape" , ESCAPE; "false" , FALSE; diff --git a/core/lib.ml b/core/lib.ml index 1fdc340a8..58b3168c6 100644 --- a/core/lib.ml +++ b/core/lib.ml @@ -1726,6 +1726,7 @@ let type_env : Types.environment = let typing_env = {Types.var_env = type_env; Types.rec_vars = StringSet.empty; tycon_env = alias_env; + effect_env = Env.String.empty; Types.effect_row = Types.closed_wild_row; Types.desugared = false } diff --git a/core/parser.mly b/core/parser.mly index a42604f2b..e2a6ac0bc 100644 --- a/core/parser.mly +++ b/core/parser.mly @@ -221,20 +221,24 @@ module MutualBindings = struct type mutual_bindings = { mut_types: typename list; + mut_effs: effectname list; mut_funs: (function_definition * Position.t) list; mut_pos: Position.t } - let empty pos = { mut_types = []; mut_funs = []; mut_pos = pos } + let empty pos = { mut_types = []; mut_effs = []; mut_funs = []; mut_pos = pos } - let add ({ mut_types = ts; mut_funs = fs; _ } as block) binding = + let add ({ mut_types = ts; mut_effs = rs; mut_funs = fs; _ } as block) binding = let pos = WithPos.pos binding in match WithPos.node binding with | Fun f -> { block with mut_funs = ((f, pos) :: fs) } | Typenames [t] -> { block with mut_types = (t :: ts) } - | Typenames _ -> assert false + | Effectnames [r] -> + { block with mut_effs = (r :: rs) } + | Typenames _ + | Effectnames _ -> assert false | _ -> raise (ConcreteSyntaxError (pos, "Only `fun` and `typename` bindings are allowed in a `mutual` block.")) @@ -263,7 +267,7 @@ module MutualBindings = struct check fun_name funs; check ty_name tys_with_pos - let flatten { mut_types; mut_funs; mut_pos } = + let flatten { mut_types; mut_effs; mut_funs; mut_pos } = (* We need to take care not to lift non-recursive functions to * recursive functions accidentally. *) check_dups mut_funs mut_types; @@ -286,7 +290,12 @@ module MutualBindings = struct let type_binding = function | [] -> [] | ts -> [WithPos.make ~pos:mut_pos (Typenames (List.rev ts))] in - type_binding mut_types @ fun_binding mut_funs + + let effect_binding = function + | [] -> [] + | rs -> [WithPos.make ~pos:mut_pos (Effectnames (List.rev rs))] in + + type_binding mut_types @ fun_binding mut_funs @ effect_binding mut_effs end let parse_foreign_language pos lang = @@ -344,7 +353,7 @@ let parse_foreign_language pos lang = %token SLASHFLAGS %token UNDERSCORE AS %token FIXITY -%token TYPENAME +%token TYPENAME EFFECTNAME %token TRY OTHERWISE RAISE %token OPERATOR %token USING @@ -446,7 +455,8 @@ nofun_declaration: let node = Infix { name = WithPos.node $3; precedence; assoc = $1 } in with_pos $loc node } | signature? tlvarbinding SEMICOLON { val_binding' ~ppos:$loc($2) $1 $2 } -| typedecl SEMICOLON | links_module | links_open SEMICOLON { $1 } +| typedecl SEMICOLON | effectdecl SEMICOLON { $1 } +| links_module | links_open SEMICOLON { $1 } | pollute = boption(OPEN) IMPORT CONSTRUCTOR SEMICOLON { import ~ppos:$loc($2) ~pollute [$3] } alien_datatype: @@ -507,6 +517,10 @@ signature: typedecl: | TYPENAME CONSTRUCTOR typeargs_opt EQ datatype { with_pos $loc (Typenames [with_pos $loc ($2, $3, datatype $5)]) } +effectdecl: +| EFFECTNAME CONSTRUCTOR typeargs_opt EQ LBRACE erow RBRACE { with_pos $loc (Effectnames [with_pos $loc ($2, $3, ($6,None))]) } +| EFFECTNAME CONSTRUCTOR typeargs_opt EQ effect_app { with_pos $loc (Effectnames [with_pos $loc ($2, $3, (([],$5),None))]) } + (* Lists of quantifiers in square brackets denote type abstractions *) type_abstracion_vars: | LBRACKET varlist RBRACKET { $2 } @@ -1013,16 +1027,17 @@ datatype: | mu_datatype | straight_arrow | squiggly_arrow { with_pos $loc $1 } arrow_prefix: -| LBRACE RBRACE { ([], Datatype.Closed) } -| LBRACE efields RBRACE { $2 } +| LBRACE erow RBRACE { $2 } straight_arrow_prefix: | hear_arrow_prefix | arrow_prefix { $1 } | MINUS nonrec_row_var | MINUS kinded_nonrec_row_var { ([], $2) } +| MINUS effect_app { ([], $2) } squig_arrow_prefix: | hear_arrow_prefix | arrow_prefix { $1 } | TILDE nonrec_row_var | TILDE kinded_nonrec_row_var { ([], $2) } +| TILDE effect_app { ([], $2) } hear_arrow_prefix: | LBRACE COLON datatype COMMA efields RBRACE { hear_arrow_prefix $3 $5 } @@ -1130,7 +1145,7 @@ type_arg_list: type_arg: | datatype { Datatype.Type $1 } | braced_fieldspec { Datatype.Presence $1 } -| LBRACE row RBRACE { Datatype.Row $2 } +| LBRACE trow RBRACE { Datatype.Row $2 } datatypes: | separated_nonempty_list(COMMA, datatype) { $1 } @@ -1139,6 +1154,14 @@ vrow: | vfields { $1 } | /* empty */ { ([], Datatype.Closed) } +trow: +| tfields { $1 } +| /* empty */ { ([], Datatype.Closed) } + +erow: +| efields { $1 } +| /* empty */ { ([], Datatype.Closed) } + row: | fields { $1 } | /* empty */ { ([], Datatype.Closed) } @@ -1185,14 +1208,21 @@ vfield: | CONSTRUCTOR { ($1, present) } | CONSTRUCTOR fieldspec { ($1, $2) } +tfields: +| field { ([$1], Datatype.Closed) } +| soption(field) VBAR row_var { ( $1 , $3 ) } +| soption(field) VBAR kinded_row_var { ( $1 , $3 ) } +| soption(field) VBAR effect_app { ( $1 , $3 ) } +| field COMMA tfields { ( $1::fst $3, snd $3 ) } + efields: | efield { ([$1], make_effect_var ~is_dot:false $loc) } | soption(efield) VBAR DOT { ( $1 , make_effect_var ~is_dot:true $loc) } | soption(efield) VBAR row_var { ( $1 , $3 ) } | soption(efield) VBAR kinded_row_var { ( $1 , $3 ) } +| soption(efield) VBAR effect_app { ( $1 , $3 ) } | efield COMMA efields { ( $1::fst $3, snd $3 ) } - efield: | effect_label fieldspec { ($1, $2) } @@ -1200,6 +1230,10 @@ effect_label: | CONSTRUCTOR { $1 } | VARIABLE { $1 } +effect_app: +| CONSTRUCTOR { Datatype.EffectApplication($1, []) } +| CONSTRUCTOR LPAREN type_arg_list RPAREN { Datatype.EffectApplication($1, $3) } + fieldspec: | braced_fieldspec { $1 } | COLON datatype { Datatype.Present $2 } diff --git a/core/sugarTraversals.ml b/core/sugarTraversals.ml index e806176e0..b05ac92ba 100644 --- a/core/sugarTraversals.ml +++ b/core/sugarTraversals.ml @@ -105,6 +105,10 @@ class map = method row_var : Datatype.row_var -> Datatype.row_var = let open Datatype in function + | EffectApplication (_x, _x_i1) -> + let _x = o#name _x in + let _x_i1 = o#list (fun o -> o#type_arg) _x_i1 + in EffectApplication (_x, _x_i1) | Closed -> Closed | Open _x -> let _x = o#type_variable _x in Open _x @@ -166,6 +170,12 @@ class map = let y = o#option (fun o -> o#typ) y in (x,y) + method row' : row' -> row' = + fun (x, y) -> + let x = o#row x in + let y = o#option (fun o -> o#typ) y in + (x,y) + method given_spawn_location : given_spawn_location -> given_spawn_location = function | ExplicitSpawnLocation p -> ExplicitSpawnLocation (o#phrase p) @@ -756,6 +766,9 @@ class map = | Typenames ts -> let _x = o#list (fun o -> o#typename) ts in Typenames _x + | Effectnames es -> + let _x = o#list (fun o -> o#effectname) es in + Effectnames _x | Infix { name; assoc; precedence } -> Infix { name = o#name name; assoc; precedence } | Exp _x -> let _x = o#phrase _x in Exp _x @@ -791,6 +804,18 @@ class map = fun p -> WithPos.map2 ~f_pos:o#position ~f_node:o#typenamenode p + method effectnamenode : effectnamenode -> effectnamenode = + fun (_x, _x_i1, _x_i2) -> + let _x = o#name _x in + let _x_i1 = o#list (fun o x -> o#quantifier x) + _x_i1 in + let _x_i2 = o#row' _x_i2 in + (_x, _x_i1, _x_i2) + + method effectname : effectname -> effectname = + fun p -> + WithPos.map2 ~f_pos:o#position ~f_node:o#effectnamenode p + method function_definition : function_definition -> function_definition = fun { fun_binder; fun_linearity; @@ -937,6 +962,9 @@ class fold = method row_var : Datatype.row_var -> 'self_type = let open Datatype in function + | EffectApplication (_x, _x_i1) -> + let o = o#name _x in + let o = o#list (fun o -> o#type_arg) _x_i1 in o | Closed -> o | Open _x -> let o = o#type_variable _x in o @@ -992,6 +1020,12 @@ class fold = let o = o#unknown y in o + method row' : row' -> 'self_type = + fun (x, y) -> + let o = o#row x in + let o = o#unknown y in + o + method given_spawn_location : given_spawn_location -> 'self_type = function | ExplicitSpawnLocation p -> let o = o#phrase p in o | _ -> o @@ -1513,6 +1547,9 @@ class fold = | Typenames ts -> let o = o#list (fun o -> o#typename) ts in o + | Effectnames es -> + let o = o#list (fun o -> o#effectname) es in + o | Infix { name; _ } -> o#name name | Exp _x -> let o = o#phrase _x in o @@ -1550,6 +1587,23 @@ class fold = ~f_pos:(fun o v -> o#position v) ~f_node:(fun o v -> o#typenamenode v) + method effectnamenode : effectnamenode -> 'self_type = + fun (_x, _x_i1, _x_i2) -> + let o = o#name _x in + let o = + o#list + (fun o _x -> + let o = o#quantifier _x + in o) _x_i1 in + let o = o#row' _x_i2 in + o + + method effectname : effectname -> 'self_type = + WithPos.traverse + ~o + ~f_pos:(fun o v -> o#position v) + ~f_node:(fun o v -> o#effectnamenode v) + method function_definition : function_definition -> 'self = fun { fun_binder; fun_linearity = _; @@ -1692,6 +1746,10 @@ class fold_map = method row_var : Datatype.row_var -> ('self_type * Datatype.row_var) = let open Datatype in function + | EffectApplication (_x, _x_i1) -> + let (o, _x) = o#string _x in + let (o, _x_i1) = o#list (fun o -> o#type_arg) _x_i1 + in (o, EffectApplication (_x, _x_i1)) | Closed -> (o, Closed) | Open _x -> let (o, _x) = o#type_variable _x in (o, (Open _x)) @@ -2276,6 +2334,12 @@ class fold_map = let (o, _x) = o#string _x in let (o, _x_i1) = o#list (fun o -> o#string) _x_i1 in (o, (_x, _x_i1)) + method row' : row' -> ('self_type * row') = + fun (_x, _x_i1) -> + let (o, _x) = o#row _x in + let (o, _x_i1) = o#option (fun o -> o#typ) _x_i1 + in (o, (_x, _x_i1)) + method datatype' : datatype' -> ('self_type * datatype') = fun (_x, _x_i1) -> let (o, _x) = o#datatype _x in @@ -2422,6 +2486,9 @@ class fold_map = | Typenames ts -> let (o, _x) = o#list (fun o -> o#typename) ts in (o, (Typenames _x)) + | Effectnames es -> + let (o, _x) = o#list (fun o -> o#effectname) es in + (o, (Effectnames _x)) | Infix { name; assoc; precedence } -> let (o, name) = o#name name in (o, Infix { name; assoc; precedence }) @@ -2466,6 +2533,24 @@ class fold_map = ~f_pos:(fun o v -> o#position v) ~f_node:(fun o v -> o#typenamenode v) + method effectnamenode : effectnamenode -> ('self_type * effectnamenode) = + fun (_x, _x_i1, _x_i2) -> + let (o, _x) = o#name _x in + let (o, _x_i1) = + o#list + (fun o _x -> + let (o, _x) = o#quantifier _x + in (o, _x)) + _x_i1 in + let (o, _x_i2) = o#row' _x_i2 + in (o, (_x, _x_i1, _x_i2)) + + method effectname : effectname -> ('self_effect * effectname) = + WithPos.traverse_map + ~o + ~f_pos:(fun o v -> o#position v) + ~f_node:(fun o v -> o#effectnamenode v) + method function_definition : function_definition -> 'self * function_definition = fun { fun_binder; fun_linearity; diff --git a/core/sugarTraversals.mli b/core/sugarTraversals.mli index 49e423d41..a6946be6a 100644 --- a/core/sugarTraversals.mli +++ b/core/sugarTraversals.mli @@ -63,6 +63,7 @@ class map : method datatype : Datatype.with_pos -> Datatype.with_pos method datatypenode : Datatype.t -> Datatype.t method datatype' : datatype' -> datatype' + method row' : row' -> row' method type_arg : Datatype.type_arg -> Datatype.type_arg method type_arg' : type_arg' -> type_arg' method constant : Constant.t -> Constant.t @@ -72,6 +73,8 @@ class map : method binding : binding -> binding method typenamenode : typenamenode -> typenamenode method typename : typename -> typename + method effectnamenode : effectnamenode -> effectnamenode + method effectname : effectname -> effectname method function_definition : function_definition -> function_definition method recursive_function : recursive_function -> recursive_function method recursive_functionnode : recursive_functionnode -> recursive_functionnode @@ -145,6 +148,7 @@ class fold : method datatype : Datatype.with_pos -> 'self method datatypenode : Datatype.t -> 'self method datatype' : datatype' -> 'self + method row' : row' -> 'self method type_arg : Datatype.type_arg -> 'self method type_arg' : type_arg' -> 'self method constant : Constant.t -> 'self @@ -154,6 +158,8 @@ class fold : method binding : binding -> 'self method typenamenode : typenamenode -> 'self method typename : typename -> 'self + method effectnamenode : effectnamenode -> 'self + method effectname : effectname -> 'self method function_definition : function_definition -> 'self method recursive_function : recursive_function -> 'self method recursive_functionnode : recursive_functionnode -> 'self @@ -179,6 +185,8 @@ object ('self) method bindingnode : bindingnode -> 'self * bindingnode method typenamenode : typenamenode -> 'self * typenamenode method typename : typename -> 'self * typename + method effectnamenode : effectnamenode -> 'self * effectnamenode + method effectname : effectname -> 'self * effectname method binop : BinaryOp.t -> 'self * BinaryOp.t method tybinop : tyarg list * BinaryOp.t -> 'self * (tyarg list * BinaryOp.t) method bool : bool -> 'self * bool @@ -188,6 +196,7 @@ object ('self) method datatype : Datatype.with_pos -> 'self * Datatype.with_pos method datatypenode : Datatype.t -> 'self * Datatype.t method datatype' : datatype' -> 'self * datatype' + method row' : row' -> 'self * row' method type_arg' : type_arg' -> 'self * type_arg' method directive : directive -> 'self * directive method fieldconstraint : fieldconstraint -> 'self * fieldconstraint diff --git a/core/sugartoir.ml b/core/sugartoir.ml index 0f31eaf85..238c2ca97 100644 --- a/core/sugartoir.ml +++ b/core/sugartoir.ml @@ -1318,6 +1318,7 @@ struct I.alien (Var.make_info xt x scope, Alien.object_name alien, Alien.language alien, fun v -> eval_bindings scope (extend [x] [(v, xt)] env) bs e) | Typenames _ + | Effectnames _ | Infix _ -> (* Ignore type alias and infix declarations - they shouldn't be needed in the IR *) diff --git a/core/sugartypes.ml b/core/sugartypes.ml index 8a64e764e..15b0abc43 100644 --- a/core/sugartypes.ml +++ b/core/sugartypes.ml @@ -209,6 +209,7 @@ module Datatype = struct and with_pos = t WithPos.t and row = (string * fieldspec) list * row_var and row_var = + | EffectApplication of string * type_arg list | Closed | Open of SugarTypeVar.t | Recursive of SugarTypeVar.t * row @@ -227,6 +228,9 @@ end type datatype' = Datatype.with_pos * Types.datatype option [@@deriving show] +type row' = Datatype.row * Types.row option + [@@deriving show] + type type_arg' = Datatype.type_arg * Types.type_arg option [@@deriving show] @@ -521,6 +525,7 @@ and bindingnode = | Import of { pollute: bool; path : Name.t list } | Open of Name.t list | Typenames of typename list + | Effectnames of effectname list | Infix of { assoc: Associativity.t; precedence: int; name: string } @@ -543,6 +548,8 @@ and cp_phrasenode = and cp_phrase = cp_phrasenode WithPos.t and typenamenode = Name.t * SugarQuantifier.t list * datatype' and typename = typenamenode WithPos.t +and effectnamenode = Name.t * SugarQuantifier.t list * row' +and effectname = effectnamenode WithPos.t and function_definition = { fun_binder: Binder.with_pos; fun_linearity: DeclaredLinearity.t; @@ -804,7 +811,8 @@ struct names, union_map (fun rhs -> diff (funlit rhs) names) rhss | Import _ | Open _ - | Typenames _ -> empty, empty + | Typenames _ + | Effectnames _ -> empty, empty (* This is technically a declaration, thus the name should probably be treated as bound rather than free. *) | Infix { name; _ } -> empty, singleton name diff --git a/core/transformSugar.ml b/core/transformSugar.ml index 6f06af5cf..a69f1d58f 100644 --- a/core/transformSugar.ml +++ b/core/transformSugar.ml @@ -146,6 +146,7 @@ class transform (env : Types.typing_environment) = object (o : 'self_type) val var_env = env.Types.var_env val tycon_env = env.Types.tycon_env + val effect_env = env.Types.effect_env val formlet_env = TyEnv.empty val effect_row = fst (Types.unwrap_row env.Types.effect_row) @@ -153,9 +154,9 @@ class transform (env : Types.typing_environment) = method get_tycon_env : unit -> Types.tycon_environment = fun () -> tycon_env method get_formlet_env : unit -> Types.environment = fun () -> formlet_env - method backup_envs = var_env, tycon_env, formlet_env, effect_row - method restore_envs (var_env, tycon_env, formlet_env, effect_row) = - {< var_env = var_env; tycon_env = tycon_env; formlet_env = formlet_env; + method backup_envs = var_env, tycon_env, effect_env, formlet_env, effect_row + method restore_envs (var_env, tycon_env, effect_env, formlet_env, effect_row) = + {< var_env = var_env; tycon_env = tycon_env; effect_env = effect_env; formlet_env = formlet_env; effect_row = effect_row >} method with_var_env var_env = @@ -167,6 +168,9 @@ class transform (env : Types.typing_environment) = method bind_tycon name tycon = {< tycon_env = TyEnv.bind name tycon tycon_env >} + method bind_effect name row = + {< effect_env = TyEnv.bind name row effect_env >} + method bind_binder bndr = {< var_env = TyEnv.bind (Binder.to_name bndr) (Binder.to_type bndr) var_env >} @@ -898,6 +902,16 @@ class transform (env : Types.typing_environment) = | None -> raise (internal_error "Unannotated type alias") ) ts in (o, Typenames ts) + | Effectnames rs -> + let (o, _) = listu o (fun o {node=(name, vars, (x, r')); pos} -> + match r' with + | Some r -> + let o = o#bind_effect name + (`Alias (List.map (SugarQuantifier.get_resolved_exn) vars, r)) in + (o, WithPos.make ~pos (name, vars, (x, r'))) + | None -> raise (internal_error "Unannotated type alias") + ) rs in + (o, Effectnames rs) | (Infix _) as node -> (o, node) | Exp e -> let (o, e, _) = o#phrase e in (o, Exp e) diff --git a/core/transformSugar.mli b/core/transformSugar.mli index f37e6e035..ce094f4ea 100644 --- a/core/transformSugar.mli +++ b/core/transformSugar.mli @@ -32,19 +32,21 @@ class transform : Types.typing_environment -> object ('self) val var_env : Types.environment val tycon_env : Types.tycon_environment + val effect_env : Types.effect_environment val effect_row : Types.row method get_var_env : unit -> Types.environment method get_tycon_env : unit -> Types.tycon_environment method get_formlet_env : unit -> Types.environment - method backup_envs : Types.environment * Types.tycon_environment * Types.environment * Types.row - method restore_envs : (Types.environment * Types.tycon_environment * Types.environment * Types.row) -> 'self + method backup_envs : Types.environment * Types.tycon_environment * Types.effect_environment * Types.environment * Types.row + method restore_envs : (Types.environment * Types.tycon_environment * Types.effect_environment * Types.environment * Types.row) -> 'self method with_var_env : Types.environment -> 'self method with_formlet_env : Types.environment -> 'self method bind_tycon : string -> Types.tycon_spec -> 'self + method bind_effect : string -> Types.effectalias_spec -> 'self method bind_binder : Binder.with_pos -> 'self method lookup_type : Name.t -> Types.datatype diff --git a/core/typeSugar.ml b/core/typeSugar.ml index 5747060ca..741aecca4 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -155,6 +155,7 @@ struct | Funs _ | Infix _ | Typenames _ + | Effectnames _ | Foreign _ -> true | Exp p -> is_pure p | Val (pat, (_, rhs), _, _) -> @@ -1651,6 +1652,9 @@ type context = Types.typing_environment = { and "Formlet". *) tycon_env : Types.tycon_environment; + (* mapping from effect alias names to the effect row they name *) + effect_env : Types.effect_environment; + (* the current effects *) effect_row : Types.row; @@ -1663,13 +1667,15 @@ let empty_context eff desugared = { var_env = Env.empty; rec_vars = StringSet.empty; tycon_env = Env.empty; + effect_env = Env.empty; effect_row = eff; desugared } -let bind_var context (v, t) = {context with var_env = Env.bind v t context.var_env} -let unbind_var context v = {context with var_env = Env.unbind v context.var_env} -let bind_tycon context (v, t) = {context with tycon_env = Env.bind v t context.tycon_env} -let bind_effects context r = {context with effect_row = r} +let bind_var context (v, t) = {context with var_env = Env.bind v t context.var_env} +let unbind_var context v = {context with var_env = Env.unbind v context.var_env} +let bind_tycon context (v, t) = {context with tycon_env = Env.bind v t context.tycon_env} +let bind_effectnames context (v, t) = {context with effect_env = Env.bind v t context.effect_env} +let bind_effects context r = {context with effect_row = r} (* TODO(dhil): I have extracted the Usage abstraction from my name hygiene/compilation unit patch. The below module is a compatibility @@ -4855,6 +4861,14 @@ and type_binding : context -> binding -> binding * context * Usage.t = | None -> raise (internal_error "typeSugar.ml: unannotated type") ) empty_context ts in (Typenames ts, env, Usage.empty) + | Effectnames es -> + let env = List.fold_left (fun env {node=(name, vars, (_, effrow')); _} -> + match effrow' with + | Some effrow -> + bind_effectnames env (name, `Alias (List.map (SugarQuantifier.get_resolved_exn) vars, effrow)) + | None -> raise (internal_error "typeSugar.ml: unannotated type") + ) empty_context es in + (Effectnames es, env, Usage.empty) | Infix def -> Infix def, empty_context, Usage.empty | Exp e -> let e = tc e in diff --git a/core/types.ml b/core/types.ml index 6c3658633..3cd934323 100644 --- a/core/types.ml +++ b/core/types.ml @@ -196,6 +196,14 @@ type tycon_spec = [ | `Mutual of (Quantifier.t list * tygroup ref) (* Type in same recursive group *) ] [@@deriving show] +type effectalias_type = Quantifier.t list * row [@@deriving show] + +type effectalias_spec = [ + | `Alias of effectalias_type + | `Abstract of Abstype.t + | `Mutual of (Quantifier.t list * tygroup ref) (* Type in same recursive group *) +] [@@deriving show] + (* Generation of fresh type variables *) let type_variable_counter = ref 0 @@ -1429,6 +1437,11 @@ and flatten_row : row -> row = fun row -> | Row _ -> row (* HACK: this probably shouldn't happen! *) | Meta row_var -> Row (StringMap.empty, row_var, false) + | Alias (_, row) -> row + (* Debug.print ("row: " ^ show_row row); *) + (* failwith "types.ml/flatten_row/Alias" *) + | RecursiveApplication { r_dual ; r_args ; r_unwind ; _ } -> + r_unwind r_args r_dual | _ -> assert false in let dual_if = match row with @@ -2251,6 +2264,7 @@ module type PRETTY_PRINTER = sig val string_of_type_arg : Policy.t -> names -> type_arg -> string val string_of_row_var : Policy.t -> names -> row_var -> string val string_of_tycon_spec : Policy.t -> names -> tycon_spec -> string + val string_of_effect_spec : Policy.t -> names -> effectalias_spec -> string val string_of_quantifier : Policy.t -> names -> Quantifier.t -> string val string_of_presence : Policy.t -> names -> field_spec -> string end @@ -2729,6 +2743,23 @@ struct | `Mutual _ -> "mutual" | `Abstract _ -> "abstract" + let effect_spec ({ bound_vars; _ } as context) p = + let bound_vars tyvars = + List.fold_left + (fun bound_vars tyvar -> + TypeVarSet.add (Quantifier.to_var tyvar) bound_vars) + bound_vars tyvars + in function + | `Alias (tyvars, body) -> + let ctx = { context with bound_vars = bound_vars tyvars } in + begin + match tyvars with + | [] -> datatype ctx p body + | _ -> mapstrcat "," (quantifier p) tyvars ^"."^ row "," ctx p body + end + | `Mutual _ -> "mutual" + | `Abstract _ -> "abstract" + let string_of_datatype policy names ty = let ctxt = context_with_shared_effect policy (fun o -> o#typ ty) in datatype ctxt (policy, names) ty @@ -2745,6 +2776,9 @@ struct let string_of_tycon_spec policy names tycon = tycon_spec empty_context (policy, names) tycon + let string_of_effect_spec policy names tycon = + effect_spec empty_context (policy, names) tycon + let string_of_quantifier policy names q = quantifier (policy, names) q @@ -4099,11 +4133,32 @@ module RoundtripPrinter : PRETTY_PRINTER = struct | `Mutual _ -> StringBuffer.write buf "mutual" | `Abstract _ -> StringBuffer.write buf "abstract") + let effect_spec : effectalias_spec printer + = let open Printer in + Printer (fun ctx v buf -> + match v with + | `Alias (tyvars, body) -> + let ctx = Context.bind_tyvars (List.map Quantifier.to_var tyvars) ctx in + begin + match tyvars with + | [] -> Printer.apply row ctx body buf + | _ -> Printer.concat_items ~sep:"," quantifier tyvars ctx buf; + StringBuffer.write buf "."; + Printer.apply row ctx body buf + end + | `Mutual _ -> StringBuffer.write buf "mutual" + | `Abstract _ -> StringBuffer.write buf "abstract") + let string_of_tycon_spec : Policy.t -> names -> tycon_spec -> string = fun policy' names tycon -> let ctxt = Context.(with_policy policy' (with_tyvar_names names (empty ()))) in Printer.generate_string tycon_spec ctxt tycon + let string_of_effect_spec : Policy.t -> names -> effectalias_spec -> string + = fun policy' names tycon -> + let ctxt = Context.(with_policy policy' (with_tyvar_names names (empty ()))) in + Printer.generate_string effect_spec ctxt tycon + let string_of_presence : Policy.t -> names -> field_spec -> string = fun policy' names pre -> let ctxt = Context.(with_policy policy' (with_tyvar_names names (empty ()))) in @@ -4135,6 +4190,14 @@ module DerivedPrinter : PRETTY_PRINTER = struct in show_tycon_spec (decycle_tycon_spec tycon) + let string_of_effect_spec : Policy.t -> names -> effectalias_spec -> string + = fun _policy _names tycon -> + let decycle_tycon_spec = function + | `Alias (qlist, ty) -> `Alias (List.map DecycleTypes.quantifier qlist, DecycleTypes.datatype ty) + | other -> other + in + show_effectalias_spec (decycle_tycon_spec tycon) + let string_of_presence : Policy.t -> names -> field_spec -> string = fun _policy _names pre -> show_field_spec (DecycleTypes.field_spec pre) @@ -4189,18 +4252,28 @@ type environment = datatype Env.t [@@deriving show] type tycon_environment = tycon_spec Env.t [@@deriving show] +type effect_environment = effectalias_spec Env.t + [@@deriving show] +type alias_environment = { tycon : tycon_environment ; + effectname : effect_environment } + [@@derving show] type typing_environment = { var_env : environment ; rec_vars : StringSet.t ; tycon_env : tycon_environment ; + effect_env : effect_environment ; effect_row : row; desugared : bool } [@@deriving show] -let empty_typing_environment = { var_env = Env.empty; - rec_vars = StringSet.empty; - tycon_env = Env.empty; +let empty_typing_environment = { var_env = Env.empty; + rec_vars = StringSet.empty; + tycon_env = Env.empty; + effect_env = Env.empty; effect_row = make_empty_closed_row (); - desugared = false } + desugared = false } + +let typing_to_alias typing_env = + { tycon = typing_env.tycon_env ; effectname = typing_env.effect_env } (* Which printer to use *) type pretty_printer_engine = Old | Roundtrip | Derived @@ -4311,6 +4384,12 @@ let string_of_tycon_spec : ?policy:(unit -> Policy.t) -> ?refresh_tyvar_names:bo build_tyvar_names ~refresh_tyvar_names free_bound_tycon_type_vars [tycon]; generate_string policy Vars.tyvar_name_map (fun (module Printer : PRETTY_PRINTER) -> Printer.string_of_tycon_spec) tycon +let string_of_effect_spec : ?policy:(unit -> Policy.t) -> ?refresh_tyvar_names:bool -> effectalias_spec -> string + = fun ?(policy=Policy.default_policy) ?(refresh_tyvar_names=true) tycon -> + let policy = policy () in + build_tyvar_names ~refresh_tyvar_names free_bound_tycon_type_vars [tycon]; + generate_string policy Vars.tyvar_name_map (fun (module Printer : PRETTY_PRINTER) -> Printer.string_of_effect_spec) tycon + let string_of_quantifier : ?policy:(unit -> Policy.t) -> ?refresh_tyvar_names:bool -> Quantifier.t -> string = fun ?(policy=Policy.default_policy) ?(refresh_tyvar_names=true) q -> let policy = policy () in @@ -4325,11 +4404,12 @@ let normalise_typing_environment env = (* Functions on environments *) let extend_typing_environment - {var_env = l; rec_vars = lvars; tycon_env = al; effect_row = _; desugared = _; } - {var_env = r; rec_vars = rvars; tycon_env = ar; effect_row = er; desugared = dr } : typing_environment = + {var_env = l; rec_vars = lvars; tycon_env = al; effect_env = eal; effect_row = _; desugared = _; } + {var_env = r; rec_vars = rvars; tycon_env = ar; effect_env = ear; effect_row = er; desugared = dr } : typing_environment = { var_env = Env.extend l r ; rec_vars = StringSet.union lvars rvars ; tycon_env = Env.extend al ar + ; effect_env = Env.extend eal ear ; effect_row = er ; desugared = dr } diff --git a/core/types.mli b/core/types.mli index c92fa77ec..ded4ccad9 100644 --- a/core/types.mli +++ b/core/types.mli @@ -214,16 +214,30 @@ type tycon_spec = [ | `Mutual of (Quantifier.t list * tygroup ref) (* Type in same recursive group *) ] +type effectalias_type = Quantifier.t list * row [@@deriving show] + +type effectalias_spec = [ + | `Alias of effectalias_type + | `Abstract of Abstype.t + | `Mutual of (Quantifier.t list * tygroup ref) (* Type in same recursive group *) +] + type environment = datatype Env.String.t type tycon_environment = tycon_spec Env.String.t +type effect_environment = effectalias_spec Env.String.t +type alias_environment = { tycon : tycon_environment ; + effectname : effect_environment } type typing_environment = { var_env : environment ; rec_vars : Utility.StringSet.t ; tycon_env : tycon_environment ; + effect_env : effect_environment ; effect_row : row ; desugared : bool } val empty_typing_environment : typing_environment +val typing_to_alias : typing_environment -> alias_environment + val concrete_type : datatype -> datatype val concrete_field_spec : field_spec -> field_spec @@ -415,6 +429,8 @@ val string_of_row_var : ?policy:(unit -> Policy.t) -> ?refresh_tyvar_names:bool -> row_var -> string val string_of_tycon_spec : ?policy:(unit -> Policy.t) -> ?refresh_tyvar_names:bool -> tycon_spec -> string +val string_of_effect_spec : ?policy:(unit -> Policy.t) + -> ?refresh_tyvar_names:bool -> effectalias_spec -> string val string_of_environment : environment -> string val string_of_typing_environment : typing_environment -> string diff --git a/tests/effectname.tests b/tests/effectname.tests new file mode 100644 index 000000000..ee9576c78 --- /dev/null +++ b/tests/effectname.tests @@ -0,0 +1,56 @@ +Simple effectname declarations +./tests/effectname/simple-decl.links +filemode : true +stdout : () : () + +Declaration and instanciation [1] +./tests/effectname/zero.links +filemode : true +stdout : fun : () {}-> () + +Declaration and instanciation [2] +./tests/effectname/one.links +filemode : true +stdout : fun : () {E:() {}-> ()}-> () + +Declaration and instanciation [3] +./tests/effectname/two.links +filemode : true +stdout : fun : () {E:() {}-> ()}-> () + +Twice the same effectname in one row +./tests/effectname/two-nested.links +filemode : true +stdout : fun : () {E:() {}-> ()}-> () + +Mixed typename and effectname aliases +./tests/effectname/typenames.links +filemode : true +stdout : fun : T' (Bool,Int,{}) + +Nested declaration and instanciation +./tests/effectname/nested-decl.links +filemode : true +stdout : fun : () {E:() {}-> Int,E':(Int) {}-> ()}-> () + +Recursive alias +./tests/effectname/recursive.links +filemode : true +stderr : @.* +exit : 1 + +Effectname aliases in handlers signatures +./tests/effectname/handler.links +filemode : true +args : --enable-handlers +stdout : (((), 42), (0, 42), (0, 42)) : (((), Int), (Int, Int), (Int, Int)) + +Twice the same effect label in the row +./tests/effectname/effect-same-name.links +filemode : true +stdout : fun : () {E:() {}-> Int}-> Int + +Mutual declaration +./tests/effectname/mutual.links +filemode : true +stdout : () : () diff --git a/tests/effectname/effect-same-name.links b/tests/effectname/effect-same-name.links new file mode 100755 index 000000000..dcdbbe2d4 --- /dev/null +++ b/tests/effectname/effect-same-name.links @@ -0,0 +1,8 @@ +effectname A(a,b,e::Eff) = { E: () {}-> a, E: () {}-> b | e } ; + +sig f : () -A(Int, Bool, {})-> Int +fun f () { + do E() +} + +f diff --git a/tests/effectname/handler.links b/tests/effectname/handler.links new file mode 100755 index 000000000..fd5bad41c --- /dev/null +++ b/tests/effectname/handler.links @@ -0,0 +1,38 @@ +effectname State(a,e::Eff) = { Get:() {}-> a, Put:(a) {}-> () | e } ; + +sig hstate : (() ~State(a,{ |e})~> b) -> () {Get{_}, Put{_} | e}~> (a) ~e~> (b,a) +fun hstate (m)() { + handle (m()) { + case Return(x) -> fun (s) { (x,s) } + case Get(k) -> fun (s) { k(s)(s) } + case Put(s',k) -> fun (s) { k(())(s') } + } +} + + +sig f : () ~State(Int,{})~> () +fun f () { + var x = do Get() ; + do Put(2*x) ; + () +} + +effectname Reader(a,e::Eff) = {Ask:() {}-> a | e } ; + +sig hreader : (() ~Reader(Int,{ |e})~> a) -> () {Ask{_}|e}~> a +fun hreader (m)() { + handle (m()) { + case Return(x) -> x + case Ask(k) -> k (-42) + } +} + +sig g : () ~State(Int,{ |Reader(Int,{})})~> Int +fun g () { + var x = do Get() ; + var y = do Ask() ; + do Put(2*x) ; + y + do Get() +} + +( hstate(f)()(21) , hstate(hreader(g))()(21) , hreader(fun () { hstate(g)()(21) })() ) diff --git a/tests/effectname/mutual.links b/tests/effectname/mutual.links new file mode 100755 index 000000000..20dde2793 --- /dev/null +++ b/tests/effectname/mutual.links @@ -0,0 +1,7 @@ +mutual { + effectname A = B ; + effectname B = {} ; +} + +# sig f : () -A-> () +# fun f () {} diff --git a/tests/effectname/nested-decl.links b/tests/effectname/nested-decl.links new file mode 100755 index 000000000..0c2ec0920 --- /dev/null +++ b/tests/effectname/nested-decl.links @@ -0,0 +1,8 @@ +effectname A = {} ; +effectname B(a,e::Eff) = { E: () -e-> a | A } ; +effectname C = { E': (Int) -A-> () | B(Int, { | A }) } ; + +sig f : () -C-> () +fun f () { do E'(do E()) } + +f diff --git a/tests/effectname/one.links b/tests/effectname/one.links new file mode 100644 index 000000000..9f90c70b8 --- /dev/null +++ b/tests/effectname/one.links @@ -0,0 +1,6 @@ +effectname A = {E: () {}-> ()} ; + +sig f : () -A-> () +fun f () { do E() } + +f diff --git a/tests/effectname/recursive.links b/tests/effectname/recursive.links new file mode 100755 index 000000000..f30d8b627 --- /dev/null +++ b/tests/effectname/recursive.links @@ -0,0 +1,10 @@ +effectname A = { E: ( () -A-> () ) {}-> () } ; + +sig f : () -A-> () +fun f () {} + +sig g : () -A-> () +fun g () { do E(f) } + +sig h : () -A-> () +fun h () { do E(g) } diff --git a/tests/effectname/simple-decl.links b/tests/effectname/simple-decl.links new file mode 100755 index 000000000..7f5370ab2 --- /dev/null +++ b/tests/effectname/simple-decl.links @@ -0,0 +1,16 @@ +effectname Void = {} ; +effectname Box(e::Eff) = { | e } ; +effectname OneEffect(a,e::Eff) = { E:a | e } ; +effectname JustOneEffect(a,e::Eff) = { E:a } ; # aka Joe +effectname W(e::Eff) = { wild:() | e } ; +effectname Wild = { wild:() } ; +effectname TwoEffects(a,e::Eff) = { E1:a, E2:a | e } ; + +typename BoxIsCompletlyUseless(e::Eff) = () -Box({ |e })-> () ; + +typename Fun(a,b,e::Eff) = (a) -e-> b ; +typename SquigglyFun(a,b,e::Eff) = (a) -W({ |e})-> b ; # as (a) ~e~> b +typename SimpleSquigglyFunInfix(a,b) = (a) -Wild-> b ; # as (a) ~> b +typename SimpleSquigglyFunPrefix(a,b) = (a) { | Wild }-> b ; +typename SimpleSquigglyFunPrefix2(a,b) = (a) { wild:() }-> b ; +typename SimpleSquigglyFunBoxWVoid(a,b) = (a) -Box({ |W({ |Void})})-> b ; diff --git a/tests/effectname/two-nested.links b/tests/effectname/two-nested.links new file mode 100755 index 000000000..95e3c6a96 --- /dev/null +++ b/tests/effectname/two-nested.links @@ -0,0 +1,9 @@ +effectname A(e::Eff) = { E: () {}-> () | e } ; +# effectname B = A({ | A({}) }) ; + +sig f : () -A({}) -> () +fun f () { + do E() +} + +f diff --git a/tests/effectname/two.links b/tests/effectname/two.links new file mode 100755 index 000000000..a1f92fc3a --- /dev/null +++ b/tests/effectname/two.links @@ -0,0 +1,7 @@ +effectname A = {} ; +effectname B(a,e::Eff) = { E: () {}-> a | e } ; + +sig f : () -B((),{ |A})-> () +fun f () { do E() } + +f diff --git a/tests/effectname/typenames.links b/tests/effectname/typenames.links new file mode 100755 index 000000000..9330ff991 --- /dev/null +++ b/tests/effectname/typenames.links @@ -0,0 +1,12 @@ +typename T(e::Eff) = (Int) -e-> Int ; + +effectname A(a,e::Eff) = { E1: T({}), E2: (Int) {}-> a | e } ; + +typename T'(a,b,e::Eff) = (a) { E: (a) {}-> Int | A(b,{ |e}) }-> b ; + +sig f : T'(Bool, Int, {}) +fun f (x) { + do E2( do E1( do E(x) ) ) +} + +f diff --git a/tests/effectname/zero.links b/tests/effectname/zero.links new file mode 100644 index 000000000..59ed3fe7c --- /dev/null +++ b/tests/effectname/zero.links @@ -0,0 +1,6 @@ +effectname A = {} ; + +sig f : () -A-> () +fun f () {} + +f From 49a9a61591382ca4a15408b644c7673c8b325dcc Mon Sep 17 00:00:00 2001 From: RJ Date: Fri, 13 May 2022 17:19:52 +0100 Subject: [PATCH 02/63] desalias inline --- core/desugarDatatypes.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/core/desugarDatatypes.ml b/core/desugarDatatypes.ml index 24fbe72a0..bb54b9b2d 100644 --- a/core/desugarDatatypes.ml +++ b/core/desugarDatatypes.ml @@ -252,9 +252,9 @@ module Desugar = struct | None -> raise (UnboundTyCon (node.pos, name)) | Some (`Alias (qs, _r)) -> let ts = match_quantifiers snd qs in - (* let Alias(_,body) = Instantiate.effectalias name ts alias_env.effectname in *) - (* body *) - Instantiate.effectalias name ts alias_env.effectname + let Alias(_,body) = Instantiate.effectalias name ts alias_env.effectname in + body + (* Instantiate.effectalias name ts alias_env.effectname *) | Some (`Abstract abstype) -> let ts = match_quantifiers identity (Abstype.arity abstype) in Application (abstype, ts) From 36a488f963bfcb33b549a88affc39aa063689843 Mon Sep 17 00:00:00 2001 From: RJ Date: Wed, 18 May 2022 18:19:09 +0100 Subject: [PATCH 03/63] alias = effectname and typename | init --- core/desugarEffects.ml | 38 ++++++++----- core/desugarModules.ml | 6 +- core/desugarTypeVariables.ml | 26 +-------- core/moduleUtils.ml | 4 +- core/parser.mly | 30 ++++------ core/sugarTraversals.ml | 105 +++++++++++------------------------ core/sugarTraversals.mli | 21 +++---- core/sugartoir.ml | 3 +- core/sugartypes.ml | 15 +++-- core/typeSugar.ml | 3 +- 10 files changed, 92 insertions(+), 159 deletions(-) diff --git a/core/desugarEffects.ml b/core/desugarEffects.ml index cfe28eb9e..07babcd54 100644 --- a/core/desugarEffects.ml +++ b/core/desugarEffects.ml @@ -1068,7 +1068,7 @@ class main_traversal simple_tycon_env = let o = o#set_allow_implictly_bound_vars allow_implictly_bound_vars in (o, b) - | Typenames ts -> + | Aliases ts -> let open SourceCode.WithPos in let tycon_env, tycons = List.fold_left @@ -1090,16 +1090,20 @@ class main_traversal simple_tycon_env = (* First determine which types require an implicit effect variable. *) let implicits, dep_graph = List.fold_left - (fun (implicits, dep_graph) { node = t, _, (d, _); _ } -> - let d = cleanup_effects tycon_env d in - let eff = gather_mutual_info tycon_env d in - let has_imp = eff#has_implicit in - let implicits = StringMap.add t has_imp implicits in - let used_mutuals = StringSet.inter eff#used_types tycons in - let dep_graph = - StringMap.add t (StringSet.elements used_mutuals) dep_graph - in - (implicits, dep_graph)) + (fun (implicits, dep_graph) { node = t, _, b; _ } -> + match b with + | Typename (d,_) -> + let d = cleanup_effects tycon_env d in + let eff = gather_mutual_info tycon_env d in + let has_imp = eff#has_implicit in + let implicits = StringMap.add t has_imp implicits in + let used_mutuals = StringSet.inter eff#used_types tycons in + let dep_graph = + StringMap.add t (StringSet.elements used_mutuals) dep_graph + in + (implicits, dep_graph) + | Effectname _ -> (* do nothing ? *) + (implicits, dep_graph)) (StringMap.empty, StringMap.empty) ts in @@ -1127,7 +1131,7 @@ class main_traversal simple_tycon_env = in (* Now patch up the types to include this effect variable. *) let patch_type_param_list ((tycon_env : simple_tycon_env), shared_var_env, ts) - ({ node = t, args, (d, _); pos } as tn) = + ({ node = t, args, b; pos } as tn) = if StringMap.find t implicits then let var = Types.fresh_raw_variable () in let q = (var, (PrimaryKind.Row, (lin_unl, res_effect))) in @@ -1149,9 +1153,13 @@ class main_traversal simple_tycon_env = let shared_var_env = StringMap.add t (Some shared_effect_var) shared_var_env in + let b' = match b with + | Typename (d,_) -> Typename (d, None) + | Effectname (r,_) -> Effectname (r,None) + in ( tycon_env, shared_var_env, - SourceCode.WithPos.make ~pos (t, args, (d, None)) :: ts ) + SourceCode.WithPos.make ~pos (t, args, b') :: ts ) else (* Note that we initially set the has-implict flag to false, so there is nothing to do here *) @@ -1175,13 +1183,13 @@ class main_traversal simple_tycon_env = in (* TODO: no info to flow back out? *) - let _o, dt' = o#datatype' dt in + let _o, dt' = o#aliasbody dt in SourceCode.WithPos.make ~pos (name, args, dt') in let ts' = List.map traverse_body ts in - ({}, Typenames ts') + ({}, Aliases ts') | b -> super#bindingnode b method super_datatype = super#datatype diff --git a/core/desugarModules.ml b/core/desugarModules.ml index 9cddfdd9f..c2a481ea7 100644 --- a/core/desugarModules.ml +++ b/core/desugarModules.ml @@ -446,7 +446,7 @@ and desugar ?(toplevel=false) (renamer' : Epithet.t) (scope' : Scope.t) = fs' [] in Funs fs'' - | Typenames ts -> + | Aliases ts -> (* Must be processed before any mutual function bindings in the same mutual binding group. *) (* Same procedure as above. *) @@ -459,11 +459,11 @@ and desugar ?(toplevel=false) (renamer' : Epithet.t) (scope' : Scope.t) = let ts'' = List.fold_right (fun (name, tyvars, dt, pos) ts -> - let dt' = self#datatype' dt in + let dt' = self#aliasbody dt in SourceCode.WithPos.make ~pos (name, tyvars, dt') :: ts) ts' [] in - Typenames ts'' + Aliases ts'' | Val (pat, (tvs, body), loc, dt) -> (* It is important to process [body] before [pat] to avoid inadvertently bringing the binder(s) in [pat] into the diff --git a/core/desugarTypeVariables.ml b/core/desugarTypeVariables.ml index 5e50f4ef3..b6035f01a 100644 --- a/core/desugarTypeVariables.ml +++ b/core/desugarTypeVariables.ml @@ -522,7 +522,7 @@ object (o : 'self) rec_frozen}) - method! typenamenode (name, unresolved_qs, body) = + method! aliasnode (name, unresolved_qs, body) = (* Don't allow unbound named type variables in type definitions. We do allow unbound *anoynmous* variables, because those may be @@ -531,30 +531,10 @@ object (o : 'self) Hence, we must re-check the free variables in the type definiton later on. *) let o = o#set_allow_implictly_bound_vars false in - (* Typenames must never use type variables from an outer scope *) + (* Aliases must never use type variables from an outer scope *) let o = o#reset_vars in - let o, resolved_qs, body = o#quantified ~rigidify:true unresolved_qs (fun o' -> o'#datatype' body) in - - let o = o#set_allow_implictly_bound_vars allow_implictly_bound_vars in - let o = o#set_vars tyvar_map in - - o, (name, resolved_qs, body) - - - method! effectnamenode (name, unresolved_qs, body) = - - (* Don't allow unbound named type variables in type definitions. - We do allow unbound *anoynmous* variables, because those may be - effect variables that the effect sugar handling will generalize the - type binding over. - Hence, we must re-check the free variables in the type definiton later on. *) - - let o = o#set_allow_implictly_bound_vars false in - (* Typenames must never use type variables from an outer scope *) - let o = o#reset_vars in - - let o, resolved_qs, body = o#quantified ~rigidify:true unresolved_qs (fun o' -> o'#row' body) in + let o, resolved_qs, body = o#quantified ~rigidify:true unresolved_qs (fun o' -> o'#aliasbody body) in let o = o#set_allow_implictly_bound_vars allow_implictly_bound_vars in let o = o#set_vars tyvar_map in diff --git a/core/moduleUtils.ml b/core/moduleUtils.ml index 5098d7365..6ee4597e8 100644 --- a/core/moduleUtils.ml +++ b/core/moduleUtils.ml @@ -210,12 +210,12 @@ let create_module_info_map program = @ get_binding_names bs | _ :: bs -> get_binding_names bs in (* Other binding types are uninteresting for this pass *) - (* Getting type names -- we're interested in typename decls *) + (* Getting type names -- we're interested in typename/effectname decls *) let rec get_type_names = function | [] -> [] | b :: bs -> match node b with - | Typenames ts -> + | Aliases ts -> let ns = ListUtils.concat_map (fun {node=(n, _, _); _} -> [n]) ts in ns @ (get_type_names bs) | _ -> get_type_names bs in diff --git a/core/parser.mly b/core/parser.mly index e2a6ac0bc..e143263e7 100644 --- a/core/parser.mly +++ b/core/parser.mly @@ -220,25 +220,21 @@ let make_effect_var : is_dot:bool -> ParserPosition.t -> Datatype.row_var module MutualBindings = struct type mutual_bindings = - { mut_types: typename list; - mut_effs: effectname list; + { mut_types: alias list; mut_funs: (function_definition * Position.t) list; mut_pos: Position.t } - let empty pos = { mut_types = []; mut_effs = []; mut_funs = []; mut_pos = pos } + let empty pos = { mut_types = []; mut_funs = []; mut_pos = pos } - let add ({ mut_types = ts; mut_effs = rs; mut_funs = fs; _ } as block) binding = + let add ({ mut_types = ts; mut_funs = fs; _ } as block) binding = let pos = WithPos.pos binding in match WithPos.node binding with | Fun f -> { block with mut_funs = ((f, pos) :: fs) } - | Typenames [t] -> + | Aliases [t] -> { block with mut_types = (t :: ts) } - | Effectnames [r] -> - { block with mut_effs = (r :: rs) } - | Typenames _ - | Effectnames _ -> assert false + | Aliases _ -> assert false | _ -> raise (ConcreteSyntaxError (pos, "Only `fun` and `typename` bindings are allowed in a `mutual` block.")) @@ -267,7 +263,7 @@ module MutualBindings = struct check fun_name funs; check ty_name tys_with_pos - let flatten { mut_types; mut_effs; mut_funs; mut_pos } = + let flatten { mut_types; mut_funs; mut_pos } = (* We need to take care not to lift non-recursive functions to * recursive functions accidentally. *) check_dups mut_funs mut_types; @@ -289,13 +285,9 @@ module MutualBindings = struct let type_binding = function | [] -> [] - | ts -> [WithPos.make ~pos:mut_pos (Typenames (List.rev ts))] in + | ts -> [WithPos.make ~pos:mut_pos (Aliases (List.rev ts))] in - let effect_binding = function - | [] -> [] - | rs -> [WithPos.make ~pos:mut_pos (Effectnames (List.rev rs))] in - - type_binding mut_types @ fun_binding mut_funs @ effect_binding mut_effs + type_binding mut_types @ fun_binding mut_funs end let parse_foreign_language pos lang = @@ -515,11 +507,11 @@ signature: | SIG sigop COLON datatype { with_pos $loc ($2, datatype $4) } typedecl: -| TYPENAME CONSTRUCTOR typeargs_opt EQ datatype { with_pos $loc (Typenames [with_pos $loc ($2, $3, datatype $5)]) } +| TYPENAME CONSTRUCTOR typeargs_opt EQ datatype { with_pos $loc (Aliases [with_pos $loc ($2, $3, Typename (datatype $5))]) } effectdecl: -| EFFECTNAME CONSTRUCTOR typeargs_opt EQ LBRACE erow RBRACE { with_pos $loc (Effectnames [with_pos $loc ($2, $3, ($6,None))]) } -| EFFECTNAME CONSTRUCTOR typeargs_opt EQ effect_app { with_pos $loc (Effectnames [with_pos $loc ($2, $3, (([],$5),None))]) } +| EFFECTNAME CONSTRUCTOR typeargs_opt EQ LBRACE erow RBRACE { with_pos $loc (Aliases [with_pos $loc ($2, $3, Effectname ( $6 ,None))]) } +| EFFECTNAME CONSTRUCTOR typeargs_opt EQ effect_app { with_pos $loc (Aliases [with_pos $loc ($2, $3, Effectname (([],$5),None))]) } (* Lists of quantifiers in square brackets denote type abstractions *) type_abstracion_vars: diff --git a/core/sugarTraversals.ml b/core/sugarTraversals.ml index b05ac92ba..5a8c4312b 100644 --- a/core/sugarTraversals.ml +++ b/core/sugarTraversals.ml @@ -763,12 +763,9 @@ class map = | Open _xs -> let _xs = o#list (fun o -> o#name) _xs in Open _xs - | Typenames ts -> - let _x = o#list (fun o -> o#typename) ts in - Typenames _x - | Effectnames es -> - let _x = o#list (fun o -> o#effectname) es in - Effectnames _x + | Aliases ts -> + let _x = o#list (fun o -> o#alias) ts in + Aliases _x | Infix { name; assoc; precedence } -> Infix { name = o#name name; assoc; precedence } | Exp _x -> let _x = o#phrase _x in Exp _x @@ -792,29 +789,22 @@ class map = fun p -> WithPos.map2 ~f_pos:o#position ~f_node:o#bindingnode p - method typenamenode : typenamenode -> typenamenode = + method aliasnode : aliasnode -> aliasnode = fun (_x, _x_i1, _x_i2) -> let _x = o#name _x in let _x_i1 = o#list (fun o x -> o#quantifier x) _x_i1 in - let _x_i2 = o#datatype' _x_i2 in + let _x_i2 = o#aliasbody _x_i2 in (_x, _x_i1, _x_i2) - method typename : typename -> typename = - fun p -> - WithPos.map2 ~f_pos:o#position ~f_node:o#typenamenode p - - method effectnamenode : effectnamenode -> effectnamenode = - fun (_x, _x_i1, _x_i2) -> - let _x = o#name _x in - let _x_i1 = o#list (fun o x -> o#quantifier x) - _x_i1 in - let _x_i2 = o#row' _x_i2 in - (_x, _x_i1, _x_i2) + method aliasbody : aliasbody -> aliasbody = + function + | Typename _x -> Typename (o#datatype' _x) + | Effectname _x -> Effectname (o#row' _x) - method effectname : effectname -> effectname = + method alias : alias -> alias = fun p -> - WithPos.map2 ~f_pos:o#position ~f_node:o#effectnamenode p + WithPos.map2 ~f_pos:o#position ~f_node:o#aliasnode p method function_definition : function_definition -> function_definition = fun { fun_binder; @@ -1544,11 +1534,8 @@ class fold = | Open _xs -> let o = o#list (fun o -> o#name) _xs in o - | Typenames ts -> - let o = o#list (fun o -> o#typename) ts in - o - | Effectnames es -> - let o = o#list (fun o -> o#effectname) es in + | Aliases ts -> + let o = o#list (fun o -> o#alias) ts in o | Infix { name; _ } -> o#name name @@ -1570,7 +1557,7 @@ class fold = ~f_pos:(fun o v -> o#position v) ~f_node:(fun o v -> o#bindingnode v) - method typenamenode : typenamenode -> 'self_type = + method aliasnode : aliasnode -> 'self_type = fun (_x, _x_i1, _x_i2) -> let o = o#name _x in let o = @@ -1578,31 +1565,19 @@ class fold = (fun o _x -> let o = o#quantifier _x in o) _x_i1 in - let o = o#datatype' _x_i2 in + let o = o#aliasbody _x_i2 in o - method typename : typename -> 'self_type = - WithPos.traverse - ~o - ~f_pos:(fun o v -> o#position v) - ~f_node:(fun o v -> o#typenamenode v) - - method effectnamenode : effectnamenode -> 'self_type = - fun (_x, _x_i1, _x_i2) -> - let o = o#name _x in - let o = - o#list - (fun o _x -> - let o = o#quantifier _x - in o) _x_i1 in - let o = o#row' _x_i2 in - o + method aliasbody : aliasbody -> 'self_type = + function + | Typename _x -> o#datatype' _x + | Effectname _x -> o#row' _x - method effectname : effectname -> 'self_type = + method alias : alias -> 'self_type = WithPos.traverse ~o ~f_pos:(fun o v -> o#position v) - ~f_node:(fun o v -> o#effectnamenode v) + ~f_node:(fun o v -> o#aliasnode v) method function_definition : function_definition -> 'self = fun { fun_binder; @@ -2483,12 +2458,9 @@ class fold_map = | Open _xs -> let (o, _xs) = o#list (fun o n -> o#name n) _xs in (o, Open _xs) - | Typenames ts -> - let (o, _x) = o#list (fun o -> o#typename) ts in - (o, (Typenames _x)) - | Effectnames es -> - let (o, _x) = o#list (fun o -> o#effectname) es in - (o, (Effectnames _x)) + | Aliases ts -> + let (o, _x) = o#list (fun o -> o#alias) ts in + (o, (Aliases _x)) | Infix { name; assoc; precedence } -> let (o, name) = o#name name in (o, Infix { name; assoc; precedence }) @@ -2515,7 +2487,7 @@ class fold_map = ~f_pos:(fun o v -> o#position v) ~f_node:(fun o v -> o#bindingnode v) - method typenamenode : typenamenode -> ('self_type * typenamenode) = + method aliasnode : aliasnode -> ('self_type * aliasnode) = fun (_x, _x_i1, _x_i2) -> let (o, _x) = o#name _x in let (o, _x_i1) = @@ -2524,32 +2496,19 @@ class fold_map = let (o, _x) = o#quantifier _x in (o, _x)) _x_i1 in - let (o, _x_i2) = o#datatype' _x_i2 + let (o, _x_i2) = o#aliasbody _x_i2 in (o, (_x, _x_i1, _x_i2)) - method typename : typename -> ('self_type * typename) = + method alias : alias -> ('self_type * alias) = WithPos.traverse_map ~o ~f_pos:(fun o v -> o#position v) - ~f_node:(fun o v -> o#typenamenode v) - - method effectnamenode : effectnamenode -> ('self_type * effectnamenode) = - fun (_x, _x_i1, _x_i2) -> - let (o, _x) = o#name _x in - let (o, _x_i1) = - o#list - (fun o _x -> - let (o, _x) = o#quantifier _x - in (o, _x)) - _x_i1 in - let (o, _x_i2) = o#row' _x_i2 - in (o, (_x, _x_i1, _x_i2)) + ~f_node:(fun o v -> o#aliasnode v) - method effectname : effectname -> ('self_effect * effectname) = - WithPos.traverse_map - ~o - ~f_pos:(fun o v -> o#position v) - ~f_node:(fun o v -> o#effectnamenode v) + method aliasbody : aliasbody -> ('self_type * aliasbody) = + function + | Typename _x -> let o, _x = o#datatype' _x in (o, Typename _x) + | Effectname _x -> let o, _x = o#row' _x in (o, Effectname _x) method function_definition : function_definition -> 'self * function_definition = fun { fun_binder; diff --git a/core/sugarTraversals.mli b/core/sugarTraversals.mli index a6946be6a..d3fb2a34d 100644 --- a/core/sugarTraversals.mli +++ b/core/sugarTraversals.mli @@ -71,10 +71,9 @@ class map : method tybinop : tyarg list * BinaryOp.t -> tyarg list * BinaryOp.t method bindingnode : bindingnode -> bindingnode method binding : binding -> binding - method typenamenode : typenamenode -> typenamenode - method typename : typename -> typename - method effectnamenode : effectnamenode -> effectnamenode - method effectname : effectname -> effectname + method aliasnode : aliasnode -> aliasnode + method alias : alias -> alias + method aliasbody : aliasbody -> aliasbody method function_definition : function_definition -> function_definition method recursive_function : recursive_function -> recursive_function method recursive_functionnode : recursive_functionnode -> recursive_functionnode @@ -156,10 +155,9 @@ class fold : method tybinop : tyarg list * BinaryOp.t -> 'self method bindingnode : bindingnode -> 'self method binding : binding -> 'self - method typenamenode : typenamenode -> 'self - method typename : typename -> 'self - method effectnamenode : effectnamenode -> 'self - method effectname : effectname -> 'self + method aliasnode : aliasnode -> 'self + method alias : alias -> 'self + method aliasbody : aliasbody -> 'self method function_definition : function_definition -> 'self method recursive_function : recursive_function -> 'self method recursive_functionnode : recursive_functionnode -> 'self @@ -183,10 +181,9 @@ object ('self) method binder : Binder.with_pos -> 'self * Binder.with_pos method binding : binding -> 'self * binding method bindingnode : bindingnode -> 'self * bindingnode - method typenamenode : typenamenode -> 'self * typenamenode - method typename : typename -> 'self * typename - method effectnamenode : effectnamenode -> 'self * effectnamenode - method effectname : effectname -> 'self * effectname + method aliasnode : aliasnode -> 'self * aliasnode + method alias : alias -> 'self * alias + method aliasbody : aliasbody -> 'self * aliasbody method binop : BinaryOp.t -> 'self * BinaryOp.t method tybinop : tyarg list * BinaryOp.t -> 'self * (tyarg list * BinaryOp.t) method bool : bool -> 'self * bool diff --git a/core/sugartoir.ml b/core/sugartoir.ml index 238c2ca97..380ec60e3 100644 --- a/core/sugartoir.ml +++ b/core/sugartoir.ml @@ -1317,8 +1317,7 @@ struct let xt = Binder.to_type binder in I.alien (Var.make_info xt x scope, Alien.object_name alien, Alien.language alien, fun v -> eval_bindings scope (extend [x] [(v, xt)] env) bs e) - | Typenames _ - | Effectnames _ + | Aliases _ | Infix _ -> (* Ignore type alias and infix declarations - they shouldn't be needed in the IR *) diff --git a/core/sugartypes.ml b/core/sugartypes.ml index 15b0abc43..f323178e6 100644 --- a/core/sugartypes.ml +++ b/core/sugartypes.ml @@ -524,8 +524,7 @@ and bindingnode = | Foreign of Alien.single Alien.t | Import of { pollute: bool; path : Name.t list } | Open of Name.t list - | Typenames of typename list - | Effectnames of effectname list + | Aliases of alias list | Infix of { assoc: Associativity.t; precedence: int; name: string } @@ -546,10 +545,11 @@ and cp_phrasenode = | CPLink of Binder.with_pos * Binder.with_pos | CPComp of Binder.with_pos * cp_phrase * cp_phrase and cp_phrase = cp_phrasenode WithPos.t -and typenamenode = Name.t * SugarQuantifier.t list * datatype' -and typename = typenamenode WithPos.t -and effectnamenode = Name.t * SugarQuantifier.t list * row' -and effectname = effectnamenode WithPos.t +and aliasnode = Name.t * SugarQuantifier.t list * aliasbody +and alias = aliasnode WithPos.t +and aliasbody = + | Typename of datatype' + | Effectname of row' and function_definition = { fun_binder: Binder.with_pos; fun_linearity: DeclaredLinearity.t; @@ -811,8 +811,7 @@ struct names, union_map (fun rhs -> diff (funlit rhs) names) rhss | Import _ | Open _ - | Typenames _ - | Effectnames _ -> empty, empty + | Aliases _ -> empty, empty (* This is technically a declaration, thus the name should probably be treated as bound rather than free. *) | Infix { name; _ } -> empty, singleton name diff --git a/core/typeSugar.ml b/core/typeSugar.ml index 741aecca4..6c5c44980 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -154,8 +154,7 @@ struct | Fun _ | Funs _ | Infix _ - | Typenames _ - | Effectnames _ + | Aliases _ | Foreign _ -> true | Exp p -> is_pure p | Val (pat, (_, rhs), _, _) -> From dbb6b5b88f5cf07c12faddb908790f6539eae80b Mon Sep 17 00:00:00 2001 From: RJ Date: Thu, 19 May 2022 12:31:33 +0100 Subject: [PATCH 04/63] merge into 1 construct ok; still 2 contexts --- core/desugarDatatypes.ml | 160 ++++++++++++--------------------------- core/desugarEffects.ml | 6 +- core/transformSugar.ml | 26 +++---- core/typeSugar.ml | 22 ++---- 4 files changed, 71 insertions(+), 143 deletions(-) diff --git a/core/desugarDatatypes.ml b/core/desugarDatatypes.ml index bb54b9b2d..32c3f79dc 100644 --- a/core/desugarDatatypes.ml +++ b/core/desugarDatatypes.ml @@ -304,14 +304,16 @@ module Desugar = struct | Row r -> Row, row alias_env r node | Presence f -> Presence, fieldspec alias_env f node - - let datatype' alias_env ((dt, _) : datatype') = (dt, Some (datatype alias_env dt)) let row' alias_env ((r, _) :row') = (r, Some (row alias_env r (WithPos.make (Datatype.Effect r)))) (* TODO(rj) should keep the pos *) + let aliasbody alias_env = function + | Typename dt' -> Typename (datatype' alias_env dt') + | Effectname r' -> Effectname (row' alias_env r') + let type_arg' alias_env ((ta, _) : type_arg') : type_arg' = let unlocated = WithPos.make Datatype.Unit in (ta, Some (type_arg alias_env ta unlocated)) @@ -398,7 +400,7 @@ object (self) method! bindingnode = function - | Typenames ts -> + | Aliases ts -> (* Maps syntactic types in the recursive group to semantic types. *) (* This must be empty to start off with, because there's a cycle * in calculating the semantic types: we need the alias environment @@ -414,36 +416,49 @@ object (self) (* Add all type declarations in the group to the alias * environment, as mutuals. Quantifiers need to be desugared. *) let ((mutual_env : Types.alias_environment), ts) = - List.fold_left (fun (alias_env, ts) {node=(t, args, (d, _)); pos} -> + List.fold_left (fun (alias_env, ts) {node=(t, args, b); pos} -> let qs = Desugar.desugar_quantifiers args in - let alias_env = { tycon = SEnv.bind t (`Mutual (qs, tygroup_ref)) alias_env.tycon ; - effectname = alias_env.effectname } in - (alias_env, WithPos.make ~pos (t, args, (d, None)) :: ts)) + match b with + | Typename (d,_) -> + let alias_env = { tycon = SEnv.bind t (`Mutual (qs, tygroup_ref)) alias_env.tycon ; + effectname = alias_env.effectname } in + (alias_env, WithPos.make ~pos (t, args, Typename (d, None)) :: ts) + | Effectname (r,_) -> + let alias_env = { tycon = alias_env.tycon ; + effectname = SEnv.bind t (`Mutual (qs, tygroup_ref)) alias_env.effectname } in + (alias_env, WithPos.make ~pos (t, args, Effectname (r, None)) :: ts) ) (alias_env, []) ts in (* Desugar all DTs, given the temporary new alias environment. *) let desugared_mutuals = List.map (fun {node=(name, args, dt); pos} -> (* Desugar the datatype *) - let dt' = Desugar.datatype' mutual_env dt in (* Check if the datatype has actually been desugared *) - let (t, dt) = - match dt' with - | (t, Some dt) -> (t, dt) - | _ -> assert false in - WithPos.make ~pos (name, args, (t, Some dt)) + let dt' = match Desugar.aliasbody mutual_env dt with + | Typename (_, Some _) as dt' -> dt' + | Effectname (_, Some _) as dt' -> dt' + | _ -> assert false + in + WithPos.make ~pos (name, args, dt') ) ts in (* Given the desugared datatypes, we now need to handle linearity. First, calculate linearity up to recursive application *) let (linearity_env, dep_graph) = List.fold_left (fun (lin_map, dep_graph) mutual -> - let (name, _, (_, dt)) = SourceCode.WithPos.node mutual in - let dt = OptionUtils.val_of dt in - let lin_map = StringMap.add name (not @@ Unl.type_satisfies dt) lin_map in - let deps = recursive_applications dt in - let dep_graph = (name, deps) :: dep_graph in - (lin_map, dep_graph) + match SourceCode.WithPos.node mutual with + | (name, _, Typename (_, dt)) -> + let dt = OptionUtils.val_of dt in + let lin_map = StringMap.add name (not @@ Unl.type_satisfies dt) lin_map in + let deps = recursive_applications dt in + let dep_graph = (name, deps) :: dep_graph in + (lin_map, dep_graph) + | (name, _, Effectname (_, r)) -> + let r = OptionUtils.val_of r in + let lin_map = StringMap.add name (not @@ Unl.type_satisfies r) lin_map in + let deps = recursive_applications r in + let dep_graph = (name, deps) :: dep_graph in + (lin_map, dep_graph) ) (StringMap.empty, []) desugared_mutuals in (* Next, use the toposorted dependency graph from above. We need to reverse since we propagate linearity information downwards from the @@ -474,11 +489,20 @@ object (self) (* NB: type aliases are scoped; we allow shadowing. We also allow type aliases to shadow abstract types. *) let alias_env = - List.fold_left (fun alias_env {node=(t, args, (_, dt')); _} -> - let dt = OptionUtils.val_of dt' in + List.fold_left (fun alias_env {node=(t, args, b); _} -> let semantic_qs = List.map SugarQuantifier.get_resolved_exn args in - let alias_env = { tycon = SEnv.bind t (`Alias (semantic_qs, dt)) alias_env.tycon ; - effectname = alias_env.effectname } in + let dt, alias_env = match b with + | Typename (_, d') -> + let dt = OptionUtils.val_of d' in + let alias_env = { tycon = SEnv.bind t (`Alias (semantic_qs, dt)) alias_env.tycon ; + effectname = alias_env.effectname } in + (dt, alias_env) + | Effectname (_, r') -> + let dt = OptionUtils.val_of r' in + let alias_env = { tycon = alias_env.tycon ; + effectname = SEnv.bind t (`Alias (semantic_qs, dt)) alias_env.effectname } in + (dt, alias_env) + in tygroup_ref := { !tygroup_ref with type_map = (StringMap.add t (semantic_qs, dt) !tygroup_ref.type_map); @@ -486,96 +510,8 @@ object (self) alias_env ) alias_env desugared_mutuals in - ({< alias_env = alias_env >}, Typenames desugared_mutuals) - | Effectnames rs -> - (* Maps syntactic types in the recursive group to semantic types. *) - (* This must be empty to start off with, because there's a cycle - * in calculating the semantic types: we need the alias environment - * populated with all types in the group in order to calculate a - * semantic type. We populate the reference in a later pass. *) - let tygroup_ref = ref { - id = fresh_tygroup_id (); - type_map = StringMap.empty; - linearity_map = StringMap.empty - } in - - - (* Add all type declarations in the group to the alias - * environment, as mutuals. Quantifiers need to be desugared. *) - let ((mutual_env : Types.alias_environment), rs) = - List.fold_left (fun (alias_env, rs) {node=(t, args, (r, _)); pos} -> - let qs = Desugar.desugar_quantifiers args in - let alias_env = { tycon = alias_env.tycon ; - effectname = SEnv.bind t (`Mutual (qs, tygroup_ref)) alias_env.effectname } in - (alias_env, WithPos.make ~pos (t, args, (r, None)) :: rs)) - (alias_env, []) rs in - - (* Desugar all DTs, given the temporary new alias environment. *) - let desugared_mutuals = - List.map (fun {node=(name, args, r); pos} -> - (* Desugar the datatype *) - let r' = Desugar.row' mutual_env r in - (* Check if the datatype has actually been desugared *) - let (t, r) = - match r' with - | (t, Some r) -> (t, r) - | _ -> assert false in - WithPos.make ~pos (name, args, (t, Some r)) - ) rs in - - (* Given the desugared datatypes, we now need to handle linearity. - First, calculate linearity up to recursive application *) - let (linearity_env, dep_graph) = - List.fold_left (fun (lin_map, dep_graph) mutual -> - let (name, _, (_, r)) = SourceCode.WithPos.node mutual in - let r = OptionUtils.val_of r in - let lin_map = StringMap.add name (not @@ Unl.type_satisfies r) lin_map in - let deps = recursive_applications r in - let dep_graph = (name, deps) :: dep_graph in - (lin_map, dep_graph) - ) (StringMap.empty, []) desugared_mutuals in - (* Next, use the toposorted dependency graph from above. We need to - reverse since we propagate linearity information downwards from the - SCCs which everything depends on, rather than upwards. *) - let sorted_graph = Graph.topo_sort_sccs dep_graph |> List.rev in - (* Next, propagate the linearity information through the graph, - in order to construct the final linearity map. - * Given the topo-sorted dependency graph, we propagate linearity based - * on the following rules: - * 1. If any type in a SCC is linear, then all types in that SCC must - * also be linear. - * 2. If a type depends on a linear type, then it must also be linear. - * 3. Otherwise, the type is unrestricted. - * - * Given that we have a topo-sorted graph, as soon as we come across a - * linear SCC, we know that the remaining types are also linear. *) - let (linearity_map, _) = - List.fold_right (fun scc (acc, lin_found) -> - let scc_linear = - lin_found || List.exists (fun x -> StringMap.find x linearity_env) scc in - let acc = - List.fold_left (fun acc x -> StringMap.add x scc_linear acc) acc scc in - (acc, scc_linear)) sorted_graph (StringMap.empty, false) in - - (* Finally, construct a new alias environment, and populate the map from - * strings to the desugared datatypes which in turn allows recursive type - * unwinding in unification. *) - (* NB: type aliases are scoped; we allow shadowing. - We also allow type aliases to shadow abstract types. *) - let alias_env = - List.fold_left (fun alias_env {node=(t, args, (_, r')); _} -> - let r = OptionUtils.val_of r' in - let semantic_qs = List.map SugarQuantifier.get_resolved_exn args in - let alias_env = { tycon = alias_env.tycon ; - effectname = SEnv.bind t (`Alias (semantic_qs, r)) alias_env.effectname } in - tygroup_ref := - { !tygroup_ref with - type_map = (StringMap.add t (semantic_qs, r) !tygroup_ref.type_map); - linearity_map }; - alias_env - ) alias_env desugared_mutuals in + ({< alias_env = alias_env >}, Aliases desugared_mutuals) - ({< alias_env = alias_env >}, Effectnames desugared_mutuals) | Foreign alien -> let binder, datatype = Alien.declaration alien in let _, binder = self#binder binder in diff --git a/core/desugarEffects.ml b/core/desugarEffects.ml index 07babcd54..7b655815b 100644 --- a/core/desugarEffects.ml +++ b/core/desugarEffects.ml @@ -1103,6 +1103,10 @@ class main_traversal simple_tycon_env = in (implicits, dep_graph) | Effectname _ -> (* do nothing ? *) + let implicits = StringMap.add t false implicits in + let dep_graph = + StringMap.add t [] dep_graph + in (implicits, dep_graph)) (StringMap.empty, StringMap.empty) ts @@ -1155,7 +1159,7 @@ class main_traversal simple_tycon_env = in let b' = match b with | Typename (d,_) -> Typename (d, None) - | Effectname (r,_) -> Effectname (r,None) + | Effectname (r,_) -> Effectname (r, None) in ( tycon_env, shared_var_env, diff --git a/core/transformSugar.ml b/core/transformSugar.ml index a69f1d58f..44bf68e8c 100644 --- a/core/transformSugar.ml +++ b/core/transformSugar.ml @@ -892,26 +892,20 @@ class transform (env : Types.typing_environment) = in let o, language = o#foreign_language (Alien.language alien) in (o, Foreign (Alien.modify ~language ~declarations alien)) - | Typenames ts -> - let (o, _) = listu o (fun o {node=(name, vars, (x, dt')); pos} -> - match dt' with - | Some dt -> + | Aliases ts -> + let (o, _) = listu o (fun o {node=(name, vars, b); pos} -> + match b with + | Typename (x, (Some dt as dt')) -> let o = o#bind_tycon name (`Alias (List.map (SugarQuantifier.get_resolved_exn) vars, dt)) in - (o, WithPos.make ~pos (name, vars, (x, dt'))) - | None -> raise (internal_error "Unannotated type alias") - ) ts in - (o, Typenames ts) - | Effectnames rs -> - let (o, _) = listu o (fun o {node=(name, vars, (x, r')); pos} -> - match r' with - | Some r -> + (o, WithPos.make ~pos (name, vars, Typename (x, dt'))) + | Effectname (x, (Some r as r')) -> let o = o#bind_effect name (`Alias (List.map (SugarQuantifier.get_resolved_exn) vars, r)) in - (o, WithPos.make ~pos (name, vars, (x, r'))) - | None -> raise (internal_error "Unannotated type alias") - ) rs in - (o, Effectnames rs) + (o, WithPos.make ~pos (name, vars, Effectname (x, r'))) + | _ -> raise (internal_error "Unannotated type alias") + ) ts in + (o, Aliases ts) | (Infix _) as node -> (o, node) | Exp e -> let (o, e, _) = o#phrase e in (o, Exp e) diff --git a/core/typeSugar.ml b/core/typeSugar.ml index 6c5c44980..b322c6e20 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -4852,22 +4852,16 @@ and type_binding : context -> binding -> binding * context * Usage.t = ( Foreign (Alien.modify ~declarations:[(binder, (dt, Some datatype))] alien) , bind_var empty_context (Binder.to_name binder, datatype) , Usage.empty ) - | Typenames ts -> - let env = List.fold_left (fun env {node=(name, vars, (_, dt')); _} -> - match dt' with - | Some dt -> + | Aliases ts -> + let env = List.fold_left (fun env {node=(name, vars, b); _} -> + match b with + | Typename (_, Some dt) -> bind_tycon env (name, `Alias (List.map (SugarQuantifier.get_resolved_exn) vars, dt)) - | None -> raise (internal_error "typeSugar.ml: unannotated type") + | Effectname (_, Some r) -> + bind_effectnames env (name, `Alias (List.map (SugarQuantifier.get_resolved_exn) vars, r)) + | _ -> raise (internal_error "typeSugar.ml: unannotated type") ) empty_context ts in - (Typenames ts, env, Usage.empty) - | Effectnames es -> - let env = List.fold_left (fun env {node=(name, vars, (_, effrow')); _} -> - match effrow' with - | Some effrow -> - bind_effectnames env (name, `Alias (List.map (SugarQuantifier.get_resolved_exn) vars, effrow)) - | None -> raise (internal_error "typeSugar.ml: unannotated type") - ) empty_context es in - (Effectnames es, env, Usage.empty) + (Aliases ts, env, Usage.empty) | Infix def -> Infix def, empty_context, Usage.empty | Exp e -> let e = tc e in From 84ffd9b84bc38ebb2691396da509bc18903c8743 Mon Sep 17 00:00:00 2001 From: RJ Date: Fri, 20 May 2022 13:52:35 +0100 Subject: [PATCH 05/63] merge type and effect aliases contexts --- bin/repl.ml | 31 ++----- core/defaultAliases.ml | 2 +- core/desugarDatatypes.ml | 57 +++++-------- core/desugarDatatypes.mli | 2 +- core/desugarEffects.ml | 24 +++--- core/desugarEffects.mli | 2 +- core/desugarPages.ml | 2 +- core/desugarRegexes.ml | 4 +- core/instantiate.ml | 25 ------ core/instantiate.mli | 3 +- core/lens_type_conv.mli | 4 +- core/lib.ml | 9 +- core/transformSugar.ml | 20 ++--- core/transformSugar.mli | 12 ++- core/typeSugar.ml | 46 +++++----- core/types.ml | 173 +++++++++++++------------------------- core/types.mli | 20 +---- core/webserver.ml | 2 +- 18 files changed, 154 insertions(+), 284 deletions(-) diff --git a/bin/repl.ml b/bin/repl.ml index d019774e7..bdda97174 100644 --- a/bin/repl.ml +++ b/bin/repl.ml @@ -123,7 +123,7 @@ let rec directives : (string * ((Context.t -> string list -> Context.t) * string (fun k s () -> Printf.fprintf stderr "typename %s = %s\n" k (Types.string_of_tycon_spec s)) - (Lib.typing_env.Types.tycon_env) (); + (Lib.typing_env.Types.alias_env) (); StringSet.iter (fun n -> let t = Env.String.find n Lib.type_env in Printf.fprintf stderr " %-16s : %s\n" @@ -155,14 +155,14 @@ let rec directives : (string * ((Context.t -> string list -> Context.t) * string ((fun context _ -> let tycon_env = let tenv = Context.typing_environment context in - tenv.Types.tycon_env + tenv.Types.alias_env in StringSet.iter (fun k -> let s = Env.String.find k tycon_env in Printf.fprintf stderr " %s = %s\n" (Module_hacks.Name.prettify k) (Types.string_of_tycon_spec s)) - (StringSet.diff (Env.String.domain tycon_env) (Env.String.domain Lib.typing_env.Types.tycon_env)); + (StringSet.diff (Env.String.domain tycon_env) (Env.String.domain Lib.typing_env.Types.alias_env)); context), "display the current type alias environment"); @@ -221,7 +221,7 @@ let rec directives : (string * ((Context.t -> string list -> Context.t) * string ((fun context args -> let tenv, aliases = let tyenv = Context.typing_environment context in - tyenv.Types.var_env, tyenv.Types.tycon_env + tyenv.Types.var_env, tyenv.Types.alias_env in match args with | [] -> prerr_endline "syntax: @withtype type"; context @@ -265,26 +265,19 @@ let execute_directive context (name, args) = let handle previous_context current_context = function | `Definitions _defs -> - let tycon_env', effect_env' = + let tycon_env' = let tenv = Context.typing_environment previous_context in let tenv' = Context.typing_environment current_context in - let tycon_env, tycon_env', effect_env, effect_env' = - Types.(tenv.tycon_env, tenv'.tycon_env, tenv.effect_env, tenv'.effect_env) + let tycon_env, tycon_env'= + Types.(tenv.alias_env, tenv'.alias_env) in - ( Env.String.fold + Env.String.fold (fun name def new_tycons -> (* This is a bit of a hack, but it will have to do until names become hygienic. *) if not (Env.String.has name tycon_env) || not (Env.String.find name tycon_env == def) then Env.String.bind name def new_tycons else new_tycons) - tycon_env' Env.String.empty , - Env.String.fold - (fun name def new_effects -> - (* This is a bit of a hack, but it will have to do until names become hygienic. *) - if not (Env.String.has name effect_env) || not (Env.String.find name effect_env == def) - then Env.String.bind name def new_effects - else new_effects) - effect_env' Env.String.empty ) + tycon_env' Env.String.empty in Env.String.fold (fun name spec () -> @@ -292,12 +285,6 @@ let handle previous_context current_context = function (Module_hacks.Name.prettify name) (Types.string_of_tycon_spec spec)) tycon_env' (); - Env.String.fold - (fun name spec () -> - Printf.printf "%s = %s\n%!" - (Module_hacks.Name.prettify name) - (Types.string_of_effect_spec spec)) - effect_env' (); let diff previous_context current_context = let new_vars = let nenv, nenv' = diff --git a/core/defaultAliases.ml b/core/defaultAliases.ml index 54f127035..ba1d2af9b 100644 --- a/core/defaultAliases.ml +++ b/core/defaultAliases.ml @@ -3,7 +3,7 @@ open CommonTypes (* Alias environment *) module AliasEnv = Env.String -let alias_env : Types.tycon_environment = +let alias_env : Types.alias_environment = (* TableHandle is now an alias of TemporalTable, so set it up *) let mk_arg () = let open Types in diff --git a/core/desugarDatatypes.ml b/core/desugarDatatypes.ml index 32c3f79dc..0eace9a82 100644 --- a/core/desugarDatatypes.ml +++ b/core/desugarDatatypes.ml @@ -152,11 +152,11 @@ module Desugar = struct else raise (TypeApplicationArityMismatch { pos; name = tycon; expected = qn; provided = tn }) in - begin match SEnv.find_opt tycon alias_env.tycon with + begin match SEnv.find_opt tycon alias_env with | None -> raise (UnboundTyCon (pos, tycon)) | Some (`Alias (qs, _dt)) -> let ts = match_quantifiers snd qs in - Instantiate.alias tycon ts alias_env.tycon + Instantiate.alias tycon ts alias_env | Some (`Abstract abstype) -> let ts = match_quantifiers identity (Abstype.arity abstype) in Application (abstype, ts) @@ -248,13 +248,13 @@ module Desugar = struct else raise (TypeApplicationArityMismatch { pos = node.pos; name = name; expected = qn; provided = tn }) in - begin match SEnv.find_opt name alias_env.effectname with + begin match SEnv.find_opt name alias_env with | None -> raise (UnboundTyCon (node.pos, name)) | Some (`Alias (qs, _r)) -> let ts = match_quantifiers snd qs in - let Alias(_,body) = Instantiate.effectalias name ts alias_env.effectname in + let Alias(_,body) = Instantiate.alias name ts alias_env in body - (* Instantiate.effectalias name ts alias_env.effectname *) + (* Instantiate.alias name ts alias_env *) | Some (`Abstract abstype) -> let ts = match_quantifiers identity (Abstype.arity abstype) in Application (abstype, ts) @@ -263,6 +263,7 @@ module Desugar = struct * a `RecursiveApplication. *) let r_args = match_quantifiers snd qs in let r_unwind args dual = + Debug.print "et ça boucel [desugarDT/r_unwind]" ; let _, body = StringMap.find name !tygroup_ref.type_map in let body = Instantiate.recursive_application name qs args body in if dual then dual_type body else body @@ -420,26 +421,24 @@ object (self) let qs = Desugar.desugar_quantifiers args in match b with | Typename (d,_) -> - let alias_env = { tycon = SEnv.bind t (`Mutual (qs, tygroup_ref)) alias_env.tycon ; - effectname = alias_env.effectname } in + let alias_env = SEnv.bind t (`Mutual (qs, tygroup_ref)) alias_env in (alias_env, WithPos.make ~pos (t, args, Typename (d, None)) :: ts) | Effectname (r,_) -> - let alias_env = { tycon = alias_env.tycon ; - effectname = SEnv.bind t (`Mutual (qs, tygroup_ref)) alias_env.effectname } in + let alias_env = SEnv.bind t (`Mutual (qs, tygroup_ref)) alias_env in (alias_env, WithPos.make ~pos (t, args, Effectname (r, None)) :: ts) ) (alias_env, []) ts in (* Desugar all DTs, given the temporary new alias environment. *) let desugared_mutuals = - List.map (fun {node=(name, args, dt); pos} -> + List.map (fun {node=(name, args, b); pos} -> (* Desugar the datatype *) (* Check if the datatype has actually been desugared *) - let dt' = match Desugar.aliasbody mutual_env dt with - | Typename (_, Some _) as dt' -> dt' - | Effectname (_, Some _) as dt' -> dt' + let b' = match Desugar.aliasbody mutual_env b with + | Typename (_, Some _) as b' -> b' + | Effectname (_, Some _) as b' -> b' | _ -> assert false in - WithPos.make ~pos (name, args, dt') + WithPos.make ~pos (name, args, b') ) ts in (* Given the desugared datatypes, we now need to handle linearity. @@ -447,18 +446,13 @@ object (self) let (linearity_env, dep_graph) = List.fold_left (fun (lin_map, dep_graph) mutual -> match SourceCode.WithPos.node mutual with - | (name, _, Typename (_, dt)) -> + | (name, _, Typename (_, dt)) + | (name, _, Effectname (_, dt)) -> let dt = OptionUtils.val_of dt in let lin_map = StringMap.add name (not @@ Unl.type_satisfies dt) lin_map in let deps = recursive_applications dt in let dep_graph = (name, deps) :: dep_graph in (lin_map, dep_graph) - | (name, _, Effectname (_, r)) -> - let r = OptionUtils.val_of r in - let lin_map = StringMap.add name (not @@ Unl.type_satisfies r) lin_map in - let deps = recursive_applications r in - let dep_graph = (name, deps) :: dep_graph in - (lin_map, dep_graph) ) (StringMap.empty, []) desugared_mutuals in (* Next, use the toposorted dependency graph from above. We need to reverse since we propagate linearity information downwards from the @@ -492,15 +486,10 @@ object (self) List.fold_left (fun alias_env {node=(t, args, b); _} -> let semantic_qs = List.map SugarQuantifier.get_resolved_exn args in let dt, alias_env = match b with - | Typename (_, d') -> - let dt = OptionUtils.val_of d' in - let alias_env = { tycon = SEnv.bind t (`Alias (semantic_qs, dt)) alias_env.tycon ; - effectname = alias_env.effectname } in - (dt, alias_env) - | Effectname (_, r') -> - let dt = OptionUtils.val_of r' in - let alias_env = { tycon = alias_env.tycon ; - effectname = SEnv.bind t (`Alias (semantic_qs, dt)) alias_env.effectname } in + | Typename (_, dt') + | Effectname (_, dt') -> + let dt = OptionUtils.val_of dt' in + let alias_env = SEnv.bind t (`Alias (semantic_qs, dt)) alias_env in (dt, alias_env) in tygroup_ref := @@ -567,7 +556,7 @@ let toplevel_bindings alias_env bs = let program typing_env (bindings, p : Sugartypes.program) : Sugartypes.program = - let alias_env = Types.typing_to_alias typing_env in + let alias_env = typing_env.alias_env in let alias_env, bindings = toplevel_bindings alias_env bindings in (* let typing_env = { typing_env with tycon_env = alias_env } in *) @@ -575,9 +564,9 @@ let program typing_env (bindings, p : Sugartypes.program) : let sentence typing_env = function | Definitions bs -> - let _alias_env, bs' = toplevel_bindings (Types.typing_to_alias typing_env) bs in + let _alias_env, bs' = toplevel_bindings typing_env.alias_env bs in Definitions bs' - | Expression p -> let _o, p = phrase (Types.typing_to_alias typing_env) p in + | Expression p -> let _o, p = phrase typing_env.alias_env p in Expression p | Directive d -> Directive d @@ -585,7 +574,7 @@ let read ~aliases s = let dt, _ = parse_string ~in_context:(LinksLexer.fresh_context ()) datatype s in let dt = DesugarTypeVariables.standalone_signature dt in let dt = DesugarEffects.standalone_signature aliases dt in - let _, ty = Generalise.generalise Env.String.empty (Desugar.datatype {tycon = aliases ; effectname = SEnv.empty} dt) in + let _, ty = Generalise.generalise Env.String.empty (Desugar.datatype aliases dt) in ty module Untyped = struct diff --git a/core/desugarDatatypes.mli b/core/desugarDatatypes.mli index 5ae5347e8..e098e394a 100644 --- a/core/desugarDatatypes.mli +++ b/core/desugarDatatypes.mli @@ -1,4 +1,4 @@ -val read : aliases:Types.tycon_environment -> string -> Types.datatype +val read : aliases:Types.alias_environment -> string -> Types.datatype val sentence : Types.typing_environment -> diff --git a/core/desugarEffects.ml b/core/desugarEffects.ml index 7b655815b..d3a09fd98 100644 --- a/core/desugarEffects.ml +++ b/core/desugarEffects.ml @@ -115,7 +115,7 @@ type tycon_info = Kind.t list * bool * Types.typ option type simple_tycon_env = tycon_info SEnv.t -let simplify_tycon_env (tycon_env : Types.tycon_environment) : simple_tycon_env +let simplify_tycon_env (tycon_env : Types.alias_environment) : simple_tycon_env = let simplify_tycon name tycon simpl_env = let param_kinds, internal_type = @@ -1090,7 +1090,7 @@ class main_traversal simple_tycon_env = (* First determine which types require an implicit effect variable. *) let implicits, dep_graph = List.fold_left - (fun (implicits, dep_graph) { node = t, _, b; _ } -> + (fun (implicits, dep_graph) { node = t, _, b; pos ;_ } -> match b with | Typename (d,_) -> let d = cleanup_effects tycon_env d in @@ -1102,10 +1102,14 @@ class main_traversal simple_tycon_env = StringMap.add t (StringSet.elements used_mutuals) dep_graph in (implicits, dep_graph) - | Effectname _ -> (* do nothing ? *) - let implicits = StringMap.add t false implicits in + | Effectname (r,_) -> (* is this the right thing to do ? *) + let d = cleanup_effects tycon_env (SourceCode.WithPos.make ~pos (Datatype.Effect r)) in + let eff = gather_mutual_info tycon_env d in + let has_imp = eff#has_implicit in + let implicits = StringMap.add t has_imp implicits in + let used_mutuals = StringSet.inter eff#used_types tycons in let dep_graph = - StringMap.add t [] dep_graph + StringMap.add t (StringSet.elements used_mutuals) dep_graph in (implicits, dep_graph)) (StringMap.empty, StringMap.empty) @@ -1256,12 +1260,12 @@ class main_traversal simple_tycon_env = (o, rec_def) end -let program (tycon_env : Types.tycon_environment) p = +let program (tycon_env : Types.alias_environment) p = let s_env = simplify_tycon_env tycon_env in let v = new main_traversal s_env in snd (v#program p) -let sentence (tycon_env : Types.tycon_environment) = +let sentence (tycon_env : Types.alias_environment) = let s_env = simplify_tycon_env tycon_env in function | Definitions bs -> @@ -1274,7 +1278,7 @@ let sentence (tycon_env : Types.tycon_environment) = Expression p | Directive d -> Directive d -let standalone_signature (tycon_env : Types.tycon_environment) t = +let standalone_signature (tycon_env : Types.alias_environment) t = let s_env = simplify_tycon_env tycon_env in let v = new main_traversal s_env in snd (v#datatype t) @@ -1287,12 +1291,12 @@ module Untyped = struct let program state program' = let open Types in let tyenv = Context.typing_environment (context state) in - let program' = program tyenv.tycon_env program' in + let program' = program tyenv.alias_env program' in return state program' let sentence state sentence' = let open Types in let tyenv = Context.typing_environment (context state) in - let sentence'' = sentence tyenv.tycon_env sentence' in + let sentence'' = sentence tyenv.alias_env sentence' in return state sentence'' end diff --git a/core/desugarEffects.mli b/core/desugarEffects.mli index df6a8dc8e..3fa894715 100644 --- a/core/desugarEffects.mli +++ b/core/desugarEffects.mli @@ -1,4 +1,4 @@ (* Act on a type that's a lib.ml signature. Used by DesugarDatatypes.read *) -val standalone_signature : Types.tycon_environment -> Sugartypes.Datatype.with_pos -> Sugartypes.Datatype.with_pos +val standalone_signature : Types.alias_environment -> Sugartypes.Datatype.with_pos -> Sugartypes.Datatype.with_pos include Transform.Untyped.S diff --git a/core/desugarPages.ml b/core/desugarPages.ml index 8ad49c2d4..326142956 100644 --- a/core/desugarPages.ml +++ b/core/desugarPages.ml @@ -71,7 +71,7 @@ object method! phrasenode = function | Page e -> let (o, e, _t) = super#phrase e in - let page_type = Instantiate.alias "Page" [] env.Types.tycon_env in + let page_type = Instantiate.alias "Page" [] env.Types.alias_env in let e = desugar_page (o, page_type) e in (o, e.node, page_type) | e -> super#phrasenode e diff --git a/core/desugarRegexes.ml b/core/desugarRegexes.ml index ac5b59d1b..34f2ad17b 100644 --- a/core/desugarRegexes.ml +++ b/core/desugarRegexes.ml @@ -70,8 +70,8 @@ let desugar_regexes env = object(self) inherit (TransformSugar.transform env) as super - val regex_type = Instantiate.alias "Regex" [] env.Types.tycon_env - val repeat_type = Instantiate.alias "Repeat" [] env.Types.tycon_env + val regex_type = Instantiate.alias "Regex" [] env.Types.alias_env + val repeat_type = Instantiate.alias "Repeat" [] env.Types.alias_env method! phrase ({node=p; pos} as ph) = match p with | InfixAppl ((tyargs, BinaryOp.RegexMatch flags), e1, {node=Regex((Replace(_,_) as r)); _}) -> diff --git a/core/instantiate.ml b/core/instantiate.ml index 405c596a4..dca06b557 100644 --- a/core/instantiate.ml +++ b/core/instantiate.ml @@ -450,28 +450,3 @@ let alias name tyargs env : Types.typ = top-level quantifiers *) let (_, body) = typ (instantiate_datatype inst_map body) in Alias ((name, List.map snd vars, tyargs, false), body) - -let effectalias name tyargs env : Types.typ = - (* This is just type application. - - (\Lambda x1 ... xn . t) (t1 ... tn) ~> t[ti/xi] - *) - let open Types in - match (SEnv.find_opt name env : Types.effectalias_spec option) with - | None -> - raise (internal_error (Printf.sprintf "Unrecognised type constructor: %s" name)) - | Some (`Abstract _) - (* | Some (`Mutual _) *)-> - raise (internal_error (Printf.sprintf "The type constructor: %s is not an alias" name)) - | Some (`Alias (vars, _)) when List.length vars <> List.length tyargs -> - raise (internal_error - (Printf.sprintf - "Type alias %s applied with incorrect arity (%d instead of %d). This should have been checked prior to instantiation." - name (List.length tyargs) (List.length vars))) - | Some (`Alias (vars, body)) -> - let inst_map = populate_instantiation_map ~name vars tyargs in - (* instantiate the type variables bound by the alias - definition with the type arguments *and* instantiate any - top-level quantifiers *) - let (_, body) = typ (instantiate_datatype inst_map body) in - Alias ((name, List.map snd vars, tyargs, false), body) diff --git a/core/instantiate.mli b/core/instantiate.mli index b828d0f7a..6af281d6c 100644 --- a/core/instantiate.mli +++ b/core/instantiate.mli @@ -15,8 +15,7 @@ val typ_rigid : Types.datatype -> (Types.type_arg list * Types.datatype) val datatype : instantiation_maps -> Types.datatype -> Types.datatype val row : instantiation_maps -> Types.row -> Types.row val presence : instantiation_maps -> Types.field_spec -> Types.field_spec -val alias : string -> Types.type_arg list -> Types.tycon_environment -> Types.datatype -val effectalias : string -> Types.type_arg list -> Types.effect_environment -> Types.datatype +val alias : string -> Types.type_arg list -> Types.alias_environment -> Types.datatype val recursive_application : string -> Quantifier.t list -> Types.type_arg list -> Types.datatype -> Types.datatype (* Given a quantified type and a list of type arguments, create the corresponding instantiation map *) diff --git a/core/lens_type_conv.mli b/core/lens_type_conv.mli index c6b8b12e2..09a309376 100644 --- a/core/lens_type_conv.mli +++ b/core/lens_type_conv.mli @@ -1,13 +1,13 @@ type 'a die = string -> 'a (** Lookup a type alias in the typing environment context. *) -val lookup_alias : Types.tycon_environment -> alias:string -> Types.typ +val lookup_alias : Types.alias_environment -> alias:string -> Types.typ val lens_type_of_type : die:Lens.Type.t die -> Types.typ -> Lens.Type.t (** Convert a native Links language type to a lens phrase type. *) val type_of_lens_phrase_type : - context:Types.tycon_environment -> Lens.Phrase.Type.t -> Types.typ + context:Types.alias_environment -> Lens.Phrase.Type.t -> Types.typ (** Convert a lens phrase type to a native Links type. *) val lens_phrase_type_of_type : Types.typ -> Lens.Phrase.Type.t diff --git a/core/lib.ml b/core/lib.ml index 58b3168c6..7089a55f7 100644 --- a/core/lib.ml +++ b/core/lib.ml @@ -20,12 +20,12 @@ module AliasEnv = Env.String (* This is done in two stages because the datatype for regexes refers to the String alias *) -let alias_env : Types.tycon_environment = DefaultAliases.alias_env +let alias_env : Types.alias_environment = DefaultAliases.alias_env -let alias_env : Types.tycon_environment = +let alias_env : Types.alias_environment = AliasEnv.bind "Repeat" (`Alias ([], (DesugarDatatypes.read ~aliases:alias_env Linksregex.Repeat.datatype))) alias_env -let alias_env : Types.tycon_environment = +let alias_env : Types.alias_environment = AliasEnv.bind "Regex" (`Alias ([], (DesugarDatatypes.read ~aliases:alias_env Linksregex.Regex.datatype))) alias_env let datatype = DesugarDatatypes.read ~aliases:alias_env @@ -1725,8 +1725,7 @@ let type_env : Types.environment = let typing_env = {Types.var_env = type_env; Types.rec_vars = StringSet.empty; - tycon_env = alias_env; - effect_env = Env.String.empty; + alias_env = alias_env; Types.effect_row = Types.closed_wild_row; Types.desugared = false } diff --git a/core/transformSugar.ml b/core/transformSugar.ml index 44bf68e8c..79a705750 100644 --- a/core/transformSugar.ml +++ b/core/transformSugar.ml @@ -145,18 +145,17 @@ class transform (env : Types.typing_environment) = let open PrimaryKind in object (o : 'self_type) val var_env = env.Types.var_env - val tycon_env = env.Types.tycon_env - val effect_env = env.Types.effect_env + val tycon_env = env.Types.alias_env val formlet_env = TyEnv.empty val effect_row = fst (Types.unwrap_row env.Types.effect_row) method get_var_env : unit -> Types.environment = fun () -> var_env - method get_tycon_env : unit -> Types.tycon_environment = fun () -> tycon_env + method get_tycon_env : unit -> Types.alias_environment = fun () -> tycon_env method get_formlet_env : unit -> Types.environment = fun () -> formlet_env - method backup_envs = var_env, tycon_env, effect_env, formlet_env, effect_row - method restore_envs (var_env, tycon_env, effect_env, formlet_env, effect_row) = - {< var_env = var_env; tycon_env = tycon_env; effect_env = effect_env; formlet_env = formlet_env; + method backup_envs = var_env, tycon_env, formlet_env, effect_row + method restore_envs (var_env, tycon_env, formlet_env, effect_row) = + {< var_env = var_env; tycon_env = tycon_env; formlet_env = formlet_env; effect_row = effect_row >} method with_var_env var_env = @@ -165,12 +164,9 @@ class transform (env : Types.typing_environment) = method with_formlet_env formlet_env = {< formlet_env = formlet_env >} - method bind_tycon name tycon = + method bind_alias name tycon = {< tycon_env = TyEnv.bind name tycon tycon_env >} - method bind_effect name row = - {< effect_env = TyEnv.bind name row effect_env >} - method bind_binder bndr = {< var_env = TyEnv.bind (Binder.to_name bndr) (Binder.to_type bndr) var_env >} @@ -896,11 +892,11 @@ class transform (env : Types.typing_environment) = let (o, _) = listu o (fun o {node=(name, vars, b); pos} -> match b with | Typename (x, (Some dt as dt')) -> - let o = o#bind_tycon name + let o = o#bind_alias name (`Alias (List.map (SugarQuantifier.get_resolved_exn) vars, dt)) in (o, WithPos.make ~pos (name, vars, Typename (x, dt'))) | Effectname (x, (Some r as r')) -> - let o = o#bind_effect name + let o = o#bind_alias name (`Alias (List.map (SugarQuantifier.get_resolved_exn) vars, r)) in (o, WithPos.make ~pos (name, vars, Effectname (x, r'))) | _ -> raise (internal_error "Unannotated type alias") diff --git a/core/transformSugar.mli b/core/transformSugar.mli index ce094f4ea..0c75bd104 100644 --- a/core/transformSugar.mli +++ b/core/transformSugar.mli @@ -31,22 +31,20 @@ val listu : class transform : Types.typing_environment -> object ('self) val var_env : Types.environment - val tycon_env : Types.tycon_environment - val effect_env : Types.effect_environment + val tycon_env : Types.alias_environment val effect_row : Types.row method get_var_env : unit -> Types.environment - method get_tycon_env : unit -> Types.tycon_environment + method get_tycon_env : unit -> Types.alias_environment method get_formlet_env : unit -> Types.environment - method backup_envs : Types.environment * Types.tycon_environment * Types.effect_environment * Types.environment * Types.row - method restore_envs : (Types.environment * Types.tycon_environment * Types.effect_environment * Types.environment * Types.row) -> 'self + method backup_envs : Types.environment * Types.alias_environment * Types.environment * Types.row + method restore_envs : (Types.environment * Types.alias_environment * Types.environment * Types.row) -> 'self method with_var_env : Types.environment -> 'self method with_formlet_env : Types.environment -> 'self - method bind_tycon : string -> Types.tycon_spec -> 'self - method bind_effect : string -> Types.effectalias_spec -> 'self + method bind_alias : string -> Types.tycon_spec -> 'self method bind_binder : Binder.with_pos -> 'self method lookup_type : Name.t -> Types.datatype diff --git a/core/typeSugar.ml b/core/typeSugar.ml index b322c6e20..900985009 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -1649,10 +1649,7 @@ type context = Types.typing_environment = { type inference. Instead, we use it to resolve references introduced here to aliases defined in the prelude such as "Page" and "Formlet". *) - tycon_env : Types.tycon_environment; - - (* mapping from effect alias names to the effect row they name *) - effect_env : Types.effect_environment; + alias_env : Types.alias_environment; (* the current effects *) effect_row : Types.row; @@ -1665,15 +1662,13 @@ type context = Types.typing_environment = { let empty_context eff desugared = { var_env = Env.empty; rec_vars = StringSet.empty; - tycon_env = Env.empty; - effect_env = Env.empty; + alias_env = Env.empty; effect_row = eff; desugared } let bind_var context (v, t) = {context with var_env = Env.bind v t context.var_env} let unbind_var context v = {context with var_env = Env.unbind v context.var_env} -let bind_tycon context (v, t) = {context with tycon_env = Env.bind v t context.tycon_env} -let bind_effectnames context (v, t) = {context with effect_env = Env.bind v t context.effect_env} +let bind_alias context (v, t) = {context with alias_env = Env.bind v t context.alias_env} let bind_effects context r = {context with effect_row = r} (* TODO(dhil): I have extracted the Usage abstraction from my name @@ -1860,7 +1855,7 @@ let add_usages (p, t) m = (p, t, m) let add_empty_usages (p, t) = (p, t, Usage.empty) let type_unary_op pos env = - let datatype = datatype env.tycon_env in + let datatype = datatype env.alias_env in function | UnaryOp.Minus -> add_empty_usages (datatype "(Int) -> Int") | UnaryOp.FloatMinus -> add_empty_usages (datatype "(Float) -> Float") @@ -1874,7 +1869,7 @@ let type_unary_op pos env = let type_binary_op pos ctxt = let open BinaryOp in let open Types in - let datatype = datatype ctxt.tycon_env in function + let datatype = datatype ctxt.alias_env in function | Minus -> add_empty_usages (Utils.instantiate ctxt.var_env "-") | FloatMinus -> add_empty_usages (Utils.instantiate ctxt.var_env "-.") | RegexMatch flags -> @@ -2919,7 +2914,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = let typ = let tlens = typ lens |> Lens_type_conv.lens_type_of_type ~die:(Gripers.die pos) in let trow = Lens.Type.sort tlens |> Lens.Sort.record_type in - let {tycon_env = context;_} = context in + let {alias_env = context;_} = context in let ltrow = Lens_type_conv.type_of_lens_phrase_type ~context trow in let tmatch = Types.make_pure_function_type [ltrow] Types.bool_type in unify (pos_and_typ tpredicate, (exp_pos lens, tmatch)) ~handle:Gripers.lens_predicate; @@ -2954,7 +2949,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = let typ = typ lens |> Lens_type_conv.lens_type_of_type ~die:(Gripers.die pos) in Lens.Type.ensure_checked typ |> Lens_errors.unpack_lens_checked_result ~die:(Gripers.die pos); let sort = Lens.Type.sort typ in - let {tycon_env = context;_} = context in + let {alias_env = context;_} = context in let trowtype = Lens.Sort.record_type sort |> Lens_type_conv.type_of_lens_phrase_type ~context in LensGetLit (erase lens, Some trowtype), Types.make_list_type trowtype, usages lens | LensCheckLit (lens, _) -> @@ -2971,7 +2966,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = Lens.Type.ensure_checked typ |> Lens_errors.unpack_lens_checked_result ~die:(Gripers.die pos); let data = tc data in let trow = Lens.Type.sort typ |> Lens.Sort.record_type in - let {tycon_env = context;_} = context in + let {alias_env = context;_} = context in let ltrow = Lens_type_conv.type_of_lens_phrase_type ~context trow in unify (pos_and_typ data, (exp_pos lens, Types.make_list_type ltrow)) ~handle:Gripers.lens_put_input; LensPutLit (erase lens, erase data, Some Types.unit_type), make_tuple_type [], Usage.combine (usages lens) (usages data) @@ -3628,7 +3623,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = (fun e -> unify ~handle:Gripers.xml_attributes (pos_and_typ e, no_pos ( - (Instantiate.alias "Attributes" [] context.tycon_env)))) attrexp + (Instantiate.alias "Attributes" [] context.alias_env)))) attrexp and () = List.iter (fun child -> unify ~handle:Gripers.xml_child (pos_and_typ child, no_pos Types.xml_type)) children in @@ -3649,12 +3644,12 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = let yields = type_check context' yields in unify ~handle:Gripers.formlet_body (pos_and_typ body, no_pos Types.xml_type); (Formlet (erase body, erase yields), - Instantiate.alias "Formlet" [PrimaryKind.Type, typ yields] context.tycon_env, + Instantiate.alias "Formlet" [PrimaryKind.Type, typ yields] context.alias_env, Usage.combine (usages body) (Usage.restrict (usages yields) vs)) | Page e -> let e = tc e in unify ~handle:Gripers.page_body (pos_and_typ e, no_pos Types.xml_type); - Page (erase e), Instantiate.alias "Page" [] context.tycon_env, usages e + Page (erase e), Instantiate.alias "Page" [] context.alias_env, usages e | FormletPlacement (f, h, attributes) -> let t = Types.fresh_type_variable (lin_any, res_any) in @@ -3662,24 +3657,24 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = and h = tc h and attributes = tc attributes in let () = unify ~handle:Gripers.render_formlet - (pos_and_typ f, no_pos (Instantiate.alias "Formlet" [PrimaryKind.Type, t] context.tycon_env)) in + (pos_and_typ f, no_pos (Instantiate.alias "Formlet" [PrimaryKind.Type, t] context.alias_env)) in let () = unify ~handle:Gripers.render_handler (pos_and_typ h, (exp_pos f, - Instantiate.alias "Handler" [PrimaryKind.Type, t] context.tycon_env)) in + Instantiate.alias "Handler" [PrimaryKind.Type, t] context.alias_env)) in let () = unify ~handle:Gripers.render_attributes - (pos_and_typ attributes, no_pos (Instantiate.alias "Attributes" [] context.tycon_env)) + (pos_and_typ attributes, no_pos (Instantiate.alias "Attributes" [] context.alias_env)) in FormletPlacement (erase f, erase h, erase attributes), Types.xml_type, Usage.combine_many [usages f; usages h; usages attributes] | PagePlacement e -> let e = tc e in - let pt = Instantiate.alias "Page" [] context.tycon_env in + let pt = Instantiate.alias "Page" [] context.alias_env in unify ~handle:Gripers.page_placement (pos_and_typ e, no_pos pt); PagePlacement (erase e), Types.xml_type, usages e | FormBinding (e, pattern) -> let e = tc e and pattern = tpc pattern in let a = Types.fresh_type_variable (lin_unl, res_any) in - let ft = Instantiate.alias "Formlet" [PrimaryKind.Type, a] context.tycon_env in + let ft = Instantiate.alias "Formlet" [PrimaryKind.Type, a] context.alias_env in unify ~handle:Gripers.form_binding_body (pos_and_typ e, no_pos ft); unify ~handle:Gripers.form_binding_pattern (ppos_and_typ pattern, (exp_pos e, a)); FormBinding (erase e, erase_pat pattern), Types.xml_type, usages e @@ -3819,7 +3814,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = Block (bindings, erase e), typ e, usage_builder (usages e) | Regex r -> Regex (type_regex context r), - Instantiate.alias "Regex" [] context.tycon_env, + Instantiate.alias "Regex" [] context.alias_env, Usage.empty | Projection (r,l) -> (* @@ -4855,10 +4850,9 @@ and type_binding : context -> binding -> binding * context * Usage.t = | Aliases ts -> let env = List.fold_left (fun env {node=(name, vars, b); _} -> match b with - | Typename (_, Some dt) -> - bind_tycon env (name, `Alias (List.map (SugarQuantifier.get_resolved_exn) vars, dt)) - | Effectname (_, Some r) -> - bind_effectnames env (name, `Alias (List.map (SugarQuantifier.get_resolved_exn) vars, r)) + | Typename (_, Some dt) + | Effectname (_, Some dt) -> + bind_alias env (name, `Alias (List.map (SugarQuantifier.get_resolved_exn) vars, dt)) | _ -> raise (internal_error "typeSugar.ml: unannotated type") ) empty_context ts in (Aliases ts, env, Usage.empty) diff --git a/core/types.ml b/core/types.ml index 3cd934323..ded103189 100644 --- a/core/types.ml +++ b/core/types.ml @@ -196,15 +196,6 @@ type tycon_spec = [ | `Mutual of (Quantifier.t list * tygroup ref) (* Type in same recursive group *) ] [@@deriving show] -type effectalias_type = Quantifier.t list * row [@@deriving show] - -type effectalias_spec = [ - | `Alias of effectalias_type - | `Abstract of Abstype.t - | `Mutual of (Quantifier.t list * tygroup ref) (* Type in same recursive group *) -] [@@deriving show] - - (* Generation of fresh type variables *) let type_variable_counter = ref 0 let fresh_raw_variable () : int = @@ -1019,7 +1010,7 @@ module Env = Env.String | row -> is_closed rec_vars row end - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 1013 :" ; raise tag_expectation_mismatch in is_closed TypeVarSet.empty @@ -1027,7 +1018,7 @@ module Env = Env.String fun row -> let row_var = match row with | Row (_, row_var, _) -> row_var - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 1021 :" ; raise tag_expectation_mismatch in let rec get_row_var' rec_vars = function | Closed -> None @@ -1038,7 +1029,7 @@ module Env = Env.String else get_row_var' (TypeVarSet.add var rec_vars) (Unionfind.find row_var') | Row (_, row_var', _) -> get_row_var' rec_vars (Unionfind.find row_var') - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 1032 :" ; raise tag_expectation_mismatch in get_row_var' TypeVarSet.empty (Unionfind.find row_var) @@ -1090,7 +1081,7 @@ let make_singleton_open_row (label, field_spec) subkind = let is_absent_from_row label row (* (field_env, _, _ as row) *) = let field_env = match row with | Row (field_env, _, _) -> field_env - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 1084 :" ; raise tag_expectation_mismatch in if FieldEnv.mem label field_env then FieldEnv.find label field_env = Absent @@ -1099,7 +1090,7 @@ let is_absent_from_row label row (* (field_env, _, _ as row) *) = let row_with (label, f : string * field_spec) = function | Row (field_env, row_var, dual) -> Row (FieldEnv.add label f field_env, row_var, dual) - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 1093 :" ; raise tag_expectation_mismatch (*** end of type_basis ***) @@ -1241,7 +1232,7 @@ let is_rigid_row : row -> bool = | row -> is_rigid rec_vars row end - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 1235 :" ; raise tag_expectation_mismatch in is_rigid TypeVarSet.empty row @@ -1260,7 +1251,7 @@ let is_rigid_row_with_var : int -> row -> bool = | row -> is_rigid rec_vars row end - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 1254 :" ; raise tag_expectation_mismatch in is_rigid TypeVarSet.empty row @@ -1276,7 +1267,7 @@ let is_flattened_row : row -> bool = else is_flattened (TypeVarSet.add var rec_vars) rec_row | _ -> false end - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 1270 :" ; raise tag_expectation_mismatch in is_flattened TypeVarSet.empty row @@ -1292,7 +1283,7 @@ let is_empty_row : row -> bool = | Recursive (var, _kind, rec_row) -> is_empty (TypeVarSet.add var rec_vars) rec_row | row -> is_empty rec_vars row end - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 1286 :" ; raise tag_expectation_mismatch in is_empty TypeVarSet.empty row @@ -1342,11 +1333,11 @@ and dual_row : var_map -> row -> row = | Present t -> Present (dual_type rec_points t) | Meta _ -> assert false (* TODO: what should happen here? *) - | _ -> raise tag_expectation_mismatch) + | _ -> Debug.print "in 1336 :" ; raise tag_expectation_mismatch) fields in Row (fields', row_var, not dual) - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 1340 :" ; raise tag_expectation_mismatch and subst_dual_type : var_map -> datatype -> datatype = fun rec_points t -> @@ -1415,14 +1406,14 @@ and subst_dual_row : var_map -> row -> row = fields in Row (fields', row_var, dual) - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 1409 :" ; raise tag_expectation_mismatch and subst_dual_field_spec : var_map -> field_spec -> field_spec = fun rec_points field_spec -> match field_spec with | Absent -> Absent | Present t -> Present (subst_dual_type rec_points t) | Meta _ -> (* TODO: what should happen here? *) assert false - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 1416 :" ; raise tag_expectation_mismatch and subst_dual_type_arg : var_map -> type_arg -> type_arg = fun rec_points (pk, t) -> let open PrimaryKind in @@ -1440,8 +1431,12 @@ and flatten_row : row -> row = fun row -> | Alias (_, row) -> row (* Debug.print ("row: " ^ show_row row); *) (* failwith "types.ml/flatten_row/Alias" *) - | RecursiveApplication { r_dual ; r_args ; r_unwind ; _ } -> - r_unwind r_args r_dual + | RecursiveApplication { r_dual ; r_args ; r_unwind ; _ } -> (* TODO HERE wtf à quoi sert cette fonction ? *) + (* Debug.print "am i there ? [types/flatten_row]" ; *) + (* if StringSet.mem r_unique_name rec_appl then *) + (* row *) + (* else *) + r_unwind r_args r_dual | _ -> assert false in let dual_if = match row with @@ -1449,7 +1444,7 @@ and flatten_row : row -> row = fun row -> fun r -> if dual then dual_row TypeVarMap.empty r else r | _ -> Debug.print ("row: " ^ show_row row); - raise tag_expectation_mismatch + Debug.print "in 1443 :" ; raise tag_expectation_mismatch in let rec flatten_row' : meta_row_var IntMap.t -> row -> row = fun rec_env row -> @@ -1474,19 +1469,19 @@ and flatten_row : row -> row = fun row -> let field_env', row_var', dual = match flatten_row' rec_env (dual_if row') with | Row (field_env, row_var, dual) -> field_env, row_var, dual - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 1468 :" ; raise tag_expectation_mismatch in Row (field_env_union (field_env, field_env'), row_var', dual) in assert (is_flattened_row row'); row' - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 1474 :" ; raise tag_expectation_mismatch in let field_env, row_var, dual = match flatten_row' IntMap.empty row with | Row (field_env, row_var, dual) -> field_env, row_var, dual - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 1480 :" ; raise tag_expectation_mismatch in let field_env = concrete_fields field_env in Row (field_env, row_var, dual) @@ -1508,7 +1503,7 @@ and unwrap_row : row -> (row * row_var option) = function match row with | Row (field_env, row_var, dual) -> field_env, row_var, dual - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 1502 :" ; raise tag_expectation_mismatch in let row' = match Unionfind.find row_var with @@ -1525,7 +1520,7 @@ and unwrap_row : row -> (row * row_var option) = function match unwrapped_body with | Row (field_env', row_var', dual') -> field_env', row_var', dual' - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 1519 :" ; raise tag_expectation_mismatch in Row (field_env_union (field_env, field_env'), row_var', dual'), Some point | row' -> @@ -1533,7 +1528,7 @@ and unwrap_row : row -> (row * row_var option) = function match unwrap_row' rec_env (dual_if row') with | Row (field_env', row_var', dual), rec_row -> (field_env', row_var', dual), rec_row - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 1527 :" ; raise tag_expectation_mismatch in Row (field_env_union (field_env, field_env'), row_var', dual), rec_row in @@ -1544,12 +1539,12 @@ and unwrap_row : row -> (row * row_var option) = function match unwrap_row' IntMap.empty (Row (field_env, row_var, dual)) with | Row (field_env, row_var, dual), rec_row -> (field_env, row_var, dual), rec_row - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 1538 :" ; raise tag_expectation_mismatch in let field_env = concrete_fields field_env in Row (field_env, row_var, dual), rec_row | _ -> - raise tag_expectation_mismatch + Debug.print "in 1543 :" ; raise tag_expectation_mismatch @@ -1606,7 +1601,7 @@ and normalise_datatype rec_names t = let fields, row_var, dual = match flatten_row row with | Row (fields, row_var, dual) -> fields, row_var, dual - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 1600 :" ; raise tag_expectation_mismatch in let closed = is_closed_row (Row (fields, row_var, dual)) in let fields = @@ -1703,7 +1698,7 @@ let is_tuple ?(allow_onetuples=false) row = match row with | Row (field_env, row_var, _) -> field_env, row_var - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 1697 :" ; raise tag_expectation_mismatch in match Unionfind.find row_var with | Closed -> @@ -1718,7 +1713,7 @@ let is_tuple ?(allow_onetuples=false) row = | Present _ -> true | Absent -> false | Meta _ -> false - | _ -> raise tag_expectation_mismatch)) + | _ -> Debug.print "in 1712 :" ; raise tag_expectation_mismatch)) (fromTo 1 (n+1))) (* need to go up to n *) (* (Samo) I think there was a bug here, calling (fromTo 1 n): (dis)allowing one-tuples is handled below, but here we need to make sure @@ -1735,7 +1730,7 @@ let extract_tuple = function | Present t -> t | Absent | Meta _ -> assert false | _ -> raise tag_expectation_mismatch) field_env - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 1729 :" ; raise tag_expectation_mismatch exception TypeDestructionError of string @@ -2264,7 +2259,6 @@ module type PRETTY_PRINTER = sig val string_of_type_arg : Policy.t -> names -> type_arg -> string val string_of_row_var : Policy.t -> names -> row_var -> string val string_of_tycon_spec : Policy.t -> names -> tycon_spec -> string - val string_of_effect_spec : Policy.t -> names -> effectalias_spec -> string val string_of_quantifier : Policy.t -> names -> Quantifier.t -> string val string_of_presence : Policy.t -> names -> field_spec -> string end @@ -2306,7 +2300,7 @@ struct let r = match fst (unwrap_row r) with | Row (_, r, _) -> r - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 2299 :" ; raise tag_expectation_mismatch in begin match Unionfind.find r with | Var (var, _, _) -> Some var @@ -2426,7 +2420,7 @@ struct match f with | Present t -> IntMap.add (int_of_string i) t tuple_env | (Absent | Meta _) -> assert false - | _ -> raise tag_expectation_mismatch) + | _ -> Debug.print "in 2419 :" ; raise tag_expectation_mismatch) field_env IntMap.empty in let ss = List.rev (IntMap.fold (fun _ t ss -> (datatype context p t) :: ss) tuple_env []) in @@ -2472,7 +2466,7 @@ struct match unwrap effects with | Row (fields, row_var, dual) -> (fields, row_var, dual) - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 2465 :" ; raise tag_expectation_mismatch in assert (not dual); @@ -2531,7 +2525,7 @@ struct let fields = match fst (unwrap_row r') with | Row (fields, _, _) -> fields - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 2524 :" ; raise tag_expectation_mismatch in if StringMap.is_empty fields then ts @@ -2588,7 +2582,7 @@ struct let r = match r with | Row (fields, row_var, dual) -> fields, row_var, dual - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 2581 :" ; raise tag_expectation_mismatch in (if is_tuple ur then string_of_tuple context r else "(" ^ row "," context p (Row r) ^ ")") @@ -2675,7 +2669,7 @@ struct | f -> presence context p f end - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 2668 :" ; raise tag_expectation_mismatch and row ?(name=name_of_type) ?(strip_wild=false) sep context p = function | Row (field_env, rv, dual) -> @@ -2703,7 +2697,7 @@ struct row sep context ~name:name ~strip_wild:strip_wild p (Row (StringMap.empty, rv, false)) | t -> failwith ("Illformed row:"^show_datatype t) - (* raise tag_expectation_mismatch *) + (* Debug.print "in 2696 :" ; raise tag_expectation_mismatch *) and row_var name_of_type sep ({ bound_vars; _ } as context) ((policy, vars) as p) rv = match Unionfind.find rv with | Closed -> None @@ -2776,9 +2770,6 @@ struct let string_of_tycon_spec policy names tycon = tycon_spec empty_context (policy, names) tycon - let string_of_effect_spec policy names tycon = - effect_spec empty_context (policy, names) tycon - let string_of_quantifier policy names q = quantifier (policy, names) q @@ -3751,7 +3742,7 @@ module RoundtripPrinter : PRETTY_PRINTER = struct | _ -> StringBuffer.write buf ":" in Printer.apply (meta ctx pt) ctx () buf - | _ -> raise tag_expectation_mismatch)) + | _ -> Debug.print "in 3741 :" ; raise tag_expectation_mismatch)) and meta : Context.t -> typ point -> unit printer = let open Printer in @@ -3785,7 +3776,7 @@ module RoundtripPrinter : PRETTY_PRINTER = struct (match r with | Row rp -> Printer.apply row_parts ctx rp buf | Meta pt -> Printer.apply (meta ctx pt) ctx () buf - | _ -> raise tag_expectation_mismatch); + | _ -> Debug.print "in 3775 :" ; raise tag_expectation_mismatch); StringBuffer.write buf "}"; end | P.Presence -> @@ -3822,7 +3813,7 @@ module RoundtripPrinter : PRETTY_PRINTER = struct match FieldEnv.lookup lbl fields with | Some (Present _) -> true | None | Some Absent | Some (Meta _) -> false - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 3812 :" ; raise tag_expectation_mismatch in let decide_skip ctx vid = let anonymity = get_var_anonymity ctx vid in @@ -3942,7 +3933,7 @@ module RoundtripPrinter : PRETTY_PRINTER = struct let t_char = match tp with | Input _ -> "?" | Output _ -> "!" - | _ -> raise tag_expectation_mismatch (* this will never happen, because the function session_io + | _ -> Debug.print "in 3932 :" ; raise tag_expectation_mismatch (* this will never happen, because the function session_io * will only ever be called for Input | Output *) in match tp with @@ -4133,32 +4124,11 @@ module RoundtripPrinter : PRETTY_PRINTER = struct | `Mutual _ -> StringBuffer.write buf "mutual" | `Abstract _ -> StringBuffer.write buf "abstract") - let effect_spec : effectalias_spec printer - = let open Printer in - Printer (fun ctx v buf -> - match v with - | `Alias (tyvars, body) -> - let ctx = Context.bind_tyvars (List.map Quantifier.to_var tyvars) ctx in - begin - match tyvars with - | [] -> Printer.apply row ctx body buf - | _ -> Printer.concat_items ~sep:"," quantifier tyvars ctx buf; - StringBuffer.write buf "."; - Printer.apply row ctx body buf - end - | `Mutual _ -> StringBuffer.write buf "mutual" - | `Abstract _ -> StringBuffer.write buf "abstract") - let string_of_tycon_spec : Policy.t -> names -> tycon_spec -> string = fun policy' names tycon -> let ctxt = Context.(with_policy policy' (with_tyvar_names names (empty ()))) in Printer.generate_string tycon_spec ctxt tycon - let string_of_effect_spec : Policy.t -> names -> effectalias_spec -> string - = fun policy' names tycon -> - let ctxt = Context.(with_policy policy' (with_tyvar_names names (empty ()))) in - Printer.generate_string effect_spec ctxt tycon - let string_of_presence : Policy.t -> names -> field_spec -> string = fun policy' names pre -> let ctxt = Context.(with_policy policy' (with_tyvar_names names (empty ()))) in @@ -4190,14 +4160,6 @@ module DerivedPrinter : PRETTY_PRINTER = struct in show_tycon_spec (decycle_tycon_spec tycon) - let string_of_effect_spec : Policy.t -> names -> effectalias_spec -> string - = fun _policy _names tycon -> - let decycle_tycon_spec = function - | `Alias (qlist, ty) -> `Alias (List.map DecycleTypes.quantifier qlist, DecycleTypes.datatype ty) - | other -> other - in - show_effectalias_spec (decycle_tycon_spec tycon) - let string_of_presence : Policy.t -> names -> field_spec -> string = fun _policy _names pre -> show_field_spec (DecycleTypes.field_spec pre) @@ -4250,31 +4212,21 @@ See Note [Variable names in error messages]. type environment = datatype Env.t [@@deriving show] -type tycon_environment = tycon_spec Env.t +type alias_environment = tycon_spec Env.t [@@deriving show] -type effect_environment = effectalias_spec Env.t - [@@deriving show] -type alias_environment = { tycon : tycon_environment ; - effectname : effect_environment } - [@@derving show] type typing_environment = { var_env : environment ; rec_vars : StringSet.t ; - tycon_env : tycon_environment ; - effect_env : effect_environment ; + alias_env : alias_environment ; effect_row : row; desugared : bool } [@@deriving show] let empty_typing_environment = { var_env = Env.empty; rec_vars = StringSet.empty; - tycon_env = Env.empty; - effect_env = Env.empty; + alias_env = Env.empty; effect_row = make_empty_closed_row (); desugared = false } -let typing_to_alias typing_env = - { tycon = typing_env.tycon_env ; effectname = typing_env.effect_env } - (* Which printer to use *) type pretty_printer_engine = Old | Roundtrip | Derived @@ -4384,12 +4336,6 @@ let string_of_tycon_spec : ?policy:(unit -> Policy.t) -> ?refresh_tyvar_names:bo build_tyvar_names ~refresh_tyvar_names free_bound_tycon_type_vars [tycon]; generate_string policy Vars.tyvar_name_map (fun (module Printer : PRETTY_PRINTER) -> Printer.string_of_tycon_spec) tycon -let string_of_effect_spec : ?policy:(unit -> Policy.t) -> ?refresh_tyvar_names:bool -> effectalias_spec -> string - = fun ?(policy=Policy.default_policy) ?(refresh_tyvar_names=true) tycon -> - let policy = policy () in - build_tyvar_names ~refresh_tyvar_names free_bound_tycon_type_vars [tycon]; - generate_string policy Vars.tyvar_name_map (fun (module Printer : PRETTY_PRINTER) -> Printer.string_of_effect_spec) tycon - let string_of_quantifier : ?policy:(unit -> Policy.t) -> ?refresh_tyvar_names:bool -> Quantifier.t -> string = fun ?(policy=Policy.default_policy) ?(refresh_tyvar_names=true) q -> let policy = policy () in @@ -4404,12 +4350,11 @@ let normalise_typing_environment env = (* Functions on environments *) let extend_typing_environment - {var_env = l; rec_vars = lvars; tycon_env = al; effect_env = eal; effect_row = _; desugared = _; } - {var_env = r; rec_vars = rvars; tycon_env = ar; effect_env = ear; effect_row = er; desugared = dr } : typing_environment = + {var_env = l; rec_vars = lvars; alias_env = al; effect_row = _; desugared = _; } + {var_env = r; rec_vars = rvars; alias_env = ar; effect_row = er; desugared = dr } : typing_environment = { var_env = Env.extend l r ; rec_vars = StringSet.union lvars rvars - ; tycon_env = Env.extend al ar - ; effect_env = Env.extend eal ear + ; alias_env = Env.extend al ar ; effect_row = er ; desugared = dr } @@ -4597,12 +4542,12 @@ let is_sub_type, is_sub_row = is_sub_type rec_vars (t', t)) | Absent | Meta _ -> false - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 4541 :" ; raise tag_expectation_mismatch else false | Absent -> true | Meta _ -> assert false (* TODO *) - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 4546 :" ; raise tag_expectation_mismatch ) lfield_env true in let sub_row_vars = match Unionfind.find lrow_var, Unionfind.find rrow_var with @@ -4614,7 +4559,7 @@ let is_sub_type, is_sub_row = raise (internal_error "not implemented subtyping on recursive rows yet") | _, _ -> false in sub_fields && sub_row_vars - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 4558 :" ; raise tag_expectation_mismatch and is_sub_row = fun rec_vars (lrow, rrow) -> match lrow, rrow with @@ -4628,12 +4573,12 @@ let is_sub_type, is_sub_row = | Present t' -> is_sub_type rec_vars (t, t') | Absent | Meta _ -> false - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 4572 :" ; raise tag_expectation_mismatch else false | Absent -> true | Meta _ -> assert false (* TODO *) - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 4577 :" ; raise tag_expectation_mismatch ) lfield_env true in let sub_row_vars = @@ -4648,7 +4593,7 @@ let is_sub_type, is_sub_row = | _, _ -> false in sub_fields && sub_row_vars - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 4592 :" ; raise tag_expectation_mismatch in ((fun t -> is_sub_type S.empty t), (fun row -> is_sub_row S.empty row)) @@ -4682,7 +4627,7 @@ let extend_row_check_duplicates fields row = fields (fields', false) in Row (unified_fields,row_var, dual), has_duplicates - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 4626 :" ; raise tag_expectation_mismatch let extend_row_safe fields row = match extend_row_check_duplicates fields row with @@ -4695,13 +4640,13 @@ let open_row subkind = function | Row (fieldenv, rho, dual) when rho = closed_row_var -> Row (fieldenv, fresh_row_variable subkind, dual) | Row _ -> raise (internal_error "attempt to open an already open row") - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 4639 :" ; raise tag_expectation_mismatch let close_row = function | Row (fieldenv, rho, dual) when rho <> closed_row_var -> Row (fieldenv, closed_row_var, dual) | Row _ -> raise (internal_error "attempt to close an already closed row") - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 4645 :" ; raise tag_expectation_mismatch let closed_wild_row = make_singleton_closed_row wild_present @@ -4712,7 +4657,7 @@ let remove_field : ?idempotent:bool -> Label.t -> row -> row if idempotent || StringMap.mem lbl fieldenv then Row (StringMap.remove lbl fieldenv, var, dual) else raise (internal_error "attempt to remove non-existent field") - | _ -> raise tag_expectation_mismatch + | _ -> Debug.print "in 4656 :" ; raise tag_expectation_mismatch diff --git a/core/types.mli b/core/types.mli index ded4ccad9..7f2f69b79 100644 --- a/core/types.mli +++ b/core/types.mli @@ -214,30 +214,16 @@ type tycon_spec = [ | `Mutual of (Quantifier.t list * tygroup ref) (* Type in same recursive group *) ] -type effectalias_type = Quantifier.t list * row [@@deriving show] - -type effectalias_spec = [ - | `Alias of effectalias_type - | `Abstract of Abstype.t - | `Mutual of (Quantifier.t list * tygroup ref) (* Type in same recursive group *) -] - type environment = datatype Env.String.t -type tycon_environment = tycon_spec Env.String.t -type effect_environment = effectalias_spec Env.String.t -type alias_environment = { tycon : tycon_environment ; - effectname : effect_environment } +type alias_environment = tycon_spec Env.String.t type typing_environment = { var_env : environment ; rec_vars : Utility.StringSet.t ; - tycon_env : tycon_environment ; - effect_env : effect_environment ; + alias_env : alias_environment ; effect_row : row ; desugared : bool } val empty_typing_environment : typing_environment -val typing_to_alias : typing_environment -> alias_environment - val concrete_type : datatype -> datatype val concrete_field_spec : field_spec -> field_spec @@ -429,8 +415,6 @@ val string_of_row_var : ?policy:(unit -> Policy.t) -> ?refresh_tyvar_names:bool -> row_var -> string val string_of_tycon_spec : ?policy:(unit -> Policy.t) -> ?refresh_tyvar_names:bool -> tycon_spec -> string -val string_of_effect_spec : ?policy:(unit -> Policy.t) - -> ?refresh_tyvar_names:bool -> effectalias_spec -> string val string_of_environment : environment -> string val string_of_typing_environment : typing_environment -> string diff --git a/core/webserver.ml b/core/webserver.ml index 51e291743..ca9c45d09 100644 --- a/core/webserver.ml +++ b/core/webserver.ml @@ -364,7 +364,7 @@ struct let start_server host port rt = let render_cont () = - let (_, nenv, {Types.tycon_env = tycon_env; _ }) = !env in + let (_, nenv, {Types.alias_env = tycon_env; _ }) = !env in let _, x = Var.fresh_global_var_of_type (Instantiate.alias "Page" [] tycon_env) in let render_page = Env.String.find "renderPage" nenv in let tail = Ir.Apply (Ir.Variable render_page, [Ir.Variable x]) in From 51506157c10f54f6e6423de8317cff90484a741e Mon Sep 17 00:00:00 2001 From: RJ Date: Fri, 20 May 2022 14:52:29 +0100 Subject: [PATCH 06/63] effectname body desugared into effectname allow better printing --- core/desugarDatatypes.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/desugarDatatypes.ml b/core/desugarDatatypes.ml index 0eace9a82..732aae4be 100644 --- a/core/desugarDatatypes.ml +++ b/core/desugarDatatypes.ml @@ -309,7 +309,7 @@ module Desugar = struct (dt, Some (datatype alias_env dt)) let row' alias_env ((r, _) :row') = - (r, Some (row alias_env r (WithPos.make (Datatype.Effect r)))) (* TODO(rj) should keep the pos *) + (r, Some (Types.Effect (row alias_env r (WithPos.make (Datatype.Effect r))))) (* TODO(rj) should keep the pos *) let aliasbody alias_env = function | Typename dt' -> Typename (datatype' alias_env dt') From a2d8bdc38e1cd3be640ec8f84711e91f4a7d08e8 Mon Sep 17 00:00:00 2001 From: RJ Date: Mon, 23 May 2022 09:50:11 +0100 Subject: [PATCH 07/63] Revert "desalias inline" This reverts commit 49a9a61591382ca4a15408b644c7673c8b325dcc. --- core/desugarDatatypes.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/desugarDatatypes.ml b/core/desugarDatatypes.ml index 732aae4be..3c8226b5b 100644 --- a/core/desugarDatatypes.ml +++ b/core/desugarDatatypes.ml @@ -254,7 +254,7 @@ module Desugar = struct let ts = match_quantifiers snd qs in let Alias(_,body) = Instantiate.alias name ts alias_env in body - (* Instantiate.alias name ts alias_env *) + (* Instantiate.effectalias name ts alias_env.effectname *) | Some (`Abstract abstype) -> let ts = match_quantifiers identity (Abstype.arity abstype) in Application (abstype, ts) From 419aca41125e1cbbffe98331ee2eb01d233640cb Mon Sep 17 00:00:00 2001 From: RJ Date: Mon, 23 May 2022 10:36:19 +0100 Subject: [PATCH 08/63] Revert "effectname body desugared into effectname" This reverts commit 51506157c10f54f6e6423de8317cff90484a741e. --- core/desugarDatatypes.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/desugarDatatypes.ml b/core/desugarDatatypes.ml index 3c8226b5b..3bba45a2a 100644 --- a/core/desugarDatatypes.ml +++ b/core/desugarDatatypes.ml @@ -309,7 +309,7 @@ module Desugar = struct (dt, Some (datatype alias_env dt)) let row' alias_env ((r, _) :row') = - (r, Some (Types.Effect (row alias_env r (WithPos.make (Datatype.Effect r))))) (* TODO(rj) should keep the pos *) + (r, Some (row alias_env r (WithPos.make (Datatype.Effect r)))) (* TODO(rj) should keep the pos *) let aliasbody alias_env = function | Typename dt' -> Typename (datatype' alias_env dt') From 6e8c0df9705398cd616d2bb475903050efeacc84 Mon Sep 17 00:00:00 2001 From: RJ Date: Tue, 24 May 2022 11:27:43 +0100 Subject: [PATCH 09/63] "effectname" in links-mode.el --- links-mode.el | 1 + 1 file changed, 1 insertion(+) diff --git a/links-mode.el b/links-mode.el index 5087e9726..1fcec5287 100644 --- a/links-mode.el +++ b/links-mode.el @@ -62,6 +62,7 @@ "do" "else" "escape" + "effectname" "false" "for" "forall" From 1355a93dfd2abf322c01294fd1bd79ec3dd4f4f1 Mon Sep 17 00:00:00 2001 From: RJ Date: Tue, 24 May 2022 16:57:15 +0100 Subject: [PATCH 10/63] cleaning before pr --- core/desugarDatatypes.ml | 7 ++++--- core/desugarEffects.ml | 3 ++- core/parser.mly | 1 - core/sugartypes.ml | 2 +- core/types.ml | 31 +++++++++++++------------------ tests/effectname.tests | 6 ++++++ 6 files changed, 26 insertions(+), 24 deletions(-) diff --git a/core/desugarDatatypes.ml b/core/desugarDatatypes.ml index 3bba45a2a..9bd40317b 100644 --- a/core/desugarDatatypes.ml +++ b/core/desugarDatatypes.ml @@ -252,8 +252,10 @@ module Desugar = struct | None -> raise (UnboundTyCon (node.pos, name)) | Some (`Alias (qs, _r)) -> let ts = match_quantifiers snd qs in - let Alias(_,body) = Instantiate.alias name ts alias_env in - body + begin match Instantiate.alias name ts alias_env with + | Alias(_,body) -> body + | _ -> raise (internal_error "Instantiation failed") + end (* Instantiate.effectalias name ts alias_env.effectname *) | Some (`Abstract abstype) -> let ts = match_quantifiers identity (Abstype.arity abstype) in @@ -263,7 +265,6 @@ module Desugar = struct * a `RecursiveApplication. *) let r_args = match_quantifiers snd qs in let r_unwind args dual = - Debug.print "et ça boucel [desugarDT/r_unwind]" ; let _, body = StringMap.find name !tygroup_ref.type_map in let body = Instantiate.recursive_application name qs args body in if dual then dual_type body else body diff --git a/core/desugarEffects.ml b/core/desugarEffects.ml index d3a09fd98..d2716036c 100644 --- a/core/desugarEffects.ml +++ b/core/desugarEffects.ml @@ -710,6 +710,7 @@ let gather_operations (tycon_env : simple_tycon_env) allow_fresh dt = method! row_var = let open Datatype in function + | EffectApplication _ (* TODO(rj) should I do semething there ? *) | Closed | Open _ -> self @@ -978,7 +979,7 @@ class main_traversal simple_tycon_env = let module D = Datatype in let o, rv = match rv with - | D.EffectApplication (name, ts) -> (o, rv) (* TODO(rj) i may need to do something there *) + | D.EffectApplication _ -> (o, rv) (* TODO(rj) do i need to do something there ? *) | D.Closed -> (o, rv) | D.Open stv when (not (SugarTypeVar.is_resolved stv)) diff --git a/core/parser.mly b/core/parser.mly index e143263e7..84e0e1139 100644 --- a/core/parser.mly +++ b/core/parser.mly @@ -286,7 +286,6 @@ module MutualBindings = struct let type_binding = function | [] -> [] | ts -> [WithPos.make ~pos:mut_pos (Aliases (List.rev ts))] in - type_binding mut_types @ fun_binding mut_funs end diff --git a/core/sugartypes.ml b/core/sugartypes.ml index f323178e6..b17421516 100644 --- a/core/sugartypes.ml +++ b/core/sugartypes.ml @@ -117,7 +117,7 @@ let get_unresolved_exn = function let get_unresolved_name_exn = get_unresolved_exn ->- fst3 - let get_resolved_type_exn = +let get_resolved_type_exn = function | TResolvedType point -> point | _ -> raise (internal_error "requested kind does not match existing kind info") diff --git a/core/types.ml b/core/types.ml index ded103189..8bf35fcaf 100644 --- a/core/types.ml +++ b/core/types.ml @@ -1429,14 +1429,9 @@ and flatten_row : row -> row = fun row -> (* HACK: this probably shouldn't happen! *) | Meta row_var -> Row (StringMap.empty, row_var, false) | Alias (_, row) -> row - (* Debug.print ("row: " ^ show_row row); *) - (* failwith "types.ml/flatten_row/Alias" *) - | RecursiveApplication { r_dual ; r_args ; r_unwind ; _ } -> (* TODO HERE wtf à quoi sert cette fonction ? *) - (* Debug.print "am i there ? [types/flatten_row]" ; *) - (* if StringSet.mem r_unique_name rec_appl then *) - (* row *) - (* else *) - r_unwind r_args r_dual + (* | RecursiveApplication { r_dual ; r_args ; r_unwind ; _ } -> *) + (* (\* TODO(rj) what should this function do ? r_unwind like this provokes a stack overflow *\) *) + (* r_unwind r_args r_dual *) | _ -> assert false in let dual_if = match row with @@ -4542,12 +4537,12 @@ let is_sub_type, is_sub_row = is_sub_type rec_vars (t', t)) | Absent | Meta _ -> false - | _ -> Debug.print "in 4541 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch else false | Absent -> true | Meta _ -> assert false (* TODO *) - | _ -> Debug.print "in 4546 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch ) lfield_env true in let sub_row_vars = match Unionfind.find lrow_var, Unionfind.find rrow_var with @@ -4559,7 +4554,7 @@ let is_sub_type, is_sub_row = raise (internal_error "not implemented subtyping on recursive rows yet") | _, _ -> false in sub_fields && sub_row_vars - | _ -> Debug.print "in 4558 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch and is_sub_row = fun rec_vars (lrow, rrow) -> match lrow, rrow with @@ -4573,12 +4568,12 @@ let is_sub_type, is_sub_row = | Present t' -> is_sub_type rec_vars (t, t') | Absent | Meta _ -> false - | _ -> Debug.print "in 4572 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch else false | Absent -> true | Meta _ -> assert false (* TODO *) - | _ -> Debug.print "in 4577 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch ) lfield_env true in let sub_row_vars = @@ -4593,7 +4588,7 @@ let is_sub_type, is_sub_row = | _, _ -> false in sub_fields && sub_row_vars - | _ -> Debug.print "in 4592 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch in ((fun t -> is_sub_type S.empty t), (fun row -> is_sub_row S.empty row)) @@ -4627,7 +4622,7 @@ let extend_row_check_duplicates fields row = fields (fields', false) in Row (unified_fields,row_var, dual), has_duplicates - | _ -> Debug.print "in 4626 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch let extend_row_safe fields row = match extend_row_check_duplicates fields row with @@ -4640,13 +4635,13 @@ let open_row subkind = function | Row (fieldenv, rho, dual) when rho = closed_row_var -> Row (fieldenv, fresh_row_variable subkind, dual) | Row _ -> raise (internal_error "attempt to open an already open row") - | _ -> Debug.print "in 4639 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch let close_row = function | Row (fieldenv, rho, dual) when rho <> closed_row_var -> Row (fieldenv, closed_row_var, dual) | Row _ -> raise (internal_error "attempt to close an already closed row") - | _ -> Debug.print "in 4645 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch let closed_wild_row = make_singleton_closed_row wild_present @@ -4657,7 +4652,7 @@ let remove_field : ?idempotent:bool -> Label.t -> row -> row if idempotent || StringMap.mem lbl fieldenv then Row (StringMap.remove lbl fieldenv, var, dual) else raise (internal_error "attempt to remove non-existent field") - | _ -> Debug.print "in 4656 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch diff --git a/tests/effectname.tests b/tests/effectname.tests index ee9576c78..0fadc7c63 100644 --- a/tests/effectname.tests +++ b/tests/effectname.tests @@ -54,3 +54,9 @@ Mutual declaration ./tests/effectname/mutual.links filemode : true stdout : () : () + +Underscore in effect alias application +./tests/effectname/underscore-not-working.links +filemode : true +stderr : @.* +exit : 1 From 50edb6483282bf357be12e6666b5726ce8e96615 Mon Sep 17 00:00:00 2001 From: RJ Date: Tue, 24 May 2022 16:59:34 +0100 Subject: [PATCH 11/63] re-cleaning --- core/types.ml | 74 +++++++++++++++++++++++++-------------------------- 1 file changed, 37 insertions(+), 37 deletions(-) diff --git a/core/types.ml b/core/types.ml index 8bf35fcaf..e13eb3642 100644 --- a/core/types.ml +++ b/core/types.ml @@ -1010,7 +1010,7 @@ module Env = Env.String | row -> is_closed rec_vars row end - | _ -> Debug.print "in 1013 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch in is_closed TypeVarSet.empty @@ -1018,7 +1018,7 @@ module Env = Env.String fun row -> let row_var = match row with | Row (_, row_var, _) -> row_var - | _ -> Debug.print "in 1021 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch in let rec get_row_var' rec_vars = function | Closed -> None @@ -1029,7 +1029,7 @@ module Env = Env.String else get_row_var' (TypeVarSet.add var rec_vars) (Unionfind.find row_var') | Row (_, row_var', _) -> get_row_var' rec_vars (Unionfind.find row_var') - | _ -> Debug.print "in 1032 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch in get_row_var' TypeVarSet.empty (Unionfind.find row_var) @@ -1081,7 +1081,7 @@ let make_singleton_open_row (label, field_spec) subkind = let is_absent_from_row label row (* (field_env, _, _ as row) *) = let field_env = match row with | Row (field_env, _, _) -> field_env - | _ -> Debug.print "in 1084 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch in if FieldEnv.mem label field_env then FieldEnv.find label field_env = Absent @@ -1090,7 +1090,7 @@ let is_absent_from_row label row (* (field_env, _, _ as row) *) = let row_with (label, f : string * field_spec) = function | Row (field_env, row_var, dual) -> Row (FieldEnv.add label f field_env, row_var, dual) - | _ -> Debug.print "in 1093 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch (*** end of type_basis ***) @@ -1232,7 +1232,7 @@ let is_rigid_row : row -> bool = | row -> is_rigid rec_vars row end - | _ -> Debug.print "in 1235 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch in is_rigid TypeVarSet.empty row @@ -1251,7 +1251,7 @@ let is_rigid_row_with_var : int -> row -> bool = | row -> is_rigid rec_vars row end - | _ -> Debug.print "in 1254 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch in is_rigid TypeVarSet.empty row @@ -1267,7 +1267,7 @@ let is_flattened_row : row -> bool = else is_flattened (TypeVarSet.add var rec_vars) rec_row | _ -> false end - | _ -> Debug.print "in 1270 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch in is_flattened TypeVarSet.empty row @@ -1283,7 +1283,7 @@ let is_empty_row : row -> bool = | Recursive (var, _kind, rec_row) -> is_empty (TypeVarSet.add var rec_vars) rec_row | row -> is_empty rec_vars row end - | _ -> Debug.print "in 1286 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch in is_empty TypeVarSet.empty row @@ -1333,11 +1333,11 @@ and dual_row : var_map -> row -> row = | Present t -> Present (dual_type rec_points t) | Meta _ -> assert false (* TODO: what should happen here? *) - | _ -> Debug.print "in 1336 :" ; raise tag_expectation_mismatch) + | _ -> raise tag_expectation_mismatch) fields in Row (fields', row_var, not dual) - | _ -> Debug.print "in 1340 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch and subst_dual_type : var_map -> datatype -> datatype = fun rec_points t -> @@ -1406,14 +1406,14 @@ and subst_dual_row : var_map -> row -> row = fields in Row (fields', row_var, dual) - | _ -> Debug.print "in 1409 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch and subst_dual_field_spec : var_map -> field_spec -> field_spec = fun rec_points field_spec -> match field_spec with | Absent -> Absent | Present t -> Present (subst_dual_type rec_points t) | Meta _ -> (* TODO: what should happen here? *) assert false - | _ -> Debug.print "in 1416 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch and subst_dual_type_arg : var_map -> type_arg -> type_arg = fun rec_points (pk, t) -> let open PrimaryKind in @@ -1439,7 +1439,7 @@ and flatten_row : row -> row = fun row -> fun r -> if dual then dual_row TypeVarMap.empty r else r | _ -> Debug.print ("row: " ^ show_row row); - Debug.print "in 1443 :" ; raise tag_expectation_mismatch + raise tag_expectation_mismatch in let rec flatten_row' : meta_row_var IntMap.t -> row -> row = fun rec_env row -> @@ -1464,19 +1464,19 @@ and flatten_row : row -> row = fun row -> let field_env', row_var', dual = match flatten_row' rec_env (dual_if row') with | Row (field_env, row_var, dual) -> field_env, row_var, dual - | _ -> Debug.print "in 1468 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch in Row (field_env_union (field_env, field_env'), row_var', dual) in assert (is_flattened_row row'); row' - | _ -> Debug.print "in 1474 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch in let field_env, row_var, dual = match flatten_row' IntMap.empty row with | Row (field_env, row_var, dual) -> field_env, row_var, dual - | _ -> Debug.print "in 1480 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch in let field_env = concrete_fields field_env in Row (field_env, row_var, dual) @@ -1498,7 +1498,7 @@ and unwrap_row : row -> (row * row_var option) = function match row with | Row (field_env, row_var, dual) -> field_env, row_var, dual - | _ -> Debug.print "in 1502 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch in let row' = match Unionfind.find row_var with @@ -1515,7 +1515,7 @@ and unwrap_row : row -> (row * row_var option) = function match unwrapped_body with | Row (field_env', row_var', dual') -> field_env', row_var', dual' - | _ -> Debug.print "in 1519 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch in Row (field_env_union (field_env, field_env'), row_var', dual'), Some point | row' -> @@ -1523,7 +1523,7 @@ and unwrap_row : row -> (row * row_var option) = function match unwrap_row' rec_env (dual_if row') with | Row (field_env', row_var', dual), rec_row -> (field_env', row_var', dual), rec_row - | _ -> Debug.print "in 1527 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch in Row (field_env_union (field_env, field_env'), row_var', dual), rec_row in @@ -1534,12 +1534,12 @@ and unwrap_row : row -> (row * row_var option) = function match unwrap_row' IntMap.empty (Row (field_env, row_var, dual)) with | Row (field_env, row_var, dual), rec_row -> (field_env, row_var, dual), rec_row - | _ -> Debug.print "in 1538 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch in let field_env = concrete_fields field_env in Row (field_env, row_var, dual), rec_row | _ -> - Debug.print "in 1543 :" ; raise tag_expectation_mismatch + raise tag_expectation_mismatch @@ -1596,7 +1596,7 @@ and normalise_datatype rec_names t = let fields, row_var, dual = match flatten_row row with | Row (fields, row_var, dual) -> fields, row_var, dual - | _ -> Debug.print "in 1600 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch in let closed = is_closed_row (Row (fields, row_var, dual)) in let fields = @@ -1693,7 +1693,7 @@ let is_tuple ?(allow_onetuples=false) row = match row with | Row (field_env, row_var, _) -> field_env, row_var - | _ -> Debug.print "in 1697 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch in match Unionfind.find row_var with | Closed -> @@ -1708,7 +1708,7 @@ let is_tuple ?(allow_onetuples=false) row = | Present _ -> true | Absent -> false | Meta _ -> false - | _ -> Debug.print "in 1712 :" ; raise tag_expectation_mismatch)) + | _ -> raise tag_expectation_mismatch)) (fromTo 1 (n+1))) (* need to go up to n *) (* (Samo) I think there was a bug here, calling (fromTo 1 n): (dis)allowing one-tuples is handled below, but here we need to make sure @@ -1725,7 +1725,7 @@ let extract_tuple = function | Present t -> t | Absent | Meta _ -> assert false | _ -> raise tag_expectation_mismatch) field_env - | _ -> Debug.print "in 1729 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch exception TypeDestructionError of string @@ -2295,7 +2295,7 @@ struct let r = match fst (unwrap_row r) with | Row (_, r, _) -> r - | _ -> Debug.print "in 2299 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch in begin match Unionfind.find r with | Var (var, _, _) -> Some var @@ -2415,7 +2415,7 @@ struct match f with | Present t -> IntMap.add (int_of_string i) t tuple_env | (Absent | Meta _) -> assert false - | _ -> Debug.print "in 2419 :" ; raise tag_expectation_mismatch) + | _ -> raise tag_expectation_mismatch) field_env IntMap.empty in let ss = List.rev (IntMap.fold (fun _ t ss -> (datatype context p t) :: ss) tuple_env []) in @@ -2461,7 +2461,7 @@ struct match unwrap effects with | Row (fields, row_var, dual) -> (fields, row_var, dual) - | _ -> Debug.print "in 2465 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch in assert (not dual); @@ -2520,7 +2520,7 @@ struct let fields = match fst (unwrap_row r') with | Row (fields, _, _) -> fields - | _ -> Debug.print "in 2524 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch in if StringMap.is_empty fields then ts @@ -2577,7 +2577,7 @@ struct let r = match r with | Row (fields, row_var, dual) -> fields, row_var, dual - | _ -> Debug.print "in 2581 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch in (if is_tuple ur then string_of_tuple context r else "(" ^ row "," context p (Row r) ^ ")") @@ -2664,7 +2664,7 @@ struct | f -> presence context p f end - | _ -> Debug.print "in 2668 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch and row ?(name=name_of_type) ?(strip_wild=false) sep context p = function | Row (field_env, rv, dual) -> @@ -2692,7 +2692,7 @@ struct row sep context ~name:name ~strip_wild:strip_wild p (Row (StringMap.empty, rv, false)) | t -> failwith ("Illformed row:"^show_datatype t) - (* Debug.print "in 2696 :" ; raise tag_expectation_mismatch *) + (* raise tag_expectation_mismatch *) and row_var name_of_type sep ({ bound_vars; _ } as context) ((policy, vars) as p) rv = match Unionfind.find rv with | Closed -> None @@ -3737,7 +3737,7 @@ module RoundtripPrinter : PRETTY_PRINTER = struct | _ -> StringBuffer.write buf ":" in Printer.apply (meta ctx pt) ctx () buf - | _ -> Debug.print "in 3741 :" ; raise tag_expectation_mismatch)) + | _ -> raise tag_expectation_mismatch)) and meta : Context.t -> typ point -> unit printer = let open Printer in @@ -3771,7 +3771,7 @@ module RoundtripPrinter : PRETTY_PRINTER = struct (match r with | Row rp -> Printer.apply row_parts ctx rp buf | Meta pt -> Printer.apply (meta ctx pt) ctx () buf - | _ -> Debug.print "in 3775 :" ; raise tag_expectation_mismatch); + | _ -> raise tag_expectation_mismatch); StringBuffer.write buf "}"; end | P.Presence -> @@ -3808,7 +3808,7 @@ module RoundtripPrinter : PRETTY_PRINTER = struct match FieldEnv.lookup lbl fields with | Some (Present _) -> true | None | Some Absent | Some (Meta _) -> false - | _ -> Debug.print "in 3812 :" ; raise tag_expectation_mismatch + | _ -> raise tag_expectation_mismatch in let decide_skip ctx vid = let anonymity = get_var_anonymity ctx vid in @@ -3928,7 +3928,7 @@ module RoundtripPrinter : PRETTY_PRINTER = struct let t_char = match tp with | Input _ -> "?" | Output _ -> "!" - | _ -> Debug.print "in 3932 :" ; raise tag_expectation_mismatch (* this will never happen, because the function session_io + | _ -> raise tag_expectation_mismatch (* this will never happen, because the function session_io * will only ever be called for Input | Output *) in match tp with From ce200de7d34f2d3f66814d214b498ee1349771f6 Mon Sep 17 00:00:00 2001 From: RJ Date: Fri, 27 May 2022 17:09:00 +0100 Subject: [PATCH 12/63] effectname -> typename _::Kind --- core/desugarDatatypes.ml | 28 +++++++++++++++++------ core/desugarEffects.ml | 12 ++++++++-- core/parser.mly | 48 ++++++++++++++++++++++++++-------------- core/sugarTraversals.ml | 29 ++++++++++++++++++++---- core/sugarTraversals.mli | 3 +++ core/sugartypes.ml | 4 ++++ core/transformSugar.ml | 4 ++++ core/typeSugar.ml | 5 +++-- core/types.mli | 1 + 9 files changed, 103 insertions(+), 31 deletions(-) diff --git a/core/desugarDatatypes.ml b/core/desugarDatatypes.ml index 9bd40317b..c71add380 100644 --- a/core/desugarDatatypes.ml +++ b/core/desugarDatatypes.ml @@ -49,6 +49,10 @@ object (self) (_, None) -> {< all_desugared = false >} | _ -> self + method! fieldspec' = function + (_, None) -> {< all_desugared = false >} + | _ -> self + method! type_arg' = function (_, None) -> {< all_desugared = false >} | _ -> self @@ -312,9 +316,13 @@ module Desugar = struct let row' alias_env ((r, _) :row') = (r, Some (row alias_env r (WithPos.make (Datatype.Effect r)))) (* TODO(rj) should keep the pos *) + let fieldspec' alias_env ((dt, _) : fieldspec') = + (dt, Some (fieldspec alias_env dt (WithPos.make (Datatype.End)))) + let aliasbody alias_env = function | Typename dt' -> Typename (datatype' alias_env dt') | Effectname r' -> Effectname (row' alias_env r') + | Presencename p' -> Presencename (fieldspec' alias_env p') let type_arg' alias_env ((ta, _) : type_arg') : type_arg' = let unlocated = WithPos.make Datatype.Unit in @@ -426,7 +434,10 @@ object (self) (alias_env, WithPos.make ~pos (t, args, Typename (d, None)) :: ts) | Effectname (r,_) -> let alias_env = SEnv.bind t (`Mutual (qs, tygroup_ref)) alias_env in - (alias_env, WithPos.make ~pos (t, args, Effectname (r, None)) :: ts) ) + (alias_env, WithPos.make ~pos (t, args, Effectname (r, None)) :: ts) + | Presencename (p,_) -> + let alias_env = SEnv.bind t (`Mutual (qs, tygroup_ref)) alias_env in + (alias_env, WithPos.make ~pos (t, args, Presencename (p, None)) :: ts) ) (alias_env, []) ts in (* Desugar all DTs, given the temporary new alias environment. *) @@ -435,8 +446,9 @@ object (self) (* Desugar the datatype *) (* Check if the datatype has actually been desugared *) let b' = match Desugar.aliasbody mutual_env b with - | Typename (_, Some _) as b' -> b' - | Effectname (_, Some _) as b' -> b' + | Typename (_, Some _) as b' -> b' + | Effectname (_, Some _) as b' -> b' + | Presencename (_, Some _) as b' -> b' | _ -> assert false in WithPos.make ~pos (name, args, b') @@ -447,8 +459,9 @@ object (self) let (linearity_env, dep_graph) = List.fold_left (fun (lin_map, dep_graph) mutual -> match SourceCode.WithPos.node mutual with - | (name, _, Typename (_, dt)) - | (name, _, Effectname (_, dt)) -> + | (name, _, Typename (_, dt)) + | (name, _, Effectname (_, dt)) + | (name, _, Presencename (_, dt)) -> let dt = OptionUtils.val_of dt in let lin_map = StringMap.add name (not @@ Unl.type_satisfies dt) lin_map in let deps = recursive_applications dt in @@ -487,8 +500,9 @@ object (self) List.fold_left (fun alias_env {node=(t, args, b); _} -> let semantic_qs = List.map SugarQuantifier.get_resolved_exn args in let dt, alias_env = match b with - | Typename (_, dt') - | Effectname (_, dt') -> + | Typename (_, dt') + | Effectname (_, dt') + | Presencename (_, dt') -> let dt = OptionUtils.val_of dt' in let alias_env = SEnv.bind t (`Alias (semantic_qs, dt)) alias_env in (dt, alias_env) diff --git a/core/desugarEffects.ml b/core/desugarEffects.ml index d2716036c..daa7149be 100644 --- a/core/desugarEffects.ml +++ b/core/desugarEffects.ml @@ -1112,6 +1112,13 @@ class main_traversal simple_tycon_env = let dep_graph = StringMap.add t (StringSet.elements used_mutuals) dep_graph in + (implicits, dep_graph) + | Presencename _ -> (* is this the right thing to do ? *) + let implicits = StringMap.add t false implicits in + let used_mutuals = StringSet.empty in + let dep_graph = + StringMap.add t (StringSet.elements used_mutuals) dep_graph + in (implicits, dep_graph)) (StringMap.empty, StringMap.empty) ts @@ -1163,8 +1170,9 @@ class main_traversal simple_tycon_env = StringMap.add t (Some shared_effect_var) shared_var_env in let b' = match b with - | Typename (d,_) -> Typename (d, None) - | Effectname (r,_) -> Effectname (r, None) + | Typename (d,_) -> Typename (d, None) + | Effectname (r,_) -> Effectname (r, None) + | Presencename (p,_) -> Presencename (p, None) in ( tycon_env, shared_var_env, diff --git a/core/parser.mly b/core/parser.mly index 84e0e1139..2dde624e4 100644 --- a/core/parser.mly +++ b/core/parser.mly @@ -173,6 +173,23 @@ let attach_row_subkind (r, subkind) = | _ -> assert false in attach_subkind_helper update subkind +let alias p name args kind body = + let aliasbody = + match kind, body with + | (Some PrimaryKind.Type , _), Datatype.Type b -> + Typename (b, None) + | (Some PrimaryKind.Row , _), Datatype.Row b -> + Effectname (b, None) + | (Some PrimaryKind.Row , _), Datatype.Type ({ WithPos.node = Datatype.TypeApplication(name, args) ; _ }) -> + let b = ([], Datatype.EffectApplication(name, args)) in + Effectname (b, None) + | (Some PrimaryKind.Presence, _), Datatype.Presence b -> + Presencename (b, None) + (* raise (ConcreteSyntaxError (pos p, "Presence aliases unsupported")) *) + | _ -> raise (ConcreteSyntaxError (pos p, "Kind mismatch")) + in + with_pos p (Aliases [with_pos p (name, args, aliasbody)]) + let labels xs = fst (List.split xs) let parseRegexFlags f = @@ -413,6 +430,7 @@ arg: | UFLOAT { string_of_float' $1 } | TRUE { "true" } | FALSE { "false" } +| DEFAULT { "default" } var: | VARIABLE { with_pos $loc $1 } @@ -446,7 +464,7 @@ nofun_declaration: let node = Infix { name = WithPos.node $3; precedence; assoc = $1 } in with_pos $loc node } | signature? tlvarbinding SEMICOLON { val_binding' ~ppos:$loc($2) $1 $2 } -| typedecl SEMICOLON | effectdecl SEMICOLON { $1 } +| typedecl SEMICOLON { $1 } | links_module | links_open SEMICOLON { $1 } | pollute = boption(OPEN) IMPORT CONSTRUCTOR SEMICOLON { import ~ppos:$loc($2) ~pollute [$3] } @@ -506,11 +524,9 @@ signature: | SIG sigop COLON datatype { with_pos $loc ($2, datatype $4) } typedecl: -| TYPENAME CONSTRUCTOR typeargs_opt EQ datatype { with_pos $loc (Aliases [with_pos $loc ($2, $3, Typename (datatype $5))]) } - -effectdecl: -| EFFECTNAME CONSTRUCTOR typeargs_opt EQ LBRACE erow RBRACE { with_pos $loc (Aliases [with_pos $loc ($2, $3, Effectname ( $6 ,None))]) } -| EFFECTNAME CONSTRUCTOR typeargs_opt EQ effect_app { with_pos $loc (Aliases [with_pos $loc ($2, $3, Effectname (([],$5),None))]) } +| TYPENAME CONSTRUCTOR typeargs_opt EQ datatype { alias $loc $2 $3 (Some pk_type, None) (Datatype.Type $5) } +| EFFECTNAME CONSTRUCTOR typeargs_opt EQ type_arg { alias $loc $2 $3 (Some pk_row , Some (lin_unl, res_effect)) $5 } +| TYPENAME CONSTRUCTOR typeargs_opt kind EQ type_arg { alias $loc $2 $3 $4 $6 } (* Lists of quantifiers in square brackets denote type abstractions *) type_abstracion_vars: @@ -1136,7 +1152,7 @@ type_arg_list: type_arg: | datatype { Datatype.Type $1 } | braced_fieldspec { Datatype.Presence $1 } -| LBRACE trow RBRACE { Datatype.Row $2 } +| LBRACE erow RBRACE { Datatype.Row $2 } datatypes: | separated_nonempty_list(COMMA, datatype) { $1 } @@ -1145,9 +1161,9 @@ vrow: | vfields { $1 } | /* empty */ { ([], Datatype.Closed) } -trow: -| tfields { $1 } -| /* empty */ { ([], Datatype.Closed) } +/* trow: */ +/* | tfields { $1 } */ +/* | /\* empty *\/ { ([], Datatype.Closed) } */ erow: | efields { $1 } @@ -1199,12 +1215,12 @@ vfield: | CONSTRUCTOR { ($1, present) } | CONSTRUCTOR fieldspec { ($1, $2) } -tfields: -| field { ([$1], Datatype.Closed) } -| soption(field) VBAR row_var { ( $1 , $3 ) } -| soption(field) VBAR kinded_row_var { ( $1 , $3 ) } -| soption(field) VBAR effect_app { ( $1 , $3 ) } -| field COMMA tfields { ( $1::fst $3, snd $3 ) } +/* tfields: */ +/* | field { ([$1], Datatype.Closed) } */ +/* | soption(field) VBAR row_var { ( $1 , $3 ) } */ +/* | soption(field) VBAR kinded_row_var { ( $1 , $3 ) } */ +/* | soption(field) VBAR effect_app { ( $1 , $3 ) } */ +/* | field COMMA tfields { ( $1::fst $3, snd $3 ) } */ efields: | efield { ([$1], make_effect_var ~is_dot:false $loc) } diff --git a/core/sugarTraversals.ml b/core/sugarTraversals.ml index 5a8c4312b..b7ce85f31 100644 --- a/core/sugarTraversals.ml +++ b/core/sugarTraversals.ml @@ -176,6 +176,12 @@ class map = let y = o#option (fun o -> o#typ) y in (x,y) + method fieldspec' : fieldspec' -> fieldspec' = + fun (x, y) -> + let x = o#fieldspec x in + let y = o#option (fun o -> o#typ) y in + (x,y) + method given_spawn_location : given_spawn_location -> given_spawn_location = function | ExplicitSpawnLocation p -> ExplicitSpawnLocation (o#phrase p) @@ -801,6 +807,7 @@ class map = function | Typename _x -> Typename (o#datatype' _x) | Effectname _x -> Effectname (o#row' _x) + | Presencename _x -> Presencename (o#fieldspec' _x) method alias : alias -> alias = fun p -> @@ -1016,6 +1023,12 @@ class fold = let o = o#unknown y in o + method fieldspec' : fieldspec' -> 'self_type = + fun (x, y) -> + let o = o#fieldspec x in + let o = o#unknown y in + o + method given_spawn_location : given_spawn_location -> 'self_type = function | ExplicitSpawnLocation p -> let o = o#phrase p in o | _ -> o @@ -1572,6 +1585,7 @@ class fold = function | Typename _x -> o#datatype' _x | Effectname _x -> o#row' _x + | Presencename _x -> o#fieldspec' _x method alias : alias -> 'self_type = WithPos.traverse @@ -2309,15 +2323,21 @@ class fold_map = let (o, _x) = o#string _x in let (o, _x_i1) = o#list (fun o -> o#string) _x_i1 in (o, (_x, _x_i1)) + method datatype' : datatype' -> ('self_type * datatype') = + fun (_x, _x_i1) -> + let (o, _x) = o#datatype _x in + let (o, _x_i1) = o#option (fun o -> o#typ) _x_i1 + in (o, (_x, _x_i1)) + method row' : row' -> ('self_type * row') = fun (_x, _x_i1) -> let (o, _x) = o#row _x in let (o, _x_i1) = o#option (fun o -> o#typ) _x_i1 in (o, (_x, _x_i1)) - method datatype' : datatype' -> ('self_type * datatype') = + method fieldspec' : fieldspec' -> ('self_type * fieldspec') = fun (_x, _x_i1) -> - let (o, _x) = o#datatype _x in + let (o, _x) = o#fieldspec _x in let (o, _x_i1) = o#option (fun o -> o#typ) _x_i1 in (o, (_x, _x_i1)) @@ -2507,8 +2527,9 @@ class fold_map = method aliasbody : aliasbody -> ('self_type * aliasbody) = function - | Typename _x -> let o, _x = o#datatype' _x in (o, Typename _x) - | Effectname _x -> let o, _x = o#row' _x in (o, Effectname _x) + | Typename _x -> let o, _x = o#datatype' _x in (o, Typename _x) + | Effectname _x -> let o, _x = o#row' _x in (o, Effectname _x) + | Presencename _x -> let o, _x = o#fieldspec' _x in (o, Presencename _x) method function_definition : function_definition -> 'self * function_definition = fun { fun_binder; diff --git a/core/sugarTraversals.mli b/core/sugarTraversals.mli index d3fb2a34d..34443b9b9 100644 --- a/core/sugarTraversals.mli +++ b/core/sugarTraversals.mli @@ -64,6 +64,7 @@ class map : method datatypenode : Datatype.t -> Datatype.t method datatype' : datatype' -> datatype' method row' : row' -> row' + method fieldspec' : fieldspec' -> fieldspec' method type_arg : Datatype.type_arg -> Datatype.type_arg method type_arg' : type_arg' -> type_arg' method constant : Constant.t -> Constant.t @@ -148,6 +149,7 @@ class fold : method datatypenode : Datatype.t -> 'self method datatype' : datatype' -> 'self method row' : row' -> 'self + method fieldspec' : fieldspec' -> 'self method type_arg : Datatype.type_arg -> 'self method type_arg' : type_arg' -> 'self method constant : Constant.t -> 'self @@ -194,6 +196,7 @@ object ('self) method datatypenode : Datatype.t -> 'self * Datatype.t method datatype' : datatype' -> 'self * datatype' method row' : row' -> 'self * row' + method fieldspec' : fieldspec' -> 'self * fieldspec' method type_arg' : type_arg' -> 'self * type_arg' method directive : directive -> 'self * directive method fieldconstraint : fieldconstraint -> 'self * fieldconstraint diff --git a/core/sugartypes.ml b/core/sugartypes.ml index b17421516..8ad62bc39 100644 --- a/core/sugartypes.ml +++ b/core/sugartypes.ml @@ -231,6 +231,9 @@ type datatype' = Datatype.with_pos * Types.datatype option type row' = Datatype.row * Types.row option [@@deriving show] +type fieldspec' = Datatype.fieldspec * Types.field_spec option + [@@deriving show] + type type_arg' = Datatype.type_arg * Types.type_arg option [@@deriving show] @@ -550,6 +553,7 @@ and alias = aliasnode WithPos.t and aliasbody = | Typename of datatype' | Effectname of row' + | Presencename of fieldspec' and function_definition = { fun_binder: Binder.with_pos; fun_linearity: DeclaredLinearity.t; diff --git a/core/transformSugar.ml b/core/transformSugar.ml index 79a705750..5c5e7d8e7 100644 --- a/core/transformSugar.ml +++ b/core/transformSugar.ml @@ -899,6 +899,10 @@ class transform (env : Types.typing_environment) = let o = o#bind_alias name (`Alias (List.map (SugarQuantifier.get_resolved_exn) vars, r)) in (o, WithPos.make ~pos (name, vars, Effectname (x, r'))) + | Presencename (x, (Some p as p')) -> + let o = o#bind_alias name + (`Alias (List.map (SugarQuantifier.get_resolved_exn) vars, p)) in + (o, WithPos.make ~pos (name, vars, Presencename (x, p'))) | _ -> raise (internal_error "Unannotated type alias") ) ts in (o, Aliases ts) diff --git a/core/typeSugar.ml b/core/typeSugar.ml index 900985009..ffc5dc093 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -4850,8 +4850,9 @@ and type_binding : context -> binding -> binding * context * Usage.t = | Aliases ts -> let env = List.fold_left (fun env {node=(name, vars, b); _} -> match b with - | Typename (_, Some dt) - | Effectname (_, Some dt) -> + | Typename (_, Some dt) + | Effectname (_, Some dt) + | Presencename (_, Some dt) -> bind_alias env (name, `Alias (List.map (SugarQuantifier.get_resolved_exn) vars, dt)) | _ -> raise (internal_error "typeSugar.ml: unannotated type") ) empty_context ts in diff --git a/core/types.mli b/core/types.mli index 7f2f69b79..3b6342c5a 100644 --- a/core/types.mli +++ b/core/types.mli @@ -445,6 +445,7 @@ val pp_row : Format.formatter -> row -> unit val pp_row' : Format.formatter -> row' -> unit val pp_type_arg : Format.formatter -> type_arg -> unit val pp_tycon_spec: Format.formatter -> tycon_spec -> unit +val pp_field_spec: Format.formatter -> field_spec -> unit (* Recursive type applications *) val recursive_applications : datatype -> string list From c0c3e5b80f3a47afb536002e9730d10184cb830d Mon Sep 17 00:00:00 2001 From: Robin Jourde <63565023+Orbion-J@users.noreply.github.com> Date: Fri, 27 May 2022 18:28:06 +0200 Subject: [PATCH 13/63] Update bin/repl.ml MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Daniel Hillerström --- bin/repl.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/bin/repl.ml b/bin/repl.ml index bdda97174..4fe4a9d51 100644 --- a/bin/repl.ml +++ b/bin/repl.ml @@ -162,7 +162,7 @@ let rec directives : (string * ((Context.t -> string list -> Context.t) * string Printf.fprintf stderr " %s = %s\n" (Module_hacks.Name.prettify k) (Types.string_of_tycon_spec s)) - (StringSet.diff (Env.String.domain tycon_env) (Env.String.domain Lib.typing_env.Types.alias_env)); + (StringSet.diff (Env.String.domain tycon_env) (Env.String.domain Lib.typing_env.Types.tycon_env)); context), "display the current type alias environment"); From eace411737154261757da3b67328c3b1f95c49bf Mon Sep 17 00:00:00 2001 From: Robin Jourde <63565023+Orbion-J@users.noreply.github.com> Date: Fri, 27 May 2022 18:28:22 +0200 Subject: [PATCH 14/63] Update bin/repl.ml MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Daniel Hillerström --- bin/repl.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/bin/repl.ml b/bin/repl.ml index 4fe4a9d51..050920bd7 100644 --- a/bin/repl.ml +++ b/bin/repl.ml @@ -155,7 +155,7 @@ let rec directives : (string * ((Context.t -> string list -> Context.t) * string ((fun context _ -> let tycon_env = let tenv = Context.typing_environment context in - tenv.Types.alias_env + tenv.Types.tycon_env in StringSet.iter (fun k -> let s = Env.String.find k tycon_env in From 93b2cf1df5f78d9c9f0d611c46fbc473898d8707 Mon Sep 17 00:00:00 2001 From: Robin Jourde <63565023+Orbion-J@users.noreply.github.com> Date: Fri, 27 May 2022 18:28:43 +0200 Subject: [PATCH 15/63] Update bin/repl.ml MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Daniel Hillerström --- bin/repl.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/bin/repl.ml b/bin/repl.ml index 050920bd7..89cfdb276 100644 --- a/bin/repl.ml +++ b/bin/repl.ml @@ -123,7 +123,7 @@ let rec directives : (string * ((Context.t -> string list -> Context.t) * string (fun k s () -> Printf.fprintf stderr "typename %s = %s\n" k (Types.string_of_tycon_spec s)) - (Lib.typing_env.Types.alias_env) (); + (Lib.typing_env.Types.tycon_env) (); StringSet.iter (fun n -> let t = Env.String.find n Lib.type_env in Printf.fprintf stderr " %-16s : %s\n" From 17360970f7c384201678bc0c9f01d16a2ac6bf32 Mon Sep 17 00:00:00 2001 From: Robin Jourde <63565023+Orbion-J@users.noreply.github.com> Date: Fri, 27 May 2022 18:28:49 +0200 Subject: [PATCH 16/63] Update bin/repl.ml MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Daniel Hillerström --- bin/repl.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/bin/repl.ml b/bin/repl.ml index 89cfdb276..7a9c85455 100644 --- a/bin/repl.ml +++ b/bin/repl.ml @@ -221,7 +221,7 @@ let rec directives : (string * ((Context.t -> string list -> Context.t) * string ((fun context args -> let tenv, aliases = let tyenv = Context.typing_environment context in - tyenv.Types.var_env, tyenv.Types.alias_env + tyenv.Types.var_env, tyenv.Types.tycon_env in match args with | [] -> prerr_endline "syntax: @withtype type"; context From bb0fb30bfa3dba9552f44802d56bfa74b2d3181c Mon Sep 17 00:00:00 2001 From: Robin Jourde <63565023+Orbion-J@users.noreply.github.com> Date: Fri, 27 May 2022 18:28:57 +0200 Subject: [PATCH 17/63] Update bin/repl.ml MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Daniel Hillerström --- bin/repl.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/bin/repl.ml b/bin/repl.ml index 7a9c85455..114ca17c5 100644 --- a/bin/repl.ml +++ b/bin/repl.ml @@ -268,7 +268,7 @@ let handle previous_context current_context = function let tycon_env' = let tenv = Context.typing_environment previous_context in let tenv' = Context.typing_environment current_context in - let tycon_env, tycon_env'= + let tycon_env, tycon_env' = Types.(tenv.alias_env, tenv'.alias_env) in Env.String.fold From 6206a6b50e8bba3655fcf5cd5f86aa16344dc9be Mon Sep 17 00:00:00 2001 From: Robin Jourde <63565023+Orbion-J@users.noreply.github.com> Date: Fri, 27 May 2022 18:29:04 +0200 Subject: [PATCH 18/63] Update core/desugarDatatypes.mli MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Daniel Hillerström --- core/desugarDatatypes.mli | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/desugarDatatypes.mli b/core/desugarDatatypes.mli index e098e394a..5ae5347e8 100644 --- a/core/desugarDatatypes.mli +++ b/core/desugarDatatypes.mli @@ -1,4 +1,4 @@ -val read : aliases:Types.alias_environment -> string -> Types.datatype +val read : aliases:Types.tycon_environment -> string -> Types.datatype val sentence : Types.typing_environment -> From 9a499fc9daa4a5f413fcda9cbfbdcbd05f2d9e28 Mon Sep 17 00:00:00 2001 From: Robin Jourde <63565023+Orbion-J@users.noreply.github.com> Date: Fri, 27 May 2022 18:29:36 +0200 Subject: [PATCH 19/63] Update bin/repl.ml MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Daniel Hillerström --- bin/repl.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/bin/repl.ml b/bin/repl.ml index 114ca17c5..708750355 100644 --- a/bin/repl.ml +++ b/bin/repl.ml @@ -269,7 +269,7 @@ let handle previous_context current_context = function let tenv = Context.typing_environment previous_context in let tenv' = Context.typing_environment current_context in let tycon_env, tycon_env' = - Types.(tenv.alias_env, tenv'.alias_env) + Types.(tenv.tycon_env, tenv'.tycon_env) in Env.String.fold (fun name def new_tycons -> From c45fbbc07f72b9e5edd3d25c7df4b3dcdc6b9f15 Mon Sep 17 00:00:00 2001 From: Robin Jourde <63565023+Orbion-J@users.noreply.github.com> Date: Fri, 27 May 2022 18:29:49 +0200 Subject: [PATCH 20/63] Update core/defaultAliases.ml MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Daniel Hillerström --- core/defaultAliases.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/defaultAliases.ml b/core/defaultAliases.ml index ba1d2af9b..54f127035 100644 --- a/core/defaultAliases.ml +++ b/core/defaultAliases.ml @@ -3,7 +3,7 @@ open CommonTypes (* Alias environment *) module AliasEnv = Env.String -let alias_env : Types.alias_environment = +let alias_env : Types.tycon_environment = (* TableHandle is now an alias of TemporalTable, so set it up *) let mk_arg () = let open Types in From 832a424b0ac752bbefd57c2f3ca356624e253767 Mon Sep 17 00:00:00 2001 From: Robin Jourde <63565023+Orbion-J@users.noreply.github.com> Date: Fri, 27 May 2022 18:29:58 +0200 Subject: [PATCH 21/63] Update core/desugarDatatypes.ml MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Daniel Hillerström --- core/desugarDatatypes.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/desugarDatatypes.ml b/core/desugarDatatypes.ml index c71add380..db2a7ff68 100644 --- a/core/desugarDatatypes.ml +++ b/core/desugarDatatypes.ml @@ -76,7 +76,7 @@ module Desugar = struct let desugar_quantifiers (sqs: SugarQuantifier.t list) : Quantifier.t list = List.map SugarQuantifier.get_resolved_exn sqs - let rec datatype (alias_env : Types.alias_environment) t' = + let rec datatype (alias_env : Types.tycon_environment) t' = let datatype t' = datatype alias_env t' in match t' with | { node = t; pos } -> From 0bd30cd40376785c025db37f9ea284f706ac75b3 Mon Sep 17 00:00:00 2001 From: Robin Jourde <63565023+Orbion-J@users.noreply.github.com> Date: Fri, 27 May 2022 18:30:30 +0200 Subject: [PATCH 22/63] Update core/desugarDatatypes.ml MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Daniel Hillerström --- core/desugarDatatypes.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/desugarDatatypes.ml b/core/desugarDatatypes.ml index db2a7ff68..8744d0e67 100644 --- a/core/desugarDatatypes.ml +++ b/core/desugarDatatypes.ml @@ -425,7 +425,7 @@ object (self) (* Add all type declarations in the group to the alias * environment, as mutuals. Quantifiers need to be desugared. *) - let ((mutual_env : Types.alias_environment), ts) = + let ((mutual_env : Types.tycon_environment), ts) = List.fold_left (fun (alias_env, ts) {node=(t, args, b); pos} -> let qs = Desugar.desugar_quantifiers args in match b with From 35e50e86e262ac39b602f248aed41ebdcce40ccf Mon Sep 17 00:00:00 2001 From: Robin Jourde <63565023+Orbion-J@users.noreply.github.com> Date: Fri, 27 May 2022 18:32:28 +0200 Subject: [PATCH 23/63] Update core/desugarDatatypes.ml MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Daniel Hillerström --- core/desugarDatatypes.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/core/desugarDatatypes.ml b/core/desugarDatatypes.ml index 8744d0e67..9490d60cc 100644 --- a/core/desugarDatatypes.ml +++ b/core/desugarDatatypes.ml @@ -245,7 +245,6 @@ module Desugar = struct let t = match_kinds i (q, t) in type_arg alias_env t node) in - let qn = List.length qs and tn = List.length ts in if qn = tn then type_args qs ts From 14df529fc812f7d821a05232bac08b6481b6b280 Mon Sep 17 00:00:00 2001 From: RJ Date: Fri, 27 May 2022 17:58:13 +0100 Subject: [PATCH 24/63] rename alias_env -> tycon_env as originally --- core/desugarDatatypes.ml | 8 ++++---- core/desugarEffects.ml | 12 ++++++------ core/desugarEffects.mli | 2 +- core/desugarPages.ml | 2 +- core/desugarRegexes.ml | 4 ++-- core/instantiate.mli | 2 +- core/lens_type_conv.mli | 4 ++-- core/lib.ml | 8 ++++---- core/parser.mly | 11 ----------- core/transformSugar.ml | 12 ++++++------ core/transformSugar.mli | 10 +++++----- core/types.ml | 12 ++++++------ core/types.mli | 4 ++-- core/webserver.ml | 2 +- 14 files changed, 41 insertions(+), 52 deletions(-) diff --git a/core/desugarDatatypes.ml b/core/desugarDatatypes.ml index 8744d0e67..df4e10fc3 100644 --- a/core/desugarDatatypes.ml +++ b/core/desugarDatatypes.ml @@ -449,7 +449,7 @@ object (self) | Typename (_, Some _) as b' -> b' | Effectname (_, Some _) as b' -> b' | Presencename (_, Some _) as b' -> b' - | _ -> assert false + | _ -> raise (internal_error "Datatype not desugared") in WithPos.make ~pos (name, args, b') ) ts in @@ -571,7 +571,7 @@ let toplevel_bindings alias_env bs = let program typing_env (bindings, p : Sugartypes.program) : Sugartypes.program = - let alias_env = typing_env.alias_env in + let alias_env = typing_env.tycon_env in let alias_env, bindings = toplevel_bindings alias_env bindings in (* let typing_env = { typing_env with tycon_env = alias_env } in *) @@ -579,9 +579,9 @@ let program typing_env (bindings, p : Sugartypes.program) : let sentence typing_env = function | Definitions bs -> - let _alias_env, bs' = toplevel_bindings typing_env.alias_env bs in + let _alias_env, bs' = toplevel_bindings typing_env.tycon_env bs in Definitions bs' - | Expression p -> let _o, p = phrase typing_env.alias_env p in + | Expression p -> let _o, p = phrase typing_env.tycon_env p in Expression p | Directive d -> Directive d diff --git a/core/desugarEffects.ml b/core/desugarEffects.ml index daa7149be..16d880207 100644 --- a/core/desugarEffects.ml +++ b/core/desugarEffects.ml @@ -115,7 +115,7 @@ type tycon_info = Kind.t list * bool * Types.typ option type simple_tycon_env = tycon_info SEnv.t -let simplify_tycon_env (tycon_env : Types.alias_environment) : simple_tycon_env +let simplify_tycon_env (tycon_env : Types.tycon_environment) : simple_tycon_env = let simplify_tycon name tycon simpl_env = let param_kinds, internal_type = @@ -1269,12 +1269,12 @@ class main_traversal simple_tycon_env = (o, rec_def) end -let program (tycon_env : Types.alias_environment) p = +let program (tycon_env : Types.tycon_environment) p = let s_env = simplify_tycon_env tycon_env in let v = new main_traversal s_env in snd (v#program p) -let sentence (tycon_env : Types.alias_environment) = +let sentence (tycon_env : Types.tycon_environment) = let s_env = simplify_tycon_env tycon_env in function | Definitions bs -> @@ -1287,7 +1287,7 @@ let sentence (tycon_env : Types.alias_environment) = Expression p | Directive d -> Directive d -let standalone_signature (tycon_env : Types.alias_environment) t = +let standalone_signature (tycon_env : Types.tycon_environment) t = let s_env = simplify_tycon_env tycon_env in let v = new main_traversal s_env in snd (v#datatype t) @@ -1300,12 +1300,12 @@ module Untyped = struct let program state program' = let open Types in let tyenv = Context.typing_environment (context state) in - let program' = program tyenv.alias_env program' in + let program' = program tyenv.tycon_env program' in return state program' let sentence state sentence' = let open Types in let tyenv = Context.typing_environment (context state) in - let sentence'' = sentence tyenv.alias_env sentence' in + let sentence'' = sentence tyenv.tycon_env sentence' in return state sentence'' end diff --git a/core/desugarEffects.mli b/core/desugarEffects.mli index 3fa894715..df6a8dc8e 100644 --- a/core/desugarEffects.mli +++ b/core/desugarEffects.mli @@ -1,4 +1,4 @@ (* Act on a type that's a lib.ml signature. Used by DesugarDatatypes.read *) -val standalone_signature : Types.alias_environment -> Sugartypes.Datatype.with_pos -> Sugartypes.Datatype.with_pos +val standalone_signature : Types.tycon_environment -> Sugartypes.Datatype.with_pos -> Sugartypes.Datatype.with_pos include Transform.Untyped.S diff --git a/core/desugarPages.ml b/core/desugarPages.ml index 326142956..8ad49c2d4 100644 --- a/core/desugarPages.ml +++ b/core/desugarPages.ml @@ -71,7 +71,7 @@ object method! phrasenode = function | Page e -> let (o, e, _t) = super#phrase e in - let page_type = Instantiate.alias "Page" [] env.Types.alias_env in + let page_type = Instantiate.alias "Page" [] env.Types.tycon_env in let e = desugar_page (o, page_type) e in (o, e.node, page_type) | e -> super#phrasenode e diff --git a/core/desugarRegexes.ml b/core/desugarRegexes.ml index 34f2ad17b..ac5b59d1b 100644 --- a/core/desugarRegexes.ml +++ b/core/desugarRegexes.ml @@ -70,8 +70,8 @@ let desugar_regexes env = object(self) inherit (TransformSugar.transform env) as super - val regex_type = Instantiate.alias "Regex" [] env.Types.alias_env - val repeat_type = Instantiate.alias "Repeat" [] env.Types.alias_env + val regex_type = Instantiate.alias "Regex" [] env.Types.tycon_env + val repeat_type = Instantiate.alias "Repeat" [] env.Types.tycon_env method! phrase ({node=p; pos} as ph) = match p with | InfixAppl ((tyargs, BinaryOp.RegexMatch flags), e1, {node=Regex((Replace(_,_) as r)); _}) -> diff --git a/core/instantiate.mli b/core/instantiate.mli index 6af281d6c..512fa9f9e 100644 --- a/core/instantiate.mli +++ b/core/instantiate.mli @@ -15,7 +15,7 @@ val typ_rigid : Types.datatype -> (Types.type_arg list * Types.datatype) val datatype : instantiation_maps -> Types.datatype -> Types.datatype val row : instantiation_maps -> Types.row -> Types.row val presence : instantiation_maps -> Types.field_spec -> Types.field_spec -val alias : string -> Types.type_arg list -> Types.alias_environment -> Types.datatype +val alias : string -> Types.type_arg list -> Types.tycon_environment -> Types.datatype val recursive_application : string -> Quantifier.t list -> Types.type_arg list -> Types.datatype -> Types.datatype (* Given a quantified type and a list of type arguments, create the corresponding instantiation map *) diff --git a/core/lens_type_conv.mli b/core/lens_type_conv.mli index 09a309376..c6b8b12e2 100644 --- a/core/lens_type_conv.mli +++ b/core/lens_type_conv.mli @@ -1,13 +1,13 @@ type 'a die = string -> 'a (** Lookup a type alias in the typing environment context. *) -val lookup_alias : Types.alias_environment -> alias:string -> Types.typ +val lookup_alias : Types.tycon_environment -> alias:string -> Types.typ val lens_type_of_type : die:Lens.Type.t die -> Types.typ -> Lens.Type.t (** Convert a native Links language type to a lens phrase type. *) val type_of_lens_phrase_type : - context:Types.alias_environment -> Lens.Phrase.Type.t -> Types.typ + context:Types.tycon_environment -> Lens.Phrase.Type.t -> Types.typ (** Convert a lens phrase type to a native Links type. *) val lens_phrase_type_of_type : Types.typ -> Lens.Phrase.Type.t diff --git a/core/lib.ml b/core/lib.ml index 7089a55f7..1fdc340a8 100644 --- a/core/lib.ml +++ b/core/lib.ml @@ -20,12 +20,12 @@ module AliasEnv = Env.String (* This is done in two stages because the datatype for regexes refers to the String alias *) -let alias_env : Types.alias_environment = DefaultAliases.alias_env +let alias_env : Types.tycon_environment = DefaultAliases.alias_env -let alias_env : Types.alias_environment = +let alias_env : Types.tycon_environment = AliasEnv.bind "Repeat" (`Alias ([], (DesugarDatatypes.read ~aliases:alias_env Linksregex.Repeat.datatype))) alias_env -let alias_env : Types.alias_environment = +let alias_env : Types.tycon_environment = AliasEnv.bind "Regex" (`Alias ([], (DesugarDatatypes.read ~aliases:alias_env Linksregex.Regex.datatype))) alias_env let datatype = DesugarDatatypes.read ~aliases:alias_env @@ -1725,7 +1725,7 @@ let type_env : Types.environment = let typing_env = {Types.var_env = type_env; Types.rec_vars = StringSet.empty; - alias_env = alias_env; + tycon_env = alias_env; Types.effect_row = Types.closed_wild_row; Types.desugared = false } diff --git a/core/parser.mly b/core/parser.mly index 2dde624e4..fa081c7ba 100644 --- a/core/parser.mly +++ b/core/parser.mly @@ -1161,10 +1161,6 @@ vrow: | vfields { $1 } | /* empty */ { ([], Datatype.Closed) } -/* trow: */ -/* | tfields { $1 } */ -/* | /\* empty *\/ { ([], Datatype.Closed) } */ - erow: | efields { $1 } | /* empty */ { ([], Datatype.Closed) } @@ -1215,13 +1211,6 @@ vfield: | CONSTRUCTOR { ($1, present) } | CONSTRUCTOR fieldspec { ($1, $2) } -/* tfields: */ -/* | field { ([$1], Datatype.Closed) } */ -/* | soption(field) VBAR row_var { ( $1 , $3 ) } */ -/* | soption(field) VBAR kinded_row_var { ( $1 , $3 ) } */ -/* | soption(field) VBAR effect_app { ( $1 , $3 ) } */ -/* | field COMMA tfields { ( $1::fst $3, snd $3 ) } */ - efields: | efield { ([$1], make_effect_var ~is_dot:false $loc) } | soption(efield) VBAR DOT { ( $1 , make_effect_var ~is_dot:true $loc) } diff --git a/core/transformSugar.ml b/core/transformSugar.ml index 5c5e7d8e7..8805ace40 100644 --- a/core/transformSugar.ml +++ b/core/transformSugar.ml @@ -145,12 +145,12 @@ class transform (env : Types.typing_environment) = let open PrimaryKind in object (o : 'self_type) val var_env = env.Types.var_env - val tycon_env = env.Types.alias_env + val tycon_env = env.Types.tycon_env val formlet_env = TyEnv.empty val effect_row = fst (Types.unwrap_row env.Types.effect_row) method get_var_env : unit -> Types.environment = fun () -> var_env - method get_tycon_env : unit -> Types.alias_environment = fun () -> tycon_env + method get_tycon_env : unit -> Types.tycon_environment = fun () -> tycon_env method get_formlet_env : unit -> Types.environment = fun () -> formlet_env method backup_envs = var_env, tycon_env, formlet_env, effect_row @@ -164,7 +164,7 @@ class transform (env : Types.typing_environment) = method with_formlet_env formlet_env = {< formlet_env = formlet_env >} - method bind_alias name tycon = + method bind_tycon name tycon = {< tycon_env = TyEnv.bind name tycon tycon_env >} method bind_binder bndr = @@ -892,15 +892,15 @@ class transform (env : Types.typing_environment) = let (o, _) = listu o (fun o {node=(name, vars, b); pos} -> match b with | Typename (x, (Some dt as dt')) -> - let o = o#bind_alias name + let o = o#bind_tycon name (`Alias (List.map (SugarQuantifier.get_resolved_exn) vars, dt)) in (o, WithPos.make ~pos (name, vars, Typename (x, dt'))) | Effectname (x, (Some r as r')) -> - let o = o#bind_alias name + let o = o#bind_tycon name (`Alias (List.map (SugarQuantifier.get_resolved_exn) vars, r)) in (o, WithPos.make ~pos (name, vars, Effectname (x, r'))) | Presencename (x, (Some p as p')) -> - let o = o#bind_alias name + let o = o#bind_tycon name (`Alias (List.map (SugarQuantifier.get_resolved_exn) vars, p)) in (o, WithPos.make ~pos (name, vars, Presencename (x, p'))) | _ -> raise (internal_error "Unannotated type alias") diff --git a/core/transformSugar.mli b/core/transformSugar.mli index 0c75bd104..f37e6e035 100644 --- a/core/transformSugar.mli +++ b/core/transformSugar.mli @@ -31,20 +31,20 @@ val listu : class transform : Types.typing_environment -> object ('self) val var_env : Types.environment - val tycon_env : Types.alias_environment + val tycon_env : Types.tycon_environment val effect_row : Types.row method get_var_env : unit -> Types.environment - method get_tycon_env : unit -> Types.alias_environment + method get_tycon_env : unit -> Types.tycon_environment method get_formlet_env : unit -> Types.environment - method backup_envs : Types.environment * Types.alias_environment * Types.environment * Types.row - method restore_envs : (Types.environment * Types.alias_environment * Types.environment * Types.row) -> 'self + method backup_envs : Types.environment * Types.tycon_environment * Types.environment * Types.row + method restore_envs : (Types.environment * Types.tycon_environment * Types.environment * Types.row) -> 'self method with_var_env : Types.environment -> 'self method with_formlet_env : Types.environment -> 'self - method bind_alias : string -> Types.tycon_spec -> 'self + method bind_tycon : string -> Types.tycon_spec -> 'self method bind_binder : Binder.with_pos -> 'self method lookup_type : Name.t -> Types.datatype diff --git a/core/types.ml b/core/types.ml index e13eb3642..ecc616185 100644 --- a/core/types.ml +++ b/core/types.ml @@ -4207,18 +4207,18 @@ See Note [Variable names in error messages]. type environment = datatype Env.t [@@deriving show] -type alias_environment = tycon_spec Env.t +type tycon_environment = tycon_spec Env.t [@@deriving show] type typing_environment = { var_env : environment ; rec_vars : StringSet.t ; - alias_env : alias_environment ; + tycon_env : tycon_environment ; effect_row : row; desugared : bool } [@@deriving show] let empty_typing_environment = { var_env = Env.empty; rec_vars = StringSet.empty; - alias_env = Env.empty; + tycon_env = Env.empty; effect_row = make_empty_closed_row (); desugared = false } @@ -4345,11 +4345,11 @@ let normalise_typing_environment env = (* Functions on environments *) let extend_typing_environment - {var_env = l; rec_vars = lvars; alias_env = al; effect_row = _; desugared = _; } - {var_env = r; rec_vars = rvars; alias_env = ar; effect_row = er; desugared = dr } : typing_environment = + {var_env = l; rec_vars = lvars; tycon_env = al; effect_row = _; desugared = _; } + {var_env = r; rec_vars = rvars; tycon_env = ar; effect_row = er; desugared = dr } : typing_environment = { var_env = Env.extend l r ; rec_vars = StringSet.union lvars rvars - ; alias_env = Env.extend al ar + ; tycon_env = Env.extend al ar ; effect_row = er ; desugared = dr } diff --git a/core/types.mli b/core/types.mli index 3b6342c5a..1da7394d9 100644 --- a/core/types.mli +++ b/core/types.mli @@ -215,10 +215,10 @@ type tycon_spec = [ ] type environment = datatype Env.String.t -type alias_environment = tycon_spec Env.String.t +type tycon_environment = tycon_spec Env.String.t type typing_environment = { var_env : environment ; rec_vars : Utility.StringSet.t ; - alias_env : alias_environment ; + tycon_env : tycon_environment ; effect_row : row ; desugared : bool } diff --git a/core/webserver.ml b/core/webserver.ml index ca9c45d09..51e291743 100644 --- a/core/webserver.ml +++ b/core/webserver.ml @@ -364,7 +364,7 @@ struct let start_server host port rt = let render_cont () = - let (_, nenv, {Types.alias_env = tycon_env; _ }) = !env in + let (_, nenv, {Types.tycon_env = tycon_env; _ }) = !env in let _, x = Var.fresh_global_var_of_type (Instantiate.alias "Page" [] tycon_env) in let render_page = Env.String.find "renderPage" nenv in let tail = Ir.Apply (Ir.Variable render_page, [Ir.Variable x]) in From 3489b8a7790c5c71a382a32178d7247b6702bc5c Mon Sep 17 00:00:00 2001 From: RJ Date: Fri, 27 May 2022 18:00:39 +0100 Subject: [PATCH 25/63] idem --- core/typeSugar.ml | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/core/typeSugar.ml b/core/typeSugar.ml index ffc5dc093..29875de8f 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -1649,7 +1649,7 @@ type context = Types.typing_environment = { type inference. Instead, we use it to resolve references introduced here to aliases defined in the prelude such as "Page" and "Formlet". *) - alias_env : Types.alias_environment; + tycon_env : Types.tycon_environment; (* the current effects *) effect_row : Types.row; @@ -1662,13 +1662,13 @@ type context = Types.typing_environment = { let empty_context eff desugared = { var_env = Env.empty; rec_vars = StringSet.empty; - alias_env = Env.empty; + tycon_env = Env.empty; effect_row = eff; desugared } let bind_var context (v, t) = {context with var_env = Env.bind v t context.var_env} let unbind_var context v = {context with var_env = Env.unbind v context.var_env} -let bind_alias context (v, t) = {context with alias_env = Env.bind v t context.alias_env} +let bind_alias context (v, t) = {context with tycon_env = Env.bind v t context.tycon_env} let bind_effects context r = {context with effect_row = r} (* TODO(dhil): I have extracted the Usage abstraction from my name @@ -1855,7 +1855,7 @@ let add_usages (p, t) m = (p, t, m) let add_empty_usages (p, t) = (p, t, Usage.empty) let type_unary_op pos env = - let datatype = datatype env.alias_env in + let datatype = datatype env.tycon_env in function | UnaryOp.Minus -> add_empty_usages (datatype "(Int) -> Int") | UnaryOp.FloatMinus -> add_empty_usages (datatype "(Float) -> Float") @@ -1869,7 +1869,7 @@ let type_unary_op pos env = let type_binary_op pos ctxt = let open BinaryOp in let open Types in - let datatype = datatype ctxt.alias_env in function + let datatype = datatype ctxt.tycon_env in function | Minus -> add_empty_usages (Utils.instantiate ctxt.var_env "-") | FloatMinus -> add_empty_usages (Utils.instantiate ctxt.var_env "-.") | RegexMatch flags -> @@ -2914,7 +2914,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = let typ = let tlens = typ lens |> Lens_type_conv.lens_type_of_type ~die:(Gripers.die pos) in let trow = Lens.Type.sort tlens |> Lens.Sort.record_type in - let {alias_env = context;_} = context in + let {tycon_env = context;_} = context in let ltrow = Lens_type_conv.type_of_lens_phrase_type ~context trow in let tmatch = Types.make_pure_function_type [ltrow] Types.bool_type in unify (pos_and_typ tpredicate, (exp_pos lens, tmatch)) ~handle:Gripers.lens_predicate; @@ -2949,7 +2949,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = let typ = typ lens |> Lens_type_conv.lens_type_of_type ~die:(Gripers.die pos) in Lens.Type.ensure_checked typ |> Lens_errors.unpack_lens_checked_result ~die:(Gripers.die pos); let sort = Lens.Type.sort typ in - let {alias_env = context;_} = context in + let {tycon_env = context;_} = context in let trowtype = Lens.Sort.record_type sort |> Lens_type_conv.type_of_lens_phrase_type ~context in LensGetLit (erase lens, Some trowtype), Types.make_list_type trowtype, usages lens | LensCheckLit (lens, _) -> @@ -2966,7 +2966,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = Lens.Type.ensure_checked typ |> Lens_errors.unpack_lens_checked_result ~die:(Gripers.die pos); let data = tc data in let trow = Lens.Type.sort typ |> Lens.Sort.record_type in - let {alias_env = context;_} = context in + let {tycon_env = context;_} = context in let ltrow = Lens_type_conv.type_of_lens_phrase_type ~context trow in unify (pos_and_typ data, (exp_pos lens, Types.make_list_type ltrow)) ~handle:Gripers.lens_put_input; LensPutLit (erase lens, erase data, Some Types.unit_type), make_tuple_type [], Usage.combine (usages lens) (usages data) @@ -3623,7 +3623,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = (fun e -> unify ~handle:Gripers.xml_attributes (pos_and_typ e, no_pos ( - (Instantiate.alias "Attributes" [] context.alias_env)))) attrexp + (Instantiate.alias "Attributes" [] context.tycon_env)))) attrexp and () = List.iter (fun child -> unify ~handle:Gripers.xml_child (pos_and_typ child, no_pos Types.xml_type)) children in @@ -3644,12 +3644,12 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = let yields = type_check context' yields in unify ~handle:Gripers.formlet_body (pos_and_typ body, no_pos Types.xml_type); (Formlet (erase body, erase yields), - Instantiate.alias "Formlet" [PrimaryKind.Type, typ yields] context.alias_env, + Instantiate.alias "Formlet" [PrimaryKind.Type, typ yields] context.tycon_env, Usage.combine (usages body) (Usage.restrict (usages yields) vs)) | Page e -> let e = tc e in unify ~handle:Gripers.page_body (pos_and_typ e, no_pos Types.xml_type); - Page (erase e), Instantiate.alias "Page" [] context.alias_env, usages e + Page (erase e), Instantiate.alias "Page" [] context.tycon_env, usages e | FormletPlacement (f, h, attributes) -> let t = Types.fresh_type_variable (lin_any, res_any) in @@ -3657,24 +3657,24 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = and h = tc h and attributes = tc attributes in let () = unify ~handle:Gripers.render_formlet - (pos_and_typ f, no_pos (Instantiate.alias "Formlet" [PrimaryKind.Type, t] context.alias_env)) in + (pos_and_typ f, no_pos (Instantiate.alias "Formlet" [PrimaryKind.Type, t] context.tycon_env)) in let () = unify ~handle:Gripers.render_handler (pos_and_typ h, (exp_pos f, - Instantiate.alias "Handler" [PrimaryKind.Type, t] context.alias_env)) in + Instantiate.alias "Handler" [PrimaryKind.Type, t] context.tycon_env)) in let () = unify ~handle:Gripers.render_attributes - (pos_and_typ attributes, no_pos (Instantiate.alias "Attributes" [] context.alias_env)) + (pos_and_typ attributes, no_pos (Instantiate.alias "Attributes" [] context.tycon_env)) in FormletPlacement (erase f, erase h, erase attributes), Types.xml_type, Usage.combine_many [usages f; usages h; usages attributes] | PagePlacement e -> let e = tc e in - let pt = Instantiate.alias "Page" [] context.alias_env in + let pt = Instantiate.alias "Page" [] context.tycon_env in unify ~handle:Gripers.page_placement (pos_and_typ e, no_pos pt); PagePlacement (erase e), Types.xml_type, usages e | FormBinding (e, pattern) -> let e = tc e and pattern = tpc pattern in let a = Types.fresh_type_variable (lin_unl, res_any) in - let ft = Instantiate.alias "Formlet" [PrimaryKind.Type, a] context.alias_env in + let ft = Instantiate.alias "Formlet" [PrimaryKind.Type, a] context.tycon_env in unify ~handle:Gripers.form_binding_body (pos_and_typ e, no_pos ft); unify ~handle:Gripers.form_binding_pattern (ppos_and_typ pattern, (exp_pos e, a)); FormBinding (erase e, erase_pat pattern), Types.xml_type, usages e @@ -3814,7 +3814,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = Block (bindings, erase e), typ e, usage_builder (usages e) | Regex r -> Regex (type_regex context r), - Instantiate.alias "Regex" [] context.alias_env, + Instantiate.alias "Regex" [] context.tycon_env, Usage.empty | Projection (r,l) -> (* From b35a3da42579bde710428b625f75d66f59c80a16 Mon Sep 17 00:00:00 2001 From: RJ Date: Mon, 30 May 2022 16:52:09 +0100 Subject: [PATCH 26/63] fixes & add primary kind in aliases --- core/defaultAliases.ml | 6 ++-- core/desugarDatatypes.ml | 57 +++++++++++++---------------- core/desugarEffects.ml | 15 +++----- core/desugarPages.ml | 2 +- core/generalise.ml | 2 +- core/instantiate.ml | 12 +++---- core/irCheck.ml | 4 +-- core/irTraversals.ml | 2 +- core/lens_type_conv.ml | 4 +-- core/lib.ml | 4 +-- core/parser.mly | 23 +++--------- core/sugarTraversals.ml | 21 ----------- core/sugarTraversals.mli | 3 -- core/sugartypes.ml | 4 --- core/transformSugar.ml | 8 ++--- core/typeSugar.ml | 12 +++---- core/typeUtils.ml | 4 +-- core/types.ml | 77 ++++++++++++++++++++-------------------- core/types.mli | 4 +-- core/typevarcheck.ml | 6 ++-- core/unify.ml | 4 +-- 21 files changed, 107 insertions(+), 167 deletions(-) diff --git a/core/defaultAliases.ml b/core/defaultAliases.ml index 54f127035..ab61de7f7 100644 --- a/core/defaultAliases.ml +++ b/core/defaultAliases.ml @@ -15,7 +15,7 @@ let alias_env : Types.tycon_environment = let wq, w = mk_arg () in let nq, n = mk_arg () in let th_alias_type = - `Alias ([rq; wq; nq], Types.make_tablehandle_alias (r, w, n)) + `Alias (pk_type, [rq; wq; nq], Types.make_tablehandle_alias (r, w, n)) in List.fold_left @@ -23,13 +23,13 @@ let alias_env : Types.tycon_environment = AliasEnv.bind name t env) AliasEnv.empty [ (* "String" , `Alias ([], `Application (Types.list, [`Type (`Primitive Primitive.Char)])); *) - "Xml" , `Alias ([], Types.Application (Types.list, [(PrimaryKind.Type, Types.Primitive Primitive.XmlItem)])); + "Xml" , `Alias (pk_type, [], Types.Application (Types.list, [(PrimaryKind.Type, Types.Primitive Primitive.XmlItem)])); "Event" , `Abstract Types.event; "List" , `Abstract Types.list; "Process" , `Abstract Types.process; "DomNode" , `Abstract Types.dom_node; "AP" , `Abstract Types.access_point; - "EndBang" , `Alias ([], Types.make_endbang_type); + "EndBang" , `Alias (pk_type, [], Types.make_endbang_type); "Socket" , `Abstract Types.socket; "ValidTime", `Abstract Types.valid_time_data; "TransactionTime", `Abstract Types.transaction_time_data; diff --git a/core/desugarDatatypes.ml b/core/desugarDatatypes.ml index d8741c2be..c0003268b 100644 --- a/core/desugarDatatypes.ml +++ b/core/desugarDatatypes.ml @@ -49,10 +49,6 @@ object (self) (_, None) -> {< all_desugared = false >} | _ -> self - method! fieldspec' = function - (_, None) -> {< all_desugared = false >} - | _ -> self - method! type_arg' = function (_, None) -> {< all_desugared = false >} | _ -> self @@ -158,9 +154,13 @@ module Desugar = struct in begin match SEnv.find_opt tycon alias_env with | None -> raise (UnboundTyCon (pos, tycon)) - | Some (`Alias (qs, _dt)) -> - let ts = match_quantifiers snd qs in - Instantiate.alias tycon ts alias_env + | Some (`Alias (k, qs, _dt)) -> + if k = pk_type then + let ts = match_quantifiers snd qs in + Instantiate.alias tycon ts alias_env + else + raise (TypeApplicationKindMismatch + {pos ; name = tycon; expected = "Type"; provided = (PrimaryKind.to_string k) ;tyarg_number=0}) | Some (`Abstract abstype) -> let ts = match_quantifiers identity (Abstype.arity abstype) in Application (abstype, ts) @@ -253,13 +253,16 @@ module Desugar = struct in begin match SEnv.find_opt name alias_env with | None -> raise (UnboundTyCon (node.pos, name)) - | Some (`Alias (qs, _r)) -> - let ts = match_quantifiers snd qs in - begin match Instantiate.alias name ts alias_env with - | Alias(_,body) -> body - | _ -> raise (internal_error "Instantiation failed") - end - (* Instantiate.effectalias name ts alias_env.effectname *) + | Some (`Alias (k, qs, _r)) -> + if k = pk_row then + let ts = match_quantifiers snd qs in + begin match Instantiate.alias name ts alias_env with + | Alias(PrimaryKind.Row, _, body) -> body + | _ -> raise (internal_error "Instantiation failed") + end + else + raise (TypeApplicationKindMismatch + {pos=node.pos ; name ; expected = "Row"; provided = (PrimaryKind.to_string k) ;tyarg_number=0}) | Some (`Abstract abstype) -> let ts = match_quantifiers identity (Abstype.arity abstype) in Application (abstype, ts) @@ -313,15 +316,11 @@ module Desugar = struct (dt, Some (datatype alias_env dt)) let row' alias_env ((r, _) :row') = - (r, Some (row alias_env r (WithPos.make (Datatype.Effect r)))) (* TODO(rj) should keep the pos *) - - let fieldspec' alias_env ((dt, _) : fieldspec') = - (dt, Some (fieldspec alias_env dt (WithPos.make (Datatype.End)))) + (r, Some (row alias_env r (WithPos.make (Datatype.Effect r)))) (* should we keep the pos ? have a real node ? *) let aliasbody alias_env = function | Typename dt' -> Typename (datatype' alias_env dt') | Effectname r' -> Effectname (row' alias_env r') - | Presencename p' -> Presencename (fieldspec' alias_env p') let type_arg' alias_env ((ta, _) : type_arg') : type_arg' = let unlocated = WithPos.make Datatype.Unit in @@ -433,10 +432,7 @@ object (self) (alias_env, WithPos.make ~pos (t, args, Typename (d, None)) :: ts) | Effectname (r,_) -> let alias_env = SEnv.bind t (`Mutual (qs, tygroup_ref)) alias_env in - (alias_env, WithPos.make ~pos (t, args, Effectname (r, None)) :: ts) - | Presencename (p,_) -> - let alias_env = SEnv.bind t (`Mutual (qs, tygroup_ref)) alias_env in - (alias_env, WithPos.make ~pos (t, args, Presencename (p, None)) :: ts) ) + (alias_env, WithPos.make ~pos (t, args, Effectname (r, None)) :: ts)) (alias_env, []) ts in (* Desugar all DTs, given the temporary new alias environment. *) @@ -447,7 +443,6 @@ object (self) let b' = match Desugar.aliasbody mutual_env b with | Typename (_, Some _) as b' -> b' | Effectname (_, Some _) as b' -> b' - | Presencename (_, Some _) as b' -> b' | _ -> raise (internal_error "Datatype not desugared") in WithPos.make ~pos (name, args, b') @@ -459,8 +454,7 @@ object (self) List.fold_left (fun (lin_map, dep_graph) mutual -> match SourceCode.WithPos.node mutual with | (name, _, Typename (_, dt)) - | (name, _, Effectname (_, dt)) - | (name, _, Presencename (_, dt)) -> + | (name, _, Effectname (_, dt)) -> let dt = OptionUtils.val_of dt in let lin_map = StringMap.add name (not @@ Unl.type_satisfies dt) lin_map in let deps = recursive_applications dt in @@ -498,14 +492,11 @@ object (self) let alias_env = List.fold_left (fun alias_env {node=(t, args, b); _} -> let semantic_qs = List.map SugarQuantifier.get_resolved_exn args in - let dt, alias_env = match b with - | Typename (_, dt') - | Effectname (_, dt') - | Presencename (_, dt') -> - let dt = OptionUtils.val_of dt' in - let alias_env = SEnv.bind t (`Alias (semantic_qs, dt)) alias_env in - (dt, alias_env) + let dt, k = match b with + | Typename (_, dt') -> OptionUtils.val_of dt', pk_type + | Effectname (_, dt') -> OptionUtils.val_of dt', pk_row in + let alias_env = SEnv.bind t (`Alias (k , semantic_qs, dt)) alias_env in tygroup_ref := { !tygroup_ref with type_map = (StringMap.add t (semantic_qs, dt) !tygroup_ref.type_map); diff --git a/core/desugarEffects.ml b/core/desugarEffects.ml index 16d880207..db95f5554 100644 --- a/core/desugarEffects.ml +++ b/core/desugarEffects.ml @@ -120,7 +120,7 @@ let simplify_tycon_env (tycon_env : Types.tycon_environment) : simple_tycon_env let simplify_tycon name tycon simpl_env = let param_kinds, internal_type = match tycon with - | `Alias (qs, tp) -> List.map Quantifier.to_kind qs, Some tp + | `Alias (_, qs, tp) -> List.map Quantifier.to_kind qs, Some tp | `Abstract abs -> Types.Abstype.arity abs, None | `Mutual _ -> raise (internal_error "Found `Mutual in global tycon env") in @@ -347,6 +347,9 @@ let cleanup_effects tycon_env = | None -> raise (Errors.UnboundTyCon (pos, name)) in TypeApplication (name, ts) + (* | Effect r -> (\* goal: same cleaning in the effectname declaration *\) *) + (* let r = self#effect_row ~allow_shared:`Disallow r in (\* what allow_shared should be ? *\) *) + (* Effect r *) | _ -> super#datatypenode t in SourceCode.WithPos.with_node dt res_t @@ -569,7 +572,7 @@ let gather_operation_of_type tp let (o, _) = o#typ r in let (o, _) = o#typ d in (o, tp) - | Alias ((_,kinds,tyargs,_), inner_tp) -> + | Alias (_, (_,kinds,tyargs,_), inner_tp) -> let o = o#alias_recapp kinds tyargs in let (o,_) = o#typ inner_tp in (o, tp) @@ -1112,13 +1115,6 @@ class main_traversal simple_tycon_env = let dep_graph = StringMap.add t (StringSet.elements used_mutuals) dep_graph in - (implicits, dep_graph) - | Presencename _ -> (* is this the right thing to do ? *) - let implicits = StringMap.add t false implicits in - let used_mutuals = StringSet.empty in - let dep_graph = - StringMap.add t (StringSet.elements used_mutuals) dep_graph - in (implicits, dep_graph)) (StringMap.empty, StringMap.empty) ts @@ -1172,7 +1168,6 @@ class main_traversal simple_tycon_env = let b' = match b with | Typename (d,_) -> Typename (d, None) | Effectname (r,_) -> Effectname (r, None) - | Presencename (p,_) -> Presencename (p, None) in ( tycon_env, shared_var_env, diff --git a/core/desugarPages.ml b/core/desugarPages.ml index 8ad49c2d4..ad433d5b0 100644 --- a/core/desugarPages.ml +++ b/core/desugarPages.ml @@ -50,7 +50,7 @@ let rec desugar_page (o, page_type) = let formlet_type = Types.concrete_type formlet_type in let a = Types.fresh_type_variable (lin_any, res_any) in let b = Types.fresh_type_variable (lin_any, res_any) in - Unify.datatypes (Types.Alias (("Formlet", [(Type, default_subkind)], [(Type, a)], false), b), formlet_type); + Unify.datatypes (Types.Alias (pk_type, ("Formlet", [(Type, default_subkind)], [(Type, a)], false), b), formlet_type); fn_appl "formP" [(Type, a); (Row, o#lookup_effects)] [formlet; handler; attributes] | PagePlacement (page) -> page | Xml ("#", [], _, children) -> diff --git a/core/generalise.ml b/core/generalise.ml index fea2713a5..710854632 100644 --- a/core/generalise.ml +++ b/core/generalise.ml @@ -30,7 +30,7 @@ let rec get_type_args : gen_kind -> TypeVarSet.t -> datatype -> type_arg list = | Not_typed -> raise (internal_error "Not_typed encountered in get_type_args") | (Var _ | Recursive _) -> failwith ("freestanding Var / Recursive not implemented yet (must be inside Meta)") - | Alias ((_, _, ts, _), t) -> + | Alias (_, (_, _, ts, _), t) -> concat_map (get_type_arg_type_args kind bound_vars) ts @ gt t | Application (_, args) -> Utility.concat_map (get_type_arg_type_args kind bound_vars) args diff --git a/core/instantiate.ml b/core/instantiate.ml index dca06b557..a35a82303 100644 --- a/core/instantiate.ml +++ b/core/instantiate.ml @@ -86,8 +86,8 @@ let instantiates : instantiation_maps -> (datatype -> datatype) * (row -> row) * List.fold_left remove_shadowed_quantifier inst_map qs in ForAll (qs, inst_typ updated_inst_map rec_env t) - | Alias ((name, qs, ts, is_dual), d) -> - Alias ((name, qs, List.map instta ts, is_dual), inst d) + | Alias (k, (name, qs, ts, is_dual), d) -> + Alias (k, (name, qs, List.map instta ts, is_dual), inst d) | Application (n, elem_type) -> Application (n, List.map instta elem_type) | RecursiveApplication app -> @@ -169,7 +169,7 @@ let instantiates : instantiation_maps -> (datatype -> datatype) * (row -> row) * match t with | Row _ -> t | Meta row_var -> Row (StringMap.empty, row_var, false) - | Alias (_,row) -> row + | Alias (PrimaryKind.Row, _,row) -> row | _ -> assert false in let instr = inst_row inst_map rec_env in let dual_if = if dual then dual_row else fun x -> x in @@ -438,15 +438,15 @@ let alias name tyargs env : Types.typ = | Some (`Abstract _) | Some (`Mutual _) -> raise (internal_error (Printf.sprintf "The type constructor: %s is not an alias" name)) - | Some (`Alias (vars, _)) when List.length vars <> List.length tyargs -> + | Some (`Alias (_, vars, _)) when List.length vars <> List.length tyargs -> raise (internal_error (Printf.sprintf "Type alias %s applied with incorrect arity (%d instead of %d). This should have been checked prior to instantiation." name (List.length tyargs) (List.length vars))) - | Some (`Alias (vars, body)) -> + | Some (`Alias (k, vars, body)) -> let inst_map = populate_instantiation_map ~name vars tyargs in (* instantiate the type variables bound by the alias definition with the type arguments *and* instantiate any top-level quantifiers *) let (_, body) = typ (instantiate_datatype inst_map body) in - Alias ((name, List.map snd vars, tyargs, false), body) + Alias (k, (name, List.map snd vars, tyargs, false), body) diff --git a/core/irCheck.ml b/core/irCheck.ml index 83fc4c725..44313a2be 100644 --- a/core/irCheck.ml +++ b/core/irCheck.ml @@ -180,7 +180,7 @@ let rec is_toplevel_rec_type = function | T.Recursive _ -> true | _ -> false end - | T.Alias (_, t') -> is_toplevel_rec_type t' + | T.Alias (_, _, t') -> is_toplevel_rec_type t' | _ -> false let is_toplevel_rec_row row = @@ -254,7 +254,7 @@ let eq_types occurrence : type_eq_context -> (Types.datatype * Types.datatype) - end | (Var _ | Recursive _ | Closed) -> raise Types.tag_expectation_mismatch - | Alias (_, _) -> assert false + | Alias _ -> assert false | Application (s, ts) -> begin match t2 with | Application (s', ts') -> diff --git a/core/irTraversals.ml b/core/irTraversals.ml index 920f78768..64d4b731b 100644 --- a/core/irTraversals.ml +++ b/core/irTraversals.ml @@ -968,7 +968,7 @@ module ElimTypeAliases = struct inherit Types.Transform.visitor as super method! typ = function - | Types.Alias (_, typ) -> o#typ typ + | Types.Alias (_, _, typ) -> o#typ typ | other -> super#typ other end diff --git a/core/lens_type_conv.ml b/core/lens_type_conv.ml index ba09cd3f7..d971c0fe9 100644 --- a/core/lens_type_conv.ml +++ b/core/lens_type_conv.ml @@ -13,9 +13,9 @@ let to_links_map m = let lookup_alias context ~alias = match Env.String.find_opt alias context with - | Some (`Alias (_, body)) -> + | Some (`Alias (k, _, body)) -> let tycon = (alias, [], [], false) in - T.Alias (tycon, body) + T.Alias (k, tycon, body) | _ -> Errors.MissingBuiltinType alias |> raise let rec type_of_lens_phrase_type ~context t = diff --git a/core/lib.ml b/core/lib.ml index 1fdc340a8..f5f9ac2ba 100644 --- a/core/lib.ml +++ b/core/lib.ml @@ -23,10 +23,10 @@ module AliasEnv = Env.String let alias_env : Types.tycon_environment = DefaultAliases.alias_env let alias_env : Types.tycon_environment = - AliasEnv.bind "Repeat" (`Alias ([], (DesugarDatatypes.read ~aliases:alias_env Linksregex.Repeat.datatype))) alias_env + AliasEnv.bind "Repeat" (`Alias (pk_type, [], (DesugarDatatypes.read ~aliases:alias_env Linksregex.Repeat.datatype))) alias_env let alias_env : Types.tycon_environment = - AliasEnv.bind "Regex" (`Alias ([], (DesugarDatatypes.read ~aliases:alias_env Linksregex.Regex.datatype))) alias_env + AliasEnv.bind "Regex" (`Alias (pk_type, [], (DesugarDatatypes.read ~aliases:alias_env Linksregex.Regex.datatype))) alias_env let datatype = DesugarDatatypes.read ~aliases:alias_env diff --git a/core/parser.mly b/core/parser.mly index fa081c7ba..1d923d458 100644 --- a/core/parser.mly +++ b/core/parser.mly @@ -173,21 +173,7 @@ let attach_row_subkind (r, subkind) = | _ -> assert false in attach_subkind_helper update subkind -let alias p name args kind body = - let aliasbody = - match kind, body with - | (Some PrimaryKind.Type , _), Datatype.Type b -> - Typename (b, None) - | (Some PrimaryKind.Row , _), Datatype.Row b -> - Effectname (b, None) - | (Some PrimaryKind.Row , _), Datatype.Type ({ WithPos.node = Datatype.TypeApplication(name, args) ; _ }) -> - let b = ([], Datatype.EffectApplication(name, args)) in - Effectname (b, None) - | (Some PrimaryKind.Presence, _), Datatype.Presence b -> - Presencename (b, None) - (* raise (ConcreteSyntaxError (pos p, "Presence aliases unsupported")) *) - | _ -> raise (ConcreteSyntaxError (pos p, "Kind mismatch")) - in +let alias p name args aliasbody = with_pos p (Aliases [with_pos p (name, args, aliasbody)]) let labels xs = fst (List.split xs) @@ -430,7 +416,6 @@ arg: | UFLOAT { string_of_float' $1 } | TRUE { "true" } | FALSE { "false" } -| DEFAULT { "default" } var: | VARIABLE { with_pos $loc $1 } @@ -524,9 +509,9 @@ signature: | SIG sigop COLON datatype { with_pos $loc ($2, datatype $4) } typedecl: -| TYPENAME CONSTRUCTOR typeargs_opt EQ datatype { alias $loc $2 $3 (Some pk_type, None) (Datatype.Type $5) } -| EFFECTNAME CONSTRUCTOR typeargs_opt EQ type_arg { alias $loc $2 $3 (Some pk_row , Some (lin_unl, res_effect)) $5 } -| TYPENAME CONSTRUCTOR typeargs_opt kind EQ type_arg { alias $loc $2 $3 $4 $6 } +| TYPENAME CONSTRUCTOR typeargs_opt EQ datatype { alias $loc $2 $3 (Typename ( $5 , None)) } +| EFFECTNAME CONSTRUCTOR typeargs_opt EQ LBRACE erow RBRACE { alias $loc $2 $3 (Effectname ( $6 , None)) } +| EFFECTNAME CONSTRUCTOR typeargs_opt EQ effect_app { alias $loc $2 $3 (Effectname (([], $5), None)) } (* Lists of quantifiers in square brackets denote type abstractions *) type_abstracion_vars: diff --git a/core/sugarTraversals.ml b/core/sugarTraversals.ml index b7ce85f31..e15e4af32 100644 --- a/core/sugarTraversals.ml +++ b/core/sugarTraversals.ml @@ -176,12 +176,6 @@ class map = let y = o#option (fun o -> o#typ) y in (x,y) - method fieldspec' : fieldspec' -> fieldspec' = - fun (x, y) -> - let x = o#fieldspec x in - let y = o#option (fun o -> o#typ) y in - (x,y) - method given_spawn_location : given_spawn_location -> given_spawn_location = function | ExplicitSpawnLocation p -> ExplicitSpawnLocation (o#phrase p) @@ -807,7 +801,6 @@ class map = function | Typename _x -> Typename (o#datatype' _x) | Effectname _x -> Effectname (o#row' _x) - | Presencename _x -> Presencename (o#fieldspec' _x) method alias : alias -> alias = fun p -> @@ -1023,12 +1016,6 @@ class fold = let o = o#unknown y in o - method fieldspec' : fieldspec' -> 'self_type = - fun (x, y) -> - let o = o#fieldspec x in - let o = o#unknown y in - o - method given_spawn_location : given_spawn_location -> 'self_type = function | ExplicitSpawnLocation p -> let o = o#phrase p in o | _ -> o @@ -1585,7 +1572,6 @@ class fold = function | Typename _x -> o#datatype' _x | Effectname _x -> o#row' _x - | Presencename _x -> o#fieldspec' _x method alias : alias -> 'self_type = WithPos.traverse @@ -2335,12 +2321,6 @@ class fold_map = let (o, _x_i1) = o#option (fun o -> o#typ) _x_i1 in (o, (_x, _x_i1)) - method fieldspec' : fieldspec' -> ('self_type * fieldspec') = - fun (_x, _x_i1) -> - let (o, _x) = o#fieldspec _x in - let (o, _x_i1) = o#option (fun o -> o#typ) _x_i1 - in (o, (_x, _x_i1)) - method datatypenode : Datatype.t -> ('self_type * Datatype.t) = let open Datatype in function @@ -2529,7 +2509,6 @@ class fold_map = function | Typename _x -> let o, _x = o#datatype' _x in (o, Typename _x) | Effectname _x -> let o, _x = o#row' _x in (o, Effectname _x) - | Presencename _x -> let o, _x = o#fieldspec' _x in (o, Presencename _x) method function_definition : function_definition -> 'self * function_definition = fun { fun_binder; diff --git a/core/sugarTraversals.mli b/core/sugarTraversals.mli index 34443b9b9..d3fb2a34d 100644 --- a/core/sugarTraversals.mli +++ b/core/sugarTraversals.mli @@ -64,7 +64,6 @@ class map : method datatypenode : Datatype.t -> Datatype.t method datatype' : datatype' -> datatype' method row' : row' -> row' - method fieldspec' : fieldspec' -> fieldspec' method type_arg : Datatype.type_arg -> Datatype.type_arg method type_arg' : type_arg' -> type_arg' method constant : Constant.t -> Constant.t @@ -149,7 +148,6 @@ class fold : method datatypenode : Datatype.t -> 'self method datatype' : datatype' -> 'self method row' : row' -> 'self - method fieldspec' : fieldspec' -> 'self method type_arg : Datatype.type_arg -> 'self method type_arg' : type_arg' -> 'self method constant : Constant.t -> 'self @@ -196,7 +194,6 @@ object ('self) method datatypenode : Datatype.t -> 'self * Datatype.t method datatype' : datatype' -> 'self * datatype' method row' : row' -> 'self * row' - method fieldspec' : fieldspec' -> 'self * fieldspec' method type_arg' : type_arg' -> 'self * type_arg' method directive : directive -> 'self * directive method fieldconstraint : fieldconstraint -> 'self * fieldconstraint diff --git a/core/sugartypes.ml b/core/sugartypes.ml index 8ad62bc39..b17421516 100644 --- a/core/sugartypes.ml +++ b/core/sugartypes.ml @@ -231,9 +231,6 @@ type datatype' = Datatype.with_pos * Types.datatype option type row' = Datatype.row * Types.row option [@@deriving show] -type fieldspec' = Datatype.fieldspec * Types.field_spec option - [@@deriving show] - type type_arg' = Datatype.type_arg * Types.type_arg option [@@deriving show] @@ -553,7 +550,6 @@ and alias = aliasnode WithPos.t and aliasbody = | Typename of datatype' | Effectname of row' - | Presencename of fieldspec' and function_definition = { fun_binder: Binder.with_pos; fun_linearity: DeclaredLinearity.t; diff --git a/core/transformSugar.ml b/core/transformSugar.ml index 8805ace40..0be2a390e 100644 --- a/core/transformSugar.ml +++ b/core/transformSugar.ml @@ -893,16 +893,12 @@ class transform (env : Types.typing_environment) = match b with | Typename (x, (Some dt as dt')) -> let o = o#bind_tycon name - (`Alias (List.map (SugarQuantifier.get_resolved_exn) vars, dt)) in + (`Alias (pk_type, List.map (SugarQuantifier.get_resolved_exn) vars, dt)) in (o, WithPos.make ~pos (name, vars, Typename (x, dt'))) | Effectname (x, (Some r as r')) -> let o = o#bind_tycon name - (`Alias (List.map (SugarQuantifier.get_resolved_exn) vars, r)) in + (`Alias (pk_row, List.map (SugarQuantifier.get_resolved_exn) vars, r)) in (o, WithPos.make ~pos (name, vars, Effectname (x, r'))) - | Presencename (x, (Some p as p')) -> - let o = o#bind_tycon name - (`Alias (List.map (SugarQuantifier.get_resolved_exn) vars, p)) in - (o, WithPos.make ~pos (name, vars, Presencename (x, p'))) | _ -> raise (internal_error "Unannotated type alias") ) ts in (o, Aliases ts) diff --git a/core/typeSugar.ml b/core/typeSugar.ml index 29875de8f..08b76aa95 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -1918,7 +1918,7 @@ let close_pattern_type : Pattern.with_pos list -> Types.datatype -> Types.dataty let open Types in let rec cpt : Pattern.with_pos list -> Types.datatype -> Types.datatype = fun pats t -> match t with - | Alias (alias, t) -> Alias (alias, cpt pats t) + | Alias (k, alias, t) -> Alias (k, alias, cpt pats t) | Record row when Types.is_tuple row-> let fields, row_var, dual = Types.unwrap_row row |> fst |> TypeUtils.extract_row_parts in let rec unwrap_at i p = @@ -4850,10 +4850,10 @@ and type_binding : context -> binding -> binding * context * Usage.t = | Aliases ts -> let env = List.fold_left (fun env {node=(name, vars, b); _} -> match b with - | Typename (_, Some dt) - | Effectname (_, Some dt) - | Presencename (_, Some dt) -> - bind_alias env (name, `Alias (List.map (SugarQuantifier.get_resolved_exn) vars, dt)) + | Typename (_, Some dt) -> + bind_alias env (name, `Alias (pk_type, List.map (SugarQuantifier.get_resolved_exn) vars, dt)) + | Effectname (_, Some dt) -> + bind_alias env (name, `Alias (pk_row , List.map (SugarQuantifier.get_resolved_exn) vars, dt)) | _ -> raise (internal_error "typeSugar.ml: unannotated type") ) empty_context ts in (Aliases ts, env, Usage.empty) @@ -4942,7 +4942,7 @@ and type_cp (context : context) = fun {node = p; pos} -> CPUnquote (bindings, e), t, usage_builder u | CPGrab ((c, _), None, p) -> let (_, t, _) = type_check context (var c) in - let ctype = T.Alias (("EndQuery", [], [], false), T.Input (Types.unit_type, T.End)) in + let ctype = T.Alias (pk_type, ("EndQuery", [], [], false), T.Input (Types.unit_type, T.End)) in unify ~pos:pos ~handle:(Gripers.cp_grab c) (t, ctype); let (p, pt, u) = type_cp (unbind_var context c) p in CPGrab ((c, Some (ctype, [])), None, p), pt, use c u diff --git a/core/typeUtils.ml b/core/typeUtils.ml index dba381b90..474bf55f7 100644 --- a/core/typeUtils.ml +++ b/core/typeUtils.ml @@ -237,7 +237,7 @@ let rec primary_kind_of_type t = failwith "Top-level Recursive should have been removed by concrete_type call" | Meta p -> primary_kind_of_type (Unionfind.find p) - | Alias (_, d) -> + | Alias (k, _, d) -> primary_kind_of_type d | Primitive _ | Function _ @@ -323,7 +323,7 @@ let check_type_wellformedness primary_kind t : unit = | (Var _ | Recursive _ | Closed) -> (* freestanding Var / Recursive / Closed not implemented yet (must be inside Meta) *) raise tag_expectation_mismatch - | Alias ((_name, qs, ts, _), d) -> + | Alias (_, (_name, qs, ts, _), d) -> List.iter2 (compare_kinds rec_env) qs ts; typ rec_env d | Application (abs_type, args) -> diff --git a/core/types.ml b/core/types.ml index ecc616185..40ac95117 100644 --- a/core/types.ml +++ b/core/types.ml @@ -138,7 +138,7 @@ and typ = | Not_typed | Var of (tid * Kind.t * Freedom.t) | Recursive of (tid * Kind.t * typ) - | Alias of ((string * Kind.t list * type_arg list * bool) * typ) + | Alias of (PrimaryKind.t * (string * Kind.t list * type_arg list * bool) * typ) | Application of (Abstype.t * type_arg list) | RecursiveApplication of rec_appl | Meta of typ point @@ -188,7 +188,7 @@ let is_present = function | _ -> failwith "Expected presence constructor." -type alias_type = Quantifier.t list * typ [@@deriving show] +type alias_type = PrimaryKind.t * Quantifier.t list * typ [@@deriving show] type tycon_spec = [ | `Alias of alias_type @@ -328,10 +328,10 @@ struct (o, Not_typed) | (Var _ | Recursive _ | Closed) -> failwith ("[0] freestanding Var / Recursive / Closed not implemented yet (must be inside Meta)") - | Alias ((name, params, args, is_dual), t) -> + | Alias (k, (name, params, args, is_dual), t) -> let (o, args') = o#type_args args in let (o, t') = o#typ t in - (o, Alias ((name, params, args', is_dual), t')) + (o, Alias (k, (name, params, args', is_dual), t')) | Application (con, args) -> let (o, args') = o#type_args args in (o, Application (con, args')) @@ -565,7 +565,7 @@ class virtual type_predicate = object(self) | Not_typed -> assert false | Var _ | Recursive _ | Closed -> failwith ("[1] freestanding Var / Recursive / Closed not implemented yet (must be inside Meta)") - | Alias (_, t) -> self#type_satisfies vars t + | Alias (_, _, t) -> self#type_satisfies vars t | Application (_, ts) -> (* This does assume that all abstract types satisfy the predicate. *) List.for_all (self#type_satisfies_arg vars) ts @@ -637,7 +637,7 @@ class virtual type_iter = object(self) | Not_typed -> assert false | Var _ | Recursive _ | Closed -> failwith ("[2] freestanding Var / Recursive / Closed not implemented yet (must be inside Meta)") - | Alias (_, t) -> self#visit_type vars t + | Alias (_, _, t) -> self#visit_type vars t | Application (_, ts) -> List.iter (self#visit_type_arg vars) ts | RecursiveApplication { r_args; _ } -> List.iter (self#visit_type_arg vars) r_args | Meta point -> self#visit_point self#visit_type vars point @@ -1159,7 +1159,7 @@ let free_type_vars, free_row_type_vars, free_tyarg_vars = S.union_all [free_type_vars' rec_vars r; free_type_vars' rec_vars w; free_type_vars' rec_vars n] | Lens _ -> S.empty - | Alias ((_, _, ts, _), datatype) -> + | Alias (_, (_, _, ts, _), datatype) -> S.union (S.union_all (List.map (free_tyarg_vars' rec_vars) ts)) (free_type_vars' rec_vars datatype) | Application (_, tyargs) -> S.union_all (List.map (free_tyarg_vars' rec_vars) tyargs) | RecursiveApplication { r_args; _ } -> @@ -1320,7 +1320,7 @@ let rec dual_type : var_map -> datatype -> datatype = | RecursiveApplication appl -> RecursiveApplication { appl with r_dual = (not appl.r_dual) } | End -> End - | Alias ((f,ks,args,isdual),t) -> Alias ((f,ks,args,not(isdual)),dt t) + | Alias (k, (f,ks,args,isdual),t) -> Alias (k, (f,ks,args,not(isdual)),dt t) | t -> raise (Invalid_argument ("Attempt to dualise non-session type: " ^ show_datatype @@ DecycleTypes.datatype t)) and dual_row : var_map -> row -> row = fun rec_points row -> @@ -1355,7 +1355,7 @@ and subst_dual_type : var_map -> datatype -> datatype = | Table (t, r, w, n) -> Table (t, sdt r, sdt w, sdt n) | Lens _sort -> t (* TODO: we could do a check to see if we can preserve aliases here *) - | Alias (_, t) -> sdt t + | Alias (_, _, t) -> sdt t | Application (abs, ts) -> Application (abs, List.map (subst_dual_type_arg rec_points) ts) | RecursiveApplication app -> (* I don't think we need to do anything with the dualisation flag @@ -1428,11 +1428,12 @@ and flatten_row : row -> row = fun row -> | Row _ -> row (* HACK: this probably shouldn't happen! *) | Meta row_var -> Row (StringMap.empty, row_var, false) - | Alias (_, row) -> row + (* | Alias (PrimaryKind.Row, _, row) -> row *) (* | RecursiveApplication { r_dual ; r_args ; r_unwind ; _ } -> *) (* (\* TODO(rj) what should this function do ? r_unwind like this provokes a stack overflow *\) *) (* r_unwind r_args r_dual *) - | _ -> assert false in + | _ -> Debug.print ("row: " ^ show_row row) ; assert false + in let dual_if = match row with | Row (_, _, dual) -> @@ -1562,8 +1563,8 @@ and normalise_datatype rec_names t = | Effect row -> Effect (nr row) | Table (t, r, w, n) -> Table (t, nt r, nt w, nt n) | Lens sort -> Lens sort - | Alias ((name, qs, ts, is_dual), datatype) -> - Alias ((name, qs, ts, is_dual), nt datatype) + | Alias (k, (name, qs, ts, is_dual), datatype) -> + Alias (k, (name, qs, ts, is_dual), nt datatype) | Application (abs, tyargs) -> Application (abs, List.map (normalise_type_arg rec_names) tyargs) | RecursiveApplication app -> @@ -1674,7 +1675,7 @@ let bool_type = Primitive Primitive.Bool let int_type = Primitive Primitive.Int let float_type = Primitive Primitive.Float let datetime_type = Primitive Primitive.DateTime -let xml_type = Alias (("Xml", [], [], false), Application (list, [(PrimaryKind.Type, Primitive Primitive.XmlItem)])) +let xml_type = Alias (pk_type, ("Xml", [], [], false), Application (list, [(PrimaryKind.Type, Primitive Primitive.XmlItem)])) let database_type = Primitive Primitive.DB (* Empty type, used for exceptions *) let empty_type = Variant (make_empty_closed_row ()) @@ -1735,7 +1736,7 @@ exception TypeDestructionError of string let concrete_type' t = let rec ct rec_names t : datatype = match t with - | Alias (_, t) -> ct rec_names t + | Alias (_, _, t) -> ct rec_names t | Meta point -> begin match Unionfind.find point with @@ -1828,7 +1829,7 @@ struct | Not_typed -> [] | Var _ | Recursive _ | Closed -> failwith ("[10] freestanding Var / Recursive / Closed not implemented yet (must be inside Meta)") - | Alias ((_, _, ts, _), _) -> + | Alias (_, (_, _, ts, _), _) -> concat_map (free_bound_tyarg_vars bound_vars) ts | Application (_, tyargs) -> List.concat (List.map (free_bound_tyarg_vars bound_vars) tyargs) @@ -1911,7 +1912,7 @@ struct (TypeVarSet.add var bound_vars, (var, spec)::vars)) (bound_vars, []) tyvars in (bound_vars, List.rev vars) in match tycon_spec with - | `Alias (tyvars, body) -> + | `Alias (k, tyvars, body) -> let (bound_vars, vars) = split_vars tyvars in vars @ (free_bound_type_vars bound_vars body) | `Mutual (tyvars, _) -> snd (split_vars tyvars) @@ -2283,7 +2284,7 @@ struct (** If this type may contain a shared effect. *) let maybe_shared_effect = function | Function _ | Lolli _ -> true - | Alias ((_, qs, _, _), _) | RecursiveApplication { r_quantifiers = qs; _ } -> + | Alias (_, (_, qs, _, _), _) | RecursiveApplication { r_quantifiers = qs; _ } -> begin match ListUtils.last_opt qs with | Some (PrimaryKind.Row, (_, Restriction.Effect)) -> true | _ -> false @@ -2307,7 +2308,7 @@ struct match t with | Function (_, _, r) | Lolli (_, _, r) when maybe_shared_effect r -> find_shared_var r | Function (_, e, _) | Lolli (_, e, _) -> find_row_var e - | Alias ((_, _, ts, _), _) | RecursiveApplication { r_args = ts; _ } when maybe_shared_effect t -> + | Alias (_, (_, _, ts, _), _) | RecursiveApplication { r_args = ts; _ } when maybe_shared_effect t -> begin match ListUtils.last ts with | (PrimaryKind.Row, (Row _ as r)) -> find_row_var r | _ -> None @@ -2512,7 +2513,7 @@ struct | Not_typed -> "not typed" | Var _ | Recursive _ | Closed -> failwith ("[11] freestanding Var / Recursive / Closed not implemented yet (must be inside Meta)") - | Alias ((s, _, ts, is_dual), _) | RecursiveApplication { r_name = s; r_args = ts; r_dual = is_dual; _ } -> + | Alias (_, (s, _, ts, is_dual), _) | RecursiveApplication { r_name = s; r_args = ts; r_dual = is_dual; _ } -> let ts = match ListUtils.unsnoc_opt ts, context.shared_effect with | Some (ts, (PrimaryKind.Row, (Row r as r'))), Some v when maybe_shared_effect t && is_row_var v r -> @@ -2722,7 +2723,7 @@ struct TypeVarSet.add (Quantifier.to_var tyvar) bound_vars) bound_vars tyvars in function - | `Alias (tyvars, body) -> + | `Alias (k, tyvars, body) -> let ctx = { context with bound_vars = bound_vars tyvars } in begin match tyvars with @@ -2739,7 +2740,7 @@ struct TypeVarSet.add (Quantifier.to_var tyvar) bound_vars) bound_vars tyvars in function - | `Alias (tyvars, body) -> + | `Alias (k, tyvars, body) -> let ctx = { context with bound_vars = bound_vars tyvars } in begin match tyvars with @@ -2936,7 +2937,7 @@ module RoundtripPrinter : PRETTY_PRINTER = struct need those to share an effect variable, we only need to look at the surface (here the kinds of type arguments), because if this has a shared effect, it must be visible in type arguments *) - | Alias ((_, kinds, _, _), _) + | Alias (_, (_, kinds, _, _), _) | RecursiveApplication { r_quantifiers = kinds; _ } -> begin (* by convention, if the alias has an argument containing shared effect, it @@ -2979,7 +2980,7 @@ module RoundtripPrinter : PRETTY_PRINTER = struct (* alternatively, this is the rightmost alias, which can also have a shared effect - this is by convention the last argument *) - | Alias ((_,_,type_args,_), _) + | Alias (_, (_,_,type_args,_), _) | RecursiveApplication { r_args = type_args ; _ } when implicit_allowed_in tp -> begin @@ -3089,7 +3090,7 @@ module RoundtripPrinter : PRETTY_PRINTER = struct let (o, _) = o#effect_row e in let (o, _) = o#typ r in (o, tp) - | Alias ((_,kinds,tyargs,_), _) + | Alias (_, (_,kinds,tyargs,_), _) | RecursiveApplication { r_quantifiers = kinds; r_args = tyargs ; _ } -> (o#alias_recapp kinds tyargs, tp) | _ -> super#typ tp @@ -3266,7 +3267,7 @@ module RoundtripPrinter : PRETTY_PRINTER = struct (** Deconstruct Alias, let tyarg_list handle it *) method alias : typ -> 'self_type * typ = fun al -> - let ((name, kinds, tyargs, dual), tp) = match al with + let (k, (name, kinds, tyargs, dual), tp) = match al with | Alias a -> a | _ -> assert false in @@ -3276,7 +3277,7 @@ module RoundtripPrinter : PRETTY_PRINTER = struct else o#tyarg_list kinds tyargs in (* let (o, tp) = o#typ tp in *) - let al = Alias ((name, kinds, tyargs, dual), tp) in + let al = Alias (k, (name, kinds, tyargs, dual), tp) in (o, al) (** Deconstruct Rec.App., let tyarg_list handle it *) @@ -4028,7 +4029,7 @@ module RoundtripPrinter : PRETTY_PRINTER = struct | Var (vid, knd, _) -> with_value var (vid, knd) | Recursive v -> with_value recursive v | Application a -> with_value application a - | Alias ((name, arg_kinds, arg_types, is_dual), _) + | Alias (_, (name, arg_kinds, arg_types, is_dual), _) | RecursiveApplication { r_name = name; r_quantifiers = arg_kinds ; r_args = arg_types; r_dual = is_dual; _ } -> with_value alias_recapp (name, arg_kinds, arg_types, is_dual) @@ -4107,7 +4108,7 @@ module RoundtripPrinter : PRETTY_PRINTER = struct = let open Printer in Printer (fun ctx v buf -> match v with - | `Alias (tyvars, body) -> + | `Alias (k, tyvars, body) -> let ctx = Context.bind_tyvars (List.map Quantifier.to_var tyvars) ctx in begin match tyvars with @@ -4150,7 +4151,7 @@ module DerivedPrinter : PRETTY_PRINTER = struct let string_of_tycon_spec : Policy.t -> names -> tycon_spec -> string = fun _policy _names tycon -> let decycle_tycon_spec = function - | `Alias (qlist, ty) -> `Alias (List.map DecycleTypes.quantifier qlist, DecycleTypes.datatype ty) + | `Alias (k, qlist, ty) -> `Alias (k, List.map DecycleTypes.quantifier qlist, DecycleTypes.datatype ty) | other -> other in show_tycon_spec (decycle_tycon_spec tycon) @@ -4377,7 +4378,7 @@ let make_fresh_envs : datatype -> datatype IntMap.t * row IntMap.t * field_spec | Effect row | Record row | Variant row -> make_env boundvars row | Table (_, r, w, n) -> union [make_env boundvars r; make_env boundvars w; make_env boundvars n] | Lens _ -> empties - | Alias ((_, _, ts, _), d) -> union (List.map (make_env_ta boundvars) ts @ [make_env boundvars d]) + | Alias (_, (_, _, ts, _), d) -> union (List.map (make_env_ta boundvars) ts @ [make_env boundvars d]) | Application (_, ds) -> union (List.map (make_env_ta boundvars) ds) | RecursiveApplication { r_args ; _ } -> union (List.map (make_env_ta boundvars) r_args) | ForAll (qs, t) -> @@ -4508,10 +4509,10 @@ let is_sub_type, is_sub_row = | Recursive _ -> false | t' -> is_sub_type rec_vars (t, t') end - | Alias ((name, [], [], is_dual), _), Alias ((name', [], [], is_dual'), _) - when name=name' && is_dual=is_dual' -> true - | (Alias (_, t)), t' - | t, (Alias (_, t')) -> is_sub_type rec_vars (t, t') + | Alias (k, (name, [], [], is_dual), _), Alias (k', (name', [], [], is_dual'), _) + when k=k' && name=name' && is_dual=is_dual' -> true + | (Alias (_, _, t)), t' + | t, (Alias (_, _, t')) -> is_sub_type rec_vars (t, t') | ForAll _, ForAll _ -> raise (internal_error "not implemented subtyping on forall types yet") | _, _ -> false @@ -4670,10 +4671,10 @@ let make_tablehandle_alias (r, w, n) = let kind = (PrimaryKind.Type, (lin_unl, res_any)) in let kinds = List.init 3 (fun _ -> kind) in let tyargs = List.map (fun x -> (PrimaryKind.Type, x)) [r; w; n] in - Alias (("TableHandle", kinds, tyargs, false), + Alias (pk_type, ("TableHandle", kinds, tyargs, false), Table (Temporality.current, r, w, n)) -let make_endbang_type : datatype = Alias (("EndBang", [], [], false), Output (unit_type, End)) +let make_endbang_type : datatype = Alias (pk_type, ("EndBang", [], [], false), Output (unit_type, End)) let make_function_type : ?linear:bool -> datatype list -> row -> datatype -> datatype = fun ?(linear=false) args effs range -> @@ -4734,7 +4735,7 @@ let pp_type_arg : Format.formatter -> type_arg -> unit = fun fmt t -> let pp_tycon_spec : Format.formatter -> tycon_spec -> unit = fun fmt t -> let decycle_tycon_spec = function - | `Alias (qlist, ty) -> `Alias (List.map DecycleTypes.quantifier qlist, DecycleTypes.datatype ty) + | `Alias (k, qlist, ty) -> `Alias (k, List.map DecycleTypes.quantifier qlist, DecycleTypes.datatype ty) | other -> other in if Settings.get print_types_pretty then diff --git a/core/types.mli b/core/types.mli index 1da7394d9..ccf5e2f42 100644 --- a/core/types.mli +++ b/core/types.mli @@ -129,7 +129,7 @@ and typ = | Not_typed | Var of (tid * Kind.t * Freedom.t) | Recursive of (tid * Kind.t * typ) - | Alias of ((string * Kind.t list * type_arg list * bool) * typ) + | Alias of (PrimaryKind.t * (string * Kind.t list * type_arg list * bool) * typ) | Application of (Abstype.t * type_arg list) | RecursiveApplication of rec_appl | Meta of typ point @@ -206,7 +206,7 @@ val get_restriction_constraint : Restriction.t -> (module Constraint) option val dual_row : row -> row val dual_type : datatype -> datatype -type alias_type = Quantifier.t list * typ [@@deriving show] +type alias_type = PrimaryKind.t * Quantifier.t list * typ [@@deriving show] type tycon_spec = [ | `Alias of alias_type diff --git a/core/typevarcheck.ml b/core/typevarcheck.ml index 214befbb4..ea99ecc68 100644 --- a/core/typevarcheck.ml +++ b/core/typevarcheck.ml @@ -33,7 +33,7 @@ let rec is_guarded : TypeVarSet.t -> StringSet.t -> int -> datatype -> bool = | Not_typed -> true | (Var _ | Recursive _) -> failwith ("freestanding Var / Recursive not implemented yet (must be inside Meta)") - | Alias (_, t) -> isg t + | Alias (k, _, t) -> isg t | Application (_, ts) -> (* don't treat abstract type constructors as guards *) List.for_all (is_guarded_type_arg bound_vars expanded_apps var) ts @@ -138,7 +138,7 @@ let rec is_negative : TypeVarSet.t -> StringSet.t -> int -> datatype -> bool = | Not_typed -> false | (Var _ | Recursive _) -> failwith ("freestanding Var / Recursive not implemented yet (must be inside Meta)") - | Alias (_, t) -> isn t + | Alias (_, _, t) -> isn t | Application (_, ts) -> List.exists (is_negative_type_arg bound_vars expanded_apps var) ts | RecursiveApplication { r_unique_name; r_args; r_unwind; r_dual; _ } -> @@ -225,7 +225,7 @@ and is_positive : TypeVarSet.t -> StringSet.t -> int -> datatype -> bool = | Not_typed -> false | (Var _ | Recursive _) -> failwith ("freestanding Var / Recursive not implemented yet (must be inside Meta)") - | Alias (_, t) -> isp t + | Alias (_, _, t) -> isp t | Application (_, ts) -> List.exists (is_positive_type_arg bound_vars expanded_apps var) ts | RecursiveApplication { r_unique_name; r_args; r_unwind; r_dual; _ } -> diff --git a/core/unify.ml b/core/unify.ml index 0d28bec09..f36cc0bf1 100644 --- a/core/unify.ml +++ b/core/unify.ml @@ -82,7 +82,7 @@ inside points *) let rec eq_types : (datatype * datatype) -> bool = fun (t1, t2) -> let rec unalias = function - | Alias (_, x) -> unalias x + | Alias (_, _, x) -> unalias x | x -> x in match unalias t1 with | Not_typed -> @@ -591,7 +591,7 @@ let rec unify' : unify_env -> (datatype * datatype) -> unit = Unionfind.change point t; *) | t' -> ut (t, t') end - | Alias (_, t1), t2 | t1, Alias (_, t2) -> ut (t1, t2) + | Alias (_, _, t1), t2 | t1, Alias (_, _, t2) -> ut (t1, t2) | Application (l, _), Application (r, _) when l <> r -> raise (Failure (`Msg ("Cannot unify abstract type '"^string_of_datatype t1^ From 69f29209d43b19dab3a46e66f6c13ff7fd5e1c39 Mon Sep 17 00:00:00 2001 From: RJ Date: Wed, 1 Jun 2022 17:07:43 +0100 Subject: [PATCH 27/63] new error kind mismatch --- core/desugarDatatypes.ml | 8 ++++---- core/errors.ml | 8 ++++++++ core/errors.mli | 3 +++ 3 files changed, 15 insertions(+), 4 deletions(-) diff --git a/core/desugarDatatypes.ml b/core/desugarDatatypes.ml index c0003268b..d2c46a9e9 100644 --- a/core/desugarDatatypes.ml +++ b/core/desugarDatatypes.ml @@ -159,8 +159,8 @@ module Desugar = struct let ts = match_quantifiers snd qs in Instantiate.alias tycon ts alias_env else - raise (TypeApplicationKindMismatch - {pos ; name = tycon; expected = "Type"; provided = (PrimaryKind.to_string k) ;tyarg_number=0}) + raise (TypeApplicationGlobalKindMismatch + {pos ; name = tycon; expected = "Type"; provided = (PrimaryKind.to_string k)}) | Some (`Abstract abstype) -> let ts = match_quantifiers identity (Abstype.arity abstype) in Application (abstype, ts) @@ -261,8 +261,8 @@ module Desugar = struct | _ -> raise (internal_error "Instantiation failed") end else - raise (TypeApplicationKindMismatch - {pos=node.pos ; name ; expected = "Row"; provided = (PrimaryKind.to_string k) ;tyarg_number=0}) + raise (TypeApplicationGlobalKindMismatch + {pos=node.pos ; name ; expected = "Row"; provided = (PrimaryKind.to_string k)}) | Some (`Abstract abstype) -> let ts = match_quantifiers identity (Abstype.arity abstype) in Application (abstype, ts) diff --git a/core/errors.ml b/core/errors.ml index 01c27d1f5..8f49a2d8a 100644 --- a/core/errors.ml +++ b/core/errors.ml @@ -47,6 +47,9 @@ exception TypeApplicationArityMismatch of exception TypeApplicationKindMismatch of { pos: Position.t; name: string; tyarg_number: int; expected: string; provided: string } +exception TypeApplicationGlobalKindMismatch of + { pos: Position.t; name: string; + expected: string; provided: string } exception SettingsError of string exception DynlinkError of string exception ModuleError of string * Position.t option @@ -131,6 +134,11 @@ let format_exception = pos_prefix ~pos (Printf.sprintf "Kind mismatch: Type argument %d for type constructor %s has kind %s, but an argument of kind %s was expected. \nIn:\n%s\n" tyarg_number name provided expected expr) + | TypeApplicationGlobalKindMismatch { pos; name; expected; provided } -> + let pos, expr = Position.resolve_start_expr pos in + pos_prefix ~pos + (Printf.sprintf "Kind mismatch: Type constructor %s has kind %s, but something of kind %s was expected. \nIn:\n%s\n" + name provided expected expr) | SettingsError message -> pos_prefix (Printf.sprintf "Settings Error: %s" message) | ModuleError (message, pos) -> diff --git a/core/errors.mli b/core/errors.mli index 4330b647d..f9e9365a5 100644 --- a/core/errors.mli +++ b/core/errors.mli @@ -34,6 +34,9 @@ exception TypeApplicationArityMismatch of exception TypeApplicationKindMismatch of { pos: Position.t; name: string; tyarg_number: int; expected: string; provided: string } +exception TypeApplicationGlobalKindMismatch of + { pos: Position.t; name: string; + expected: string; provided: string } exception SettingsError of string exception DynlinkError of string exception ModuleError of string * Position.t option From f88808d25cc0c89fbc38b3f2a15f85c6183b270b Mon Sep 17 00:00:00 2001 From: RJ Date: Fri, 3 Jun 2022 17:37:48 +0100 Subject: [PATCH 28/63] fresh label : init --- core/closures.ml | 16 ++++----- core/commonTypes.ml | 8 ++--- core/desugarCP.ml | 4 +-- core/desugarDatatypes.ml | 8 ++--- core/desugarFuns.ml | 2 +- core/generalise.ml | 6 ++-- core/instantiate.ml | 24 +++++++------- core/irCheck.ml | 12 +++---- core/label.ml | 45 +++++++++++++++++++++++++ core/label.mli | 25 ++++++++++++++ core/lens_type_conv.ml | 4 +-- core/lexer.mll | 1 + core/lib.ml | 2 +- core/parser.mly | 3 +- core/sugarTraversals.ml | 13 ++++++++ core/sugartypes.ml | 1 + core/transformSugar.ml | 2 +- core/typeSugar.ml | 6 ++-- core/typeUtils.ml | 22 ++++++------- core/types.ml | 71 +++++++++++++++++++++------------------- core/types.mli | 17 ++++++---- core/typevarcheck.ml | 8 ++--- core/unify.ml | 6 ++-- 23 files changed, 200 insertions(+), 106 deletions(-) create mode 100644 core/label.ml create mode 100644 core/label.mli diff --git a/core/closures.ml b/core/closures.ml index 7c7d2145f..2f8dea2a5 100644 --- a/core/closures.ml +++ b/core/closures.ml @@ -534,14 +534,14 @@ struct | [], [] -> o, None | _ -> let zt = - Types.make_record_type + Types.(make_record_type (List.fold_left (fun fields b -> let x = Var.var_of_binder b in let xt = Var.type_of_binder b in - StringMap.add (string_of_int x) xt fields) - StringMap.empty - zs) + FieldMap.add (Label.mk_int x) xt fields) + FieldMap.empty + zs)) in (* fresh variable for the closure environment *) let zb = Var.(fresh_binder (make_local_info (zt, "env_" ^ string_of_int f))) in @@ -610,14 +610,14 @@ struct | [], [] -> o, None | _ -> let zt = - Types.make_record_type + Types.(make_record_type (List.fold_left (fun fields b -> let x = Var.var_of_binder b in let xt = Var.type_of_binder b in - StringMap.add (string_of_int x) xt fields) - StringMap.empty - zs) + FieldMap.add (Label.mk_int x) xt fields) + FieldMap.empty + zs)) in (* fresh variable for the closure environment *) let zb = Var.(fresh_binder (make_local_info (zt, "env_" ^ string_of_int f))) in diff --git a/core/commonTypes.ml b/core/commonTypes.ml index 8db12331b..db615b72e 100644 --- a/core/commonTypes.ml +++ b/core/commonTypes.ml @@ -282,10 +282,10 @@ module Name = struct [@@deriving show] end -module Label = struct - type t = string - [@@deriving show] -end +(* module Label = struct *) +(* type t = string *) +(* [@@deriving show] *) +(* end *) module ForeignLanguage = struct type t = diff --git a/core/desugarCP.ml b/core/desugarCP.ml index dda621626..c26e278ca 100644 --- a/core/desugarCP.ml +++ b/core/desugarCP.ml @@ -115,10 +115,10 @@ object (o : 'self_type) let (eff_fields, eff_row, eff_closed) = Types.flatten_row o#lookup_effects |> TypeUtils.extract_row_parts in - let eff_fields = StringMap.remove wild_str eff_fields in + let eff_fields = Types.FieldMap.remove wild_str eff_fields in let eff_fields = if Settings.get Basicsettings.Sessions.exceptions_enabled then - StringMap.remove Value.session_exception_operation eff_fields + FieldMap.remove Value.session_exception_operation eff_fields else eff_fields in diff --git a/core/desugarDatatypes.ml b/core/desugarDatatypes.ml index d2c46a9e9..e1d0268d7 100644 --- a/core/desugarDatatypes.ml +++ b/core/desugarDatatypes.ml @@ -105,7 +105,7 @@ module Desugar = struct ForAll (qs, t) | Unit -> Types.unit_type | Tuple ks -> - let labels = map string_of_int (Utility.fromTo 1 (1 + length ks)) in + let labels = map Label.mk_int (Utility.fromTo 1 (1 + length ks)) in let unit = Types.make_empty_closed_row () in let present (s, x) = (s, Types.Present x) in @@ -288,7 +288,7 @@ module Desugar = struct | Closed -> Types.make_empty_closed_row () | Open srv -> let rv = SugarTypeVar.get_resolved_row_exn srv in - Types.Row (StringMap.empty, rv, false) + Types.Row (FieldMap.empty, rv, false) | Recursive (stv, r) -> let mrv = SugarTypeVar.get_resolved_row_exn stv in @@ -297,7 +297,7 @@ module Desugar = struct (* Turn mrv into a proper recursive row *) Unionfind.change mrv (Types.Recursive (var, sk, r)); - Types.Row (StringMap.empty, mrv, false) + Types.Row (FieldMap.empty, mrv, false) in let fields = List.map (fun (k, p) -> (k, fieldspec alias_env p node)) fields in @@ -341,7 +341,7 @@ module Desugar = struct let write_row, needed_row = match TypeUtils.concrete_type read_type with | Record (Row (fields, _, _)) -> - StringMap.fold + FieldMap.fold (fun label t (write, needed) -> match lookup label constraints with | Some cs -> diff --git a/core/desugarFuns.ml b/core/desugarFuns.ml index e87db890e..2be44d9d2 100644 --- a/core/desugarFuns.ml +++ b/core/desugarFuns.ml @@ -132,7 +132,7 @@ object (o : 'self_type) let (fields, rho, _) = TypeUtils.extract_row_parts row in let effb, row = fresh_row_quantifier default_effect_subkind in - let r = Record (Row (StringMap.add name (Present a) fields, rho, false)) in + let r = Record (Row (FieldMap.add name (Present a) fields, rho, false)) in let f = gensym ~prefix:"_fun_" () in let x = gensym ~prefix:"_fun_" () in diff --git a/core/generalise.ml b/core/generalise.ml index 710854632..ac32f6640 100644 --- a/core/generalise.ml +++ b/core/generalise.ml @@ -74,7 +74,7 @@ let rec get_type_args : gen_kind -> TypeVarSet.t -> datatype -> type_arg list = (* Row *) | Row (field_env, row_var, _) -> let field_vars = - StringMap.fold + FieldMap.fold (fun _ field_spec vars -> vars @ get_presence_type_args kind bound_vars field_spec ) field_env [] in @@ -145,7 +145,7 @@ let rigidify_type_arg : type_arg -> unit = | Type, Meta point -> rigidify_point point | Presence, Meta point -> rigidify_point point | Row, Row (fields, point, _dual) -> - assert (StringMap.is_empty fields); + assert (FieldMap.is_empty fields); rigidify_point point (* HACK: probably shouldn't happen *) | Row, Meta point -> rigidify_point point @@ -165,7 +165,7 @@ let mono_type_args : type_arg -> unit = | Type, Meta point -> check_sk point | Presence, Meta point -> check_sk point | Row, Row (fields, point, _dual) -> - assert (StringMap.is_empty fields); + assert (FieldMap.is_empty fields); check_sk point (* HACK: probably shouldn't happen *) | Row, Meta point -> check_sk point diff --git a/core/instantiate.ml b/core/instantiate.ml index a35a82303..4fe7ad13b 100644 --- a/core/instantiate.ml +++ b/core/instantiate.ml @@ -127,14 +127,14 @@ let instantiates : instantiation_maps -> (datatype -> datatype) * (row -> row) * | Closed -> true | _ -> false in - let field_env' = StringMap.fold + let field_env' = FieldMap.fold (fun label f field_env' -> let rec add = function - | Present t -> StringMap.add label (Present (inst t)) field_env' + | Present t -> FieldMap.add label (Present (inst t)) field_env' | Absent -> if is_closed then field_env' - else StringMap.add label Absent field_env' + else FieldMap.add label Absent field_env' | Meta point -> begin match Unionfind.find point with @@ -145,7 +145,7 @@ let instantiates : instantiation_maps -> (datatype -> datatype) * (row -> row) * else Meta point in - StringMap.add label f field_env' + FieldMap.add label f field_env' | f -> add f end @@ -156,9 +156,9 @@ let instantiates : instantiation_maps -> (datatype -> datatype) * (row -> row) * in add f) field_env - StringMap.empty in + FieldMap.empty in let field_env'', row_var', dual' = inst_row_var inst_map rec_env row_var dual |> TypeUtils.extract_row_parts in - Row (StringMap.fold StringMap.add field_env' field_env'', row_var', dual') + Row (FieldMap.fold FieldMap.add field_env' field_env'', row_var', dual') (* precondition: row_var has been flattened *) and inst_row_var : instantiation_maps -> inst_env -> row_var -> bool -> row = fun inst_map rec_env row_var dual -> (* HACK: fix the ill-formed rows that are introduced in the @@ -168,28 +168,28 @@ let instantiates : instantiation_maps -> (datatype -> datatype) * (row -> row) * let rowify t = match t with | Row _ -> t - | Meta row_var -> Row (StringMap.empty, row_var, false) + | Meta row_var -> Row (FieldMap.empty, row_var, false) | Alias (PrimaryKind.Row, _,row) -> row | _ -> assert false in let instr = inst_row inst_map rec_env in let dual_if = if dual then dual_row else fun x -> x in match Unionfind.find row_var with - | Closed -> Row (StringMap.empty, row_var, dual) + | Closed -> Row (FieldMap.empty, row_var, dual) | Var (var, _, _) -> if IntMap.mem var inst_map then dual_if (rowify (snd (IntMap.find var inst_map))) else - Row (StringMap.empty, row_var, dual) + Row (FieldMap.empty, row_var, dual) | Recursive (var, kind, rec_row) -> if IntMap.mem var rec_env then - Row (StringMap.empty, IntMap.find var rec_env, dual) + Row (FieldMap.empty, IntMap.find var rec_env, dual) else begin let var' = Types.fresh_raw_variable () in let point' = Unionfind.fresh (Var (var', kind, `Flexible)) in let rec_row' = inst_row inst_map (IntMap.add var point' rec_env) rec_row in let _ = Unionfind.change point' (Recursive (var', kind, rec_row')) in - Row (StringMap.empty, point', dual) + Row (FieldMap.empty, point', dual) end | row -> dual_if (instr row) @@ -233,7 +233,7 @@ let instantiate_typ : bool -> datatype -> (type_arg list * datatype) = fun rigid let open PrimaryKind in match Kind.primary_kind kind with | (Type | Presence) as pk -> pk, Meta point - | Row -> Row, Row (StringMap.empty, point, false) in + | Row -> Row, Row (FieldMap.empty, point, false) in IntMap.add var ty inst_env, ty :: tys in let inst_map, tys = diff --git a/core/irCheck.ml b/core/irCheck.ml index 44313a2be..230e23b35 100644 --- a/core/irCheck.ml +++ b/core/irCheck.ml @@ -222,7 +222,7 @@ let eq_types occurrence : type_eq_context -> (Types.datatype * Types.datatype) - row |> TypeUtils.extract_row_parts in if Types.is_closed_row row then let field_env' = - Utility.StringMap.filter + Types.FieldMap.filter ( fun _ v -> match v with | T.Absent -> false | _ -> true ) @@ -426,12 +426,12 @@ let eq_types occurrence : type_eq_context -> (Types.datatype * Types.datatype) - | _, _ -> false and eq_field_envs (context, lfield_env, rfield_env) = let lfields_in_rfields = - StringMap.for_all (fun field lp -> - match StringMap.find_opt field rfield_env with + FieldMap.for_all (fun field lp -> + match FieldMap.find_opt field rfield_env with | Some rp -> eq_presence (context, lp, rp) | None -> false ) lfield_env in - lfields_in_rfields && StringMap.cardinal lfield_env = StringMap.cardinal rfield_env + lfields_in_rfields && FieldMap.cardinal lfield_env = FieldMap.cardinal rfield_env and eq_row_vars (context, lpoint, rpoint) = match Unionfind.find lpoint, Unionfind.find rpoint with | Closed, Closed -> true @@ -469,9 +469,9 @@ let check_eq_type_lists = fun (ctx : type_eq_context) exptl actl occurrence -> let ensure_effect_present_in_row ctx allowed_effects required_effect_name required_effect_type occurrence = let (map, _, _) = fst (Types.unwrap_row allowed_effects) |> TypeUtils.extract_row_parts in - match StringMap.find_opt required_effect_name map with + match T.FieldMap.find_opt required_effect_name map with | Some (T.Present et) -> check_eq_types ctx et required_effect_type occurrence - | _ -> raise_ir_type_error ("Required effect " ^ required_effect_name ^ " not present in effect row " ^ Types.string_of_row allowed_effects) occurrence + | _ -> raise_ir_type_error ("Required effect " ^ Label.show required_effect_name ^ " not present in effect row " ^ Types.string_of_row allowed_effects) occurrence diff --git a/core/label.ml b/core/label.ml new file mode 100644 index 000000000..ee7326653 --- /dev/null +++ b/core/label.ml @@ -0,0 +1,45 @@ +open Utility +open CommonTypes + +module Label = struct + type local = Int.t + [@@deriving show] + type global = Name.t + [@@deriving show] + + type t = + | Lcl of local + | Gbl of global + [@@deriving show] + + let counter = ref 0 + + let mk_fresh () = Lcl (counter:=!counter+1 ; !counter) + + let mk_global name = Gbl name + + let make = mk_global + + let mk_int i = Gbl (string_of_int i) + + let get_int = function + | Gbl g -> int_of_string g + | _ -> failwith "local label" + + let compare lbl lbl' = match lbl,lbl' with + | Lcl l, Lcl l' -> Int.compare l l' + | Gbl g, Gbl g' -> String.compare g g' + | Lcl _, _ -> 1 + | Gbl _, _ -> -1 + + let is_local = function + | Lcl _ -> true + | _ -> false + + let is_global = function + | Gbl _ -> true + | _ -> false + + let one = Gbl "1" +end +include Label diff --git a/core/label.mli b/core/label.mli new file mode 100644 index 000000000..eac1b56ff --- /dev/null +++ b/core/label.mli @@ -0,0 +1,25 @@ +open CommonTypes + +type local = Int.t +type global = Name.t + +type t = + | Lcl of local + | Gbl of global + [@@deriving show] + +val mk_fresh : unit -> t + +val mk_global : Name.t -> t +val make : Name.t -> t + +val mk_int : Int.t -> t + +val get_int : t -> Int.t + +val compare : t -> t -> int + +val is_local : t -> bool +val is_global : t -> bool + +val one : t diff --git a/core/lens_type_conv.ml b/core/lens_type_conv.ml index d971c0fe9..5a97c8bef 100644 --- a/core/lens_type_conv.ml +++ b/core/lens_type_conv.ml @@ -8,8 +8,8 @@ type 'a die = string -> 'a let to_links_map m = String.Map.fold - (fun k v m -> Utility.StringMap.add k v m) - m Utility.StringMap.empty + (fun k v m -> T.FieldMap.add (Label.make k) v m) + m T.FieldMap.empty let lookup_alias context ~alias = match Env.String.find_opt alias context with diff --git a/core/lexer.mll b/core/lexer.mll index dc52081b6..74241a65a 100644 --- a/core/lexer.mll +++ b/core/lexer.mll @@ -78,6 +78,7 @@ let keywords = [ "false" , FALSE; "for" , FOR; "forall" , FORALL; + "fresh" , FRESH; "from" , FROM; "fun" , FUN; "formlet" , FORMLET; diff --git a/core/lib.ml b/core/lib.ml index f5f9ac2ba..570a9e897 100644 --- a/core/lib.ml +++ b/core/lib.ml @@ -1746,7 +1746,7 @@ let rec function_arity = function | Function (Record row, _, _) -> let (l, _, _) = TypeUtils.extract_row_parts row in - (Some (StringMap.size l)) + (Some (FieldMap.size l)) | ForAll (_, t) -> function_arity t | _ -> None diff --git a/core/parser.mly b/core/parser.mly index 1d923d458..378c5f1a3 100644 --- a/core/parser.mly +++ b/core/parser.mly @@ -347,7 +347,7 @@ let parse_foreign_language pos lang = %token SLASHFLAGS %token UNDERSCORE AS %token FIXITY -%token TYPENAME EFFECTNAME +%token TYPENAME EFFECTNAME FRESH %token TRY OTHERWISE RAISE %token OPERATOR %token USING @@ -452,6 +452,7 @@ nofun_declaration: | typedecl SEMICOLON { $1 } | links_module | links_open SEMICOLON { $1 } | pollute = boption(OPEN) IMPORT CONSTRUCTOR SEMICOLON { import ~ppos:$loc($2) ~pollute [$3] } +| FRESH CONSTRUCTOR LBRACE declarations RBRACE { with_pos $loc (FreshLabel($2, $4))} alien_datatype: | VARIABLE COLON datatype SEMICOLON { (binder ~ppos:$loc($1) $1, datatype $3) } diff --git a/core/sugarTraversals.ml b/core/sugarTraversals.ml index e15e4af32..e29c94bf7 100644 --- a/core/sugarTraversals.ml +++ b/core/sugarTraversals.ml @@ -784,6 +784,10 @@ class map = in let language = o#foreign_language (Alien.language alien) in AlienBlock (Alien.modify ~language ~declarations alien) + | FreshLabel(_x, _x_i1) -> + let _x = o#name _x in + let _x_i1 = o#list (fun o -> o#binding) _x_i1 in + FreshLabel(_x,_x_i1) method binding : binding -> binding = fun p -> @@ -1550,6 +1554,10 @@ class fold = let o = o#binder b in o#datatype' dt) (Alien.declarations alien) + | FreshLabel(_x, _x_i1) -> + let o = o#name _x in + let o = o#list (fun o -> o#binding) _x_i1 in + o method binding : binding -> 'self_type = WithPos.traverse @@ -2480,6 +2488,11 @@ class fold_map = (Alien.declarations alien) in o, AlienBlock (Alien.modify ~language:lang ~declarations alien) + | FreshLabel(_x, _x_i1) -> + let o, _x = o#name _x in + let o, _x_i1 = o#list (fun o -> o#binding) _x_i1 in + o, FreshLabel(_x,_x_i1) + method binding : binding -> ('self_type * binding) = WithPos.traverse_map diff --git a/core/sugartypes.ml b/core/sugartypes.ml index b17421516..a1c74db1c 100644 --- a/core/sugartypes.ml +++ b/core/sugartypes.ml @@ -531,6 +531,7 @@ and bindingnode = | Exp of phrase | Module of { binder: Binder.with_pos; members: binding list } | AlienBlock of Alien.multi Alien.t + | FreshLabel of Name.t * binding list and binding = bindingnode WithPos.t and block_body = binding list * phrase and cp_phrasenode = diff --git a/core/transformSugar.ml b/core/transformSugar.ml index 0be2a390e..50252549f 100644 --- a/core/transformSugar.ml +++ b/core/transformSugar.ml @@ -24,7 +24,7 @@ let type_section env = let (fields, rho, _) = TypeUtils.extract_row_parts row in let eb, e = Types.fresh_row_quantifier default_effect_subkind in - let r = Record (Row (StringMap.add label (Present a) fields, rho, false)) in + let r = Record (Row (FieldMap.add label (Present a) fields, rho, false)) in ForAll ([ab; rhob; eb], Function (Types.make_tuple_type [r], e, a)) | Name var -> TyEnv.find var env diff --git a/core/typeSugar.ml b/core/typeSugar.ml index 08b76aa95..234a5bea5 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -155,6 +155,7 @@ struct | Funs _ | Infix _ | Aliases _ + | FreshLabel _ | Foreign _ -> true | Exp p -> is_pure p | Val (pat, (_, rhs), _, _) -> @@ -1816,8 +1817,8 @@ let type_section pos context s = let a = Types.fresh_type_variable (lin_unl, res_any) in let rho = Types.fresh_row_variable (lin_unl, res_any) in let effects = Types.make_empty_open_row default_effect_subkind in (* projection is pure! *) - let r = Record (Row (StringMap.add label (Present a) StringMap.empty, rho, false)) in - ([(PrimaryKind.Type, a); (PrimaryKind.Row, Row (StringMap.empty, rho, false)); (PrimaryKind.Row, effects)], + let r = Record (Row (FieldMap.add label (Present a) FieldMap.empty, rho, false)) in + ([(PrimaryKind.Type, a); (PrimaryKind.Row, Row (FieldMap.empty, rho, false)); (PrimaryKind.Row, effects)], Function (Types.make_tuple_type [r], effects, a)), Usage.empty | Name var -> @@ -4863,6 +4864,7 @@ and type_binding : context -> binding -> binding * context * Usage.t = let () = unify pos ~handle:Gripers.bind_exp (pos_and_typ e, no_pos Types.unit_type) in Exp (erase e), empty_context, usages e + | FreshLabel(name, decls) -> assert false (* TODO *) | Import _ | Open _ | AlienBlock _ diff --git a/core/typeUtils.ml b/core/typeUtils.ml index 474bf55f7..f5d726ada 100644 --- a/core/typeUtils.ml +++ b/core/typeUtils.ml @@ -15,22 +15,22 @@ let extract_row_parts = Types.extract_row_parts let split_row name row = let (field_env, row_var, dual) = fst (unwrap_row row) |> extract_row_parts in let t = - if StringMap.mem name field_env then - match (StringMap.find name field_env) with + if FieldMap.mem name field_env then + match (FieldMap.find name field_env) with | Present t -> t | Absent -> - error ("Attempt to split row "^string_of_row row ^" on absent field " ^ name) + error ("Attempt to split row "^string_of_row row ^" on absent field " ^ Label.show name) | Meta _ -> - error ("Attempt to split row "^string_of_row row ^" on meta field " ^ name) + error ("Attempt to split row "^string_of_row row ^" on meta field " ^ Label.show name) | _ -> raise Types.tag_expectation_mismatch else - error ("Attempt to split row "^string_of_row row ^" on absent field " ^ name) + error ("Attempt to split row "^string_of_row row ^" on absent field " ^ Label.show name) in let new_field_env = if is_closed_row row then - StringMap.remove name field_env + FieldMap.remove name field_env else - StringMap.add name Absent field_env + FieldMap.add name Absent field_env in t, Row (new_field_env, row_var, dual) @@ -100,14 +100,14 @@ let rec erase_type ?(overstep_quantifiers=true) names t = let closed = is_closed_row row in let (field_env, row_var, duality) = fst (unwrap_row row) |> extract_row_parts in let field_env = - StringSet.fold + FieldSet.fold (fun name field_env -> - match StringMap.lookup name field_env with + match FieldMap.lookup name field_env with | Some (Present _) -> if closed then - StringMap.remove name field_env + FieldMap.remove name field_env else - StringMap.add name Absent field_env + FieldMap.add name Absent field_env | Some Absent -> error ("Attempt to remove absent field "^name^" from row "^string_of_row row) | Some (Meta _) -> diff --git a/core/types.ml b/core/types.ml index 40ac95117..a8344a36a 100644 --- a/core/types.ml +++ b/core/types.ml @@ -9,9 +9,12 @@ let internal_error message = let tag_expectation_mismatch = internal_error "Type tag expectation mismatch" -module FieldEnv = Utility.StringMap +module type LABELMAP = Map with type key = Label.t +module FieldMap : LABELMAP = Map.Make(Label) +module FieldEnv = FieldMap +type 'a field_env = 'a FieldMap.t [@@deriving show] + type 'a stringmap = 'a Utility.stringmap [@@deriving show] -type 'a field_env = 'a stringmap [@@deriving show] (* type var sets *) module TypeVarSet = struct @@ -171,7 +174,7 @@ and session_type = typ and datatype = typ and type_arg = PrimaryKind.t * typ and field_spec = typ -and field_spec_map = field_spec Utility.StringMap.t +and field_spec_map = field_spec FieldMap.t and meta_type_var = typ point and meta_row_var = row point and meta_presence_var = typ point @@ -291,11 +294,11 @@ struct method field_spec_map : field_spec_map -> ('self_type * field_spec_map) = fun fsmap -> - StringMap.fold + FieldMap.fold (fun lbl fs (o, fsmap') -> let (o, fs) = o#field_spec fs in - (o, StringMap.add lbl fs fsmap')) - fsmap (o, StringMap.empty) + (o, FieldMap.add lbl fs fsmap')) + fsmap (o, FieldMap.empty) method quantifier : Quantifier.t -> ('self_type * Quantifier.t) = fun q -> (o, q) @@ -993,7 +996,7 @@ module Env = Env.String let open PrimaryKind in match pk with | Type -> (Type, make_rigid_type_variable var sk) - | Row -> (Row, Row (StringMap.empty, make_rigid_row_variable var sk, false)) + | Row -> (Row, Row (FieldMap.empty, make_rigid_row_variable var sk, false)) | Presence -> (Presence, make_rigid_presence_variable var sk) let is_closed_row : row -> bool = @@ -1087,7 +1090,7 @@ let is_absent_from_row label row (* (field_env, _, _ as row) *) = then FieldEnv.find label field_env = Absent else is_closed_row row -let row_with (label, f : string * field_spec) = function +let row_with (label, f : Label.t * field_spec) = function | Row (field_env, row_var, dual) -> Row (FieldEnv.add label f field_env, row_var, dual) | _ -> raise tag_expectation_mismatch @@ -1327,7 +1330,7 @@ and dual_row : var_map -> row -> row = match fst (unwrap_row row) with | Row (fields, row_var, dual) -> let fields' = - StringMap.map + FieldMap.map (function | Absent -> Absent | Present t -> @@ -1401,7 +1404,7 @@ and subst_dual_row : var_map -> row -> row = match fst (unwrap_row row) with | Row (fields, row_var, dual) -> let fields' = - StringMap.map + FieldMap.map (subst_dual_field_spec rec_points) fields in @@ -1427,7 +1430,7 @@ and flatten_row : row -> row = fun row -> match row with | Row _ -> row (* HACK: this probably shouldn't happen! *) - | Meta row_var -> Row (StringMap.empty, row_var, false) + | Meta row_var -> Row (FieldMap.empty, row_var, false) (* | Alias (PrimaryKind.Row, _, row) -> row *) (* | RecursiveApplication { r_dual ; r_args ; r_unwind ; _ } -> *) (* (\* TODO(rj) what should this function do ? r_unwind like this provokes a stack overflow *\) *) @@ -1654,7 +1657,7 @@ let quantifier_of_type_arg = function | Type, Meta point -> quantifier_of_point point | Row, Row (fields, point, _dual) -> - assert (StringMap.is_empty fields); + assert (FieldMap.is_empty fields); quantifier_of_point point | Presence, Meta point -> quantifier_of_point point (* HACK: this probably shouldn't happen *) @@ -1679,8 +1682,8 @@ let xml_type = Alias (pk_type, ("Xml", [], [], false), Application (list, [ let database_type = Primitive Primitive.DB (* Empty type, used for exceptions *) let empty_type = Variant (make_empty_closed_row ()) -let wild = "wild" -let hear = "hear" +let wild = Label.make "wild" +let hear = Label.make "hear" let wild_present = (wild, Present unit_type) let hear_present t = (hear, Present t) @@ -1698,14 +1701,14 @@ let is_tuple ?(allow_onetuples=false) row = in match Unionfind.find row_var with | Closed -> - let n = StringMap.size field_env in + let n = FieldMap.size field_env in let b = n = 0 || (List.for_all (fun i -> - let name = string_of_int i in + let name = Label.mk_int i in FieldEnv.mem name field_env - && (match FieldEnv.find (string_of_int i) field_env with + && (match FieldEnv.find name field_env with | Present _ -> true | Absent -> false | Meta _ -> false @@ -2414,7 +2417,7 @@ struct FieldEnv.fold (fun i f tuple_env -> match f with - | Present t -> IntMap.add (int_of_string i) t tuple_env + | Present t -> IntMap.add (Label.get_int i) t tuple_env | (Absent | Meta _) -> assert false | _ -> raise tag_expectation_mismatch) field_env @@ -2523,7 +2526,7 @@ struct | Row (fields, _, _) -> fields | _ -> raise tag_expectation_mismatch in - if StringMap.is_empty fields then + if FieldMap.is_empty fields then ts else let r = row ~name:(fun _ _ -> name_of_eff_var ~allows_shared:true) "," context p r' in @@ -2677,7 +2680,7 @@ struct if strip_wild && label = wild then field_strings else - (label ^ presence context p f) :: field_strings) + (Label.show label ^ presence context p f) :: field_strings) field_env [] in let row_var_string = row_var name sep context p rv in @@ -2690,7 +2693,7 @@ struct (* FIXME: this shouldn't happen *) | Meta rv -> Debug.print ("Row variable where row expected:"^show_datatype (Meta rv)); - row sep context ~name:name ~strip_wild:strip_wild p (Row (StringMap.empty, rv, false)) + row sep context ~name:name ~strip_wild:strip_wild p (Row (FieldMap.empty, rv, false)) | t -> failwith ("Illformed row:"^show_datatype t) (* raise tag_expectation_mismatch *) @@ -3006,10 +3009,10 @@ module RoundtripPrinter : PRETTY_PRINTER = struct o#var module OperationMap = Utility.Map.Make(struct - type t = tid * string [@@deriving show] + type t = tid * Label.t [@@deriving show] let compare (xi,xs) (yi,ys) = if xi = yi - then String.compare xs ys + then Label.compare xs ys else Int.compare xi yi end) type op_entry = tid list @@ -3030,7 +3033,7 @@ module RoundtripPrinter : PRETTY_PRINTER = struct method get_operations = OperationMap.map (fun vars -> ListUtils.collect_duplicates (=) vars) operations - method with_nonpoly_operation : tid -> string -> 'self_type + method with_nonpoly_operation : tid -> Label.t -> 'self_type = let upd = function | None -> Some [] @@ -3040,7 +3043,7 @@ module RoundtripPrinter : PRETTY_PRINTER = struct let operations = OperationMap.update (effect_vid, label) upd operations in {< operations >} - method with_poly_operation : tid -> string -> tid -> 'self_type + method with_poly_operation : tid -> Label.t -> tid -> 'self_type = let upd vid = function | None -> Some [vid] @@ -3130,7 +3133,7 @@ module RoundtripPrinter : PRETTY_PRINTER = struct if d = unit_type then c else tp | tp -> tp in - let decide_field : tid -> string -> field_spec -> 'self_type * field_spec_map -> 'self_type * field_spec_map + let decide_field : tid -> Label.t -> field_spec -> 'self_type * field_spec_map -> 'self_type * field_spec_map (* Here we need to filter out the fields that are polymorphic in their presence with a fresh variable. @@ -3628,7 +3631,7 @@ module RoundtripPrinter : PRETTY_PRINTER = struct else if Context.is_ambient_tuple ctx then with_value presence pre :: printers else (Printer (fun ctx () buf -> - StringBuffer.write buf lbl; + StringBuffer.write buf (Label.show lbl); let pre = match pre with | Meta point -> Unionfind.find point | _ -> pre @@ -4408,10 +4411,10 @@ let make_fresh_envs : datatype -> datatype IntMap.t * row IntMap.t * field_spec | Closed -> empties | Var (var, kind, `Flexible) -> let tenv, renv, penv = empties in - (tenv, M.add var (Row (StringMap.empty, fresh_row_variable (Kind.subkind kind), false)) renv, penv) + (tenv, M.add var (Row (FieldMap.empty, fresh_row_variable (Kind.subkind kind), false)) renv, penv) | Var (var, kind, `Rigid) -> let tenv, renv, penv = empties in - (tenv, M.add var (Row (StringMap.empty, fresh_rigid_row_variable (Kind.subkind kind), false)) renv, penv) + (tenv, M.add var (Row (FieldMap.empty, fresh_rigid_row_variable (Kind.subkind kind), false)) renv, penv) | Recursive (l, _, _) when S.mem l boundvars -> empties | Recursive (l, _, row) -> make_env (S.add l boundvars) row | row -> make_env boundvars row @@ -4436,13 +4439,13 @@ let make_fresh_envs : datatype -> datatype IntMap.t * row IntMap.t * field_spec let make_rigid_envs datatype : datatype IntMap.t * row IntMap.t * field_spec Utility.IntMap.t = let tenv, renv, penv = make_fresh_envs datatype in (IntMap.map (fun _ -> fresh_rigid_type_variable (lin_any, res_any)) tenv, - IntMap.map (fun _ -> Row (StringMap.empty, fresh_rigid_row_variable (lin_any, res_any), false)) renv, + IntMap.map (fun _ -> Row (FieldMap.empty, fresh_rigid_row_variable (lin_any, res_any), false)) renv, IntMap.map (fun _ -> fresh_rigid_presence_variable (lin_any, res_any)) penv) let make_wobbly_envs datatype : datatype IntMap.t * row IntMap.t * field_spec Utility.IntMap.t = let tenv, renv, penv = make_fresh_envs datatype in (IntMap.map (fun _ -> fresh_type_variable (lin_any, res_any)) tenv, - IntMap.map (fun _ -> Row (StringMap.empty, fresh_row_variable (lin_any, res_any), false)) renv, + IntMap.map (fun _ -> Row (FieldMap.empty, fresh_row_variable (lin_any, res_any), false)) renv, IntMap.map (fun _ -> fresh_presence_variable (lin_any, res_any)) penv) let combine_per_kind_envs : datatype IntMap.t * row IntMap.t * field_spec IntMap.t -> type_arg IntMap.t = @@ -4599,7 +4602,7 @@ let make_tuple_type (ts : datatype list) : datatype = Record (snd (List.fold_left - (fun (n, row) t -> n+1, row_with (string_of_int n, Present t) row) + (fun (n, row) t -> n+1, row_with (Label.mk_int n, Present t) row) (1, make_empty_closed_row ()) ts)) @@ -4650,8 +4653,8 @@ let remove_field : ?idempotent:bool -> Label.t -> row -> row = fun ?(idempotent=true) lbl row -> match row with | Row (fieldenv, var, dual) -> - if idempotent || StringMap.mem lbl fieldenv - then Row (StringMap.remove lbl fieldenv, var, dual) + if idempotent || FieldMap.mem lbl fieldenv + then Row (FieldMap.remove lbl fieldenv, var, dual) else raise (internal_error "attempt to remove non-existent field") | _ -> raise tag_expectation_mismatch diff --git a/core/types.mli b/core/types.mli index ccf5e2f42..9129b01b8 100644 --- a/core/types.mli +++ b/core/types.mli @@ -2,8 +2,11 @@ open CommonTypes (* field environments *) +module type LABELMAP = Utility.Map with type key = Label.t +module FieldMap : LABELMAP +type 'a field_env = 'a FieldMap.t [@@deriving show] + type 'a stringmap = 'a Utility.StringMap.t [@@deriving show] -type 'a field_env = 'a stringmap [@@deriving show] (* type var sets *) module TypeVarSet : sig @@ -162,7 +165,7 @@ and session_type = typ and datatype = typ and type_arg = PrimaryKind.t * typ and field_spec = typ -and field_spec_map = field_spec Utility.StringMap.t +and field_spec_map = field_spec FieldMap.t and meta_type_var = typ point and meta_row_var = row point and meta_presence_var = typ point @@ -249,7 +252,7 @@ val wild : Label.t val hear : Label.t val wild_present : Label.t * datatype val hear_present : datatype -> (Label.t * datatype) -val is_builtin_effect : string -> bool +val is_builtin_effect : Label.t -> bool (** get type variables *) val free_type_vars : datatype -> TypeVarSet.t @@ -302,12 +305,12 @@ val make_empty_closed_row : unit -> row val make_empty_open_row : Subkind.t -> row (** singleton row constructors *) -val make_singleton_closed_row : (string * field_spec) -> row -val make_singleton_open_row : (string * field_spec) -> Subkind.t -> row +val make_singleton_closed_row : (Label.t * field_spec) -> row +val make_singleton_open_row : (Label.t * field_spec) -> Subkind.t -> row (** row predicates *) val is_closed_row : row -> bool -val is_absent_from_row : string -> row -> bool +val is_absent_from_row : Label.t -> row -> bool val is_tuple : ?allow_onetuples:bool -> row -> bool @@ -316,7 +319,7 @@ val get_row_var : row -> int option (** building rows *) val make_closed_row : datatype field_env -> row -val row_with : (string * field_spec) -> row -> row +val row_with : (Label.t * field_spec) -> row -> row val extend_row : datatype field_env -> row -> row val extend_row_safe : datatype field_env -> row -> row option val open_row : Subkind.t -> row -> row diff --git a/core/typevarcheck.ml b/core/typevarcheck.ml index ea99ecc68..f44cb4a76 100644 --- a/core/typevarcheck.ml +++ b/core/typevarcheck.ml @@ -1,7 +1,7 @@ open Utility open Types -module FieldEnv = Utility.StringMap +module FieldEnv = FieldMap (* TODO @@ -66,11 +66,11 @@ let rec is_guarded : TypeVarSet.t -> StringSet.t -> int -> datatype -> bool = match row with | Row (fields, row_var, _dual) when - (FieldEnv.mem "1" fields && + (FieldEnv.mem Label.one fields && FieldEnv.size fields = 1 && Unionfind.find row_var = Closed) -> begin - match FieldEnv.find "1" fields with + match FieldEnv.find Label.one fields with | Present t -> isg t | (Absent | Var _) -> true | _ -> raise Types.tag_expectation_mismatch @@ -91,7 +91,7 @@ let rec is_guarded : TypeVarSet.t -> StringSet.t -> int -> datatype -> bool = | Row (fields, row_var, _dual) -> let check_fields = false in (if check_fields then - (StringMap.fold + (FieldMap.fold (fun _ f b -> b && isg f) fields true) diff --git a/core/unify.ml b/core/unify.ml index f36cc0bf1..145e53379 100644 --- a/core/unify.ml +++ b/core/unify.ml @@ -217,7 +217,7 @@ and eq_presence = fun (l, r) -> eq_types (l, r) and eq_field_envs (lfield_env, rfield_env) = let eq_specs lf rf = eq_presence (lf, rf) in - StringMap.equal eq_specs lfield_env rfield_env + FieldMap.equal eq_specs lfield_env rfield_env and eq_row_vars (lpoint, rpoint) = (* QUESTION: Do we need to deal with closed rows specially? @@ -788,7 +788,7 @@ and unify_rows' : ?var_sk:Subkind.t -> unify_env -> ((row' * row') -> unit) = let is_unguarded_recursive row = let rec is_unguarded rec_rows (field_env, row_var, _) = - StringMap.is_empty field_env && + FieldMap.is_empty field_env && (match Unionfind.find row_var with | Closed | Var _ -> false @@ -799,7 +799,7 @@ and unify_rows' : ?var_sk:Subkind.t -> unify_env -> ((row' * row') -> unit) = is_unguarded IntSet.empty row in let domain_of_env : field_spec_map -> StringSet.t = - fun env -> StringMap.fold (fun label _ labels -> StringSet.add label labels) env StringSet.empty in + fun env -> FieldMap.fold (fun label _ labels -> StringSet.add label labels) env StringSet.empty in (* unify_field_envs closed rec_env (lenv, renv) From 5bce8343447d23a060fa67ee3cd709f43cb28f56 Mon Sep 17 00:00:00 2001 From: RJ Date: Mon, 13 Jun 2022 16:10:21 +0100 Subject: [PATCH 29/63] local labels : working --- core/buildTables.ml | 2 +- core/channelVarUtils.ml | 14 +-- core/closures.ml | 16 +-- core/compilePatterns.ml | 152 ++++++++++++++-------------- core/desugarCP.ml | 17 ++-- core/desugarDatatypes.ml | 11 +- core/desugarEffects.ml | 64 ++++++------ core/desugarFuns.ml | 5 +- core/desugarLabels.ml | 68 +++++++++++++ core/desugarProcesses.ml | 3 +- core/desugarSessionExceptions.ml | 6 +- core/evalir.ml | 22 ++-- core/frontend.ml | 1 + core/generalise.ml | 6 +- core/instantiate.ml | 24 ++--- core/ir.ml | 8 +- core/ir.mli | 6 +- core/irCheck.ml | 59 +++++------ core/irTraversals.ml | 16 +-- core/irtojs.ml | 30 +++--- core/label.ml | 146 +++++++++++++++++++++++--- core/label.mli | 44 ++++++-- core/lens_ir_conv.ml | 2 +- core/lens_sugar_conv.ml | 2 +- core/lens_type_conv.ml | 18 ++-- core/lexer.mll | 3 + core/lib.ml | 2 +- core/moduleUtils.ml | 2 +- core/page.ml | 2 +- core/parser.mly | 43 ++++---- core/query/delateralize.ml | 2 +- core/query/evalNestedQuery.ml | 5 +- core/query/evalQuery.ml | 2 +- core/query/mixingQuery.ml | 18 ++-- core/query/mixingQuery.mli | 4 +- core/query/query.ml | 16 +-- core/query/queryLang.ml | 12 +-- core/query/temporalQuery.ml | 26 ++--- core/sugarConstructors.ml | 2 +- core/sugarConstructorsIntf.ml | 10 +- core/sugarTraversals.ml | 138 ++++++++++++++++--------- core/sugarTraversals.mli | 6 ++ core/sugartoir.ml | 47 +++++---- core/sugartypes.ml | 43 ++++---- core/transformSugar.ml | 13 ++- core/typeSugar.ml | 149 ++++++++++++++------------- core/typeUtils.ml | 50 ++++----- core/typeUtils.mli | 26 ++--- core/types.ml | 46 ++++----- core/types.mli | 7 +- core/typevarcheck.ml | 4 +- core/unify.ml | 64 ++++++------ core/utility.ml | 2 +- core/value.ml | 12 +-- core/value.mli | 4 +- links-mode.el | 1 + tests/labels.tests | 50 +++++++++ tests/labels/handler.links | 24 +++++ tests/labels/multiple.links | 12 +++ tests/labels/nested-pollution.links | 27 +++++ tests/labels/nested.links | 20 ++++ tests/labels/pollution.links | 56 ++++++++++ tests/labels/simple-names.links | 9 ++ tests/labels/simple.links | 5 + tests/labels/unbounded.links | 1 + tests/labels/wrong-handler.links | 29 ++++++ 66 files changed, 1144 insertions(+), 592 deletions(-) create mode 100644 core/desugarLabels.ml create mode 100644 tests/labels.tests create mode 100644 tests/labels/handler.links create mode 100644 tests/labels/multiple.links create mode 100644 tests/labels/nested-pollution.links create mode 100644 tests/labels/nested.links create mode 100644 tests/labels/pollution.links create mode 100644 tests/labels/simple-names.links create mode 100644 tests/labels/simple.links create mode 100644 tests/labels/unbounded.links create mode 100755 tests/labels/wrong-handler.links diff --git a/core/buildTables.ml b/core/buildTables.ml index 5ac05cb13..5d5421d5d 100644 --- a/core/buildTables.ml +++ b/core/buildTables.ml @@ -255,7 +255,7 @@ struct let bindings tyenv bound_vars cont_vars bs = let o = new visitor tyenv bound_vars cont_vars in - let _ = o#computation (bs, Return (Extend (StringMap.empty, None))) in () + let _ = o#computation (bs, Return (Extend (Label.Map.empty, None))) in () let program tyenv bound_vars cont_vars e = let _ = (new visitor tyenv bound_vars cont_vars)#computation e in () diff --git a/core/channelVarUtils.ml b/core/channelVarUtils.ml index 369296a7a..7ff50a7a9 100644 --- a/core/channelVarUtils.ml +++ b/core/channelVarUtils.ml @@ -11,9 +11,9 @@ let variables_in_computation comp = let variable_set = ref IntSet.empty in let add_variable var = variable_set := (IntSet.add var !variable_set) in - let rec traverse_stringmap : 'a . ('a -> unit) -> 'a stringmap -> unit = + let rec traverse_name_map : 'a . ('a -> unit) -> 'a name_map -> unit = fun proj_fn smap -> (* (proj_fn: 'a . 'a -> 'b) (smap: 'a stringmap) : unit = *) - StringMap.fold (fun _ v _ -> proj_fn v) smap () + Label.Map.fold (fun _ v _ -> proj_fn v) smap () and traverse_value = function | Variable v -> add_variable v | Closure (_, _, value) @@ -24,13 +24,13 @@ let variables_in_computation comp = | Coerce (value, _) | Erase (_, value) -> traverse_value value | XmlNode (_, v_map, vs) -> - traverse_stringmap (traverse_value) v_map; + traverse_name_map (traverse_value) v_map; List.iter traverse_value vs | ApplyPure (v, vs) -> traverse_value v; List.iter traverse_value vs | Extend (v_map, v_opt) -> - traverse_stringmap (traverse_value) v_map; + traverse_name_map (traverse_value) v_map; begin match v_opt with | Some v -> traverse_value v | None -> () end | Constant _ -> () and traverse_tail_computation = function @@ -42,7 +42,7 @@ let variables_in_computation comp = traverse_value v; List.iter traverse_computation [c1 ; c2] | Case (scrutinee, cases, case_opt) -> traverse_value scrutinee; - traverse_stringmap (fun (_, c) -> traverse_computation c) cases; + traverse_name_map (fun (_, c) -> traverse_computation c) cases; OptionUtils.opt_iter (fun (_, c) -> traverse_computation c) case_opt and traverse_fundef {fn_binder = bnd; _} = let fun_var = Var.var_of_binder bnd in @@ -109,7 +109,7 @@ let variables_in_computation comp = | DoOperation (_, vs, _) -> List.iter (traverse_value) vs | Choice (v, clauses) -> traverse_value v; - traverse_stringmap (fun (_, c) -> + traverse_name_map (fun (_, c) -> traverse_computation c) clauses | Lens (value, _) | LensSerial { lens = value; _ } @@ -124,7 +124,7 @@ let variables_in_computation comp = and traverse_clause (_, _, c) = traverse_computation c and traverse_handler (h: Ir.handler) = traverse_computation (h.ih_comp); - traverse_stringmap (traverse_clause) h.ih_cases; + traverse_name_map (traverse_clause) h.ih_cases; traverse_computation (snd h.ih_return) in traverse_computation comp; diff --git a/core/closures.ml b/core/closures.ml index 2f8dea2a5..18980bfce 100644 --- a/core/closures.ml +++ b/core/closures.ml @@ -428,9 +428,9 @@ struct let close f zs tyargs = Closure (f, tyargs, Extend (List.fold_right (fun (zname, zv) fields -> - StringMap.add zname zv fields) + Label.Map.add zname zv fields) zs - StringMap.empty, None)) + Label.Map.empty, None)) class visitor tenv fenv = object (o : 'self) inherit IrTraversals.Transform.visitor(tenv) as super @@ -456,7 +456,7 @@ struct if IntSet.mem x cvars then (* We cannot return t as the type of the result here. If x refers to a hoisted function that was generalised, then t has additional quantifiers that are not present in the corresponding type of projecting x from parent_env *) - let projected_t = TypeUtils.project_type (string_of_int x) (thd3 (o#var parent_env)) in + let projected_t = TypeUtils.project_type (Label.mk_int x) (thd3 (o#var parent_env)) in Project (string_of_int x, Variable parent_env), projected_t else if IntMap.mem x fenv then let zs = (IntMap.find x fenv).termvars in @@ -476,7 +476,7 @@ struct (fun b -> let z = Var.var_of_binder b in let v = fst (var_val z) in - (string_of_int z, v)) + (Label.mk_int z, v)) zs in close x zs tyargs, overall_type @@ -539,8 +539,8 @@ struct (fun fields b -> let x = Var.var_of_binder b in let xt = Var.type_of_binder b in - FieldMap.add (Label.mk_int x) xt fields) - FieldMap.empty + Label.Map.add (Label.mk_int x) xt fields) + Label.Map.empty zs)) in (* fresh variable for the closure environment *) @@ -615,8 +615,8 @@ struct (fun fields b -> let x = Var.var_of_binder b in let xt = Var.type_of_binder b in - FieldMap.add (Label.mk_int x) xt fields) - FieldMap.empty + Label.Map.add (Label.mk_int x) xt fields) + Label.Map.empty zs)) in (* fresh variable for the closure environment *) diff --git a/core/compilePatterns.ml b/core/compilePatterns.ml index 796a02153..a86e939c2 100644 --- a/core/compilePatterns.ml +++ b/core/compilePatterns.ml @@ -30,10 +30,10 @@ struct | Any | Nil | Cons of t * t - | Variant of Name.t * t - | Effect of Name.t * t list * t - | Negative of StringSet.t - | Record of t StringMap.t * t option + | Variant of Label.t * t + | Effect of Label.t * t list * t + | Negative of Label.Set.t + | Record of t Label.Map.t * t option | Constant of Constant.t | Variable of binder | As of binder * t @@ -43,8 +43,8 @@ struct type context = | CNil | CCons - | CVariant of string - | CNVariant of StringSet.t + | CVariant of Label.t + | CNVariant of Label.Set.t | CConstant of Constant.t | CNConstant of ConstSet.t @@ -138,15 +138,15 @@ let rec desugar_pattern : Types.row -> Sugartypes.Pattern.with_pos -> Pattern.t in let k, env' = desugar_pattern k in Pattern.Effect (name, ps, k), env ++ env' - | Negative names -> Pattern.Negative (StringSet.from_list names), empty + | Negative names -> Pattern.Negative (Label.Set.from_list names), empty | Record (bs, p) -> let bs, env = List.fold_right (fun (name, p) (bs, env) -> let p, env' = desugar_pattern p in - StringMap.add name p bs, env ++ env') + Label.Map.add name p bs, env ++ env') bs - (StringMap.empty, empty) in + (Label.Map.empty, empty) in let p, env = match p with | None -> None, env @@ -156,7 +156,7 @@ let rec desugar_pattern : Types.row -> Sugartypes.Pattern.with_pos -> Pattern.t in Pattern.Record (bs, p), env | Tuple ps -> - let bs = mapIndex (fun p i -> (string_of_int (i+1), p)) ps in + let bs = mapIndex (fun p i -> (Label.mk_int (i+1), p)) ps in desugar_pattern (WithPos.make ~pos (Record (bs, None))) | Constant constant -> Pattern.Constant constant, empty @@ -258,7 +258,7 @@ let let_pattern : raw_env -> Pattern.t -> value * Types.datatype -> computation let case_type = TypeUtils.variant_at name t in let case_binder, case_variable = Var.fresh_var_of_type case_type in let body = lp case_type patt (Variable case_variable) body in - let cases = StringMap.singleton name (case_binder, body) in + let cases = Label.Map.singleton name (case_binder, body) in [], Case (value, cases, None) | Pattern.Negative names -> (* The following expands the negative pattern into @@ -273,18 +273,18 @@ let let_pattern : raw_env -> Pattern.t -> value * Types.datatype -> computation } *) let negative_cases, t' = - StringSet.fold + Label.Set.fold (fun label (cases, t) -> let case_type = TypeUtils.variant_at label t in let case_binder = Var.fresh_binder_of_type case_type in let body = ([], Special (Wrong body_type)) in - let cases' = StringMap.add label (case_binder, body) cases in + let cases' = Label.Map.add label (case_binder, body) cases in let t' = let row = TypeUtils.extract_row t in Types.Variant (Types.row_with (label, Types.Absent) row) in (cases', t')) - names (StringMap.empty, t) + names (Label.Map.empty, t) in let success_case = let case_binder = Var.fresh_binder_of_type t' in @@ -297,19 +297,19 @@ let let_pattern : raw_env -> Pattern.t -> value * Types.datatype -> computation | None -> body | Some p -> let names = - StringMap.fold + Label.Map.fold (fun name _ names -> - StringSet.add name names) + Label.Set.add name names) fields - StringSet.empty in + Label.Set.empty in let rt = TypeUtils.erase_type names t in lp rt p (Erase (names, value)) body (* lp rt p (`Coerce (value, rt)) body *) in - StringMap.fold + Label.Map.fold (fun name p body -> let t' = (TypeUtils.project_type name t) in - (lp t' p (Project (name, value)) body)) + (lp t' p (Project (Label.name name, value)) body)) fields body | Pattern.Constant c -> @@ -404,21 +404,21 @@ let arrange_list_clauses : clause list -> (annotated_clause list * annotated_cla (* arrange variant clauses by constructor *) let arrange_variant_clauses - : clause list -> (annotated_clause list) StringMap.t = + : clause list -> (annotated_clause list) Label.Map.t = fun clauses -> (List.fold_right (fun (ps, body) env -> match ps with | (annotation, Pattern.Variant (name, pattern))::ps -> let annotated_clauses = - if StringMap.mem name env then - StringMap.find name env + if Label.Map.mem name env then + Label.Map.find name env else [] in let pattern = reduce_pattern pattern in - StringMap.add name ((annotation, (pattern::ps, body))::annotated_clauses) env + Label.Map.add name ((annotation, (pattern::ps, body))::annotated_clauses) env | _ -> assert false - ) clauses StringMap.empty) + ) clauses Label.Map.empty) (* arrange constant clauses by constant value *) let arrange_constant_clauses @@ -444,7 +444,7 @@ let arrange_constant_clauses This function flattens all the record clauses. *) let arrange_record_clauses - : clause list -> (annotated_pattern StringMap.t * annotated_pattern option * annotated_clause) list = + : clause list -> (annotated_pattern Label.Map.t * annotated_pattern option * annotated_clause) list = fun clauses -> let rec flatten = function @@ -452,16 +452,16 @@ let arrange_record_clauses bs, None | Pattern.Record (bs, Some p) -> let bs', p' = flatten p in - StringMap.union_disjoint bs bs', p' + Label.Map.union_disjoint bs bs', p' | p -> - StringMap.empty, Some p + Label.Map.empty, Some p in List.fold_right (fun (ps, body) xs -> match ps with | (annotation, p)::ps -> let bs, p = flatten p in - let bs = StringMap.map reduce_pattern bs in + let bs = Label.Map.map reduce_pattern bs in let p = opt_map reduce_pattern p in (bs, p, (annotation, (ps, body)))::xs | _ -> assert false @@ -616,7 +616,7 @@ and match_list *) and match_variant - : var list -> (annotated_clause list) StringMap.t -> bound_computation -> var -> bound_computation = + : var list -> (annotated_clause list) Label.Map.t -> bound_computation -> var -> bound_computation = fun vars bs def var env -> let t = lookup_type var env in @@ -624,14 +624,14 @@ and match_variant if mem_context var env then lookup_context var env else - Pattern.CNVariant StringSet.empty, Variable var + Pattern.CNVariant Label.Set.empty, Variable var in match context with | Pattern.CVariant name -> - if StringMap.mem name bs then + if Label.Map.mem name bs then match cexp with | Inject (_, (Variable case_variable), _) -> - let annotated_clauses = StringMap.find name bs in + let annotated_clauses = Label.Map.find name bs in (* let case_type = lookup_type case_variable env in *) (* let inject_type = TypeUtils.inject_type name case_type in *) let clauses = apply_annotations cexp annotated_clauses in @@ -641,9 +641,9 @@ and match_variant def env | Pattern.CNVariant names -> let cases, cs = - StringMap.fold + Label.Map.fold (fun name annotated_clauses (cases, cs) -> - if StringSet.mem name names then + if Label.Set.mem name names then (cases, cs) else let case_type = TypeUtils.variant_at name t in @@ -653,20 +653,20 @@ and match_variant let match_env = bind_context var (Pattern.CVariant name, - Inject (name, Variable case_variable, t)) match_env in + Inject (Label.name name, Variable case_variable, t)) match_env in let clauses = apply_annotations - (Inject (name, Variable case_variable, t)) annotated_clauses + (Inject (Label.name name, Variable case_variable, t)) annotated_clauses in - (StringMap.add name + (Label.Map.add name (case_binder, match_cases (case_variable::vars) clauses def match_env) cases, - StringSet.add name cs)) + Label.Set.add name cs)) bs - (StringMap.empty, names) in + (Label.Map.empty, names) in let default_type = - StringSet.fold + Label.Set.fold (fun name t -> let _, t = TypeUtils.split_variant_type name t in t) cs t in begin @@ -703,21 +703,21 @@ and match_negative if mem_context var env then lookup_context var env else - Pattern.CNVariant StringSet.empty, Variable var + Pattern.CNVariant Label.Set.empty, Variable var in begin match context with - | Pattern.CVariant name when StringSet.mem name names -> + | Pattern.CVariant name when Label.Set.mem name names -> def env | Pattern.CVariant _name -> let body = apply_annotation (Variable var) (annotation, body) in match_cases vars [(ps, body)] def env | Pattern.CNVariant names' -> - let diff = StringSet.diff names names' in - let cs = StringSet.union names names' in + let diff = Label.Set.diff names names' in + let cs = Label.Set.union names names' in let cases = - StringSet.fold + Label.Set.fold (fun name cases -> let case_type = TypeUtils.variant_at name t in (* let inject_type = TypeUtils.inject_type name case_type in *) @@ -726,13 +726,13 @@ and match_negative let match_env = bind_context var (Pattern.CVariant name, - Inject (name, Variable case_variable, t)) match_env + Inject (Label.name name, Variable case_variable, t)) match_env in - StringMap.add name (case_binder, def match_env) cases) + Label.Map.add name (case_binder, def match_env) cases) diff - StringMap.empty in + Label.Map.empty in let default_type = - StringSet.fold + Label.Set.fold (fun name t -> let _, t = TypeUtils.split_variant_type name t in t) cs t in let (default_binder, default_variable) = Var.fresh_var_of_type default_type in @@ -796,7 +796,7 @@ and match_constant | _ -> assert false and match_record - : var list -> (annotated_pattern StringMap.t * annotated_pattern option * annotated_clause) list -> + : var list -> (annotated_pattern Label.Map.t * annotated_pattern option * annotated_clause) list -> bound_computation -> var -> bound_computation = fun vars xs def var env -> let t = lookup_type var env in @@ -804,7 +804,7 @@ and match_record let names = List.fold_right (fun (bs, _, _) names -> - StringMap.fold (fun name _ names -> StringSet.add name names) bs names) xs StringSet.empty in + Label.Map.fold (fun name _ names -> Label.Set.add name names) bs names) xs Label.Set.empty in let all_closed = List.for_all (function | (_, None, _) -> true | (_, Some _, _) -> false) xs in @@ -822,19 +822,19 @@ and match_record | Some p -> p, false in let rps, fields = - StringSet.fold + Label.Set.fold (fun name (ps, fields) -> - if StringMap.mem name bs then - StringMap.find name bs :: ps, fields + if Label.Map.mem name bs then + Label.Map.find name bs :: ps, fields else if closed then ([], Pattern.Any)::ps, fields else let xt = TypeUtils.project_type name t in let xb, x = Var.fresh_var_of_type xt in - ([], Pattern.Variable xb)::ps, StringMap.add name (Variable x) fields) + ([], Pattern.Variable xb)::ps, Label.Map.add name (Variable x) fields) names - ([], StringMap.empty) in + ([], Label.Map.empty) in let rps, body = if all_closed then rps, body @@ -842,11 +842,11 @@ and match_record ([], Pattern.Any)::List.rev rps, body else let original_names = - StringMap.fold + Label.Map.fold (fun name _ names -> - StringSet.add name names) + Label.Set.add name names) bs - StringSet.empty in + Label.Set.empty in (* type of the original record continuation *) let pt = TypeUtils.erase_type original_names t in @@ -874,11 +874,11 @@ and match_record ) xs [] in let bindings, xs, env = - StringSet.fold + Label.Set.fold (fun name (bindings, xs, env) -> let xt = TypeUtils.project_type name t in let xb, x = Var.fresh_var_of_type xt in - let binding = letmv (xb, Project (name, Variable var)) in + let binding = letmv (xb, Project (Label.name name, Variable var)) in binding::bindings, x::xs, bind_type x xt env) names ([], [], env) in @@ -968,13 +968,13 @@ let compile_handle_cases in let compiled_effect_cases = (* The compiled cases *) if List.length raw_effect_clauses = 0 then - StringMap.empty + Label.Map.empty else begin let (comp_eff, comp_ty, _, _) = Sugartypes.(desc.shd_types) in let variant_type = let (fields,_,_) = comp_eff |> TypeUtils.extract_row_parts in let fields' = - StringMap.filter + Label.Map.filter (fun _ -> function | Types.Present _ -> true @@ -982,15 +982,15 @@ let compile_handle_cases fields in let fields'' = - StringMap.map + Label.Map.map (function | Types.Present t -> begin match TypeUtils.concrete_type t with | Types.Function (domain, _, _) -> let (fields, _, _) = TypeUtils.extract_row domain |> TypeUtils.extract_row_parts in - let arity = StringMap.size fields in + let arity = Label.Map.size fields in if arity = 1 then - match StringMap.find "1" fields with + match Label.Map.find Label.one fields with | Types.Present t -> t | _ -> assert false else @@ -1015,9 +1015,9 @@ let compile_handle_cases | [Pattern.Effect (name, ps, _)] -> let packaged_args = let fields = - List.mapi (fun i p -> (string_of_int (i+1), p)) ps + List.mapi (fun i p -> (Label.mk_int (i+1), p)) ps in - Pattern.Record (StringMap.from_alist fields, None) + Pattern.Record (Label.Map.from_alist fields, None) in Pattern.Variant (name, packaged_args) | _ -> assert false @@ -1037,9 +1037,9 @@ let compile_handle_cases in let continuation_binders = let upd effname ks map = - match StringMap.lookup effname map with - | None -> StringMap.add effname ks map - | Some ks' -> StringMap.add effname (ks @ ks') map + match Label.Map.lookup effname map with + | None -> Label.Map.add effname ks map + | Some ks' -> Label.Map.add effname (ks @ ks') map in let rec gather_binders = function | Pattern.Any -> [] @@ -1052,14 +1052,14 @@ let compile_handle_cases | [Pattern.Effect (name, _, k)] -> upd name (gather_binders k) acc | _ -> assert false) - StringMap.empty (List.map fst raw_effect_clauses) + Label.Map.empty (List.map fst raw_effect_clauses) in - StringMap.mapi + Label.Map.mapi (fun effname (x, body) -> let body = with_parameters body in - match StringMap.find effname continuation_binders with + match Label.Map.find effname continuation_binders with | [] -> let resume = Var.(make_local_info ->- fresh_binder) (Types.Not_typed, "_resume") @@ -1130,9 +1130,9 @@ let match_choices : var -> clause list -> bound_computation = failwith ("Only choice patterns are supported in choice compilation") in let x = Var.var_of_binder b in let body = apply_annotation (Variable x) (annotation, body) in - StringMap.add name (b, body env) cases + Label.Map.add name (b, body env) cases | _ -> assert false) - StringMap.empty + Label.Map.empty clauses))) let compile_choices diff --git a/core/desugarCP.ml b/core/desugarCP.ml index c26e278ca..6f0c1ab67 100644 --- a/core/desugarCP.ml +++ b/core/desugarCP.ml @@ -13,7 +13,6 @@ let receive_str = "receive" let request_str = "request" let send_str = "send" let wait_str = "wait" -let wild_str = "wild" class desugar_cp env = let open CommonTypes.PrimaryKind in @@ -48,8 +47,8 @@ object (o : 'self_type) let o = o#restore_envs envs in o, block_node ([val_binding (with_dummy_pos ( - Pattern.Record ([("1", variable_pat ~ty:u x); - ("2", variable_pat ~ty:s c)], None))) + Pattern.Record ([(Label.one, variable_pat ~ty:u x); + (Label.two, variable_pat ~ty:s c)], None))) (fn_appl receive_str grab_tyargs [var c])], with_dummy_pos e), t | CPGive ((c, _), None, p) -> @@ -71,7 +70,8 @@ object (o : 'self_type) let c = Binder.to_name bndr in let t = Binder.to_type bndr in o, Var c, t - | CPSelect (bndr, label, p) -> + | CPSelect (bndr, name, p) -> + let label = Label.make name in let c = Binder.to_name bndr in let s = Binder.to_type bndr in let envs = o#backup_envs in @@ -85,11 +85,12 @@ object (o : 'self_type) | CPOffer (bndr, cases) -> let c = Binder.to_name bndr in let s = Binder.to_type bndr in - let desugar_branch (label, p) (o, cases) = + let desugar_branch (name, p) (o, cases) = + let label = Label.make name in let envs = o#backup_envs in let o = {< var_env = TyEnv.bind c (TypeUtils.choice_at label s) (o#get_var_env ()) >} in let (o, p, t) = desugar_cp o p in - let pat : Pattern.with_pos = with_dummy_pos (Pattern.Variant (label, + let pat : Pattern.with_pos = with_dummy_pos (Pattern.Variant (Label.make name, Some (variable_pat ~ty:(TypeUtils.choice_at label s) c))) in o#restore_envs envs, ((pat, with_dummy_pos p), t) :: cases in let (o, cases) = List.fold_right desugar_branch cases (o, []) in @@ -115,10 +116,10 @@ object (o : 'self_type) let (eff_fields, eff_row, eff_closed) = Types.flatten_row o#lookup_effects |> TypeUtils.extract_row_parts in - let eff_fields = Types.FieldMap.remove wild_str eff_fields in + let eff_fields = Label.Map.remove Types.wild eff_fields in let eff_fields = if Settings.get Basicsettings.Sessions.exceptions_enabled then - FieldMap.remove Value.session_exception_operation eff_fields + Label.Map.remove Value.session_exception_operation eff_fields else eff_fields in diff --git a/core/desugarDatatypes.ml b/core/desugarDatatypes.ml index e1d0268d7..6fc09bbcf 100644 --- a/core/desugarDatatypes.ml +++ b/core/desugarDatatypes.ml @@ -249,7 +249,10 @@ module Desugar = struct if qn = tn then type_args qs ts else - raise (TypeApplicationArityMismatch { pos = node.pos; name = name; expected = qn; provided = tn }) + raise (TypeApplicationArityMismatch + { pos = node.pos; + name = name; + expected = qn; provided = tn }) in begin match SEnv.find_opt name alias_env with | None -> raise (UnboundTyCon (node.pos, name)) @@ -288,7 +291,7 @@ module Desugar = struct | Closed -> Types.make_empty_closed_row () | Open srv -> let rv = SugarTypeVar.get_resolved_row_exn srv in - Types.Row (FieldMap.empty, rv, false) + Types.Row (Label.Map.empty, rv, false) | Recursive (stv, r) -> let mrv = SugarTypeVar.get_resolved_row_exn stv in @@ -297,7 +300,7 @@ module Desugar = struct (* Turn mrv into a proper recursive row *) Unionfind.change mrv (Types.Recursive (var, sk, r)); - Types.Row (FieldMap.empty, mrv, false) + Types.Row (Label.Map.empty, mrv, false) in let fields = List.map (fun (k, p) -> (k, fieldspec alias_env p node)) fields in @@ -341,7 +344,7 @@ module Desugar = struct let write_row, needed_row = match TypeUtils.concrete_type read_type with | Record (Row (fields, _, _)) -> - FieldMap.fold + Label.Map.fold (fun label t (write, needed) -> match lookup label constraints with | Some cs -> diff --git a/core/desugarEffects.ml b/core/desugarEffects.ml index db95f5554..cc200604d 100644 --- a/core/desugarEffects.ml +++ b/core/desugarEffects.ml @@ -361,25 +361,25 @@ let cleanup_effects tycon_env = let fields = List.map (function - | ( name, + | ( label, Present { node = Function (domain, (fields, rv), codomain); pos } ) as op - when not (TypeUtils.is_builtin_effect name) -> ( + when not (TypeUtils.is_builtin_effect label) -> ( (* Elaborates `Op : a -> b' to `Op : a {}-> b' *) match (rv, fields) with | Closed, [] -> op | Open _, [] | Recursive _, [] -> (* might need an extra check on recursive rows *) - ( name, + ( label, Present (SourceCode.WithPos.make ~pos (Function (domain, ([], Closed), codomain))) ) - | _, _ -> raise (unexpected_effects_on_abstract_op pos name) ) - | name, Present node when not (TypeUtils.is_builtin_effect name) -> + | _, _ -> raise (unexpected_effects_on_abstract_op pos (Label.name label)) ) + | label, Present node when not (TypeUtils.is_builtin_effect label) -> (* Elaborates `Op : a' to `Op : () {}-> a' *) - ( name, + ( label, Present (SourceCode.WithPos.make ~pos:node.pos (Function ([], ([], Closed), node))) ) @@ -506,7 +506,7 @@ let gather_operation_of_type tp let seen_recapps = StringSet.add name seen_recapps in {< seen_recapps >} - val operations : stringset RowVarMap.t = RowVarMap.empty + val operations : Label.Set.t RowVarMap.t = RowVarMap.empty method operations = operations val implicit_shared_var : int option = None @@ -518,8 +518,8 @@ let gather_operation_of_type tp method with_label vid label = let operations = RowVarMap.update vid (function - | None -> Some (StringSet.singleton label) - | Some sset -> Some (StringSet.add label sset)) + | None -> Some (Label.Set.singleton label) + | Some sset -> Some (Label.Set.add label sset)) operations in {< operations >} @@ -536,7 +536,7 @@ let gather_operation_of_type tp then o#set_implicit_shared_var vid else o in - FieldEnv.fold + Label.Map.fold (fun label _field acc -> acc#with_label vid label) fields o @@ -615,13 +615,13 @@ let gather_operations (tycon_env : simple_tycon_env) allow_fresh dt = method operations = operations method with_operations operations = {< operations >} - val hidden_operations : stringset stringmap = StringMap.empty + val hidden_operations : Label.Set.t stringmap = StringMap.empty method hidden_operations = hidden_operations method add_hidden_op alias_name label = let hidden_operations = StringMap.update alias_name (function - | None -> Some (StringSet.singleton label) - | Some lset -> Some (StringSet.add label lset)) + | None -> Some (Label.Set.singleton label) + | Some lset -> Some (Label.Set.add label lset)) hidden_operations in {< hidden_operations >} @@ -646,8 +646,8 @@ let gather_operations (tycon_env : simple_tycon_env) allow_fresh dt = else let ops = match RowVarMap.find_opt var operations with - | None -> StringSet.singleton op - | Some t -> StringSet.add op t + | None -> Label.Set.singleton op + | Some t -> Label.Set.add op t in {} @@ -687,14 +687,14 @@ let gather_operations (tycon_env : simple_tycon_env) allow_fresh dt = RowVarMap.update vid (function | None -> Some sset - | Some opset -> Some (StringSet.union opset sset)) + | Some opset -> Some (Label.Set.union opset sset)) acc) ops self#operations in let self = match RowVarMap.find_raw_opt (-1) ops with | None -> self | Some hide_ops -> - StringSet.fold + Label.Set.fold (fun label acc -> acc#add_hidden_op name label) hide_ops self @@ -738,15 +738,15 @@ let gather_operations (tycon_env : simple_tycon_env) allow_fresh dt = let o = o#datatype dt in (o#operations |> RowVarMap.map (fun v -> - StringSet.fold + Label.Set.fold (fun op m -> let point = lazy (let var = Types.fresh_raw_variable () in Unionfind.fresh (Types.Var (var, (PrimaryKind.Presence, default_subkind), `Rigid))) in - StringMap.add op point m) - v StringMap.empty), + Label.Map.add op point m) + v Label.Map.empty), o#hidden_operations) else (RowVarMap.empty, StringMap.empty) @@ -794,11 +794,11 @@ class main_traversal simple_tycon_env = (** Map of effect variables to all mentioned operations, and their corresponding effect variables. *) - val row_operations : Types.meta_presence_var Lazy.t StringMap.t RowVarMap.t + val row_operations : Types.meta_presence_var Lazy.t Label.Map.t RowVarMap.t = RowVarMap.empty - val hidden_operations : stringset stringmap = StringMap.empty + val hidden_operations : Label.Set.t stringmap = StringMap.empty method set_inside_type inside_type = {} @@ -937,12 +937,12 @@ class main_traversal simple_tycon_env = | None -> [] | Some ops -> let ops_to_hide = match StringMap.find_opt tycon hidden_operations with - | None -> StringSet.empty + | None -> Label.Set.empty | Some hidden -> hidden in - StringMap.fold + Label.Map.fold (fun op p fields -> - if StringSet.mem op ops_to_hide + if Label.Set.mem op ops_to_hide then fields else begin let mpv : Types.meta_presence_var = @@ -953,7 +953,7 @@ class main_traversal simple_tycon_env = (SugarTypeVar.mk_resolved_presence mpv) in if not allow_implictly_bound_vars then - raise (cannot_insert_presence_var2 pos op); + raise (cannot_insert_presence_var2 pos (Label.show op)); (op, fieldspec) :: fields end) ops [] @@ -1030,27 +1030,27 @@ class main_traversal simple_tycon_env = match RowVarMap.find_opt stv row_operations with | Some ops -> let ops_to_hide = match in_alias with - | None -> StringSet.empty + | None -> Label.Set.empty | Some name -> (match StringMap.find_opt name hidden_operations with - | None -> StringSet.empty + | None -> Label.Set.empty | Some hidden -> hidden) in let ops_to_add = List.fold_left - (fun ops (op, _) -> StringMap.remove op ops) + (fun ops (op, _) -> Label.Map.remove op ops) ops fields in let add_op op pres_var fields = if not allow_implictly_bound_vars then (* Alternatively, we could just decide not to touch the row and let the type checker complain about the incompatible rows? *) - raise (cannot_insert_presence_var dpos op); - if StringSet.mem op ops_to_hide + raise (cannot_insert_presence_var dpos (Label.show op)); + if Label.Set.mem op ops_to_hide then fields else let rpv = SugarTypeVar.mk_resolved_presence (Lazy.force pres_var) in (op, Datatype.Var rpv) :: fields in - StringMap.fold add_op ops_to_add fields + Label.Map.fold add_op ops_to_add fields | None -> fields ) | _ -> fields in diff --git a/core/desugarFuns.ml b/core/desugarFuns.ml index 2be44d9d2..bf16db717 100644 --- a/core/desugarFuns.ml +++ b/core/desugarFuns.ml @@ -132,7 +132,8 @@ object (o : 'self_type) let (fields, rho, _) = TypeUtils.extract_row_parts row in let effb, row = fresh_row_quantifier default_effect_subkind in - let r = Record (Row (FieldMap.add name (Present a) fields, rho, false)) in + let label = Label.make name in + let r = Record (Row (Label.Map.add label (Present a) fields, rho, false)) in let f = gensym ~prefix:"_fun_" () in let x = gensym ~prefix:"_fun_" () in @@ -140,7 +141,7 @@ object (o : 'self_type) , Function (Types.make_tuple_type [r], row, a)) in let pss = [[variable_pat ~ty:r x]] in - let body = with_dummy_pos (Projection (var x, name)) in + let body = with_dummy_pos (Projection (var x, label)) in let tyvars = List.map SugarQuantifier.mk_resolved [ab; rhob; effb] in let e : phrasenode = block_node diff --git a/core/desugarLabels.ml b/core/desugarLabels.ml new file mode 100644 index 000000000..40d31f27c --- /dev/null +++ b/core/desugarLabels.ml @@ -0,0 +1,68 @@ +open Utility +open Sugartypes + +module Env = Utility.StringMap + +let visitor = + object (self) + inherit SugarTraversals.map as super + + val mutable label_env : (Label.t list) Env.t = Env.empty + + method bind_labels = List.iter (fun l -> + let old_ls = match Env.find_opt (Label.name l) label_env with + | None -> [] + | Some ls -> ls in + label_env <- Env.add (Label.name l) (l::old_ls) label_env + ) + + method unbind_labels = List.iter (fun l -> + match Env.find_opt (Label.name l) label_env with + | None -> () + | Some [] | Some [_] -> label_env <- Env.remove (Label.name l) label_env + | Some (_::ls) -> label_env <- Env.add (Label.name l) ls label_env + ) + + method! label lbl = + if Label.is_global lbl || not (Label.is_free lbl) then + lbl + else + let bind_with = match Env.find_opt (Label.name lbl) label_env with + | Some (bw :: _) -> bw + | _ -> failwith ("The local label " ^ Label.show lbl ^ " is not bound") + in + Label.bind_local ~bind_with lbl + + method! bindingnode = function + | FreshLabel (labels, decls) -> + let labels = List.map Label.bind_local labels in + self#bind_labels labels ; + let decls = List.map self#binding decls in + self#unbind_labels labels ; + FreshLabel(labels, decls) + | b -> super#bindingnode b + + end + +let program p = visitor#program p + +let sentence = function + | Definitions bs -> + let bs' = visitor#list (fun o b -> o#binding b) bs in + Definitions bs' + | Expression p -> Expression p + | Directive d -> Directive d + +module Untyped = struct + open Transform.Untyped + + let name = "labels" + + let program state program' = + let program' = program program' in + return state program' + + let sentence state sentence' = + let sentence' = sentence sentence' in + return state sentence' +end diff --git a/core/desugarProcesses.ml b/core/desugarProcesses.ml index ae073231d..e0c9c22d0 100644 --- a/core/desugarProcesses.ml +++ b/core/desugarProcesses.ml @@ -1,4 +1,3 @@ -open Utility open CommonTypes open Sugartypes open SugarConstructors.DummyPositions @@ -81,7 +80,7 @@ object (o : 'self_type) Types.(remove_field hear (remove_field wild (Row (fieldenv, rho, false)))) in begin - match StringMap.find Types.hear fieldenv with + match Label.Map.find Types.hear fieldenv with | (Types.Present mbt) -> o#phrasenode (Switch (fn_appl "recv" [(Type, mbt); (Row, other_effects)] [], diff --git a/core/desugarSessionExceptions.ml b/core/desugarSessionExceptions.ml index 6f3ca2b4f..1acba4a41 100644 --- a/core/desugarSessionExceptions.ml +++ b/core/desugarSessionExceptions.ml @@ -127,7 +127,7 @@ object (o : 'self_type) let effect_cases = [otherwise_clause] in (* Manually construct a row with the two hardwired handler cases. *) - let raw_row = Types.row_with ("Return", (Types.Present try_dt)) inner_effects in + let raw_row = Types.row_with (Label.return, (Types.Present try_dt)) inner_effects in (* Dummy types *) let types = (inner_effects, try_dt, outer_effects, otherwise_dt) in @@ -193,8 +193,8 @@ let wrap_linear_handlers = constructor ~body:(var fresh_var) "Just", constructor "Nothing", dtopt)), [ - (with_dummy_pos (Pattern.Variant ("Just", (Some x))), super#phrase m); - (with_dummy_pos (Pattern.Variant ("Nothing", None)), super#phrase n) + (with_dummy_pos (Pattern.Variant (Label.make "Just", (Some x))), super#phrase m); + (with_dummy_pos (Pattern.Variant (Label.make "Nothing", None)), super#phrase n) ], None)) | p -> super#phrase p end diff --git a/core/evalir.ml b/core/evalir.ml index 505bcdafd..12769099e 100644 --- a/core/evalir.ml +++ b/core/evalir.ml @@ -167,7 +167,7 @@ struct opt_app (value env) (Lwt.return (`Record [])) r >>= fun res -> match res with | `Record fs -> - let fields = StringMap.bindings fields in + let fields = StringMap.bindings (Label.label_to_string_map fields) in LwtHelpers.foldr_lwt (fun (label, v) (fs: (string * Value.t) list) -> if List.mem_assoc label fs then @@ -194,11 +194,11 @@ struct begin match v with | `Record fields when - StringSet.for_all (fun label -> List.mem_assoc label fields) labels -> + Label.Set.for_all (fun label -> List.mem_assoc (Label.name label) fields) labels -> Lwt.return ( - `Record (StringSet.fold (fun label fields -> List.remove_assoc label fields) labels fields)) + `Record (Label.Set.fold (fun label fields -> List.remove_assoc (Label.name label) fields) labels fields)) | v -> - type_error ~action:(Printf.sprintf "erase labels {%s}" (String.concat "," (StringSet.elements labels))) + type_error ~action:(Printf.sprintf "erase labels {%s}" (String.concat "," (StringSet.elements (Label.label_to_string_set labels)))) "record" v end | Inject (label, v, _) -> @@ -211,7 +211,7 @@ struct value env v >>= fun v -> Lwt.return (List.map Value.unbox_xml (Value.unbox_list v) @ children)) children (Lwt.return []) >>= fun children -> - let attrs = StringMap.bindings attrs in + let attrs = StringMap.bindings (Label.label_to_string_map attrs) in LwtHelpers.foldr_lwt (fun (name, v) attrs -> value env v >>= fun str -> @@ -574,7 +574,7 @@ struct begin match v with | `Variant (label, _) as v -> begin - match StringMap.lookup label cases, default, v with + match StringMap.lookup label (Label.label_to_string_map cases), default, v with | Some (b, c), _, `Variant (_, v) | _, Some (b, c), v -> let var = Var.var_of_binder b in @@ -781,11 +781,11 @@ struct let r, _ = Types.unwrap_row (TypeUtils.extract_row t) in TypeUtils.extract_row_parts r in let fields = - StringMap.fold + Label.Map.fold (fun name t fields -> let open Types in match t with - | Present t -> (name, t)::fields + | Present t -> (Label.name name, t)::fields | _ -> assert false) fieldMap [] @@ -880,7 +880,7 @@ struct StringMap.map (function | Types.Present t -> t - | _ -> assert false) fields + | _ -> assert false) (Label.label_to_string_map fields) in Lwt.return (db, table, field_types, temporal_fields) @@ -918,7 +918,7 @@ struct StringMap.map (function | Types.Present t -> t - | _ -> assert false) fields + | _ -> assert false) (Label.label_to_string_map fields) in Lwt.return (db, table, field_types, temporal_fields) @@ -1016,7 +1016,7 @@ struct Debug.print ("chose label: " ^ label); begin - match StringMap.lookup label cases with + match StringMap.lookup label (Label.label_to_string_map cases) with | Some (b, body) -> let var = Var.var_of_binder b in computation (Value.Env.bind var (chan, Scope.Local) env) cont body diff --git a/core/frontend.ml b/core/frontend.ml index acdedb7f6..27a629b8e 100644 --- a/core/frontend.ml +++ b/core/frontend.ml @@ -133,6 +133,7 @@ module Untyped = struct ; (module DesugarLAttributes) ; (module LiftRecursive) ; (module DesugarTypeVariables) + ; (module DesugarLabels) ; (module DesugarEffects) ; (module DesugarDatatypes) |] diff --git a/core/generalise.ml b/core/generalise.ml index ac32f6640..3844fabf7 100644 --- a/core/generalise.ml +++ b/core/generalise.ml @@ -74,7 +74,7 @@ let rec get_type_args : gen_kind -> TypeVarSet.t -> datatype -> type_arg list = (* Row *) | Row (field_env, row_var, _) -> let field_vars = - FieldMap.fold + Label.Map.fold (fun _ field_spec vars -> vars @ get_presence_type_args kind bound_vars field_spec ) field_env [] in @@ -145,7 +145,7 @@ let rigidify_type_arg : type_arg -> unit = | Type, Meta point -> rigidify_point point | Presence, Meta point -> rigidify_point point | Row, Row (fields, point, _dual) -> - assert (FieldMap.is_empty fields); + assert (Label.Map.is_empty fields); rigidify_point point (* HACK: probably shouldn't happen *) | Row, Meta point -> rigidify_point point @@ -165,7 +165,7 @@ let mono_type_args : type_arg -> unit = | Type, Meta point -> check_sk point | Presence, Meta point -> check_sk point | Row, Row (fields, point, _dual) -> - assert (FieldMap.is_empty fields); + assert (Label.Map.is_empty fields); check_sk point (* HACK: probably shouldn't happen *) | Row, Meta point -> check_sk point diff --git a/core/instantiate.ml b/core/instantiate.ml index 4fe7ad13b..03ce6ab4b 100644 --- a/core/instantiate.ml +++ b/core/instantiate.ml @@ -127,14 +127,14 @@ let instantiates : instantiation_maps -> (datatype -> datatype) * (row -> row) * | Closed -> true | _ -> false in - let field_env' = FieldMap.fold + let field_env' = Label.Map.fold (fun label f field_env' -> let rec add = function - | Present t -> FieldMap.add label (Present (inst t)) field_env' + | Present t -> Label.Map.add label (Present (inst t)) field_env' | Absent -> if is_closed then field_env' - else FieldMap.add label Absent field_env' + else Label.Map.add label Absent field_env' | Meta point -> begin match Unionfind.find point with @@ -145,7 +145,7 @@ let instantiates : instantiation_maps -> (datatype -> datatype) * (row -> row) * else Meta point in - FieldMap.add label f field_env' + Label.Map.add label f field_env' | f -> add f end @@ -156,9 +156,9 @@ let instantiates : instantiation_maps -> (datatype -> datatype) * (row -> row) * in add f) field_env - FieldMap.empty in + Label.Map.empty in let field_env'', row_var', dual' = inst_row_var inst_map rec_env row_var dual |> TypeUtils.extract_row_parts in - Row (FieldMap.fold FieldMap.add field_env' field_env'', row_var', dual') + Row (Label.Map.fold Label.Map.add field_env' field_env'', row_var', dual') (* precondition: row_var has been flattened *) and inst_row_var : instantiation_maps -> inst_env -> row_var -> bool -> row = fun inst_map rec_env row_var dual -> (* HACK: fix the ill-formed rows that are introduced in the @@ -168,28 +168,28 @@ let instantiates : instantiation_maps -> (datatype -> datatype) * (row -> row) * let rowify t = match t with | Row _ -> t - | Meta row_var -> Row (FieldMap.empty, row_var, false) + | Meta row_var -> Row (Label.Map.empty, row_var, false) | Alias (PrimaryKind.Row, _,row) -> row | _ -> assert false in let instr = inst_row inst_map rec_env in let dual_if = if dual then dual_row else fun x -> x in match Unionfind.find row_var with - | Closed -> Row (FieldMap.empty, row_var, dual) + | Closed -> Row (Label.Map.empty, row_var, dual) | Var (var, _, _) -> if IntMap.mem var inst_map then dual_if (rowify (snd (IntMap.find var inst_map))) else - Row (FieldMap.empty, row_var, dual) + Row (Label.Map.empty, row_var, dual) | Recursive (var, kind, rec_row) -> if IntMap.mem var rec_env then - Row (FieldMap.empty, IntMap.find var rec_env, dual) + Row (Label.Map.empty, IntMap.find var rec_env, dual) else begin let var' = Types.fresh_raw_variable () in let point' = Unionfind.fresh (Var (var', kind, `Flexible)) in let rec_row' = inst_row inst_map (IntMap.add var point' rec_env) rec_row in let _ = Unionfind.change point' (Recursive (var', kind, rec_row')) in - Row (FieldMap.empty, point', dual) + Row (Label.Map.empty, point', dual) end | row -> dual_if (instr row) @@ -233,7 +233,7 @@ let instantiate_typ : bool -> datatype -> (type_arg list * datatype) = fun rigid let open PrimaryKind in match Kind.primary_kind kind with | (Type | Presence) as pk -> pk, Meta point - | Row -> Row, Row (FieldMap.empty, point, false) in + | Row -> Row, Row (Label.Map.empty, point, false) in IntMap.add var ty inst_env, ty :: tys in let inst_map, tys = diff --git a/core/ir.ml b/core/ir.ml index 1a7b660bb..81ce44c8e 100644 --- a/core/ir.ml +++ b/core/ir.ml @@ -18,9 +18,9 @@ type tyvar = Quantifier.t type tyarg = Types.type_arg [@@deriving show] -type name_set = Utility.stringset +type name_set = Label.Set.t [@@deriving show] -type 'a name_map = 'a Utility.stringmap +type 'a name_map = 'a Label.Map.t [@@deriving show] type 'a var_map = 'a Utility.intmap @@ -117,7 +117,7 @@ and special = | Select of Name.t * value | Choice of value * (binder * computation) name_map | Handle of handler - | DoOperation of Name.t * value list * Types.t + | DoOperation of Label.t * value list * Types.t and computation = binding list * tail_computation and effect_case = binder * binder * computation and handler = { @@ -174,7 +174,7 @@ let rec is_atom = let with_bindings bs' (bs, tc) = (bs' @ bs, tc) -let unit = Extend (Utility.StringMap.empty, None) +let unit = Extend (Label.Map.empty, None) let unit_comp = ([], Return unit) type program = computation diff --git a/core/ir.mli b/core/ir.mli index 060918cb8..280e71285 100644 --- a/core/ir.mli +++ b/core/ir.mli @@ -18,9 +18,9 @@ type tyvar = Quantifier.t type tyarg = Types.type_arg [@@deriving show] -type name_set = Utility.stringset +type name_set = Label.Set.t [@@deriving show] -type 'a name_map = 'a Utility.stringmap +type 'a name_map = 'a Label.Map.t [@@deriving show] type 'a var_map = 'a Utility.intmap @@ -119,7 +119,7 @@ and special = | Select of Name.t * value | Choice of value * (binder * computation) name_map | Handle of handler - | DoOperation of Name.t * value list * Types.t + | DoOperation of Label.t * value list * Types.t and computation = binding list * tail_computation and effect_case = binder * binder * computation and handler = { diff --git a/core/irCheck.ml b/core/irCheck.ml index 230e23b35..122e53383 100644 --- a/core/irCheck.ml +++ b/core/irCheck.ml @@ -222,7 +222,7 @@ let eq_types occurrence : type_eq_context -> (Types.datatype * Types.datatype) - row |> TypeUtils.extract_row_parts in if Types.is_closed_row row then let field_env' = - Types.FieldMap.filter + Label.Map.filter ( fun _ v -> match v with | T.Absent -> false | _ -> true ) @@ -426,12 +426,12 @@ let eq_types occurrence : type_eq_context -> (Types.datatype * Types.datatype) - | _, _ -> false and eq_field_envs (context, lfield_env, rfield_env) = let lfields_in_rfields = - FieldMap.for_all (fun field lp -> - match FieldMap.find_opt field rfield_env with + Label.Map.for_all (fun field lp -> + match Label.Map.find_opt field rfield_env with | Some rp -> eq_presence (context, lp, rp) | None -> false ) lfield_env in - lfields_in_rfields && FieldMap.cardinal lfield_env = FieldMap.cardinal rfield_env + lfields_in_rfields && Label.Map.cardinal lfield_env = Label.Map.cardinal rfield_env and eq_row_vars (context, lpoint, rpoint) = match Unionfind.find lpoint, Unionfind.find rpoint with | Closed, Closed -> true @@ -469,7 +469,7 @@ let check_eq_type_lists = fun (ctx : type_eq_context) exptl actl occurrence -> let ensure_effect_present_in_row ctx allowed_effects required_effect_name required_effect_type occurrence = let (map, _, _) = fst (Types.unwrap_row allowed_effects) |> TypeUtils.extract_row_parts in - match T.FieldMap.find_opt required_effect_name map with + match Label.Map.find_opt required_effect_name map with | Some (T.Present et) -> check_eq_types ctx et required_effect_type occurrence | _ -> raise_ir_type_error ("Required effect " ^ Label.show required_effect_name ^ " not present in effect row " ^ Types.string_of_row allowed_effects) occurrence @@ -585,7 +585,7 @@ struct o, Extend (fields, base), t | Project (name, v) -> let (o, v, vt) = o#value v in - o, Project (name, v), project_type ~overstep_quantifiers:false name vt + o, Project (name, v), project_type ~overstep_quantifiers:false (Label.make name) vt | Erase (names, v) -> let (o, v, vt) = o#value v in @@ -595,7 +595,7 @@ struct let o, v, vt = o#value v in let _ = match TypeUtils.concrete_type t with | Variant _ -> - o#check_eq_types (variant_at ~overstep_quantifiers:false name t) vt (SVal orig) + o#check_eq_types (variant_at ~overstep_quantifiers:false (Label.make name) t) vt (SVal orig) | _ -> raise_ir_type_error "trying to inject into non-variant type" (SVal orig) in o, Inject (name, v, t), t | TAbs (tyvars, v) -> @@ -617,7 +617,7 @@ struct let (o, attributes, attribute_types) = o#name_map (fun o -> o#value) attributes in let (o, children , children_types) = o#list (fun o -> o#value) children in - let _ = StringMap.iter (fun _ t -> o#check_eq_types (Primitive Primitive.String) t (SVal orig)) attribute_types in + let _ = Label.Map.iter (fun _ t -> o#check_eq_types (Primitive Primitive.String) t (SVal orig)) attribute_types in let _ = List.iter (fun t -> o#check_eq_types Types.xml_type t (SVal orig)) children_types in o, XmlNode (tag, attributes, children), Types.xml_type @@ -725,32 +725,32 @@ struct | Variant row as variant -> let unwrapped_row = fst (unwrap_row row) |> TypeUtils.extract_row_parts in let present_fields, has_bad_presence_polymorphism = - StringMap.fold (fun field field_spec (fields, poly) -> match field_spec with - | Present _ -> (StringSet.add field fields), poly - | Meta _ -> fields, StringMap.mem field cases + Label.Map.fold (fun field field_spec (fields, poly) -> match field_spec with + | Present _ -> (Label.Set.add field fields), poly + | Meta _ -> fields, Label.Map.mem field cases | Absent -> fields, poly | _ -> raise Types.tag_expectation_mismatch) - (fst3 unwrapped_row) (StringSet.empty, false) in + (fst3 unwrapped_row) (Label.Set.empty, false) in let is_closed = is_closed_row row in let has_default = OptionUtils.is_some default in - let case_fields = StringMap.fold (fun field _ fields -> StringSet.add field fields) cases StringSet.empty in + let case_fields = Label.Map.fold (fun field _ fields -> Label.Set.add field fields) cases Label.Set.empty in ensure (not has_bad_presence_polymorphism) "row contains presence-polymorphic labels with corresponding \ match clauses. These can only be handled by a default case." (STC orig); if has_default then - ensure (StringSet.subset case_fields present_fields) "superfluous case" (STC orig) + ensure (Label.Set.subset case_fields present_fields) "superfluous case" (STC orig) else begin - ensure (not (StringSet.is_empty present_fields)) "Case with neither cases nor default" (STC orig); + ensure (not (Label.Set.is_empty present_fields)) "Case with neither cases nor default" (STC orig); ensure (is_closed) "case without default over open row" (STC orig); - ensure (StringSet.equal case_fields present_fields) + ensure (Label.Set.equal case_fields present_fields) "cases not identical to present fields in closed row, no default case" (STC orig) end; let o, cases, types = - StringMap.fold + Label.Map.fold (fun name (binder, comp) (o, cases, types) -> let type_binder = Var.type_of_binder binder in let type_variant = variant_at ~overstep_quantifiers:false name variant in @@ -758,14 +758,14 @@ struct let o, b = o#binder binder in let o, c, t = o#computation comp in let o = o#remove_binder binder in - o, StringMap.add name (b,c) cases, t :: types) - cases (o, StringMap.empty, []) in + o, Label.Map.add name (b,c) cases, t :: types) + cases (o, Label.Map.empty, []) in let o, default, default_type = o#option (fun o (b, c) -> let o, b = o#binder b in let actual_default_type = Var.type_of_binder b in let expected_default_t = - StringMap.fold + Label.Map.fold (fun case _ v -> TypeUtils.split_variant_type case v |> snd) cases variant @@ -800,7 +800,8 @@ struct | Database v -> let o, v, vt = o#value v in (* v must be a record containing string fields name, args, and driver*) - List.iter (fun field -> + List.iter (fun name -> + let field = Label.make name in o#check_eq_types (project_type field vt) Types.string_type (SSpec special) ) ["name"; "args"; "driver"]; o, Database v, Primitive Primitive.DB @@ -904,7 +905,7 @@ struct | InsertReturning (tmp, _, _, (Constant (Constant.String id) as ret)) -> (* The return value must be encoded as a string literal, denoting a column *) - let ret_type = TypeUtils.project_type id table_read in + let ret_type = TypeUtils.project_type (Label.make id) table_read in o#check_eq_types Types.int_type ret_type (SSpec special); o, InsertReturning (tmp, source, rows, ret), Types.int_type | InsertReturning (_, _, _, _) -> @@ -980,7 +981,7 @@ struct let o, b = o#binder b in let o, c, t = o#computation c in o, (b, c), t) bs in - let t = (StringMap.to_alist ->- List.hd ->- snd) branch_types in + let t = (Label.Map.to_alist ->- List.hd ->- snd) branch_types in o, Choice (v, bs), t | Handle ({ ih_comp; ih_cases; ih_return; ih_depth }) -> (* outer effects is R_d in the IR formalization *) @@ -1039,19 +1040,19 @@ struct (* We now construct the inner effects from the outer effects and branch_presence_spec_types *) let (outer_effects_map, outer_effects_var, outer_effects_dualized) = outer_effects_parts in (* For each case branch, the corresponding entry goes directly into the field spec map of the inner effect row *) - let inner_effects_map_from_branches = StringMap.map (fun x -> Present x) branch_presence_spec_types in + let inner_effects_map_from_branches = Label.Map.map (fun x -> Present x) branch_presence_spec_types in (* We now add all entries from the outer effects that were not touched by the handler to the inner effects *) - let inner_effects_map = StringMap.fold (fun effect outer_presence_spec map -> - if StringMap.mem effect inner_effects_map_from_branches then + let inner_effects_map = Label.Map.fold (fun effect outer_presence_spec map -> + if Label.Map.mem effect inner_effects_map_from_branches then map else - StringMap.add effect outer_presence_spec map + Label.Map.add effect outer_presence_spec map ) inner_effects_map_from_branches outer_effects_map in let inner_effects = Row (inner_effects_map, outer_effects_var, outer_effects_dualized) in (if not (Types.is_closed_row outer_effects) then - let outer_effects_contain e = StringMap.mem e outer_effects_map in - ensure (StringMap.for_all (fun e _ -> outer_effects_contain e) cases) "Outer effects are open but do not mention an effect handled by handler" (SSpec special)); + let outer_effects_contain e = Label.Map.mem e outer_effects_map in + ensure (Label.Map.for_all (fun e _ -> outer_effects_contain e) cases) "Outer effects are open but do not mention an effect handled by handler" (SSpec special)); (* comp_t is A_c in the IR formalization *) let o, _ = o#set_allowed_effects inner_effects in diff --git a/core/irTraversals.ml b/core/irTraversals.ml index 64d4b731b..01c30cbc0 100644 --- a/core/irTraversals.ml +++ b/core/irTraversals.ml @@ -130,13 +130,13 @@ struct ('self_type -> 'a -> ('self_type * 'a * datatype)) -> 'a name_map -> 'self_type * 'a name_map * datatype name_map = fun f vmap -> - StringMap.fold + Label.Map.fold (fun name v (o, vmap, tmap) -> let (o, v, t) = f o v in - (o, StringMap.add name v vmap, - StringMap.add name t tmap)) + (o, Label.Map.add name v vmap, + Label.Map.add name t tmap)) vmap - (o, StringMap.empty, StringMap.empty) + (o, Label.Map.empty, Label.Map.empty) method var_map : 'a. @@ -196,7 +196,7 @@ struct o, Extend (fields, base), t | Project (name, v) -> let (o, v, vt) = o#value v in - o, Project (name, v), deconstruct (project_type name) vt + o, Project (name, v), deconstruct (project_type (Label.make name)) vt | Erase (names, v) -> let (o, v, vt) = o#value v in let t = deconstruct (erase_type names) vt in @@ -284,8 +284,8 @@ struct let o, c, t = o#computation c in o, (b, c), t) default in let t = - if not (StringMap.is_empty case_types) then - (StringMap.to_alist ->- List.hd ->- snd) case_types + if not (Label.Map.is_empty case_types) then + (Label.Map.to_alist ->- List.hd ->- snd) case_types else val_of default_type in @@ -389,7 +389,7 @@ struct let o, b = o#binder b in let o, c, t = o#computation c in o, (b, c), t) bs in - let t = (StringMap.to_alist ->- List.hd ->- snd) branch_types in + let t = (Label.Map.to_alist ->- List.hd ->- snd) branch_types in o, Choice (v, bs), t | Handle ({ ih_comp; ih_cases; ih_return; ih_depth }) -> let (o, comp, _) = o#computation ih_comp in diff --git a/core/irtojs.ml b/core/irtojs.ml index f81cfc79b..34cf3d226 100644 --- a/core/irtojs.ml +++ b/core/irtojs.ml @@ -1,7 +1,7 @@ -1 (** JavaScript generation *) open Utility open CommonTypes +module L = Label let js_hide_database_info = Js.hide_database_info let session_exceptions_enabled = Settings.get Basicsettings.Sessions.exceptions_enabled @@ -861,9 +861,9 @@ end = functor (K : CONTINUATION) -> struct | Ir.Extend (field_map, rest) -> let dict = Dict - (StringMap.fold + (L.Map.fold (fun name v dict -> - (name, gv v) :: dict) + (L.name name, gv v) :: dict) field_map []) in begin @@ -876,7 +876,7 @@ end = functor (K : CONTINUATION) -> struct project (gv v) name | Ir.Erase (names, v) -> call Runtime.Links.erase - [gv v; Aux.set_of_array (Arr (List.map strlit (StringSet.elements names)))] + [gv v; Aux.set_of_array (Arr (List.map strlit (StringSet.elements (L.label_to_string_set names))))] | Ir.Inject (name, v, _t) -> Dict [("_label", strlit name); ("_value", gv v)] @@ -926,8 +926,8 @@ end = functor (K : CONTINUATION) -> struct let open Code in call Runtime.Links.xml [Constructors.strlit tag; - Dict (StringMap.fold (fun name v bs -> - (name, generate_value env v) :: bs) attrs []); + Dict (L.Map.fold (fun name v bs -> + (L.name name, generate_value env v) :: bs) attrs []); Aux.List.of_array (Arr (List.map (generate_value env) children))] let generate_remote_call f_var xs_names env = @@ -1106,7 +1106,7 @@ end = functor (K : CONTINUATION) -> struct let comp = snd (generate_computation (VEnv.bind x x_name env) comp kappa) in Bind (x_name, project scrutinee "_value", comp) in - let cases = StringMap.map gen_cont cases in + let cases = L.Map.map gen_cont cases |> L.label_to_string_map in let default = opt_map gen_cont default in k (Switch (project scrutinee "_label", cases, default))) | Ir.If (v, c1, c2) -> @@ -1171,7 +1171,7 @@ end = functor (K : CONTINUATION) -> struct let (ch, chname) = name_binder cb in Bind (chname, channel, snd (generate_computation (VEnv.bind ch chname env) comp K.(skappa <> kappa))) in - let branches = StringMap.map generate_branch bs in + let branches = L.Map.map generate_branch bs |> L.label_to_string_map in Fn ([result], (Bind (received, message, (Switch (project (Var received) "_label", branches, None)))))) in let cont = K.(skappa' <> skappas) in @@ -1200,15 +1200,15 @@ end = functor (K : CONTINUATION) -> struct * environment passed as an argument already) need to be compiled specially *) let op = if (session_exceptions_enabled && - name = Value.session_exception_operation && + L.eq name Value.session_exception_operation && List.length args = 0) then let affected_variables = VariableInspection.get_affected_variables (K.reify kappa) in let affected_arr = Dict ([("1", Aux.List.of_array (Arr affected_variables))]) in - Dict [ ("_label", strlit name) + Dict [ ("_label", strlit (L.name name)) ; ("_value", Dict [("p", affected_arr); ("s", resumption)]) ] else - Dict [ ("_label", strlit name) + Dict [ ("_label", strlit (L.name name)) ; ("_value", Dict [("p", maybe_box args); ("s", resumption)]) ] in bind_skappa (bind_seta (return (apply_yielding (K.reify seta) [op] kappas)))) @@ -1242,8 +1242,8 @@ end = functor (K : CONTINUATION) -> struct let name_map = List.fold_left (fun box (i, _, initial_value) -> - StringMap.add (string_of_int i) initial_value box) - StringMap.empty params + L.Map.add (L.mk_int i) initial_value box) + L.Map.empty params in (Ir.Let (param_ptr_binder, ([], Ir.Return (Ir.Extend (name_map, None)))) :: bs, tc) in @@ -1307,12 +1307,12 @@ end = functor (K : CONTINUATION) -> struct StringMap.fold (fun operation_name clause cases -> StringMap.add operation_name - (if session_exceptions_enabled && operation_name = Value.session_exception_operation + (if session_exceptions_enabled && operation_name = L.name Value.session_exception_operation then let (xb,_,body) = clause in translate_exn_case env scrutinee (xb, body) kappas else translate_eff_case env scrutinee clause kappas) cases) - eff_cases StringMap.empty + (L.label_to_string_map eff_cases) StringMap.empty in let forward y ks = K.bind ks diff --git a/core/label.ml b/core/label.ml index ee7326653..c759b67ff 100644 --- a/core/label.ml +++ b/core/label.ml @@ -1,36 +1,96 @@ open Utility open CommonTypes +let internal_error message = + Errors.internal_error ~filename:"label.ml" ~message +let local_error show lbl = + internal_error ("Label " ^ show lbl ^ " is local but a global label was expected") +let not_local_error show lbl = + internal_error ("Label " ^ show lbl ^ " is global but a local label was expected") +let not_free_error show lbl = + internal_error ("Label " ^ show lbl ^ " is not free") + +module Uid = struct + type t = Id of Int.t | Free + + let show = function + | Free -> "free" + | Id id -> string_of_int id + + let compare uid uid' = match uid, uid' with + | Id id, Id id' -> Int.compare id id' + | Free, Free -> 0 + | Id _, _ -> -1 + | _, Id _ -> 1 + + let counter = ref 0 + + let new_uid () = counter:=!counter+1 ; Id !counter + + let is_free = function + | Free -> true + | _ -> false +end + module Label = struct - type local = Int.t - [@@deriving show] + type local = Name.t * Uid.t type global = Name.t - [@@deriving show] + (* type unresolved = Name.t *) type t = | Lcl of local | Gbl of global - [@@deriving show] + (* | Unr of unresolved *) - let counter = ref 0 + let show = function + | Lcl (name, id) -> "`" ^ name ^ "(" ^ Uid.show id ^ ")" + | Gbl name -> name + (* | Unr name -> "`?" ^ name *) - let mk_fresh () = Lcl (counter:=!counter+1 ; !counter) + let pp f l = + Format.pp_print_string f begin match l with + | Lcl (name, _) -> "`"^name + | Gbl name -> name + (* | Unr name -> "`?" ^ name *) + end + + let mk_local name = Lcl (name, Uid.Free) let mk_global name = Gbl name - let make = mk_global + (* let mk_unresolved name = Unr name *) + + let make ?(local=false) name = + if local then + mk_local name + else + mk_global name - let mk_int i = Gbl (string_of_int i) + let mk_int i = mk_global (string_of_int i) - let get_int = function + let to_int = function | Gbl g -> int_of_string g - | _ -> failwith "local label" + | l -> raise (local_error show l) + + let name = function + (* | Gbl name | Lcl (name,_) | Unr name -> name *) + | Lcl (name,_) -> "`"^name + | Gbl name -> name + (* | Unr name -> name *) + let compare lbl lbl' = match lbl,lbl' with - | Lcl l, Lcl l' -> Int.compare l l' + | Lcl(name, Uid.Free), Lcl(name', Uid.Free) -> String.compare name name' + | Lcl(_, uid), Lcl(_, uid') -> Uid.compare uid uid' | Gbl g, Gbl g' -> String.compare g g' - | Lcl _, _ -> 1 - | Gbl _, _ -> -1 + (* | Unr u, Unr u' -> String.compare u u' *) + (* | Unr _, _ *) + | Lcl _, Gbl _ -> 1 + | _, _ -> -1 + + let eq lbl lbl' = compare lbl lbl' = 0 + + let eq_name lbl name = eq lbl (mk_global name) let is_local = function | Lcl _ -> true @@ -40,6 +100,64 @@ module Label = struct | Gbl _ -> true | _ -> false - let one = Gbl "1" + let is_free = function + | Lcl (_, uid) -> Uid.is_free uid + | l -> raise (not_local_error show l) + + let uid = function + | Lcl (_, uid) -> uid + | l -> raise (not_local_error show l) + + let bind_local ?bind_with lbl = match bind_with, lbl with + | Some bind_lbl, Lcl (name, Uid.Free) -> Lcl (name, uid bind_lbl) + | Some _ , Lcl _ -> raise (not_free_error show lbl) + | None , Lcl (name, _) -> Lcl (name, Uid.new_uid ()) + | _ -> raise (not_local_error show lbl) + + + (* let is_resolved = function *) + (* | Unr _ -> false *) + (* | _ -> true *) + + + let one = mk_global "1" + let two = mk_global "2" + let return = mk_global "Return" + + + (* let resolve_global = function *) + (* | Unr name -> Gbl name *) + (* | _ -> failwith "already resolved" *) + + (* let resolve_local = function *) + (* | Unr name -> mk_local name *) + (* | _ -> failwith "already resolved" *) end + include Label + +module type LABELMAP = Utility.Map with type key = t +module Map : LABELMAP = Utility.Map.Make(Label) + +module type LABELSET = Utility.Set with type elt = t +module Set : LABELSET = Utility.Set.Make(Label) + +let string_to_label_map m = + Utility.StringMap.fold + (fun k v m -> Map.add (Label.make k) v m) + m Map.empty + +let label_to_string_map m = + Map.fold + (fun k v m -> Utility.StringMap.add (Label.name k) v m) + m Utility.StringMap.empty + +let string_to_label_set m = + Utility.StringSet.fold + (fun k m -> Set.add (Label.make k) m) + m Set.empty + +let label_to_string_set m = + Set.fold + (fun k m -> Utility.StringSet.add (Label.name k) m) + m Utility.StringSet.empty diff --git a/core/label.mli b/core/label.mli index eac1b56ff..1ea8deca5 100644 --- a/core/label.mli +++ b/core/label.mli @@ -1,25 +1,57 @@ open CommonTypes -type local = Int.t +module Uid : sig + type t = Id of Int.t | Free +end + +type local = Name.t * Uid.t type global = Name.t +(* type unresolved = Name.t *) type t = | Lcl of local | Gbl of global + (* | Unr of unresolved *) +(* type t = string *) [@@deriving show] -val mk_fresh : unit -> t - +val mk_local : Name.t -> t val mk_global : Name.t -> t -val make : Name.t -> t +(* val mk_unresolved : Name.t -> t *) +val make : ?local:bool -> Name.t -> t val mk_int : Int.t -> t - -val get_int : t -> Int.t +val to_int : t -> Int.t +val name : t -> Name.t val compare : t -> t -> int +val eq : t -> t -> bool +val eq_name : t -> Name.t -> bool val is_local : t -> bool val is_global : t -> bool +val is_free : t -> bool +(* val is_resolved : t -> bool *) + +val uid : t -> Uid.t +val bind_local : ?bind_with:t -> t -> t + val one : t +val two : t +val return : t + +(* val resolve_local : t -> t *) +(* val resolve_global : t -> t *) + + +module type LABELMAP = Utility.Map with type key = t +module Map : LABELMAP + +module type LABELSET = Utility.Set with type elt = t +module Set : LABELSET + +val string_to_label_map : 'a Utility.StringMap.t -> 'a Map.t +val label_to_string_map : 'a Map.t -> 'a Utility.StringMap.t +val string_to_label_set : Utility.StringSet.t -> Set.t +val label_to_string_set : Set.t -> Utility.StringSet.t diff --git a/core/lens_ir_conv.ml b/core/lens_ir_conv.ml index 5f1b0fead..7e6c09a60 100644 --- a/core/lens_ir_conv.ml +++ b/core/lens_ir_conv.ml @@ -348,7 +348,7 @@ let lens_sugar_phrase_of_ir p env = | I.Extend (ext_fields, r) -> let r = Option.map ~f:(links_value env) r in Option.value r ~default:(`Record [] |> Result.return) >>= fun r -> - let fields = StringMap.to_alist ext_fields in + let fields = StringMap.to_alist (Label.label_to_string_map ext_fields) in List.map_result ~f:(fun (k, v) -> links_value env v >>| fun v -> (k, v)) fields diff --git a/core/lens_sugar_conv.ml b/core/lens_sugar_conv.ml index 9d755e2c6..197f3474c 100644 --- a/core/lens_sugar_conv.ml +++ b/core/lens_sugar_conv.ml @@ -95,7 +95,7 @@ let rec lens_sugar_phrase_of_body v p = Format.asprintf "Unexpected expression to project on: %a" S.pp_phrase var |> Error.internal_error_res) - >>| fun () -> LPS.Var field + >>| fun () -> LPS.Var (Label.name field) | _ -> Format.asprintf "Unsupported sugar phrase in lens sugar phrase of body: %a" S.pp_phrase diff --git a/core/lens_type_conv.ml b/core/lens_type_conv.ml index 5a97c8bef..c9ff1f251 100644 --- a/core/lens_type_conv.ml +++ b/core/lens_type_conv.ml @@ -8,8 +8,14 @@ type 'a die = string -> 'a let to_links_map m = String.Map.fold - (fun k v m -> T.FieldMap.add (Label.make k) v m) - m T.FieldMap.empty + (fun k v m -> Label.Map.add (Label.make k) v m) + m Label.Map.empty + +let to_string_map m = + Label.Map.fold + (fun k v m -> String.Map.add (Label.name k) v m) + m String.Map.empty + let lookup_alias context ~alias = match Env.String.find_opt alias context with @@ -50,9 +56,9 @@ let rec lens_phrase_type_of_type t = | T.Record r -> lens_phrase_type_of_type r | T.Row (fields, _, _) -> let fields = - Utility.StringMap.to_alist fields - |> String.Map.from_alist - |> String.Map.map (fun v -> + Label.Map.to_alist fields + |> Label.Map.from_alist + |> Label.Map.map (fun v -> match v with | T.Present t -> lens_phrase_type_of_type t | _ -> @@ -60,7 +66,7 @@ let rec lens_phrase_type_of_type t = "lens_phrase_type_of_type only works on records with \ present types.") in - LPT.Record fields + LPT.Record (to_string_map fields) | _ -> failwith @@ Format.asprintf "Unsupported type %a in lens_phrase_type_of_type." T.pp diff --git a/core/lexer.mll b/core/lexer.mll index 74241a65a..9b445649d 100644 --- a/core/lexer.mll +++ b/core/lexer.mll @@ -237,6 +237,9 @@ rule lex ctxt nl = parse | '%' { PERCENT } | "/\\" { CAPITAL_LAMBDA } | initopchar opchar * as op { OPERATOR op } + | "`" (def_id as var) { if List.mem_assoc var keywords || not (Char.isUpper var.[0]) then + raise (LexicalError (lexeme lexbuf, lexeme_end_p lexbuf)) + else BTCONSTRUCTOR var } | '`' (def_id as var) '`' { if List.mem_assoc var keywords || Char.isUpper var.[0] then raise (LexicalError (lexeme lexbuf, lexeme_end_p lexbuf)) else OPERATOR var } diff --git a/core/lib.ml b/core/lib.ml index 570a9e897..7df8d0762 100644 --- a/core/lib.ml +++ b/core/lib.ml @@ -1746,7 +1746,7 @@ let rec function_arity = function | Function (Record row, _, _) -> let (l, _, _) = TypeUtils.extract_row_parts row in - (Some (FieldMap.size l)) + (Some (Label.Map.size l)) | ForAll (_, t) -> function_arity t | _ -> None diff --git a/core/moduleUtils.ml b/core/moduleUtils.ml index 6ee4597e8..94ba99d2e 100644 --- a/core/moduleUtils.ml +++ b/core/moduleUtils.ml @@ -173,7 +173,7 @@ let get_data_constructors init_constrs = method! datatypenode = function | Datatype.Variant (xs, _) -> - self#list (fun o (lbl, _) -> o#add_constr lbl) xs + self#list (fun o (lbl, _) -> o#add_constr (Label.name lbl)) xs | dt -> super#datatypenode dt end diff --git a/core/page.ml b/core/page.ml index 33c74c6da..17daf4bf7 100644 --- a/core/page.ml +++ b/core/page.ml @@ -120,7 +120,7 @@ module Make_RealPage (C : JS_PAGE_COMPILER) (G : JS_CODEGEN) = struct let escaped_state_string = `String state_string |> Json.json_to_string in let printed_code = - let _venv, code = C.generate_program venv ([], Ir.Return (Ir.Extend (StringMap.empty, None))) in + let _venv, code = C.generate_program venv ([], Ir.Return (Ir.Extend (Label.Map.empty, None))) in let code = f code in let code = code |> (C.generate_stubs valenv defs) |> C.wrap_with_server_lib_stubs diff --git a/core/parser.mly b/core/parser.mly index 378c5f1a3..36ade457d 100644 --- a/core/parser.mly +++ b/core/parser.mly @@ -298,6 +298,9 @@ let parse_foreign_language pos lang = raise (ConcreteSyntaxError (pos, Printf.sprintf "Unrecognised foreign language '%s'." lang)) +let local_label = Label.mk_local +let label = Label.mk_global + %} %token EOF @@ -334,7 +337,7 @@ let parse_foreign_language pos lang = %token UFLOAT %token STRING CDATA REGEXREPL %token CHAR -%token VARIABLE CONSTRUCTOR KEYWORD PERCENTVAR +%token VARIABLE CONSTRUCTOR KEYWORD PERCENTVAR BTCONSTRUCTOR %token LXML ENDTAG %token RXML SLASHRXML %token MU FORALL ALIEN SIG UNSAFE @@ -452,7 +455,8 @@ nofun_declaration: | typedecl SEMICOLON { $1 } | links_module | links_open SEMICOLON { $1 } | pollute = boption(OPEN) IMPORT CONSTRUCTOR SEMICOLON { import ~ppos:$loc($2) ~pollute [$3] } -| FRESH CONSTRUCTOR LBRACE declarations RBRACE { with_pos $loc (FreshLabel($2, $4))} +| FRESH separated_nonempty_list(COMMA, BTCONSTRUCTOR) + LBRACE declarations RBRACE { with_pos $loc (FreshLabel(List.map local_label $2, $4))} alien_datatype: | VARIABLE COLON datatype SEMICOLON { (binder ~ppos:$loc($1) $1, datatype $3) } @@ -677,7 +681,7 @@ unary_expression: | MINUSDOT unary_expression { unary_appl ~ppos:$loc UnaryOp.FloatMinus $2 } | OPERATOR unary_expression { unary_appl ~ppos:$loc (UnaryOp.Name $1) $2 } | postfix_expression | constructor_expression { $1 } -| DOOP CONSTRUCTOR loption(arg_spec) { with_pos $loc (DoOperation ($2, $3, None)) } +| DOOP constructor loption(arg_spec) { with_pos $loc (DoOperation ($2, $3, None)) } infix_appl: | unary_expression { $1 } @@ -1001,7 +1005,7 @@ block_contents: | /* empty */ { ([], with_pos $loc (TupleLit [])) } labeled_exp: -| preceded(EQ, VARIABLE) { ($1, with_pos $loc (Var $1)) } +| preceded(EQ, VARIABLE) { (label $1, with_pos $loc (Var $1)) } | separated_pair(record_label, EQ, exp) { $1 } labeled_exps: @@ -1166,14 +1170,14 @@ fields: | fields_def(field, COMMA, row_var, kinded_row_var) { $1 } field: -| CONSTRUCTOR /* allows nullary variant labels */ { ($1, present) } +| CONSTRUCTOR /* allows nullary variant labels */ { (label $1, present) } | field_label fieldspec { ($1, $2) } field_label: -| CONSTRUCTOR { $1 } -| VARIABLE { $1 } -| STRING { $1 } -| UINTEGER { string_of_int $1 } +| CONSTRUCTOR { label $1 } +| VARIABLE { label $1 } +| STRING { label $1 } +| UINTEGER { label (string_of_int $1) } rfields: | fields_def(rfield, COMMA, row_var, kinded_row_var) { $1 } @@ -1194,8 +1198,8 @@ vfields: | kinded_vrow_var { ([] , $1 ) } vfield: -| CONSTRUCTOR { ($1, present) } -| CONSTRUCTOR fieldspec { ($1, $2) } +| CONSTRUCTOR { (label $1, present) } +| CONSTRUCTOR fieldspec { (label $1, $2) } efields: | efield { ([$1], make_effect_var ~is_dot:false $loc) } @@ -1209,8 +1213,13 @@ efield: | effect_label fieldspec { ($1, $2) } effect_label: -| CONSTRUCTOR { $1 } -| VARIABLE { $1 } +| constructor { $1 } +| VARIABLE { label $1 } + +constructor: +| CONSTRUCTOR { label $1 } +| BTCONSTRUCTOR { local_label $1 } + effect_app: | CONSTRUCTOR { Datatype.EffectApplication($1, []) } @@ -1311,14 +1320,14 @@ cons_pattern: constructor_pattern: | negative_pattern { $1 } -| CONSTRUCTOR parenthesized_pattern? { with_pos $loc (Pattern.Variant ($1, $2)) } +| constructor parenthesized_pattern? { with_pos $loc (Pattern.Variant ($1, $2)) } constructors: -| separated_nonempty_list(COMMA, CONSTRUCTOR) { $1 } +| separated_nonempty_list(COMMA, constructor) { $1 } negative_pattern: | primary_pattern { $1 } -| MINUS CONSTRUCTOR { with_pos $loc (Pattern.Negative [$2]) } +| MINUS constructor { with_pos $loc (Pattern.Negative [$2]) } | MINUS LPAREN constructors RPAREN { with_pos $loc (Pattern.Negative $3) } parenthesized_pattern: @@ -1339,7 +1348,7 @@ patterns: | separated_nonempty_list(COMMA, pattern) { $1 } labeled_pattern: -| preceded(EQ, VARIABLE) { ($1, variable_pat ~ppos:$loc $1) } +| preceded(EQ, VARIABLE) { (label $1, variable_pat ~ppos:$loc $1) } | separated_pair(record_label, EQ, pattern) { $1 } labeled_patterns: diff --git a/core/query/delateralize.ml b/core/query/delateralize.ml index d34ab5e6e..6d6c27381 100644 --- a/core/query/delateralize.ml +++ b/core/query/delateralize.ml @@ -33,7 +33,7 @@ let graph_query (q1,ty1) x (q2,ty2) = let prom_delateralize gs q1 x (q2,ty2) y (q3,ty3) = let p = Var.fresh_raw_var () in let graph, ftys = graph_query (QL.Dedup q2,ty2) x (q3,ty3) in - let vp = QL.Var (p,Types.make_record_type ftys) in + let vp = QL.Var (p,Types.make_record_type (Label.string_to_label_map ftys)) in let vx = QL.Var (x,ty2) in let eq_test a b = QL.Apply (QL.Primitive "==", [a;b]) in let and_query a b = QL.Apply (QL.Primitive "&&", [a;b]) in diff --git a/core/query/evalNestedQuery.ml b/core/query/evalNestedQuery.ml index 321425222..1d037a342 100644 --- a/core/query/evalNestedQuery.ml +++ b/core/query/evalNestedQuery.ml @@ -90,7 +90,7 @@ struct match TypeUtils.concrete_type t with | Types.Primitive t -> `Primitive t | Types.Record row -> - let (fields, _, _) = TypeUtils.extract_row_parts row in + let fields = TypeUtils.extract_row_parts row |> fst3 |> Label.label_to_string_map in `Record (StringMap.map (function | Present t -> nested_type_of_type t @@ -463,7 +463,7 @@ struct (fun (x, source) -> match source with | QL.Table t -> - let tyx = Types.make_record_type (QL.table_field_types t) in + let tyx = Types.make_record_type (QL.table_field_types t |> Label.string_to_label_map) in QL.eta_expand_var (x, tyx) | _ -> assert false) gs_out) in @@ -487,6 +487,7 @@ struct QL.recdty_field_types (Types.make_tuple_type [r_out_type; index_type]) + |> Label.string_to_label_map |> Types.make_record_type in (q, QL.For (None, gs_out, [], where x_out (QL.Singleton (pair r_out index))), diff --git a/core/query/evalQuery.ml b/core/query/evalQuery.ml index f3faa2b08..57ff5d8d9 100644 --- a/core/query/evalQuery.ml +++ b/core/query/evalQuery.ml @@ -104,7 +104,7 @@ struct function | (x, QL.Table t) -> let field_types = QL.table_field_types t in - let tyx = Types.make_record_type field_types in + let tyx = Types.make_record_type (Label.string_to_label_map field_types) in List.rev (StringMap.fold (fun name _t es -> diff --git a/core/query/mixingQuery.ml b/core/query/mixingQuery.ml index 16173272f..eae33001b 100644 --- a/core/query/mixingQuery.ml +++ b/core/query/mixingQuery.ml @@ -111,8 +111,8 @@ let rec flattened_pair_ft x y = in StringMap.fold (fun f t acc -> StringMap.add (flatfield "2" f) t acc) (Q.field_types_of_row rowy) out1 (* XXX: same as above, using a field with an empty name to deal with variables of non-record type ... will it work? *) - | Q.Var (nx, tyx), _ -> flattened_pair_ft (Q.Var (nx, Types.make_record_type (StringMap.from_alist ["", tyx]))) y - | _, Q.Var (ny, tyy) -> flattened_pair_ft x (Q.Var (ny, Types.make_record_type (StringMap.from_alist ["", tyy]))) + | Q.Var (nx, tyx), _ -> flattened_pair_ft (Q.Var (nx, Types.make_record_type (Label.Map.from_alist [Label.make "", tyx]))) y + | _, Q.Var (ny, tyy) -> flattened_pair_ft x (Q.Var (ny, Types.make_record_type (Label.Map.from_alist [Label.make "", tyy]))) | _ -> assert false (* gs must ALWAYS be non-empty, both input and output!*) @@ -410,12 +410,12 @@ struct label else StringMap.add label (xlate env v) fields) - ext_fields + (Label.label_to_string_map ext_fields) fields) | _ -> Q.query_error "Error adding fields: non-record" end | Project (label, r) -> Q.Project (xlate env r, label) - | Erase (labels, r) -> Q.Erase (xlate env r, labels) + | Erase (labels, r) -> Q.Erase (xlate env r, Label.label_to_string_set labels) | Inject (label, v, _) -> Q.Variant (label, xlate env v) | TAbs (_, v) -> xlate env v | TApp (v, _) -> xlate env v @@ -429,9 +429,9 @@ struct List.map Q.unbox_xml (Q.unbox_list v) @ children) children [] in let children = - StringMap.fold + Label.Map.fold (fun name v attrs -> - Value.Attr (name, Q.unbox_string (xlate env v)) :: attrs) + Value.Attr (Label.name name, Q.unbox_string (xlate env v)) :: attrs) attrs children in Q.Singleton (Q.XML (Value.Node (tag, children))) @@ -513,7 +513,7 @@ struct raise (Errors.runtime_error "special not allowed in query block") | Case (v, cases, default) -> let v' = xlate env v in - let cases' = StringMap.map (fun (x,y) -> (x, computation env y)) cases in + let cases' = Label.Map.map (fun (x,y) -> (x, computation env y)) cases |> Label.label_to_string_map in let default' = opt_app (fun (x,y) -> Some (x, computation env y)) None default in Q.Case (v', cases', default') | If (c, t, e) -> @@ -806,7 +806,7 @@ struct end let compile_update : Value.database -> Value.env -> - ((Ir.var * string * Types.datatype StringMap.t) * Ir.computation option * Ir.computation) -> Sql.query = + ((Ir.var * string * Types.datatype Label.Map.t) * Ir.computation option * Ir.computation) -> Sql.query = fun db env ((x, table, field_types), where, body) -> let tyx = Types.make_record_type field_types in let env = Q.bind (Q.env_of_value_env QueryPolicy.Mixing env) (x, Q.Var (x, tyx)) in @@ -819,7 +819,7 @@ let compile_update : Value.database -> Value.env -> q let compile_delete : Value.database -> Value.env -> - ((Ir.var * string * Types.datatype StringMap.t) * Ir.computation option) -> Sql.query = + ((Ir.var * string * Types.datatype Label.Map.t) * Ir.computation option) -> Sql.query = fun db env ((x, table, field_types), where) -> let tyx = Types.make_record_type field_types in let env = Q.bind (Q.env_of_value_env QueryPolicy.Mixing env) (x, Q.Var (x, tyx)) in diff --git a/core/query/mixingQuery.mli b/core/query/mixingQuery.mli index 789daab11..f393adcd2 100644 --- a/core/query/mixingQuery.mli +++ b/core/query/mixingQuery.mli @@ -29,7 +29,7 @@ sig end val compile_update : Value.database -> Value.env -> - ((Ir.var * string * Types.datatype StringMap.t) * Ir.computation option * Ir.computation) -> Sql.query + ((Ir.var * string * Types.datatype Label.Map.t) * Ir.computation option * Ir.computation) -> Sql.query val compile_delete : Value.database -> Value.env -> - ((Ir.var * string * Types.datatype StringMap.t) * Ir.computation option) -> Sql.query \ No newline at end of file + ((Ir.var * string * Types.datatype Label.Map.t) * Ir.computation option) -> Sql.query diff --git a/core/query/query.ml b/core/query/query.ml index 57f65f850..1489c9454 100644 --- a/core/query/query.ml +++ b/core/query/query.ml @@ -173,7 +173,7 @@ let rec reduce_for_source : Q.t * (Q.t -> Q.t) -> Q.t = let (from_field, to_field) = OptionUtils.val_of temporal_fields in (* Transaction / Valid-time tables: Need to wrap as metadata *) (* First, generate a fresh variable for the table *) - let make_spec_map = StringMap.map (fun x -> Types.Present x) in + let make_spec_map m = Label.Map.map (fun x -> Types.Present x) (Label.string_to_label_map m) in let field_types = Q.table_field_types table in let base_field_types = StringMap.filter @@ -323,12 +323,12 @@ struct label else StringMap.add label (xlate env v) fields) - ext_fields + (Label.label_to_string_map ext_fields) fields) | _ -> Q.query_error "Error adding fields: non-record" end | Project (label, r) -> Q.Project (xlate env r, label) - | Erase (labels, r) -> Q.Erase (xlate env r, labels) + | Erase (labels, r) -> Q.Erase (xlate env r, Label.label_to_string_set labels) | Inject (label, v, _) -> Q.Variant (label, xlate env v) | TAbs (_, v) -> xlate env v | TApp (v, _) -> xlate env v @@ -342,9 +342,9 @@ struct List.map Q.unbox_xml (Q.unbox_list v) @ children) children [] in let children = - StringMap.fold + Label.Map.fold (fun name v attrs -> - Value.Attr (name, Q.unbox_string (xlate env v)) :: attrs) + Value.Attr (Label.name name, Q.unbox_string (xlate env v)) :: attrs) attrs children in Q.Singleton (Q.XML (Value.Node (tag, children))) @@ -426,7 +426,7 @@ struct raise (Errors.runtime_error "special not allowed in query block") | Case (v, cases, default) -> let v' = xlate env v in - let cases' = StringMap.map (fun (x,y) -> (x, computation env y)) cases in + let cases' = Label.Map.map (fun (x,y) -> (x, computation env y)) cases |> Label.label_to_string_map in let default' = opt_app (fun (x,y) -> Some (x, computation env y)) None default in Q.Case (v', cases', default') | If (c, t, e) -> @@ -598,7 +598,7 @@ end let compile_update : Value.database -> Value.env -> ((Ir.var * string * Types.datatype StringMap.t) * Ir.computation option * Ir.computation) -> Sql.query = fun db env ((x, table, field_types), where, body) -> - let tyx = Types.make_record_type field_types in + let tyx = Types.make_record_type (Label.string_to_label_map field_types) in let env = Q.bind (Q.env_of_value_env QueryPolicy.Flat env) (x, Q.Var (x, tyx)) in (* let () = opt_iter (fun where -> Debug.print ("where: "^Ir.show_computation where)) where in*) let where = opt_map (Eval.norm_comp env) where in @@ -611,7 +611,7 @@ let compile_update : Value.database -> Value.env -> let compile_delete : Value.database -> Value.env -> ((Ir.var * string * Types.datatype StringMap.t) * Ir.computation option) -> Sql.query = fun db env ((x, table, field_types), where) -> - let tyx = Types.make_record_type field_types in + let tyx = Types.make_record_type (Label.string_to_label_map field_types) in let env = Q.bind (Q.env_of_value_env QueryPolicy.Flat env) (x, Q.Var (x, tyx)) in let where = opt_map (Eval.norm_comp env) where in let q = Q.delete ((x, table), where) in diff --git a/core/query/queryLang.ml b/core/query/queryLang.ml index 7afde1c59..2faf141cd 100644 --- a/core/query/queryLang.ml +++ b/core/query/queryLang.ml @@ -164,10 +164,10 @@ let rec expression_of_base_value : Value.t -> t = function raise (internal_error ("expression_of_base_value undefined for " ^ Value.string_of_value other)) -let field_types_of_spec_map = - StringMap.map (function +let field_types_of_spec_map m = + Label.label_to_string_map (Label.Map.map (function | Types.Present t -> t - | _ -> assert false) + | _ -> assert false) m) let field_types_of_row r = let (field_spec_map,_,_) = TypeUtils.extract_row_parts r in @@ -299,7 +299,7 @@ let rec occurs_free_gens (gs : (Var.var * t) list) q = let rec type_of_expression : t -> Types.datatype = fun v -> let te = type_of_expression in let record fields : Types.datatype = - Types.make_record_type (StringMap.map te fields) + Types.make_record_type (Label.Map.map te (Label.string_to_label_map fields)) in match v with | Var (_,ty) -> ty @@ -634,8 +634,8 @@ let rec select_clause : Sql.index -> bool -> t -> Sql.select_clause = let fields = Sql.Fields (List.rev - (StringMap.fold - (fun name _ fields -> + (Label.Map.fold + (fun label _ fields -> let name = Label.name label in (Sql.Project (var, name), name)::fields) fields [])) diff --git a/core/query/temporalQuery.ml b/core/query/temporalQuery.ml index f04081851..678f63515 100644 --- a/core/query/temporalQuery.ml +++ b/core/query/temporalQuery.ml @@ -191,7 +191,7 @@ module TransactionTime = struct let env = Q.bind (Q.env_of_value_env QueryPolicy.Nested env) - (x, Q.Var (x, Types.make_record_type field_types)) + (x, Q.Var (x, Types.make_record_type (Label.string_to_label_map field_types))) in let where = opt_map (Query.Eval.norm_comp env) where in let body = Query.Eval.norm_comp env body in @@ -207,7 +207,7 @@ module TransactionTime = struct let env = Q.bind (Q.env_of_value_env QueryPolicy.Nested env) - (x, Q.Var (x, Types.make_record_type field_types)) in + (x, Q.Var (x, Types.make_record_type (Label.string_to_label_map field_types))) in let where = opt_map (Query.Eval.norm_comp env) where in let q = delete ((x, table), where) to_field in Debug.print ("Generated delete query: " ^ (db#string_of_query q)); @@ -221,8 +221,8 @@ module ValidTime = struct let metadata x field_types from_field to_field = let extended_field_types = field_types - |> StringMap.add from_field Types.datetime_type - |> StringMap.add to_field Types.datetime_type in + |> Label.Map.add (Label.make from_field) Types.datetime_type + |> Label.Map.add (Label.make to_field) Types.datetime_type in let table_var = Q.Var (x, Types.make_record_type extended_field_types) in let metadata_record = StringMap.from_alist [ @@ -681,11 +681,12 @@ module ValidTime = struct fun upd db env ((x, table, field_types), where, body) from_field to_field -> + let field_types' = Label.string_to_label_map field_types in let to_bind = match upd with | Ir.NonsequencedUpdate _ -> - metadata x field_types from_field to_field - | _ -> Q.Var (x, Types.make_record_type field_types) in + metadata x field_types' from_field to_field + | _ -> Q.Var (x, Types.make_record_type field_types') in let env = Q.bind @@ -727,6 +728,7 @@ module ValidTime = struct string (* to field *) -> Sql.query = fun del db env ((x, table, field_types), where) from_field to_field -> + let field_types' = Label.string_to_label_map field_types in let env to_bind = Q.bind (Q.env_of_value_env QueryPolicy.Nested env) @@ -736,7 +738,7 @@ module ValidTime = struct begin match del with | CurrentDeletion -> - let env = env (Q.Var (x, Types.make_record_type field_types)) in + let env = env (Q.Var (x, Types.make_record_type field_types')) in let where = opt_map (Query.Eval.norm_comp env) where in Delete.current ((x, table), where) from_field to_field @@ -744,11 +746,11 @@ module ValidTime = struct (* Same logic as deletion -- just that the metadata * we've bound will be different *) let md = - metadata x field_types from_field to_field in + metadata x field_types' from_field to_field in let where = opt_map (Query.Eval.norm_comp (env md)) where in QueryLang.delete ((x, table), where) | SequencedDeletion { validity_from; validity_to } -> - let env = env (Q.Var (x, Types.make_record_type field_types)) in + let env = env (Q.Var (x, Types.make_record_type field_types')) in let where = opt_map (Query.Eval.norm_comp env) where in Delete.sequenced field_types ((x, table), where, @@ -837,10 +839,10 @@ module TemporalJoin = struct List.fold_left (fun acc (k, x) -> match x with - | Present t -> StringMap.add k t acc + | Present t -> Label.Map.add k t acc | _ -> assert false) - (StringMap.empty) - (fst3 x.row |> StringMap.to_alist) in + (Label.Map.empty) + (fst3 x.row |> Label.Map.to_alist) in (Q.Var (v, Types.make_record_type ty), from_field, to_field) ) tables in diff --git a/core/sugarConstructors.ml b/core/sugarConstructors.ml index 33200fcd9..e35223134 100644 --- a/core/sugarConstructors.ml +++ b/core/sugarConstructors.ml @@ -76,7 +76,7 @@ module SugarConstructors (Position : Pos) (* Create a tuple for orderby clauses (includes a hack to ensure that 1-tuples are preserved) *) let orderby_tuple ?(ppos=dp) = function - | [e] -> record ~ppos [("1", e)] + | [e] -> record ~ppos [(Label.one, e)] | es -> with_pos ppos (TupleLit es) let cp_unit ppos = with_pos ppos (CPUnquote ([], tuple ~ppos [])) diff --git a/core/sugarConstructorsIntf.ml b/core/sugarConstructorsIntf.ml index e1a59bf32..666cbcb4b 100644 --- a/core/sugarConstructorsIntf.ml +++ b/core/sugarConstructorsIntf.ml @@ -56,7 +56,7 @@ module type SugarConstructorsSig = sig val block_node : block_body -> phrasenode val datatype : Datatype.with_pos -> Datatype.with_pos * 'a option val cp_unit : t -> cp_phrase - val record : ?ppos:t -> ?exp:phrase -> (Name.t * phrase) list -> phrase + val record : ?ppos:t -> ?exp:phrase -> (Label.t * phrase) list -> phrase val tuple : ?ppos:t -> phrase list -> phrase val orderby_tuple : ?ppos:t -> phrase list -> phrase val list : @@ -138,9 +138,9 @@ module type SugarConstructorsSig = sig (* Database queries *) val db_exps - : ?ppos:t -> (Name.t * phrase) list -> phrase + : ?ppos:t -> (Label.t * phrase) list -> phrase val db_insert - : ?ppos:t -> temporal_insertion option -> phrase -> Name.t list -> phrase -> string option + : ?ppos:t -> temporal_insertion option -> phrase -> Label.t list -> phrase -> string option -> phrase val query : ?ppos:t -> (phrase * phrase) option -> QueryPolicy.t -> phrase -> phrase @@ -172,8 +172,8 @@ module type SugarConstructorsSig = sig -> tbl_keys:(phrase option) -> phrase (* Name *) -> Datatype.with_pos (* Type *) - -> (Name.t * fieldconstraint list) list (* Field constraints *) - -> (Temporality.t * (string * string)) option (* Temporal to/from fields *) + -> (Label.t * fieldconstraint list) list (* Field constraints *) + -> (Temporality.t * (Label.t * Label.t)) option (* Temporal to/from fields *) -> phrase (* Database *) -> phrase (* TableLit *) end diff --git a/core/sugarTraversals.ml b/core/sugarTraversals.ml index e29c94bf7..bc9205f98 100644 --- a/core/sugarTraversals.ml +++ b/core/sugarTraversals.ml @@ -121,7 +121,7 @@ class map = let _x = o#list (fun o (_x, _x_i1) -> - let _x = o#name _x in + let _x = o#label _x in let _x_i1 = o#fieldspec _x_i1 in (_x, _x_i1)) _x in let _x_i1 = o#row_var _x_i1 in (_x, _x_i1) @@ -280,20 +280,20 @@ class map = let _x = o#list (fun o (_x, _x_i1) -> - let _x = o#name _x in + let _x = o#label _x in let _x_i1 = o#phrase _x_i1 in (_x, _x_i1)) _x in let _x_i1 = o#option (fun o -> o#phrase) _x_i1 in RecordLit ((_x, _x_i1)) | Projection ((_x, _x_i1)) -> let _x = o#phrase _x in - let _x_i1 = o#name _x_i1 in Projection ((_x, _x_i1)) + let _x_i1 = o#label _x_i1 in Projection ((_x, _x_i1)) | With ((_x, _x_i1)) -> let _x = o#phrase _x in let _x_i1 = o#list (fun o (_x, _x_i1) -> - let _x = o#name _x in + let _x = o#label _x in let _x_i1 = o#phrase _x_i1 in (_x, _x_i1)) _x_i1 in With ((_x, _x_i1)) @@ -316,6 +316,7 @@ class map = let _x_i2 = o#option (fun o -> o#typ) _x_i2 in ConstructorLit ((_x, _x_i1, _x_i2)) | DoOperation (name, ps, t) -> + let name = o#label name in let ps = o#list (fun o -> o#phrase) ps in let t = o#option (fun o -> o#typ) t in DoOperation (name, ps, t) @@ -364,7 +365,7 @@ class map = (* let _x = o#phrase _x in *) (* let _x_i1 = o#phrase _x_i1 in Link ((_x, _x_i1)) *) | Select ((_x, _x_i1)) -> - let _x = o#name _x in + let _x = o#label _x in let _x_i1 = o#phrase _x_i1 in Select (_x, _x_i1) | Offer ((_x, _x_i1, _x_i2)) -> @@ -400,7 +401,7 @@ class map = let tbl_field_constraints = o#list (fun o (_x, _x_i1) -> - let _x = o#name _x in + let _x = o#label _x in let _x_i1 = o#list (fun o -> o#fieldconstraint) _x_i1 in (_x, _x_i1)) tbl_field_constraints in @@ -428,8 +429,8 @@ class map = LensFunDepsLit (_x, _x_i1, _x_i2) | LensDropLit ((_x, _x_i1, _x_i2, _x_i3, _x_i4)) -> let _x = o#phrase _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#string _x_i2 in + let _x_i1 = o#label _x_i1 in + let _x_i2 = o#label _x_i2 in let _x_i3 = o#phrase _x_i3 in let _x_i4 = o#option (fun o -> o#unknown) _x_i4 in LensDropLit((_x, _x_i1, _x_i2, _x_i3, _x_i4)) @@ -466,7 +467,7 @@ class map = in DBDelete ((_del, _x, _x_i1, _x_i2)) | DBInsert ((_mode, _x, _x_i1, _x_i2, _x_i3)) -> let _x = o#phrase _x in - let _x_i1 = o#list (fun o -> o#name) _x_i1 in + let _x_i1 = o#list (fun o -> o#label) _x_i1 in let _x_i2 = o#phrase _x_i2 in let _x_i3 = o#option (fun o -> o#phrase) _x_i3 in DBInsert ((_mode, _x, _x_i1, _x_i2, _x_i3)) @@ -478,7 +479,7 @@ class map = let _x_i3 = o#list (fun o (_x, _x_i1) -> - let _x = o#name _x in + let _x = o#label _x in let _x_i1 = o#phrase _x_i1 in (_x, _x_i1)) _x_i3 in DBUpdate ((_upd, _x, _x_i1, _x_i2, _x_i3)) @@ -552,22 +553,22 @@ class map = let _x_i1 = o#pattern _x_i1 in Cons ((_x, _x_i1)) | List _x -> let _x = o#list (fun o -> o#pattern) _x in List _x | Variant ((_x, _x_i1)) -> - let _x = o#name _x in + let _x = o#label _x in let _x_i1 = o#option (fun o -> o#pattern) _x_i1 in Variant ((_x, _x_i1)) | Effect (name, ps, k) -> - let name = o#name name in + let name = o#label name in let ps = o#list (fun o -> o#pattern) ps in let k = o#pattern k in Effect (name, ps, k) | Negative _x -> - let _x = o#list (fun o -> o#name) _x + let _x = o#list (fun o -> o#label) _x in Negative _x | Record ((_x, _x_i1)) -> let _x = o#list (fun o (_x, _x_i1) -> - let _x = o#name _x in + let _x = o#label _x in let _x_i1 = o#pattern _x_i1 in (_x, _x_i1)) _x in let _x_i1 = o#option (fun o -> o#pattern) _x_i1 @@ -635,6 +636,20 @@ class map = | Absent -> Absent | Var _x -> let _x = o#type_variable _x in Var _x + method label : Datatype.label -> Datatype.label = + let open Label in function + (* | Unr _x -> let _x = o#name _x in Unr _x *) + | Gbl _x -> let _x = o#name _x in Gbl _x + | Lcl (_x, _x_i1) -> + let _x = o#name _x in + let _x_i1 = o#uid _x_i1 in + Lcl (_x, _x_i1) + + method uid : Label.Uid.t -> Label.Uid.t = + let open Label.Uid in function + | Free -> Free + | Id _x -> let _x = o#int _x in Id _x + method fieldconstraint : fieldconstraint -> fieldconstraint = fun fc -> fc @@ -785,7 +800,7 @@ class map = let language = o#foreign_language (Alien.language alien) in AlienBlock (Alien.modify ~language ~declarations alien) | FreshLabel(_x, _x_i1) -> - let _x = o#name _x in + let _x = o#list (fun o -> o#label) _x in let _x_i1 = o#list (fun o -> o#binding) _x_i1 in FreshLabel(_x,_x_i1) @@ -970,7 +985,7 @@ class fold = let o = o#list (fun o (_x, _x_i1) -> - let o = o#name _x in let o = o#fieldspec _x_i1 in o) + let o = o#label _x in let o = o#fieldspec _x_i1 in o) _x in let o = o#row_var _x_i1 in o @@ -1106,17 +1121,17 @@ class fold = let o = o#list (fun o (_x, _x_i1) -> - let o = o#name _x in let o = o#phrase _x_i1 in o) + let o = o#label _x in let o = o#phrase _x_i1 in o) _x in let o = o#option (fun o -> o#phrase) _x_i1 in o | Projection ((_x, _x_i1)) -> - let o = o#phrase _x in let o = o#name _x_i1 in o + let o = o#phrase _x in let o = o#label _x_i1 in o | With ((_x, _x_i1)) -> let o = o#phrase _x in let o = o#list (fun o (_x, _x_i1) -> - let o = o#name _x in let o = o#phrase _x_i1 in o) + let o = o#label _x in let o = o#phrase _x_i1 in o) _x_i1 in o | TypeAnnotation ((_x, _x_i1)) -> @@ -1130,7 +1145,7 @@ class fold = let o = o#name _x in let o = o#option (fun o -> o#phrase) _x_i1 in o | DoOperation (name,ps,t) -> - let o = o#name name in + let o = o#label name in let o = o#option (fun o -> o#unknown) t in let o = o#list (fun o -> o#phrase) ps in o | Handle { sh_expr; sh_effect_cases; sh_value_cases; sh_descr } -> @@ -1176,7 +1191,7 @@ class fold = (* let o = o#phrase _x_i1 *) (* in o *) | Select ((_x, _x_i1)) -> - let o = o#name _x in + let o = o#label _x in let o = o#phrase _x_i1 in o | Offer ((_x, _x_i1, _x_i2)) -> @@ -1209,7 +1224,7 @@ class fold = let o = o#list (fun o (_x, _x_i1) -> - let o = o#name _x in + let o = o#label _x in let o = o#list (fun o -> o#fieldconstraint) _x_i1 in o) tbl_field_constraints in let o = o#phrase tbl_keys in @@ -1233,8 +1248,8 @@ class fold = o | LensDropLit ((_x, _x_i1, _x_i2, _x_i3, _x_i4)) -> let o = o#phrase _x in - let o = o#string _x_i1 in - let o = o#string _x_i2 in + let o = o#label _x_i1 in + let o = o#label _x_i2 in let o = o#phrase _x_i3 in let o = o#option (fun o -> o#unknown) _x_i4 in o @@ -1269,7 +1284,7 @@ class fold = let o = o#option (fun o -> o#phrase) _x_i2 in o | DBInsert ((_mode, _x, _x_i1, _x_i2, _x_i3)) -> let o = o#phrase _x in - let o = o#list (fun o -> o#name) _x_i1 in + let o = o#list (fun o -> o#label) _x_i1 in let o = o#phrase _x_i2 in let o = o#option (fun o -> o#phrase) _x_i3 in o | DBUpdate ((_upd, _x, _x_i1, _x_i2, _x_i3)) -> let o = o#option (fun o -> o#temporal_update) _upd in @@ -1279,7 +1294,7 @@ class fold = let o = o#list (fun o (_x, _x_i1) -> - let o = o#name _x in let o = o#phrase _x_i1 in o) + let o = o#label _x in let o = o#phrase _x_i1 in o) _x_i3 in o | Xml ((_x, _x_i1, _x_i2, _x_i3)) -> @@ -1342,20 +1357,20 @@ class fold = let o = o#pattern _x in let o = o#pattern _x_i1 in o | List _x -> let o = o#list (fun o -> o#pattern) _x in o | Variant ((_x, _x_i1)) -> - let o = o#name _x in + let o = o#label _x in let o = o#option (fun o -> o#pattern) _x_i1 in o | Effect (name, ps, k) -> - let o = o#name name in + let o = o#label name in let o = o#list (fun o -> o#pattern) ps in let o = o#pattern k in o | Negative _x -> - let o = o#list (fun o -> o#name) _x in o + let o = o#list (fun o -> o#label) _x in o | Record ((_x, _x_i1)) -> let o = o#list (fun o (_x, _x_i1) -> - let o = o#name _x in let o = o#pattern _x_i1 in o) + let o = o#label _x in let o = o#pattern _x_i1 in o) _x in let o = o#option (fun o -> o#pattern) _x_i1 in o | Tuple _x -> let o = o#list (fun o -> o#pattern) _x in o @@ -1418,6 +1433,20 @@ class fold = method fieldconstraint : fieldconstraint -> 'self_type = fun _ -> o + method label : Datatype.label -> 'self_type = + let open Label in function + (* | Unr _x -> let o = o#name _x in o *) + | Gbl _x -> let o = o#name _x in o + | Lcl (_x, _x_i1) -> + let o = o#name _x in + let o = o#uid _x_i1 in + o + + method uid : Label.Uid.t -> 'self_type = + let open Label.Uid in function + | Free -> o + | Id _x -> let o = o#int _x in o + method directive : directive -> 'self_type = fun (_x, _x_i1) -> let o = o#string _x in let o = o#list (fun o -> o#string) _x_i1 in o @@ -1555,7 +1584,7 @@ class fold = o#datatype' dt) (Alien.declarations alien) | FreshLabel(_x, _x_i1) -> - let o = o#name _x in + let o = o#list (fun o -> o#label) _x in let o = o#list (fun o -> o#binding) _x_i1 in o @@ -1730,7 +1759,7 @@ class fold_map = method row_var : Datatype.row_var -> ('self_type * Datatype.row_var) = let open Datatype in function | EffectApplication (_x, _x_i1) -> - let (o, _x) = o#string _x in + let (o, _x) = o#name _x in let (o, _x_i1) = o#list (fun o -> o#type_arg) _x_i1 in (o, EffectApplication (_x, _x_i1)) | Closed -> (o, Closed) @@ -1745,7 +1774,7 @@ class fold_map = let (o, _x) = o#list (fun o (_x, _x_i1) -> - let (o, _x) = o#string _x in + let (o, _x) = o#label _x in let (o, _x_i1) = o#fieldspec _x_i1 in (o, (_x, _x_i1))) _x in let (o, _x_i1) = o#row_var _x_i1 in (o, (_x, _x_i1)) @@ -1907,20 +1936,20 @@ class fold_map = let (o, _x) = o#list (fun o (_x, _x_i1) -> - let (o, _x) = o#name _x in + let (o, _x) = o#label _x in let (o, _x_i1) = o#phrase _x_i1 in (o, (_x, _x_i1))) _x in let (o, _x_i1) = o#option (fun o -> o#phrase) _x_i1 in (o, (RecordLit ((_x, _x_i1)))) | Projection ((_x, _x_i1)) -> let (o, _x) = o#phrase _x in - let (o, _x_i1) = o#name _x_i1 in (o, (Projection ((_x, _x_i1)))) + let (o, _x_i1) = o#label _x_i1 in (o, (Projection ((_x, _x_i1)))) | With ((_x, _x_i1)) -> let (o, _x) = o#phrase _x in let (o, _x_i1) = o#list (fun o (_x, _x_i1) -> - let (o, _x) = o#name _x in + let (o, _x) = o#label _x in let (o, _x_i1) = o#phrase _x_i1 in (o, (_x, _x_i1))) _x_i1 in (o, (With ((_x, _x_i1)))) @@ -1945,6 +1974,7 @@ class fold_map = let o, _x_i2 = o#option (fun o -> o#typ) _x_i2 in (o, (ConstructorLit ((_x, _x_i1, _x_i2)))) | DoOperation (name, ps, t) -> + let (o, name) = o#label name in let (o, t) = o#option (fun o -> o#typ) t in let (o, ps) = o#list (fun o -> o#phrase) ps in (o, DoOperation (name, ps, t)) @@ -1993,7 +2023,7 @@ class fold_map = (* let (o, _x) = o#phrase _x in *) (* let (o, _x_i1) = o#phrase _x in (o, (Link(_x, _x_i1))) *) | Select ((_x, _x_i1)) -> - let (o, _x) = o#name _x in + let (o, _x) = o#label _x in let (o, _x_i1) = o#phrase _x_i1 in (o, (Select (_x, _x_i1))) | Offer ((_x, _x_i1, _x_i2)) -> @@ -2039,7 +2069,7 @@ class fold_map = let (o, tbl_field_constraints) = o#list (fun o (_x, _x_i1) -> - let (o, _x) = o#name _x in + let (o, _x) = o#label _x in let (o, _x_i1) = o#list (fun o -> o#fieldconstraint) _x_i1 in (o, (_x, _x_i1))) tbl_field_constraints in @@ -2068,8 +2098,8 @@ class fold_map = (o, (LensFunDepsLit (_x, _x_i1, _x_i2))) | LensDropLit ((_x, _x_i1, _x_i2, _x_i3, _x_i4)) -> let (o, _x) = o#phrase _x in - let (o, _x_i1) = o#string _x_i1 in - let (o, _x_i2) = o#string _x_i2 in + let (o, _x_i1) = o#label _x_i1 in + let (o, _x_i2) = o#label _x_i2 in let (o, _x_i3) = o#phrase _x_i3 in let (o, _x_i4) = o#option (fun o -> o#unknown) _x_i4 in (o, (LensDropLit ((_x, _x_i1, _x_i2, _x_i3, _x_i4)))) @@ -2106,7 +2136,7 @@ class fold_map = in (o, (DBDelete ((_del, _x, _x_i1, _x_i2)))) | DBInsert ((_mode, _x, _x_i1, _x_i2, _x_i3)) -> let (o, _x) = o#phrase _x in - let (o, _x_i1) = o#list (fun o -> o#name) _x_i1 in + let (o, _x_i1) = o#list (fun o -> o#label) _x_i1 in let (o, _x_i2) = o#phrase _x_i2 in let (o, _x_i3) = o#option (fun o -> o#phrase) _x_i3 in (o, (DBInsert ((_mode, _x, _x_i1, _x_i2, _x_i3)))) @@ -2118,7 +2148,7 @@ class fold_map = let (o, _x_i3) = o#list (fun o (_x, _x_i1) -> - let (o, _x) = o#name _x in + let (o, _x) = o#label _x in let (o, _x_i1) = o#phrase _x_i1 in (o, (_x, _x_i1))) _x_i3 in (o, (DBUpdate ((_upd, _x, _x_i1, _x_i2, _x_i3)))) @@ -2223,21 +2253,21 @@ class fold_map = | List _x -> let (o, _x) = o#list (fun o -> o#pattern) _x in (o, (List _x)) | Variant ((_x, _x_i1)) -> - let (o, _x) = o#name _x in + let (o, _x) = o#label _x in let (o, _x_i1) = o#option (fun o -> o#pattern) _x_i1 in (o, (Variant ((_x, _x_i1)))) | Effect (name, ps, k) -> - let (o, name) = o#name name in + let (o, name) = o#label name in let (o, ps) = o#list (fun o -> o#pattern) ps in let (o, k) = o#pattern k in (o, Effect (name, ps, k)) | Negative _x -> - let (o, _x) = o#list (fun o -> o#name) _x in (o, (Negative _x)) + let (o, _x) = o#list (fun o -> o#label) _x in (o, (Negative _x)) | Record ((_x, _x_i1)) -> let (o, _x) = o#list (fun o (_x, _x_i1) -> - let (o, _x) = o#name _x in + let (o, _x) = o#label _x in let (o, _x_i1) = o#pattern _x_i1 in (o, (_x, _x_i1))) _x in let (o, _x_i1) = o#option (fun o -> o#pattern) _x_i1 @@ -2312,6 +2342,20 @@ class fold_map = method fieldconstraint : fieldconstraint -> ('self_type * fieldconstraint) = fun fc -> (o, fc) + method label : Datatype.label -> ('self_type * Datatype.label) = + let open Label in function + (* | Unr _x -> let (o,_x) = o#name _x in (o, Unr _x) *) + | Gbl _x -> let (o,_x) = o#name _x in (o, Gbl _x) + | Lcl (_x, _x_i1) -> + let (o, _x) = o#name _x in + let (o, _x_i1) = o#uid _x_i1 in + (o, Lcl (_x, _x_i1)) + + method uid : Label.Uid.t -> ('self_type * Label.Uid.t) = + let open Label.Uid in function + | Free -> (o, Free) + | Id _x -> let (o, _x) = o#int _x in (o, Id _x) + method directive : directive -> ('self_type * directive) = fun (_x, _x_i1) -> let (o, _x) = o#string _x in @@ -2489,7 +2533,7 @@ class fold_map = in o, AlienBlock (Alien.modify ~language:lang ~declarations alien) | FreshLabel(_x, _x_i1) -> - let o, _x = o#name _x in + let o, _x = o#list (fun o -> o#label) _x in let o, _x_i1 = o#list (fun o -> o#binding) _x_i1 in o, FreshLabel(_x,_x_i1) diff --git a/core/sugarTraversals.mli b/core/sugarTraversals.mli index d3fb2a34d..8a5f45e3f 100644 --- a/core/sugarTraversals.mli +++ b/core/sugarTraversals.mli @@ -59,6 +59,8 @@ class map : method handle_params : handler_parameterisation -> handler_parameterisation method fieldspec : Datatype.fieldspec -> Datatype.fieldspec method fieldconstraint : fieldconstraint -> fieldconstraint + method label : Datatype.label -> Datatype.label + method uid : Label.Uid.t -> Label.Uid.t method directive : directive -> directive method datatype : Datatype.with_pos -> Datatype.with_pos method datatypenode : Datatype.t -> Datatype.t @@ -143,6 +145,8 @@ class fold : method handle_params : handler_parameterisation -> 'self method fieldspec : Datatype.fieldspec -> 'self method fieldconstraint : fieldconstraint -> 'self + method label : Datatype.label -> 'self + method uid : Label.Uid.t -> 'self method directive : directive -> 'self method datatype : Datatype.with_pos -> 'self method datatypenode : Datatype.t -> 'self @@ -198,6 +202,8 @@ object ('self) method directive : directive -> 'self * directive method fieldconstraint : fieldconstraint -> 'self * fieldconstraint method fieldspec : Datatype.fieldspec -> 'self * Datatype.fieldspec + method label : Datatype.label -> 'self * Datatype.label + method uid : Label.Uid.t -> 'self * Label.Uid.t method int : int -> 'self * int method float : float -> 'self * float method funlit : funlit -> 'self * funlit diff --git a/core/sugartoir.ml b/core/sugartoir.ml index 380ec60e3..adbc3eb4b 100644 --- a/core/sugartoir.ml +++ b/core/sugartoir.ml @@ -129,11 +129,11 @@ sig val letvar : (var_info * tail_computation sem * tyvar list * (var -> tail_computation sem)) -> tail_computation sem - val xml : value sem * string * (Name.t * (value sem) list) list * (value sem) list -> value sem - val record : (Name.t * value sem) list * (value sem) option -> value sem + val xml : value sem * string * (Label.t * (value sem) list) list * (value sem) list -> value sem + val record : (Label.t * value sem) list * (value sem) option -> value sem val project : value sem * Name.t -> value sem - val update : value sem * (Name.t * value sem) list -> value sem + val update : value sem * (Label.t * value sem) list -> value sem val coerce : value sem * datatype -> value sem @@ -155,7 +155,7 @@ sig | `ValidSequencedDelete of (value sem * value sem) | `ValidNonsequencedDelete ] option * CompilePatterns.Pattern.t * value sem * tail_computation sem option) -> tail_computation sem - val do_operation : Name.t * (value sem) list * Types.datatype -> tail_computation sem + val do_operation : Label.t * (value sem) list * Types.datatype -> tail_computation sem val handle : env -> (tail_computation sem * (CompilePatterns.Pattern.t * (env -> tail_computation sem)) list * @@ -423,14 +423,14 @@ struct (fun attrs -> M.bind children (fun children -> - let attrs = StringMap.from_alist attrs in + let attrs = Label.Map.from_alist attrs in lift (XmlNode (name, attrs, children), Types.xml_type))) let record (fields, r) = let field_types = List.fold_left - (fun field_types (name, s) -> StringMap.add name (sem_type s) field_types) - StringMap.empty + (fun field_types (name, s) -> Label.Map.add name (sem_type s) field_types) + Label.Map.empty fields in let s' = lift_alist fields in match r with @@ -438,16 +438,16 @@ struct let t = Types.make_record_type field_types in M.bind s' (fun fields -> - lift (Extend (StringMap.from_alist fields, None), t)) + lift (Extend (Label.Map.from_alist fields, None), t)) | Some s -> let t = Types.Record (Types.extend_row field_types (TypeUtils.extract_row (sem_type s))) in bind s (fun r -> M.bind s' - (fun fields -> lift (Extend (StringMap.from_alist fields, Some r), t))) + (fun fields -> lift (Extend (Label.Map.from_alist fields, Some r), t))) let project (s, name) = - let t = TypeUtils.project_type name (sem_type s) in + let t = TypeUtils.project_type (Label.make name) (sem_type s) in bind s (fun v -> lift (Project (name, v), t)) let erase (s, names) = @@ -466,8 +466,8 @@ struct let names = List.fold_left (fun names (name, _) -> - StringSet.add name names) - StringSet.empty + Label.Set.add name names) + Label.Set.empty fields in record (fields, Some (erase (s, names))) @@ -492,7 +492,7 @@ struct let case_zero (s, t) = bind s (fun v -> - lift (Case (v, StringMap.empty, None), t)) + lift (Case (v, Label.Map.empty, None), t)) let database s = bind s (fun v -> lift (Special (Database v), Types.Primitive Primitive.DB)) @@ -572,7 +572,7 @@ struct M.bind (alien_binding (x_info, object_name, language)) rest let select (l, e) = - let t = TypeUtils.select_type l (sem_type e) in + let t = TypeUtils.select_type (Label.make l) (sem_type e) in bind e (fun v -> lift (Special (Select (l, v)), t)) let offer env (v, cases, t) = @@ -960,15 +960,15 @@ struct *) ec e | TupleLit es -> - let fields = mapIndex (fun e i -> (string_of_int (i+1), ev e)) es in + let fields = mapIndex (fun e i -> (Label.mk_int (i+1), ev e)) es in cofv (I.record (fields, None)) | RecordLit (fields, rest) -> cofv (I.record (List.map (fun (name, e) -> (name, ev e)) fields, opt_map ev rest)) - | Projection (e, name) -> - cofv (I.project (ev e, name)) + | Projection (e, label) -> + cofv (I.project (ev e, Label.name label)) | With (e, fields) -> cofv (I.update (ev e, @@ -1031,7 +1031,7 @@ struct in I.switch env (ev e, cases, t) | DatabaseLit (name, (None, _)) -> - I.database (ev (WithPos.make ~pos (RecordLit ([("name", name)], + I.database (ev (WithPos.make ~pos (RecordLit ([(Label.make "name", name)], Some (WithPos.make ~pos (FnAppl (WithPos.make ~pos (Var "getDatabaseConfig"), []))))))) | DatabaseLit (name, (Some driver, args)) -> let args = @@ -1040,7 +1040,7 @@ struct | Some args -> args in I.database - (ev (WithPos.make ~pos (RecordLit ([("name", name); ("driver", driver); ("args", args)], None)))) + (ev (WithPos.make ~pos (RecordLit ([(Label.make "name", name); (Label.make "driver", driver); (Label.make "args", args)], None)))) | LensLit (table, Some t) -> let table = ev table in I.lens_handle (table, t) @@ -1051,7 +1051,7 @@ struct | LensDropLit (lens, drop, key, default, Some t) -> let lens = ev lens in let default = ev default in - I.lens_drop_handle (lens, drop, key, default, t) + I.lens_drop_handle (lens, Label.name drop, Label.name key, default, t) | LensSelectLit (lens, pred, Some t) -> let lens = ev lens in let trow = Lens.Type.sort t |> Lens.Sort.record_type in @@ -1082,7 +1082,7 @@ struct tbl_name; tbl_type = (tmp, _, Some (readtype, writetype, neededtype)); tbl_keys; tbl_temporal_fields; tbl_database; _ } -> I.table_handle (ev tbl_database, ev tbl_name, ev tbl_keys, - (tmp, readtype, writetype, neededtype), tbl_temporal_fields) + (tmp, readtype, writetype, neededtype), OptionUtils.opt_map (fun (x,y) -> Label.name x, Label.name y) tbl_temporal_fields) (* (name, (_, Some (readtype, writetype, neededtype)), _constraints, keys, db) -> *) | Xml (tag, attrs, attrexp, children) -> if tag = "#" then @@ -1094,6 +1094,7 @@ struct List.map ev children)) else let attrs = alistmap (List.map ev) attrs in + let attrs = List.map (fun (l,v) -> Label.make l, v) attrs in let children = List.map ev children in let body = I.xml (instantiate "^^" [(Row, eff)], tag, attrs, children) in @@ -1169,7 +1170,7 @@ struct I.db_delete env (del, p, source, where) | DBTemporalJoin (mode, e, _) -> I.temporal_join (mode, ec e) | Select (l, e) -> - I.select (l, ev e) + I.select (Label.name l, ev e) | Offer (e, cases, Some t) -> let eff = lookup_effects env in let cases = @@ -1317,6 +1318,8 @@ struct let xt = Binder.to_type binder in I.alien (Var.make_info xt x scope, Alien.object_name alien, Alien.language alien, fun v -> eval_bindings scope (extend [x] [(v, xt)] env) bs e) + | FreshLabel (_, decls) -> (* TODO: is that right ? ignore local labels *) + eval_bindings scope env (decls @ bs) e | Aliases _ | Infix _ -> (* Ignore type alias and infix declarations - they diff --git a/core/sugartypes.ml b/core/sugartypes.ml index a1c74db1c..78256860b 100644 --- a/core/sugartypes.ml +++ b/core/sugartypes.ml @@ -207,9 +207,9 @@ module Datatype = struct | Dual of with_pos | End and with_pos = t WithPos.t - and row = (string * fieldspec) list * row_var + and row = (label * fieldspec) list * row_var and row_var = - | EffectApplication of string * type_arg list + | EffectApplication of Name.t * type_arg list | Closed | Open of SugarTypeVar.t | Recursive of SugarTypeVar.t * row @@ -221,6 +221,7 @@ module Datatype = struct | Type of with_pos | Row of row | Presence of fieldspec + and label = Label.t [@@deriving show] end @@ -241,10 +242,10 @@ module Pattern = struct | Nil | Cons of with_pos * with_pos | List of with_pos list - | Variant of Name.t * with_pos option - | Effect of Name.t * with_pos list * with_pos - | Negative of Name.t list - | Record of (Name.t * with_pos) list * with_pos option + | Variant of Label.t * with_pos option + | Effect of Label.t * with_pos list * with_pos + | Negative of Label.t list + | Record of (Label.t * with_pos) list * with_pos option | Tuple of with_pos list | Constant of Constant.t | Variable of Binder.with_pos @@ -398,9 +399,9 @@ and table_lit = { tbl_type: (Temporality.t * Datatype.with_pos * (Types.datatype * Types.datatype * Types.datatype) option); - tbl_field_constraints: (Name.t * fieldconstraint list) list; + tbl_field_constraints: (Label.t * fieldconstraint list) list; tbl_keys: phrase; - tbl_temporal_fields: (string * string) option; + tbl_temporal_fields: (Label.t * Label.t) option; tbl_database: phrase } and iterpatt = @@ -463,15 +464,15 @@ and phrasenode = | TAbstr of SugarQuantifier.t list * phrase | TAppl of phrase * type_arg' list | TupleLit of phrase list - | RecordLit of (Name.t * phrase) list * phrase option - | Projection of phrase * Name.t - | With of phrase * (Name.t * phrase) list + | RecordLit of (Label.t * phrase) list * phrase option + | Projection of phrase * Label.t + | With of phrase * (Label.t * phrase) list | TypeAnnotation of phrase * datatype' | Upcast of phrase * datatype' * datatype' | Instantiate of phrase | Generalise of phrase | ConstructorLit of Name.t * phrase option * Types.datatype option - | DoOperation of Name.t * phrase list * Types.datatype option + | DoOperation of Label.t * phrase list * Types.datatype option | Handle of handler | Switch of phrase * (Pattern.with_pos * phrase) list * Types.datatype option @@ -479,18 +480,18 @@ and phrasenode = | DatabaseLit of phrase * (phrase option * phrase option) | TableLit of table_lit | DBDelete of temporal_deletion option * Pattern.with_pos * phrase * phrase option - | DBInsert of temporal_insertion option * phrase * Name.t list * phrase * phrase option + | DBInsert of temporal_insertion option * phrase * Label.t list * phrase * phrase option | DBUpdate of temporal_update option * Pattern.with_pos * phrase * - phrase option * (Name.t * phrase) list + phrase option * (Label.t * phrase) list | DBTemporalJoin of Temporality.t * phrase * Types.datatype option | LensLit of phrase * Lens.Type.t option | LensSerialLit of phrase * string list * Lens.Type.t option (* the lens keys lit is a literal that takes an expression and is converted into a LensLit with the corresponding table keys marked in the lens_sort *) | LensKeysLit of phrase * phrase * Lens.Type.t option - | LensFunDepsLit of phrase * (string list * string list) list * + | LensFunDepsLit of phrase * (Label.t list * Label.t list) list * Lens.Type.t option - | LensDropLit of phrase * string * string * phrase * + | LensDropLit of phrase * Label.t * Label.t * phrase * Lens.Type.t option | LensSelectLit of phrase * phrase * Lens.Type.t option | LensJoinLit of phrase * phrase * phrase * phrase * phrase * @@ -507,7 +508,7 @@ and phrasenode = | PagePlacement of phrase | FormBinding of phrase * Pattern.with_pos (* choose *) - | Select of Name.t * phrase + | Select of Label.t * phrase (* choice *) | Offer of phrase * (Pattern.with_pos * phrase) list * Types.datatype option @@ -531,7 +532,7 @@ and bindingnode = | Exp of phrase | Module of { binder: Binder.with_pos; members: binding list } | AlienBlock of Alien.multi Alien.t - | FreshLabel of Name.t * binding list + | FreshLabel of Label.t list * binding list and binding = bindingnode WithPos.t and block_body = binding list * phrase and cp_phrasenode = @@ -813,6 +814,12 @@ struct | Import _ | Open _ | Aliases _ -> empty, empty + | FreshLabel (_, decls) -> + List.fold_left + (fun (b,f) decl -> let b', f' = binding decl in + StringSet.union b b', StringSet.union f f') + (StringSet.empty, StringSet.empty) + decls (* This is technically a declaration, thus the name should probably be treated as bound rather than free. *) | Infix { name; _ } -> empty, singleton name diff --git a/core/transformSugar.ml b/core/transformSugar.ml index 50252549f..e9c8cddf3 100644 --- a/core/transformSugar.ml +++ b/core/transformSugar.ml @@ -24,7 +24,7 @@ let type_section env = let (fields, rho, _) = TypeUtils.extract_row_parts row in let eb, e = Types.fresh_row_quantifier default_effect_subkind in - let r = Record (Row (FieldMap.add label (Present a) fields, rho, false)) in + let r = Record (Row (Label.Map.add (Label.make label) (Present a) fields, rho, false)) in ForAll ([ab; rhob; eb], Function (Types.make_tuple_type [r], e, a)) | Name var -> TyEnv.find var env @@ -432,13 +432,13 @@ class transform (env : Types.typing_environment) = let (o, fields, field_types) = let rec list o = function - | [] -> (o, [], StringMap.empty) + | [] -> (o, [], Label.Map.empty) | (name, e)::fields -> let (o, e, t) = o#phrase e in let (o, fields, field_types) = list o fields in (o, (name, e)::fields, - StringMap.add name t field_types) + Label.Map.add name t field_types) in list o fields in let (o, base, base_type) = option o (fun o -> o#phrase) base in @@ -471,7 +471,7 @@ class transform (env : Types.typing_environment) = let ( fs, rv, closed ) = Types.flatten_row row |> TypeUtils.extract_row_parts in - let fs = List.fold_left2 (fun fs (name, _) t -> StringMap.add name (Present t) fs) fs fields ts in + let fs = List.fold_left2 (fun fs (name, _) t -> Label.Map.add name (Present t) fs) fs fields ts in Record (Row (fs, rv, closed)) | _ -> t in @@ -905,6 +905,11 @@ class transform (env : Types.typing_environment) = | (Infix _) as node -> (o, node) | Exp e -> let (o, e, _) = o#phrase e in (o, Exp e) + | FreshLabel(labels, decls) -> + (* do we wanna do something with labels ? *) + let o, decls = List.fold_left_map + (fun o d -> o#binding d) o decls in + (o, FreshLabel(labels, decls)) | AlienBlock _ -> assert false | Module _ -> assert false | Import _ -> assert false diff --git a/core/typeSugar.ml b/core/typeSugar.ml index 234a5bea5..3e37c5af2 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -1672,6 +1672,13 @@ let unbind_var context v = {context with var_env = Env.unbind v co let bind_alias context (v, t) = {context with tycon_env = Env.bind v t context.tycon_env} let bind_effects context r = {context with effect_row = r} +let extend context context' = (* this might not be super smart *) + { var_env = Env.extend context.var_env context'.var_env ; + rec_vars = StringSet.union context.rec_vars context'.rec_vars; + tycon_env = Env.extend context.tycon_env context'.tycon_env ; + effect_row = context.effect_row ; + desugared = context.desugared && context'.desugared } + (* TODO(dhil): I have extracted the Usage abstraction from my name hygiene/compilation unit patch. The below module is a compatibility module which will make it easier for me to merge my other branch @@ -1817,8 +1824,8 @@ let type_section pos context s = let a = Types.fresh_type_variable (lin_unl, res_any) in let rho = Types.fresh_row_variable (lin_unl, res_any) in let effects = Types.make_empty_open_row default_effect_subkind in (* projection is pure! *) - let r = Record (Row (FieldMap.add label (Present a) FieldMap.empty, rho, false)) in - ([(PrimaryKind.Type, a); (PrimaryKind.Row, Row (FieldMap.empty, rho, false)); (PrimaryKind.Row, effects)], + let r = Record (Row (Label.Map.add (Label.make label) (Present a) Label.Map.empty, rho, false)) in + ([(PrimaryKind.Type, a); (PrimaryKind.Row, Row (Label.Map.empty, rho, false)); (PrimaryKind.Row, effects)], Function (Types.make_tuple_type [r], effects, a)), Usage.empty | Name var -> @@ -1839,11 +1846,11 @@ let type_frozen_section context s = | Project label -> let a = Types.fresh_rigid_type_variable (lin_unl, res_any) in let rho = Types.fresh_rigid_row_variable (lin_unl, res_any) in - let effects = StringMap.empty, Types.fresh_rigid_row_variable default_effect_subkind, false in - let r = Record (Row (StringMap.add label (Present a) StringMap.empty, rho, false)) in + let effects = Label.Map.empty, Types.fresh_rigid_row_variable default_effect_subkind, false in + let r = Record (Row (Label.Map.add (Label.make label) (Present a) Label.Map.empty, rho, false)) in Types.for_all (Types.quantifiers_of_type_args [(PrimaryKind.Type, a); - (PrimaryKind.Row, Row (StringMap.empty, rho, false)); + (PrimaryKind.Row, Row (Label.Map.empty, rho, false)); (PrimaryKind.Row, Row effects)], Function (Types.make_tuple_type [r], Row effects, a)), Usage.empty @@ -1931,15 +1938,15 @@ let close_pattern_type : Pattern.with_pos list -> Types.datatype -> Types.dataty List.nth ps i | Nil | Cons _ | List _ | Record _ | Variant _ | Negative _ | Effect _ -> assert false in let fields = - StringMap.fold(* true if the row variable is dualised *) + Label.Map.fold(* true if the row variable is dualised *) (fun name -> function | Present t -> - let pats = List.map (unwrap_at ((int_of_string name) - 1)) pats in - StringMap.add name (Present (cpt pats t)) + let pats = List.map (unwrap_at ((Label.to_int name) - 1)) pats in + Label.Map.add name (Present (cpt pats t)) | (Absent | Meta _) -> assert false - | _ -> raise Types.tag_expectation_mismatch) fields StringMap.empty in + | _ -> raise Types.tag_expectation_mismatch) fields Label.Map.empty in Record (Row (fields, row_var, dual)) | Record row -> let fields, row_var, lr = (Types.unwrap_row row |> fst |> TypeUtils.extract_row_parts) in @@ -1960,27 +1967,27 @@ let close_pattern_type : Pattern.with_pos list -> Types.datatype -> Types.dataty end | Nil | Cons _ | List _ | Tuple _ | Variant _ | Negative _ | Effect _ -> assert false in let fields = - StringMap.fold + Label.Map.fold (fun name -> function | Present t -> let pats = List.map (unwrap_at name) pats in - StringMap.add name (Present (cpt pats t)) + Label.Map.add name (Present (cpt pats t)) | (Absent | Meta _) -> assert false - | _ -> raise Types.tag_expectation_mismatch) fields StringMap.empty in + | _ -> raise Types.tag_expectation_mismatch) fields Label.Map.empty in Record (Row (fields, row_var, false)) | Variant row -> let fields, row_var, lr = (Types.unwrap_row row |> fst |> TypeUtils.extract_row_parts) in assert (not lr); - let rec unwrap_at : string -> Pattern.with_pos -> Pattern.with_pos list = fun name p -> + let rec unwrap_at : Label.t -> Pattern.with_pos -> Pattern.with_pos list = fun name p -> let open Pattern in match p.node with | Variable _ | Any -> [ with_pos p.pos Pattern.Any ] | As (_, p) | HasType (p, _) -> unwrap_at name p - | Variant (name', None) when name=name' -> + | Variant (name', None) when Label.eq name name' -> [with_pos p.pos (Pattern.Record ([], None))] - | Variant (name', Some p) when name=name' -> [p] + | Variant (name', Some p) when Label.eq name name' -> [p] | Variant _ -> [] | Negative names when List.mem name names -> [] | Negative _ -> [ with_pos p.pos Pattern.Any ] @@ -1994,15 +2001,15 @@ let close_pattern_type : Pattern.with_pos list -> Types.datatype -> Types.dataty | {node = (Variant _); _} :: ps -> are_open ps | {node = (Nil | Cons _ | List _ | Tuple _ | Record _ | Constant _ | Effect _); _} :: _ -> assert false in let fields = - StringMap.fold + Label.Map.fold (fun name field_spec env -> match field_spec with | Present t -> let pats = concat_map (unwrap_at name) pats in let t = cpt pats t in - (StringMap.add name (Present t)) env + (Label.Map.add name (Present t)) env | (Absent | Meta _) -> assert false - | _ -> raise Types.tag_expectation_mismatch) fields StringMap.empty + | _ -> raise Types.tag_expectation_mismatch) fields Label.Map.empty in if are_open pats then begin @@ -2024,15 +2031,15 @@ let close_pattern_type : Pattern.with_pos list -> Types.datatype -> Types.dataty let fields, row_var, lr = (Types.unwrap_row row |> fst |> TypeUtils.extract_row_parts) in assert (not lr); - let unwrap_at : string -> Pattern.with_pos -> Pattern.with_pos list = fun name p -> + let unwrap_at : Label.t -> Pattern.with_pos -> Pattern.with_pos list = fun name p -> let open Pattern in match p.node with - | Effect (name', ps, _) when name=name' -> ps + | Effect (name', ps, _) when Label.eq name name' -> ps | Effect _ -> [] | Variable _ | Any | As _ | HasType _ | Negative _ | Nil | Cons _ | List _ | Tuple _ | Record _ | Variant _ | Constant _ -> assert false in let fields = - StringMap.fold + Label.Map.fold (fun name field_spec env -> match field_spec with | Present t -> @@ -2079,11 +2086,11 @@ let close_pattern_type : Pattern.with_pos list -> Types.datatype -> Types.dataty Types.make_function_type domain effs codomain in (* Bind name |-> Pre(t) *) - StringMap.add name (Present t) env + Label.Map.add name (Present t) env | _ -> - StringMap.add name (Present t) env + Label.Map.add name (Present t) env end - | t -> StringMap.add name t env) fields StringMap.empty + | t -> Label.Map.add name t env) fields Label.Map.empty in let row = Row (fields, row_var, false) in (* NOTE: type annotations can lead to a closed type even though @@ -2383,9 +2390,9 @@ let type_pattern ?(linear_vars=true) closed List.fold_right (fun name (positive, negative) -> let a = fresh_var () in - (StringMap.add name (Present a) positive, - StringMap.add name Absent negative)) - names (StringMap.empty, StringMap.empty) in + (Label.Map.add name (Present a) positive, + Label.Map.add name Absent negative)) + names (Label.Map.empty, Label.Map.empty) in let outer_type = Types.Variant (Row (positive, row_var, false)) in let inner_type = Types.Variant (Row (negative, row_var, false)) in @@ -2656,21 +2663,21 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = (* check that each label only occurs once *) List.fold_left (fun labels (name, _) -> - if StringSet.mem name labels then - Gripers.die pos ("Duplicate labels (" ^ name ^ ") in record.") + if Label.Set.mem name labels then + Gripers.die pos ("Duplicate labels (" ^ Label.show name ^ ") in record.") else - StringSet.add name labels) - StringSet.empty fields in + Label.Set.add name labels) + Label.Set.empty fields in let fields, field_env, absent_field_env, field_usages = List.fold_right (fun (label, e) (fields, field_env, absent_field_env, field_usages) -> let e = tc e in let t = typ e in ((label, e)::fields, - StringMap.add label (T.Present t) field_env, - StringMap.add label T.Absent absent_field_env, + Label.Map.add label (T.Present t) field_env, + Label.Map.add label T.Absent absent_field_env, Usage.combine field_usages (usages e))) - fields ([], StringMap.empty, StringMap.empty, Usage.empty) in + fields ([], Label.Map.empty, Label.Map.empty, Usage.empty) in begin match rest with | None -> let r = T.Row (field_env, Unionfind.fresh T.Closed, false) in @@ -2705,22 +2712,22 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = i.e. all the labels belonging to the record r *) let field_env' = - StringMap.fold (fun label f field_env' -> + Label.Map.fold (fun label f field_env' -> match f with | T.Absent -> - if StringMap.mem label field_env then + if Label.Map.mem label field_env then field_env' else - StringMap.add label T.Absent field_env' + Label.Map.add label T.Absent field_env' | T.Present t -> - if StringMap.mem label field_env then + if Label.Map.mem label field_env then failwith ("Could not extend record "^ expr_string (erase r)^" (of type "^ Types.string_of_datatype rtype^") with the label "^ - label^ + Label.show label^ " (of type"^Types.string_of_datatype (T.Record (T.Row (field_env, Unionfind.fresh T.Closed, false)))^ ") because the labels overlap") else - StringMap.add label (T.Present t) field_env' + Label.Map.add label (T.Present t) field_env' | T.Meta _ -> assert false | _ -> raise Types.tag_expectation_mismatch) rfield_env field_env in @@ -2816,14 +2823,14 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = | ConstructorLit (c, None, _) -> let type' = T.Variant (Types.make_singleton_open_row - (c, T.Present Types.unit_type) + (Label.make c, T.Present Types.unit_type) (lin_any, res_any)) in ConstructorLit (c, None, Some type'), type', Usage.empty | ConstructorLit (c, Some v, _) -> let v = tc v in let type' = T.Variant (Types.make_singleton_open_row - (c, T.Present (typ v)) + (Label.make c, T.Present (typ v)) (lin_any, res_any)) in ConstructorLit (c, Some (erase v), Some type'), type', usages v @@ -2891,6 +2898,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = relational_lenses_guard pos; let table = tc table in let columns = Lens_type_conv.sort_cols_of_table ~table:"" (typ table) in + let fds = List.map (fun (x,y) -> (List.map Label.name x, List.map Label.name y) ) fds in let typ = Lens.Type.type_lens_fun_dep ~fds ~columns |> Lens_errors.unpack_type_lens_result ~die:(Gripers.die pos) in @@ -2903,8 +2911,8 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = let typ = let lens = typ lens |> Lens_type_conv.lens_type_of_type ~die:(Gripers.die pos) in let default = typ default |> Lens_type_conv.lens_phrase_type_of_type |> fun a -> [a] in - let drop = [drop] in - let key = Alias.Set.singleton key in + let drop = [Label.name drop] in + let key = Alias.Set.singleton (Label.name key) in Type.type_drop_lens lens ~default ~drop ~key |> Lens_errors.unpack_type_drop_lens_result ~die:(Gripers.die pos) in LensDropLit (erase lens, drop, key, erase default, Some typ), T.Lens typ, Usage.combine (usages lens) (usages default) @@ -3052,11 +3060,11 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = let field_env = List.fold_right (fun name field_env -> - if StringMap.mem name field_env then + if Label.Map.mem name field_env then Gripers.die pos "Duplicate labels in insert expression." else - StringMap.add name (T.Present (Types.fresh_type_variable (lin_any, res_base))) field_env) - labels StringMap.empty + Label.Map.add name (T.Present (Types.fresh_type_variable (lin_any, res_base))) field_env) + labels Label.Map.empty in (* Check that the fields in the type of values match the declared labels *) @@ -3076,7 +3084,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = in let needed_env = - StringMap.map + Label.Map.map (fun _f -> Types.fresh_presence_variable (lin_any, res_base)) field_env in @@ -3109,7 +3117,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = the table. *) let row = - T.Row (StringMap.singleton id (T.Present Types.int_type), + T.Row (Label.Map.singleton (Label.make id) (T.Present Types.int_type), Types.fresh_row_variable (lin_any, res_base), false) in unify ~handle:Gripers.insert_id @@ -3176,14 +3184,14 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = List.fold_right (fun (name, exp) (set, field_env) -> let exp = type_check context' exp in - if StringMap.mem name field_env then + if Label.Map.mem name field_env then Gripers.die pos "Duplicate fields in update expression." else - (name, exp)::set, StringMap.add name (T.Present (typ exp)) field_env) - set ([], StringMap.empty) in + (name, exp)::set, Label.Map.add name (T.Present (typ exp)) field_env) + set ([], Label.Map.empty) in let needed_env = - StringMap.map + Label.Map.map (fun _f -> Types.fresh_presence_variable (lin_any, res_base)) field_env in @@ -3316,7 +3324,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = | Flat -> let shape = Types.make_list_type - (T.Record (T.Row (StringMap.empty, + (T.Record (T.Row (Label.Map.empty, Types.fresh_row_variable (lin_any, res_base), false))) in unify ~handle:Gripers.query_base_row (pos_and_typ p, no_pos shape) in @@ -3847,7 +3855,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = in assert (not lr); begin - match StringMap.lookup l field_env with + match Label.Map.lookup l field_env with | Some (T.Present t) -> (* the free type variables in the projected type *) let vars = Types.free_type_vars t in @@ -3905,7 +3913,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = let rfields, row_var, lr = (TypeUtils.extract_row (typ r)) |> Types.unwrap_row |> fst |> TypeUtils.extract_row_parts in assert (not lr); let rfields = - StringMap.mapi + Label.Map.mapi (fun name t -> if List.mem_assoc name fields then T.Present (snd3 (List.assoc name fields)) @@ -3955,9 +3963,9 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = List.fold_right (fun (pat, body) (val_cases, eff_cases) -> match pat.node with - | Pattern.Variant ("Return", None) -> + | Pattern.Variant (case, None) when Label.eq case Label.return -> Gripers.die pat.pos "Improper pattern-matching on return value" - | Pattern.Variant ("Return", Some pat) -> + | Pattern.Variant (case, Some pat) when Label.eq case Label.return -> (pat, body) :: val_cases, eff_cases | _ -> val_cases, (pat, body) :: eff_cases) cases ([], []) @@ -4041,7 +4049,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = with_pos pos (Effect (opname, [], with_dummy_pos Pattern.Any)) (* already compiled to an effect *) | { node = Effect _; pos = _ } -> - pat + pat | { pos; _ } -> Gripers.die pos "Improper pattern matching" in let pat = tpo pat in unify ~handle:Gripers.handle_effect_patterns @@ -4061,7 +4069,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = in let pat, kpat = let rec find_effect_type eff = function - | (eff', t) :: _ when eff = eff' -> + | (eff', t) :: _ when Label.eq eff eff' -> begin match t with | T.Present t -> t | _ -> assert false @@ -4089,7 +4097,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = let kname = Binder.to_name bndr in let kt = let (fields,_,_) = TypeUtils.extract_row_parts (TypeUtils.extract_row effrow) in - let kt = find_effect_type effname (StringMap.to_alist fields) in + let kt = find_effect_type effname (Label.Map.to_alist fields) in let op_param = TypeUtils.return_type kt in let typ = Env.find kname env in let domain = @@ -4190,7 +4198,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = = fun row -> let (operations, rho, dual) = TypeUtils.extract_row_parts row in let operations' = - StringMap.mapi + Label.Map.mapi (fun name p -> if TypeUtils.is_builtin_effect name then p @@ -4253,9 +4261,9 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = 3. Construct effect row where the operation name gets bound to the previously constructed operation type 4. Unify with current effect context *) - if String.compare opname "Return" = 0 then + if Label.eq opname Label.return then Gripers.die pos "The implicit effect Return is not invocable" - else if String.compare opname Value.session_exception_operation = 0 && not context.desugared then + else if Label.eq opname Value.session_exception_operation && not context.desugared then Gripers.die pos "The session failure effect SessionFail is not directly invocable (use `raise` instead)" else let (row, return_type, args) = @@ -4284,11 +4292,11 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = let outer_effects = Types.row_with (Value.session_exception_operation, Types.fresh_presence_variable default_subkind) - (T.Row (StringMap.empty, rho, false)) in + (T.Row (Label.Map.empty, rho, false)) in let try_effects = Types.row_with (Value.session_exception_operation, T.Present (Types.make_pure_function_type [] Types.empty_type)) - (T.Row (StringMap.empty, rho, false)) in + (T.Row (Label.Map.empty, rho, false)) in unify ~handle:Gripers.try_effect (no_pos (T.Effect context.effect_row), no_pos (T.Effect outer_effects)); @@ -4864,7 +4872,10 @@ and type_binding : context -> binding -> binding * context * Usage.t = let () = unify pos ~handle:Gripers.bind_exp (pos_and_typ e, no_pos Types.unit_type) in Exp (erase e), empty_context, usages e - | FreshLabel(name, decls) -> assert false (* TODO *) + | FreshLabel(labels, decls) -> + let ctx, decls = List.fold_left_map + (fun ctx d -> let d', ctx', _ = type_binding ctx d in extend ctx ctx', d') context decls in + (FreshLabel(labels, decls), ctx, Usage.empty) | Import _ | Open _ | AlienBlock _ @@ -5013,7 +5024,7 @@ and type_cp (context : context) = fun {node = p; pos} -> let c = Binder.to_name bndr in let (_, t, _) = type_check context (var c) in let s = Types.fresh_session_variable lin_any in - let r = Types.make_singleton_open_row (label, T.Present s) (lin_any, res_session) in + let r = Types.make_singleton_open_row (Label.make label, T.Present s) (lin_any, res_session) in let ctype = T.Select r in unify ~pos:pos ~handle:(Gripers.cp_select c) (t, ctype); @@ -5030,7 +5041,7 @@ and type_cp (context : context) = fun {node = p; pos} -> *) let check_branch (label, body) = let s = Types.fresh_type_variable (lin_any, res_session) in - let r = Types.make_singleton_open_row (label, T.Present s) (lin_any, res_session) in + let r = Types.make_singleton_open_row (Label.make label, T.Present s) (lin_any, res_session) in unify ~pos:pos ~handle:(Gripers.cp_offer_choice c) (t, T.Choice r); let (p, t, u) = with_channel c s (type_cp (bind_var context (c, s)) body) in (label, p), t, u diff --git a/core/typeUtils.ml b/core/typeUtils.ml index f5d726ada..3c57bd82e 100644 --- a/core/typeUtils.ml +++ b/core/typeUtils.ml @@ -15,8 +15,8 @@ let extract_row_parts = Types.extract_row_parts let split_row name row = let (field_env, row_var, dual) = fst (unwrap_row row) |> extract_row_parts in let t = - if FieldMap.mem name field_env then - match (FieldMap.find name field_env) with + if Label.Map.mem name field_env then + match (Label.Map.find name field_env) with | Present t -> t | Absent -> error ("Attempt to split row "^string_of_row row ^" on absent field " ^ Label.show name) @@ -28,9 +28,9 @@ let split_row name row = in let new_field_env = if is_closed_row row then - FieldMap.remove name field_env + Label.Map.remove name field_env else - FieldMap.add name Absent field_env + Label.Map.add name Absent field_env in t, Row (new_field_env, row_var, dual) @@ -49,20 +49,20 @@ let rec split_variant_type name t = match concrete_type t with | t -> error ("Attempt to split non-variant type "^string_of_datatype t) -let rec project_type ?(overstep_quantifiers=true) name t = match (concrete_type t, overstep_quantifiers) with - | (ForAll (_, t), true) -> project_type name t +let rec project_type ?(overstep_quantifiers=true) label t = match (concrete_type t, overstep_quantifiers) with + | (ForAll (_, t), true) -> project_type label t | (Record row, _) -> - let t, _ = split_row name row in + let t, _ = split_row label row in t | (Application (absty, [PrimaryKind.Type, typ]), _) when (Abstype.name absty) = "TransactionTime" || (Abstype.name absty = "ValidTime") -> - if name = TemporalField.data_field then typ + if Label.eq_name label TemporalField.data_field then typ else if - name = TemporalField.from_field || - name = TemporalField.to_field then + Label.eq_name label TemporalField.from_field || + Label.eq_name label TemporalField.to_field then Primitive (Primitive.DateTime) else - error ("Trying to project " ^ name ^ " from temporal metadata: " ^ string_of_datatype t) + error ("Trying to project " ^ Label.show label ^ " from temporal metadata: " ^ string_of_datatype t) | (t, _) -> error ("Attempt to project non-record type "^string_of_datatype t) @@ -100,22 +100,22 @@ let rec erase_type ?(overstep_quantifiers=true) names t = let closed = is_closed_row row in let (field_env, row_var, duality) = fst (unwrap_row row) |> extract_row_parts in let field_env = - FieldSet.fold + Label.Set.fold (fun name field_env -> - match FieldMap.lookup name field_env with + match Label.Map.lookup name field_env with | Some (Present _) -> if closed then - FieldMap.remove name field_env + Label.Map.remove name field_env else - FieldMap.add name Absent field_env + Label.Map.add name Absent field_env | Some Absent -> - error ("Attempt to remove absent field "^name^" from row "^string_of_row row) + error ("Attempt to remove absent field "^Label.show name^" from row "^string_of_row row) | Some (Meta _) -> - error ("Attempt to remove meta field "^name^" from row "^string_of_row row) + error ("Attempt to remove meta field "^Label.show name^" from row "^string_of_row row) | Some _ -> raise Types.tag_expectation_mismatch | None -> - error ("Attempt to remove absent field "^name^" from row "^string_of_row row)) + error ("Attempt to remove absent field "^Label.show name^" from row "^string_of_row row)) names field_env in @@ -151,9 +151,9 @@ let rec effect_row ?(overstep_quantifiers=true) t = match (concrete_type t, over error ("Attempt to take effects of non-function: " ^ string_of_datatype t) -let iter_row (iter_func : string -> field_spec -> unit) row = +let iter_row (iter_func : Label.t -> field_spec -> unit) row = let (field_spec_map, _, _) = fst (unwrap_row row) |> extract_row_parts in - Utility.StringMap.iter iter_func field_spec_map + Label.Map.iter iter_func field_spec_map let is_function_type t = match concrete_type t with | Lolli (_, _, _) @@ -211,13 +211,13 @@ let record_without t names = match concrete_type t with | Record (Row (fields, row_var, dual) as row) -> if is_closed_row row then - let fieldm = StringSet.fold (fun name fields -> StringMap.remove name fields) names fields in + let fieldm = Label.Set.fold (fun name fields -> Label.Map.remove name fields) names fields in Record (Row (fieldm, row_var, dual)) else let fieldm = - StringMap.mapi + Label.Map.mapi (fun name f -> - if StringSet.mem name names then + if Label.Set.mem name names then Absent else f) @@ -365,7 +365,7 @@ let check_type_wellformedness primary_kind t : unit = (* Row *) | Row (field_spec_map, row_var, _dual) -> let handle_fs _label f = ifield_spec f in - StringMap.iter handle_fs field_spec_map; + Label.Map.iter handle_fs field_spec_map; meta rec_env row_var (* Session *) | Input (t, s) @@ -389,7 +389,7 @@ let row_present_types t = extract_row t |> extract_row_parts |> fst3 - |> StringMap.filter_map + |> Label.Map.filter_map (fun _ v -> match v with | Present t -> Some t diff --git a/core/typeUtils.mli b/core/typeUtils.mli index 1191b0220..bfa4298dc 100644 --- a/core/typeUtils.mli +++ b/core/typeUtils.mli @@ -5,15 +5,15 @@ exception TypeDestructionError of string val concrete_type : Types.datatype -> Types.datatype -val project_type : ?overstep_quantifiers:bool -> string -> Types.datatype -> Types.datatype -val erase_type : ?overstep_quantifiers:bool -> Utility.stringset -> Types.datatype -> Types.datatype -val inject_type : string -> Types.datatype -> Types.datatype +val project_type : ?overstep_quantifiers:bool -> Label.t -> Types.datatype -> Types.datatype +val erase_type : ?overstep_quantifiers:bool -> Label.Set.t -> Types.datatype -> Types.datatype +val inject_type : Label.t -> Types.datatype -> Types.datatype val return_type : ?overstep_quantifiers:bool -> Types.datatype -> Types.datatype val arg_types : ?overstep_quantifiers:bool -> Types.datatype -> Types.datatype list val effect_row : ?overstep_quantifiers:bool -> Types.datatype -> Types.row val is_function_type : Types.datatype -> bool val is_thunk_type : Types.datatype -> bool -val is_builtin_effect : string -> bool +val is_builtin_effect : Label.t -> bool val element_type : ?overstep_quantifiers:bool -> Types.datatype -> Types.datatype val table_read_type : Types.datatype -> Types.datatype @@ -25,26 +25,26 @@ val app_type : Types.datatype -> Types.datatype -> Types.datatype val extract_row : Types.datatype -> Types.row val extract_row_parts : Types.datatype -> Types.row' -val iter_row : (string -> Types.field_spec -> unit) -> Types.row -> unit -val split_row : string -> Types.row -> (Types.datatype * Types.row) -val split_variant_type : string -> Types.datatype -> (Types.datatype * Types.datatype) -val variant_at : ?overstep_quantifiers:bool -> string -> Types.datatype -> Types.datatype +val iter_row : (Label.t -> Types.field_spec -> unit) -> Types.row -> unit +val split_row : Label.t -> Types.row -> (Types.datatype * Types.row) +val split_variant_type : Label.t -> Types.datatype -> (Types.datatype * Types.datatype) +val variant_at : ?overstep_quantifiers:bool -> Label.t -> Types.datatype -> Types.datatype val quantifiers : Types.datatype -> Quantifier.t list val split_quantified_type : Types.datatype -> (Quantifier.t list * Types.datatype) -val record_without : Types.datatype -> Utility.StringSet.t -> Types.datatype +val record_without : Types.datatype -> Label.Set.t -> Types.datatype (* Session stuff *) (* val session_of_type : Types.datatype -> Types.session_type *) -val select_type : string -> Types.datatype -> Types.datatype -val split_choice_type : string -> Types.datatype -> (Types.datatype * Types.datatype) -val choice_at : string -> Types.datatype -> Types.datatype +val select_type : Label.t -> Types.datatype -> Types.datatype +val split_choice_type : Label.t -> Types.datatype -> (Types.datatype * Types.datatype) +val choice_at : Label.t -> Types.datatype -> Types.datatype val primary_kind_of_type : Types.datatype -> PrimaryKind.t val check_type_wellformedness : PrimaryKind.t option -> Types.datatype -> unit -val row_present_types : Types.datatype -> Types.datatype Utility.StringMap.t +val row_present_types : Types.datatype -> Types.datatype Label.Map.t val pack_types : Types.datatype list -> Types.datatype diff --git a/core/types.ml b/core/types.ml index a8344a36a..15123e60d 100644 --- a/core/types.ml +++ b/core/types.ml @@ -9,10 +9,8 @@ let internal_error message = let tag_expectation_mismatch = internal_error "Type tag expectation mismatch" -module type LABELMAP = Map with type key = Label.t -module FieldMap : LABELMAP = Map.Make(Label) -module FieldEnv = FieldMap -type 'a field_env = 'a FieldMap.t [@@deriving show] +module FieldEnv = Label.Map +type 'a field_env = 'a FieldEnv.t [@@deriving show] type 'a stringmap = 'a Utility.stringmap [@@deriving show] @@ -174,7 +172,7 @@ and session_type = typ and datatype = typ and type_arg = PrimaryKind.t * typ and field_spec = typ -and field_spec_map = field_spec FieldMap.t +and field_spec_map = field_spec Label.Map.t and meta_type_var = typ point and meta_row_var = row point and meta_presence_var = typ point @@ -294,11 +292,11 @@ struct method field_spec_map : field_spec_map -> ('self_type * field_spec_map) = fun fsmap -> - FieldMap.fold + Label.Map.fold (fun lbl fs (o, fsmap') -> let (o, fs) = o#field_spec fs in - (o, FieldMap.add lbl fs fsmap')) - fsmap (o, FieldMap.empty) + (o, Label.Map.add lbl fs fsmap')) + fsmap (o, Label.Map.empty) method quantifier : Quantifier.t -> ('self_type * Quantifier.t) = fun q -> (o, q) @@ -996,7 +994,7 @@ module Env = Env.String let open PrimaryKind in match pk with | Type -> (Type, make_rigid_type_variable var sk) - | Row -> (Row, Row (FieldMap.empty, make_rigid_row_variable var sk, false)) + | Row -> (Row, Row (Label.Map.empty, make_rigid_row_variable var sk, false)) | Presence -> (Presence, make_rigid_presence_variable var sk) let is_closed_row : row -> bool = @@ -1330,7 +1328,7 @@ and dual_row : var_map -> row -> row = match fst (unwrap_row row) with | Row (fields, row_var, dual) -> let fields' = - FieldMap.map + Label.Map.map (function | Absent -> Absent | Present t -> @@ -1404,7 +1402,7 @@ and subst_dual_row : var_map -> row -> row = match fst (unwrap_row row) with | Row (fields, row_var, dual) -> let fields' = - FieldMap.map + Label.Map.map (subst_dual_field_spec rec_points) fields in @@ -1430,7 +1428,7 @@ and flatten_row : row -> row = fun row -> match row with | Row _ -> row (* HACK: this probably shouldn't happen! *) - | Meta row_var -> Row (FieldMap.empty, row_var, false) + | Meta row_var -> Row (Label.Map.empty, row_var, false) (* | Alias (PrimaryKind.Row, _, row) -> row *) (* | RecursiveApplication { r_dual ; r_args ; r_unwind ; _ } -> *) (* (\* TODO(rj) what should this function do ? r_unwind like this provokes a stack overflow *\) *) @@ -1657,7 +1655,7 @@ let quantifier_of_type_arg = function | Type, Meta point -> quantifier_of_point point | Row, Row (fields, point, _dual) -> - assert (FieldMap.is_empty fields); + assert (Label.Map.is_empty fields); quantifier_of_point point | Presence, Meta point -> quantifier_of_point point (* HACK: this probably shouldn't happen *) @@ -1688,7 +1686,7 @@ let wild_present = (wild, Present unit_type) let hear_present t = (hear, Present t) let is_builtin_effect lbl = - lbl = wild || lbl = hear + Label.eq lbl wild || Label.eq lbl hear (* precondition: the row is unwrapped *) @@ -1701,7 +1699,7 @@ let is_tuple ?(allow_onetuples=false) row = in match Unionfind.find row_var with | Closed -> - let n = FieldMap.size field_env in + let n = Label.Map.size field_env in let b = n = 0 || (List.for_all @@ -2417,7 +2415,7 @@ struct FieldEnv.fold (fun i f tuple_env -> match f with - | Present t -> IntMap.add (Label.get_int i) t tuple_env + | Present t -> IntMap.add (Label.to_int i) t tuple_env | (Absent | Meta _) -> assert false | _ -> raise tag_expectation_mismatch) field_env @@ -2526,7 +2524,7 @@ struct | Row (fields, _, _) -> fields | _ -> raise tag_expectation_mismatch in - if FieldMap.is_empty fields then + if Label.Map.is_empty fields then ts else let r = row ~name:(fun _ _ -> name_of_eff_var ~allows_shared:true) "," context p r' in @@ -2693,7 +2691,7 @@ struct (* FIXME: this shouldn't happen *) | Meta rv -> Debug.print ("Row variable where row expected:"^show_datatype (Meta rv)); - row sep context ~name:name ~strip_wild:strip_wild p (Row (FieldMap.empty, rv, false)) + row sep context ~name:name ~strip_wild:strip_wild p (Row (Label.Map.empty, rv, false)) | t -> failwith ("Illformed row:"^show_datatype t) (* raise tag_expectation_mismatch *) @@ -4411,10 +4409,10 @@ let make_fresh_envs : datatype -> datatype IntMap.t * row IntMap.t * field_spec | Closed -> empties | Var (var, kind, `Flexible) -> let tenv, renv, penv = empties in - (tenv, M.add var (Row (FieldMap.empty, fresh_row_variable (Kind.subkind kind), false)) renv, penv) + (tenv, M.add var (Row (Label.Map.empty, fresh_row_variable (Kind.subkind kind), false)) renv, penv) | Var (var, kind, `Rigid) -> let tenv, renv, penv = empties in - (tenv, M.add var (Row (FieldMap.empty, fresh_rigid_row_variable (Kind.subkind kind), false)) renv, penv) + (tenv, M.add var (Row (Label.Map.empty, fresh_rigid_row_variable (Kind.subkind kind), false)) renv, penv) | Recursive (l, _, _) when S.mem l boundvars -> empties | Recursive (l, _, row) -> make_env (S.add l boundvars) row | row -> make_env boundvars row @@ -4439,13 +4437,13 @@ let make_fresh_envs : datatype -> datatype IntMap.t * row IntMap.t * field_spec let make_rigid_envs datatype : datatype IntMap.t * row IntMap.t * field_spec Utility.IntMap.t = let tenv, renv, penv = make_fresh_envs datatype in (IntMap.map (fun _ -> fresh_rigid_type_variable (lin_any, res_any)) tenv, - IntMap.map (fun _ -> Row (FieldMap.empty, fresh_rigid_row_variable (lin_any, res_any), false)) renv, + IntMap.map (fun _ -> Row (Label.Map.empty, fresh_rigid_row_variable (lin_any, res_any), false)) renv, IntMap.map (fun _ -> fresh_rigid_presence_variable (lin_any, res_any)) penv) let make_wobbly_envs datatype : datatype IntMap.t * row IntMap.t * field_spec Utility.IntMap.t = let tenv, renv, penv = make_fresh_envs datatype in (IntMap.map (fun _ -> fresh_type_variable (lin_any, res_any)) tenv, - IntMap.map (fun _ -> Row (FieldMap.empty, fresh_row_variable (lin_any, res_any), false)) renv, + IntMap.map (fun _ -> Row (Label.Map.empty, fresh_row_variable (lin_any, res_any), false)) renv, IntMap.map (fun _ -> fresh_presence_variable (lin_any, res_any)) penv) let combine_per_kind_envs : datatype IntMap.t * row IntMap.t * field_spec IntMap.t -> type_arg IntMap.t = @@ -4653,8 +4651,8 @@ let remove_field : ?idempotent:bool -> Label.t -> row -> row = fun ?(idempotent=true) lbl row -> match row with | Row (fieldenv, var, dual) -> - if idempotent || FieldMap.mem lbl fieldenv - then Row (FieldMap.remove lbl fieldenv, var, dual) + if idempotent || Label.Map.mem lbl fieldenv + then Row (Label.Map.remove lbl fieldenv, var, dual) else raise (internal_error "attempt to remove non-existent field") | _ -> raise tag_expectation_mismatch diff --git a/core/types.mli b/core/types.mli index 9129b01b8..09bf3e1a0 100644 --- a/core/types.mli +++ b/core/types.mli @@ -2,9 +2,8 @@ open CommonTypes (* field environments *) -module type LABELMAP = Utility.Map with type key = Label.t -module FieldMap : LABELMAP -type 'a field_env = 'a FieldMap.t [@@deriving show] +module FieldEnv : Label.LABELMAP +type 'a field_env = 'a Label.Map.t [@@deriving show] type 'a stringmap = 'a Utility.StringMap.t [@@deriving show] @@ -165,7 +164,7 @@ and session_type = typ and datatype = typ and type_arg = PrimaryKind.t * typ and field_spec = typ -and field_spec_map = field_spec FieldMap.t +and field_spec_map = field_spec Label.Map.t and meta_type_var = typ point and meta_row_var = row point and meta_presence_var = typ point diff --git a/core/typevarcheck.ml b/core/typevarcheck.ml index f44cb4a76..64bed22c2 100644 --- a/core/typevarcheck.ml +++ b/core/typevarcheck.ml @@ -1,7 +1,7 @@ open Utility open Types -module FieldEnv = FieldMap +module FieldEnv = Label.Map (* TODO @@ -91,7 +91,7 @@ let rec is_guarded : TypeVarSet.t -> StringSet.t -> int -> datatype -> bool = | Row (fields, row_var, _dual) -> let check_fields = false in (if check_fields then - (FieldMap.fold + (Label.Map.fold (fun _ f b -> b && isg f) fields true) diff --git a/core/unify.ml b/core/unify.ml index 145e53379..1a9fea1d1 100644 --- a/core/unify.ml +++ b/core/unify.ml @@ -217,7 +217,7 @@ and eq_presence = fun (l, r) -> eq_types (l, r) and eq_field_envs (lfield_env, rfield_env) = let eq_specs lf rf = eq_presence (lf, rf) in - FieldMap.equal eq_specs lfield_env rfield_env + Label.Map.equal eq_specs lfield_env rfield_env and eq_row_vars (lpoint, rpoint) = (* QUESTION: Do we need to deal with closed rows specially? @@ -788,7 +788,7 @@ and unify_rows' : ?var_sk:Subkind.t -> unify_env -> ((row' * row') -> unit) = let is_unguarded_recursive row = let rec is_unguarded rec_rows (field_env, row_var, _) = - FieldMap.is_empty field_env && + Label.Map.is_empty field_env && (match Unionfind.find row_var with | Closed | Var _ -> false @@ -798,8 +798,8 @@ and unify_rows' : ?var_sk:Subkind.t -> unify_env -> ((row' * row') -> unit) = | _ -> assert false) in is_unguarded IntSet.empty row in - let domain_of_env : field_spec_map -> StringSet.t = - fun env -> FieldMap.fold (fun label _ labels -> StringSet.add label labels) env StringSet.empty in + let domain_of_env : field_spec_map -> Label.Set.t = + fun env -> Label.Map.fold (fun label _ labels -> Label.Set.add label labels) env Label.Set.empty in (* unify_field_envs closed rec_env (lenv, renv) @@ -818,22 +818,22 @@ and unify_rows' : ?var_sk:Subkind.t -> unify_env -> ((row' * row') -> unit) = let ldom = domain_of_env lenv in let rdom = domain_of_env renv in - let shared_dom = StringSet.inter ldom rdom in + let shared_dom = Label.Set.inter ldom rdom in (* rigid row unifcation cannot tolerate extra fields unless both rows are closed and all fields can be made absent *) if rigid then - let lextras = StringSet.diff ldom rdom in - let rextras = StringSet.diff rdom ldom in + let lextras = Label.Set.diff ldom rdom in + let rextras = Label.Set.diff rdom ldom in - if not (StringSet.is_empty lextras) || not (StringSet.is_empty rextras) then + if not (Label.Set.is_empty lextras) || not (Label.Set.is_empty rextras) then (* some fields don't match *) if closed then (* closed rows don't need to explicitly mention absent *) let kill_extras extras env = - StringSet.iter + Label.Set.iter (fun label -> - match StringMap.find label env with + match Label.Map.find label env with | (Absent | Meta _) as f -> unify_presence' rec_env (f, Absent) | _ -> @@ -856,10 +856,10 @@ and unify_rows' : ?var_sk:Subkind.t -> unify_env -> ((row' * row') -> unit) = semantics wrong *) (* unify fields in shared domain *) - StringSet.iter + Label.Set.iter (fun label -> - let lf = StringMap.find label lenv in - let rf = StringMap.find label renv in + let lf = Label.Map.find label lenv in + let rf = Label.Map.find label renv in unify_presence' rec_env (lf, rf)) shared_dom in @@ -931,7 +931,7 @@ and unify_rows' : ?var_sk:Subkind.t -> unify_env -> ((row' * row') -> unit) = raise (Failure (`Msg ("Rigid row variable cannot be unified with non-empty row\n" ^string_of_row (Row extension_row)))) | Var (var, ((_, (lin, rest)) as kind), `Flexible) -> - if not (StringMap.is_empty extension_field_env) && + if not (Label.Map.is_empty extension_field_env) && TypeVarSet.mem var (free_row_type_vars (Row extension_row)) then begin if Restriction.is_base rest then @@ -960,9 +960,9 @@ and unify_rows' : ?var_sk:Subkind.t -> unify_env -> ((row' * row') -> unit) = in raise (Failure (`Msg message)) end; - if StringMap.is_empty extension_field_env then + if Label.Map.is_empty extension_field_env then if dual then - Unionfind.change point (Row (StringMap.empty, extension_row_var, true)) + Unionfind.change point (Row (Label.Map.empty, extension_row_var, true)) else Unionfind.union point extension_row_var else @@ -972,7 +972,7 @@ and unify_rows' : ?var_sk:Subkind.t -> unify_env -> ((row' * row') -> unit) = Unionfind.change point (Row extension_row) end | Recursive _ -> - unify_rows' rec_env ((StringMap.empty, point, dual), extension_row) + unify_rows' rec_env ((Label.Map.empty, point, dual), extension_row) | row -> unify_rows' rec_env (TypeUtils.extract_row_parts (if dual then dual_row row else row), extension_row) in extend row_var in @@ -983,19 +983,19 @@ and unify_rows' : ?var_sk:Subkind.t -> unify_env -> ((row' * row') -> unit) = precondition: big_field_env contains small_field_env *) - let matching_labels : field_spec_map * field_spec_map -> StringSet.t = + let matching_labels : field_spec_map * field_spec_map -> Label.Set.t = fun (big_field_env, small_field_env) -> - StringMap.fold (fun label _ labels -> - if StringMap.mem label small_field_env then - StringSet.add label labels + Label.Map.fold (fun label _ labels -> + if Label.Map.mem label small_field_env then + Label.Set.add label labels else - labels) big_field_env StringSet.empty in + labels) big_field_env Label.Set.empty in - let row_without_labels : StringSet.t -> row' -> row' = + let row_without_labels : Label.Set.t -> row' -> row' = fun labels (field_env, row_var, dual) -> let restricted_field_env = - StringSet.fold (fun label field_env -> - StringMap.remove label field_env) labels field_env in + Label.Set.fold (fun label field_env -> + Label.Map.remove label field_env) labels field_env in (restricted_field_env, row_var, dual) in (* @@ -1018,7 +1018,7 @@ and unify_rows' : ?var_sk:Subkind.t -> unify_env -> ((row' * row') -> unit) = if IntMap.mem var rec_rows then IntMap.find var rec_rows else - [Row (StringMap.empty, row_var, false)] in + [Row (Label.Map.empty, row_var, false)] in if List.exists (fun r -> eq_rows (r, Row restricted_row)) rs then None else @@ -1096,9 +1096,9 @@ and unify_rows' : ?var_sk:Subkind.t -> unify_env -> ((row' * row') -> unit) = let (flexible_field_env', flexible_row_var', flexible_dual) as flexible_row' = TypeUtils.extract_row_parts flexible_row' in (* let (flexible_field_env', flexible_row_var', flexible_dual) as flexible_row', flexible_rec_row = unwrap_row flexible_row in *) (* check that the flexible row contains no extra fields *) - StringMap.iter + Label.Map.iter (fun label f -> - if (StringMap.mem label rigid_field_env') then + if (Label.Map.mem label rigid_field_env') then () else match f with @@ -1112,7 +1112,7 @@ and unify_rows' : ?var_sk:Subkind.t -> unify_env -> ((row' * row') -> unit) = ^"\nand\n "^ string_of_row (Row flexible_row) ^"\n could not be unified because the former is rigid" ^" and the latter contains fields not present in the former, namely `" - ^ label ^"'."))) + ^ Label.show label ^"'."))) ) flexible_field_env'; let rec_env' = @@ -1124,7 +1124,7 @@ and unify_rows' : ?var_sk:Subkind.t -> unify_env -> ((row' * row') -> unit) = | None -> () | Some rec_env -> unify_field_envs ~closed:false ~rigid:false rec_env (rigid_field_env', flexible_field_env'); - let flexible_extension = StringMap.filter (fun label _ -> not (StringMap.mem label flexible_field_env')) rigid_field_env' in + let flexible_extension = Label.Map.filter (fun label _ -> not (Label.Map.mem label flexible_field_env')) rigid_field_env' in unify_row_var_with_row rec_env (flexible_row_var', flexible_dual, (flexible_extension, rigid_row_var', rigid_dual')) in let unify_both_flexible ((lfield_env, _, ldual as lrow), (rfield_env, _, rdual as rrow)) = @@ -1156,11 +1156,11 @@ and unify_rows' : ?var_sk:Subkind.t -> unify_env -> ((row' * row') -> unit) = let fresh_row_var = fresh_row_variable var_sk in (* each row can contain fields missing from the other *) - let rextension = StringMap.filter (fun label _ -> not (StringMap.mem label rfield_env')) lfield_env' in + let rextension = Label.Map.filter (fun label _ -> not (Label.Map.mem label rfield_env')) lfield_env' in (* Debug.print ("rext: "^string_of_row (Row (rextension, fresh_row_var, false))); *) unify_row_var_with_row rec_env (rrow_var', rdual', (rextension, fresh_row_var, false)); - let lextension = StringMap.filter (fun label _ -> not (StringMap.mem label lfield_env')) rfield_env' in + let lextension = Label.Map.filter (fun label _ -> not (Label.Map.mem label lfield_env')) rfield_env' in unify_row_var_with_row rec_env (lrow_var', ldual', (lextension, fresh_row_var, false)) end in diff --git a/core/utility.ml b/core/utility.ml index 2ef7870ef..072d3e7a4 100644 --- a/core/utility.ml +++ b/core/utility.ml @@ -301,13 +301,13 @@ struct end module type INTSET = Set with type elt = int +module type INTMAP = Map with type key = int module IntSet = Set.Make(Int) module IntMap = Map.Make(Int) module IntPairMap = Map.Make(IntPair) module type STRINGMAP = Map with type key = string -module type INTMAP = Map with type key = int module StringSet = Set.Make(String) module StringMap : STRINGMAP = Map.Make(String) diff --git a/core/value.ml b/core/value.ml index 8308c07ed..39825d70c 100644 --- a/core/value.ml +++ b/core/value.ml @@ -20,7 +20,7 @@ let printing_functions |> convert parse_bool |> sync) -let session_exception_operation = "SessionFail" +let session_exception_operation = Label.make "SessionFail" class type otherfield = object @@ -373,7 +373,7 @@ module type CONTINUATION_EVALUATOR = sig result val trap : v t -> (* the continuation *) - (Name.t * v) -> (* operation name and its argument *) + (Label.t * v) -> (* operation name and its argument *) trap_result end @@ -665,9 +665,9 @@ module Eff_Handler_Continuation = struct let open Trap in let rec handle k' = function | ((User_defined h, pk) :: k) -> - begin match StringMap.lookup opname h.cases with + begin match Label.Map.lookup opname h.cases with | Some (b, _, comp) - when session_exn_enabled && opname = session_exception_operation -> + when session_exn_enabled && Label.eq session_exception_operation opname -> let var = Var.var_of_binder b in let continuation_thunk = fun () -> E.computation (Env.bind var (arg, Scope.Local) h.env) k comp @@ -693,7 +693,7 @@ module Eff_Handler_Continuation = struct | None -> handle ((User_defined h, pk) :: k') k end | (identity, pk) :: k -> handle ((identity, pk) :: k') k - | [] when session_exn_enabled && opname = session_exception_operation -> + | [] when session_exn_enabled && Label.eq session_exception_operation opname -> (* If this is a session exception operation, we need to gather all * of the computations in the pure continuation stack, so we can inspect * their free variables. *) @@ -705,7 +705,7 @@ module Eff_Handler_Continuation = struct in UnhandledSessionException comps | [] -> - Trap (fun () -> E.error (Printf.sprintf "no suitable handler for operation %s has been installed." opname)) + Trap (fun () -> E.error (Printf.sprintf "no suitable handler for operation %s has been installed." (Label.show opname))) in handle [] k end diff --git a/core/value.mli b/core/value.mli index e2f85464b..9ad0ccdd8 100644 --- a/core/value.mli +++ b/core/value.mli @@ -177,7 +177,7 @@ module type CONTINUATION_EVALUATOR = sig (* trap invocation *) val trap : v t -> (* the continuation *) - (Name.t * v) -> (* operation name and its argument *) + (Label.t * v) -> (* operation name and its argument *) trap_result end @@ -325,6 +325,6 @@ val split_html : xml -> xml * xml val is_channel : t -> bool -val session_exception_operation : string +val session_exception_operation : Label.t val row_columns_values : t -> string list * t list list diff --git a/links-mode.el b/links-mode.el index 1fcec5287..c46baad48 100644 --- a/links-mode.el +++ b/links-mode.el @@ -66,6 +66,7 @@ "false" "for" "forall" + "fresh" "from" "fun" "formlet" diff --git a/tests/labels.tests b/tests/labels.tests new file mode 100644 index 000000000..4e1e85205 --- /dev/null +++ b/tests/labels.tests @@ -0,0 +1,50 @@ +Unbounded local label +./tests/labels/unbounded.links +filemode : true +stderr : @.* +exit : 1 + +Simple scope and do operation +./tests/labels/simple.links +filemode : true +stdout : () : () + +Simple scope, effectname, typename and do operation +./tests/labels/simple-names.links +filemode : true +stdout : () : () + +Multiple label bounded at a time +./tests/labels/multiple.links +filemode : true +stdout : () : () + +Handler for local effect +./tests/labels/handler.links +filemode : true +stdout : 0 : Int +args : --enable-handlers + +Nested label bindings +./tests/labels/nested.links +filemode : true +stdout : () : () + +Wrong local handler +./tests/labels/wrong-handler.links +filemode : true +stderr : @.* +exit : 1 +args : --enable-handlers + +Avoiding pollution [1] +./tests/labels/pollution.links +filemode : true +stdout : (Just(42), Nothing, Just(Just(-1))) : (Maybe (Int), Maybe (Int), Maybe (Maybint)) +args : --enable-handlers + +Avoiding pollution [2] +./tests/labels/nested-pollution.links +filemode : true +stdout : 42 : Int +args : --enable-handlers diff --git a/tests/labels/handler.links b/tests/labels/handler.links new file mode 100644 index 000000000..9d7b01b3a --- /dev/null +++ b/tests/labels/handler.links @@ -0,0 +1,24 @@ +fresh `Ask { + + effectname A(e::Eff) = {`Ask:() {}-> Int|e} ; + + sig h_ask : (Comp(a, { |A({ |e})})) -> Comp(a, {`Ask{_}|e}) + fun h_ask (m) () { + handle (m()) { + case `Ask(k) -> k(41) + } + } + + sig f : () -A({ |e})-> Int + fun f () { + do `Ask + 1 + } + + sig res : () {`Ask{_}|_}~> Int + fun res () { + h_ask(f)() + } + +} + +h_ask (f) () - res () diff --git a/tests/labels/multiple.links b/tests/labels/multiple.links new file mode 100644 index 000000000..44542fada --- /dev/null +++ b/tests/labels/multiple.links @@ -0,0 +1,12 @@ +fresh `A, `B, `C { + + sig f : () {`A:(), `B:Bool}-> Bool + fun f () { do `A ; do `B } + + sig g : () {`C:Int, `B:Bool}-> Int + fun g () { if (do `B) 1 else do `C } + + sig h : () {`C:Int, `A:()}-> Int + fun h () { do `A ; do `C } + +} diff --git a/tests/labels/nested-pollution.links b/tests/labels/nested-pollution.links new file mode 100644 index 000000000..656c0ab17 --- /dev/null +++ b/tests/labels/nested-pollution.links @@ -0,0 +1,27 @@ +fresh `A { + + fun h_a (m) () { + handle (m ()) { + case `A(x, k) -> k (2*x) + } + } + + fresh `A { + + fun h_a' (m) () { + handle (m()) { + case `A(x, k) -> k (3*x) + } + } + + fun triple (x) { do `A(x) } + + } + + fun double (x) { do `A(x) } + +} + +fun sextuple (x) () { triple(double(x)) } + +h_a ( h_a' ( sextuple (7) ) ) () diff --git a/tests/labels/nested.links b/tests/labels/nested.links new file mode 100644 index 000000000..5fc5e20ec --- /dev/null +++ b/tests/labels/nested.links @@ -0,0 +1,20 @@ +fresh `A { + + fresh `B { + + sig f : () {`A:(), `B:Bool}-> Bool + fun f () { do `A ; do `B } + + } + + fresh `C, `B, `A { + + sig g : () {`C:Int, `B:Bool}-> Int + fun g () { if (do `B) 1 else do `C } + + sig h : () {`C:Int, `A:()}-> Int + fun h () { do `A ; do `C } + + } + +} diff --git a/tests/labels/pollution.links b/tests/labels/pollution.links new file mode 100644 index 000000000..dd74763d0 --- /dev/null +++ b/tests/labels/pollution.links @@ -0,0 +1,56 @@ +fresh `Abort { + + effectname A(e::Eff) = { `Abort: () {}-> Zero | e } ; + fun aborting () { switch (do `Abort) {} } + + typename Maybint = Maybe(Int) ; + + sig maybe : ( Comp(a, { |A({ |e})} ) ) -> Comp (Maybe(a), {`Abort{_}|e}) + fun maybe (h) () { + handle (h()) { + case Return(x) -> Just(x) + case `Abort(k) -> Nothing + } + } + + effectname R(s,e::Eff) = { Receive : () {} -> s | e } ; + + sig receives : ( Comp(a, { |A({ |R(s, { |e})})}) ) -> ([s]) -> Comp(a , {Receive{_}|A({ |e})}) + fun receives (h) (ss) () { + handle (h()) (ss<-ss) { + case Receive(k) -> switch (ss) { + case [] -> aborting() + case h::t -> k(h,t) + } + } + } + + effectname AR(s,e::Eff) = {`Abort:() {}-> Zero, Receive:(){}->s|e} ; + + sig withtwo21s : ( () ~AR(Int,{ |e})~> a ) -> Comp(Maybe(a), {Receive{_}, `Abort{_}|e}) + fun withtwo21s (h) () { maybe( receives(h)([21,21]) ) () } + +} + + +typename CRI(e::Eff) = Comp(Int, { |R(Int,{ |e})}) ; + +sig f : CRI({ |e}) fun f () { do Receive + do Receive } +sig g : CRI({ |e}) fun g () { do Receive + do Receive + do Receive } + +fun h () { if (do Receive < 42) {switch (do Abort) {}} else 0 } + +sig res : ( Comp(Maybint, {Abort:Zero |e}) ) -> Comp(Maybint, {Abort{_}|e}) +fun res (h) () { + handle(h()) { + case Abort(_) -> Just(-1) + } +} + + +# return values ############################################################### +( + withtwo21s( f ) () , + withtwo21s( g ) () , + maybe (res(withtwo21s(h))) () +) diff --git a/tests/labels/simple-names.links b/tests/labels/simple-names.links new file mode 100644 index 000000000..7bd99f262 --- /dev/null +++ b/tests/labels/simple-names.links @@ -0,0 +1,9 @@ +fresh `A { + + effectname E = { `A:() {}-> () } ; + typename T = () -E-> () ; + + sig f : T + fun f () { do `A } + +} diff --git a/tests/labels/simple.links b/tests/labels/simple.links new file mode 100644 index 000000000..aa9688651 --- /dev/null +++ b/tests/labels/simple.links @@ -0,0 +1,5 @@ +fresh `A { + + fun f () { do `A } + +} diff --git a/tests/labels/unbounded.links b/tests/labels/unbounded.links new file mode 100644 index 000000000..bffd51bde --- /dev/null +++ b/tests/labels/unbounded.links @@ -0,0 +1 @@ +fun f () { do `A } diff --git a/tests/labels/wrong-handler.links b/tests/labels/wrong-handler.links new file mode 100755 index 000000000..4a216c87e --- /dev/null +++ b/tests/labels/wrong-handler.links @@ -0,0 +1,29 @@ +fresh `Ask { + + sig h_ask : (Comp(a, {`Ask:Int|e})) -> Comp(a, {`Ask{_}|e}) + fun h_ask (m) () { + handle (m()) { + case `Ask(k) -> k(42) + } + } + + sig f : () {`Ask:Int|_} -> Int + fun f () { + do `Ask + 1 + } + +} + + +fresh `Ask { + + sig h_ask' : (Comp(a, {`Ask:Int|e})) -> Comp(a, {`Ask{_}|e}) + fun h_ask' (m) () { + handle (m()) { + case `Ask(k) -> k(666) + } + } + +} + +h_ask'(f) () From dccac212bd903fc3de6ed6f1c4d488ed53055872 Mon Sep 17 00:00:00 2001 From: RJ Date: Mon, 13 Jun 2022 17:01:38 +0100 Subject: [PATCH 30/63] fix : embeded errors --- tests/effectname/underscore-not-working.links | 14 ++++++++++++++ 1 file changed, 14 insertions(+) create mode 100755 tests/effectname/underscore-not-working.links diff --git a/tests/effectname/underscore-not-working.links b/tests/effectname/underscore-not-working.links new file mode 100755 index 000000000..06da26428 --- /dev/null +++ b/tests/effectname/underscore-not-working.links @@ -0,0 +1,14 @@ +effectname A(e::Eff) = { FEct : () {}-> Bool | e } ; + +sig callF : () -A({ |_})-> Bool # with _ => error, with e => no error +fun callF () { do FEct } + +sig handlerA : ( () ~A({ |b})~> c ) {FEct{_}|b}~> c +fun handlerA (h) { + handle (h()) { + case Return(x) -> x + case FEct(k) -> k(true) + } +} + +handlerA( callF ) From fd8213882b8774e31fdba81694acf5f997431a85 Mon Sep 17 00:00:00 2001 From: RJ Date: Tue, 14 Jun 2022 14:05:47 +0100 Subject: [PATCH 31/63] fixes --- core/desugarDatatypes.ml | 28 ++++++++++------------------ core/desugarEffects.ml | 17 ++++++----------- core/errors.ml | 5 ++++- core/errors.mli | 2 ++ core/typeUtils.ml | 2 +- core/types.ml | 14 +++++--------- core/typevarcheck.ml | 2 +- 7 files changed, 29 insertions(+), 41 deletions(-) diff --git a/core/desugarDatatypes.ml b/core/desugarDatatypes.ml index d2c46a9e9..8a42cc9a5 100644 --- a/core/desugarDatatypes.ml +++ b/core/desugarDatatypes.ml @@ -129,13 +129,9 @@ module Desugar = struct let t_kind = primary_kind_of_type_arg t in if q_kind <> t_kind then raise - (TypeApplicationKindMismatch - { pos; - name = tycon; - tyarg_number = i; - expected = PrimaryKind.to_string q_kind; - provided = PrimaryKind.to_string t_kind - }) + (type_application_kind_mismatch pos tycon i + (PrimaryKind.to_string q_kind) + (PrimaryKind.to_string t_kind)) else t in let type_args qs ts = @@ -159,8 +155,8 @@ module Desugar = struct let ts = match_quantifiers snd qs in Instantiate.alias tycon ts alias_env else - raise (TypeApplicationGlobalKindMismatch - {pos ; name = tycon; expected = "Type"; provided = (PrimaryKind.to_string k)}) + raise (type_application_global_kind_mismatch pos tycon + "Type" (PrimaryKind.to_string k)) | Some (`Abstract abstype) -> let ts = match_quantifiers identity (Abstype.arity abstype) in Application (abstype, ts) @@ -229,13 +225,9 @@ module Desugar = struct let t_kind = primary_kind_of_type_arg t in if q_kind <> t_kind then raise - (TypeApplicationKindMismatch - { pos = node.pos; - name = name; - tyarg_number = i; - expected = PrimaryKind.to_string q_kind; - provided = PrimaryKind.to_string t_kind - }) + (type_application_kind_mismatch node.pos name i + (PrimaryKind.to_string q_kind) + (PrimaryKind.to_string t_kind)) else t in let type_args qs ts = @@ -261,8 +253,8 @@ module Desugar = struct | _ -> raise (internal_error "Instantiation failed") end else - raise (TypeApplicationGlobalKindMismatch - {pos=node.pos ; name ; expected = "Row"; provided = (PrimaryKind.to_string k)}) + raise (type_application_global_kind_mismatch node.pos name + "Row" (PrimaryKind.to_string k)) | Some (`Abstract abstype) -> let ts = match_quantifiers identity (Abstype.arity abstype) in Application (abstype, ts) diff --git a/core/desugarEffects.ml b/core/desugarEffects.ml index db95f5554..31855be86 100644 --- a/core/desugarEffects.ml +++ b/core/desugarEffects.ml @@ -347,13 +347,13 @@ let cleanup_effects tycon_env = | None -> raise (Errors.UnboundTyCon (pos, name)) in TypeApplication (name, ts) - (* | Effect r -> (\* goal: same cleaning in the effectname declaration *\) *) - (* let r = self#effect_row ~allow_shared:`Disallow r in (\* what allow_shared should be ? *\) *) - (* Effect r *) | _ -> super#datatypenode t in SourceCode.WithPos.with_node dt res_t + method! aliasbody a = match a with + | Typename _ -> super#aliasbody a + | Effectname (r, r') -> Debug.print "bang" ; Effectname (self#effect_row ~allow_shared:`Disallow r, r') method effect_row ~allow_shared (fields, var) = let open Datatype in @@ -877,14 +877,9 @@ class main_traversal simple_tycon_env = distracting the user from the actual error: the kind missmatch. Hence, we must report a proper error here. *) raise - (Errors.TypeApplicationKindMismatch - { - pos; - name = tycon; - tyarg_number = i; - expected = PrimaryKind.to_string (fst k); - provided = PrimaryKind.to_string pk_row; - }) + (Errors.type_application_kind_mismatch pos tycon i + (PrimaryKind.to_string (fst k)) + (PrimaryKind.to_string pk_row)) | _, ta -> snd (o#type_arg ta) in let rec match_args_to_params index = function diff --git a/core/errors.ml b/core/errors.ml index 8f49a2d8a..0bc3df9aa 100644 --- a/core/errors.ml +++ b/core/errors.ml @@ -42,7 +42,6 @@ exception UnboundTyCon of (Position.t * string) exception InternalError of { filename: string; message: string } exception TypeApplicationArityMismatch of { pos: Position.t; name: string; expected: int; provided: int} - (* tyarg_number is 1-based index *) exception TypeApplicationKindMismatch of { pos: Position.t; name: string; tyarg_number: int; @@ -254,3 +253,7 @@ let prime_alien pos = PrimeAlien pos let forbidden_client_call fn reason = ForbiddenClientCall (fn, reason) let cannot_open_file filename reason = CannotOpenFile (filename, reason) let object_file_write_error filename reason = ObjectFileWriteError (filename, reason) +let type_application_kind_mismatch pos name tyarg_number expected provided = + TypeApplicationKindMismatch { pos; name; tyarg_number; expected; provided } +let type_application_global_kind_mismatch pos name expected provided = + TypeApplicationGlobalKindMismatch { pos; name; expected; provided } diff --git a/core/errors.mli b/core/errors.mli index f9e9365a5..6ec154c65 100644 --- a/core/errors.mli +++ b/core/errors.mli @@ -66,3 +66,5 @@ val forbidden_client_call : string -> string -> exn val rethrow_errors_if_better_position : Position.t -> ('a -> 'b) -> 'a -> 'b val cannot_open_file : string -> string -> exn val object_file_write_error : string -> string -> exn +val type_application_kind_mismatch : Position.t -> string -> int -> string -> string -> exn +val type_application_global_kind_mismatch : Position.t -> string -> string -> string -> exn diff --git a/core/typeUtils.ml b/core/typeUtils.ml index 474bf55f7..4b09fa890 100644 --- a/core/typeUtils.ml +++ b/core/typeUtils.ml @@ -237,7 +237,7 @@ let rec primary_kind_of_type t = failwith "Top-level Recursive should have been removed by concrete_type call" | Meta p -> primary_kind_of_type (Unionfind.find p) - | Alias (k, _, d) -> + | Alias (_, _, d) -> primary_kind_of_type d | Primitive _ | Function _ diff --git a/core/types.ml b/core/types.ml index 40ac95117..571bf7a2c 100644 --- a/core/types.ml +++ b/core/types.ml @@ -1428,11 +1428,7 @@ and flatten_row : row -> row = fun row -> | Row _ -> row (* HACK: this probably shouldn't happen! *) | Meta row_var -> Row (StringMap.empty, row_var, false) - (* | Alias (PrimaryKind.Row, _, row) -> row *) - (* | RecursiveApplication { r_dual ; r_args ; r_unwind ; _ } -> *) - (* (\* TODO(rj) what should this function do ? r_unwind like this provokes a stack overflow *\) *) - (* r_unwind r_args r_dual *) - | _ -> Debug.print ("row: " ^ show_row row) ; assert false + | _ -> raise (internal_error "attempt to flatten, row expected") in let dual_if = match row with @@ -1912,7 +1908,7 @@ struct (TypeVarSet.add var bound_vars, (var, spec)::vars)) (bound_vars, []) tyvars in (bound_vars, List.rev vars) in match tycon_spec with - | `Alias (k, tyvars, body) -> + | `Alias (_, tyvars, body) -> let (bound_vars, vars) = split_vars tyvars in vars @ (free_bound_type_vars bound_vars body) | `Mutual (tyvars, _) -> snd (split_vars tyvars) @@ -2723,7 +2719,7 @@ struct TypeVarSet.add (Quantifier.to_var tyvar) bound_vars) bound_vars tyvars in function - | `Alias (k, tyvars, body) -> + | `Alias (_, tyvars, body) -> let ctx = { context with bound_vars = bound_vars tyvars } in begin match tyvars with @@ -2740,7 +2736,7 @@ struct TypeVarSet.add (Quantifier.to_var tyvar) bound_vars) bound_vars tyvars in function - | `Alias (k, tyvars, body) -> + | `Alias (_, tyvars, body) -> let ctx = { context with bound_vars = bound_vars tyvars } in begin match tyvars with @@ -4108,7 +4104,7 @@ module RoundtripPrinter : PRETTY_PRINTER = struct = let open Printer in Printer (fun ctx v buf -> match v with - | `Alias (k, tyvars, body) -> + | `Alias (_, tyvars, body) -> let ctx = Context.bind_tyvars (List.map Quantifier.to_var tyvars) ctx in begin match tyvars with diff --git a/core/typevarcheck.ml b/core/typevarcheck.ml index ea99ecc68..7d33b5c1e 100644 --- a/core/typevarcheck.ml +++ b/core/typevarcheck.ml @@ -33,7 +33,7 @@ let rec is_guarded : TypeVarSet.t -> StringSet.t -> int -> datatype -> bool = | Not_typed -> true | (Var _ | Recursive _) -> failwith ("freestanding Var / Recursive not implemented yet (must be inside Meta)") - | Alias (k, _, t) -> isg t + | Alias (_, _, t) -> isg t | Application (_, ts) -> (* don't treat abstract type constructors as guards *) List.for_all (is_guarded_type_arg bound_vars expanded_apps var) ts From 806570a9e154c4bfa90e35a5d9c13c23b1bd2b1f Mon Sep 17 00:00:00 2001 From: RJ Date: Tue, 14 Jun 2022 14:59:33 +0100 Subject: [PATCH 32/63] fix label projections --- core/desugarFuns.ml | 5 ++--- core/operators.ml | 2 +- core/sugarTraversals.ml | 6 +++--- core/transformSugar.ml | 2 +- core/typeSugar.ml | 4 ++-- tests/labels/pollution.links | 5 +++-- 6 files changed, 12 insertions(+), 12 deletions(-) diff --git a/core/desugarFuns.ml b/core/desugarFuns.ml index bf16db717..0b941254c 100644 --- a/core/desugarFuns.ml +++ b/core/desugarFuns.ml @@ -132,8 +132,7 @@ object (o : 'self_type) let (fields, rho, _) = TypeUtils.extract_row_parts row in let effb, row = fresh_row_quantifier default_effect_subkind in - let label = Label.make name in - let r = Record (Row (Label.Map.add label (Present a) fields, rho, false)) in + let r = Record (Row (Label.Map.add name (Present a) fields, rho, false)) in let f = gensym ~prefix:"_fun_" () in let x = gensym ~prefix:"_fun_" () in @@ -141,7 +140,7 @@ object (o : 'self_type) , Function (Types.make_tuple_type [r], row, a)) in let pss = [[variable_pat ~ty:r x]] in - let body = with_dummy_pos (Projection (var x, label)) in + let body = with_dummy_pos (Projection (var x, name)) in let tyvars = List.map SugarQuantifier.mk_resolved [ab; rhob; effb] in let e : phrasenode = block_node diff --git a/core/operators.ml b/core/operators.ml index 764017065..6a7fced14 100644 --- a/core/operators.ml +++ b/core/operators.ml @@ -57,6 +57,6 @@ end (* Operator section *) module Section = struct - type t = Minus | FloatMinus | Project of Name.t | Name of Name.t + type t = Minus | FloatMinus | Project of Label.t | Name of Name.t [@@deriving show] end diff --git a/core/sugarTraversals.ml b/core/sugarTraversals.ml index bc9205f98..a0211356d 100644 --- a/core/sugarTraversals.ml +++ b/core/sugarTraversals.ml @@ -70,7 +70,7 @@ class map = let open Section in function | Minus -> Minus | FloatMinus -> FloatMinus - | Project _x -> let _x = o#name _x in Project _x + | Project _x -> let _x = o#label _x in Project _x | Name _x -> let _x = o#name _x in Name _x method subkind : Subkind.t -> Subkind.t = fun x -> x @@ -940,7 +940,7 @@ class fold = let open Section in function | Minus -> o | FloatMinus -> o - | Project _x -> let o = o#name _x in o + | Project _x -> let o = o#label _x in o | Name _x -> let o = o#name _x in o method subkind : Subkind.t -> 'self_type = fun _ -> o @@ -1725,7 +1725,7 @@ class fold_map = let open Section in function | Minus -> (o, Minus) | FloatMinus -> (o, FloatMinus) - | Project _x -> let (o, _x) = o#name _x in (o, Project _x) + | Project _x -> let (o, _x) = o#label _x in (o, Project _x) | Name _x -> let (o, _x) = o#name _x in (o, Name _x) method subkind : Subkind.t -> ('self_type * Subkind.t) = fun k -> (o, k) diff --git a/core/transformSugar.ml b/core/transformSugar.ml index e9c8cddf3..793316712 100644 --- a/core/transformSugar.ml +++ b/core/transformSugar.ml @@ -24,7 +24,7 @@ let type_section env = let (fields, rho, _) = TypeUtils.extract_row_parts row in let eb, e = Types.fresh_row_quantifier default_effect_subkind in - let r = Record (Row (Label.Map.add (Label.make label) (Present a) fields, rho, false)) in + let r = Record (Row (Label.Map.add label (Present a) fields, rho, false)) in ForAll ([ab; rhob; eb], Function (Types.make_tuple_type [r], e, a)) | Name var -> TyEnv.find var env diff --git a/core/typeSugar.ml b/core/typeSugar.ml index 3e37c5af2..beb4ea4fd 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -1824,7 +1824,7 @@ let type_section pos context s = let a = Types.fresh_type_variable (lin_unl, res_any) in let rho = Types.fresh_row_variable (lin_unl, res_any) in let effects = Types.make_empty_open_row default_effect_subkind in (* projection is pure! *) - let r = Record (Row (Label.Map.add (Label.make label) (Present a) Label.Map.empty, rho, false)) in + let r = Record (Row (Label.Map.add label (Present a) Label.Map.empty, rho, false)) in ([(PrimaryKind.Type, a); (PrimaryKind.Row, Row (Label.Map.empty, rho, false)); (PrimaryKind.Row, effects)], Function (Types.make_tuple_type [r], effects, a)), Usage.empty @@ -1847,7 +1847,7 @@ let type_frozen_section context s = let a = Types.fresh_rigid_type_variable (lin_unl, res_any) in let rho = Types.fresh_rigid_row_variable (lin_unl, res_any) in let effects = Label.Map.empty, Types.fresh_rigid_row_variable default_effect_subkind, false in - let r = Record (Row (Label.Map.add (Label.make label) (Present a) Label.Map.empty, rho, false)) in + let r = Record (Row (Label.Map.add label (Present a) Label.Map.empty, rho, false)) in Types.for_all (Types.quantifiers_of_type_args [(PrimaryKind.Type, a); (PrimaryKind.Row, Row (Label.Map.empty, rho, false)); diff --git a/tests/labels/pollution.links b/tests/labels/pollution.links index dd74763d0..2d906b2fa 100644 --- a/tests/labels/pollution.links +++ b/tests/labels/pollution.links @@ -26,9 +26,10 @@ fresh `Abort { } effectname AR(s,e::Eff) = {`Abort:() {}-> Zero, Receive:(){}->s|e} ; + effectname NAR(s,e::Eff) = {`Abort-, Receive:(){}->s|e} ; - sig withtwo21s : ( () ~AR(Int,{ |e})~> a ) -> Comp(Maybe(a), {Receive{_}, `Abort{_}|e}) - fun withtwo21s (h) () { maybe( receives(h)([21,21]) ) () } + sig withtwo21s : ( () ~NAR(Int,{ |e})~> a ) -> Comp(Maybe(a), {Receive{_}, `Abort{_}|e}) + fun withtwo21s (h) () { maybe( receives( h:( () ~AR(Int,{ |e})~> a ) <- ( () ~NAR(Int,{ |e})~> a) ) ([21,21]) ) () } } From 7dc5f7620234047a4c6f2b32f4442153e4061f6b Mon Sep 17 00:00:00 2001 From: RJ Date: Wed, 15 Jun 2022 11:29:17 +0100 Subject: [PATCH 33/63] fix : underscore in effect app --- core/desugarEffects.ml | 2 +- tests/effectname.tests | 6 +++--- .../{underscore-not-working.links => underscore.links} | 0 3 files changed, 4 insertions(+), 4 deletions(-) rename tests/effectname/{underscore-not-working.links => underscore.links} (100%) diff --git a/core/desugarEffects.ml b/core/desugarEffects.ml index 31855be86..aee008524 100644 --- a/core/desugarEffects.ml +++ b/core/desugarEffects.ml @@ -977,7 +977,7 @@ class main_traversal simple_tycon_env = let module D = Datatype in let o, rv = match rv with - | D.EffectApplication _ -> (o, rv) (* TODO(rj) do i need to do something there ? *) + | D.EffectApplication _ -> super#row_var rv (* TODO(rj) do i need to do something there ? *) | D.Closed -> (o, rv) | D.Open stv when (not (SugarTypeVar.is_resolved stv)) diff --git a/tests/effectname.tests b/tests/effectname.tests index 0fadc7c63..765aff62f 100644 --- a/tests/effectname.tests +++ b/tests/effectname.tests @@ -56,7 +56,7 @@ filemode : true stdout : () : () Underscore in effect alias application -./tests/effectname/underscore-not-working.links +./tests/effectname/underscore.links filemode : true -stderr : @.* -exit : 1 +args : --enable-handlers +stdout : true : Bool diff --git a/tests/effectname/underscore-not-working.links b/tests/effectname/underscore.links similarity index 100% rename from tests/effectname/underscore-not-working.links rename to tests/effectname/underscore.links From ca580a52d8a4f2c130db8f52d7d99adbebdd9241 Mon Sep 17 00:00:00 2001 From: RJ Date: Wed, 15 Jun 2022 14:15:18 +0100 Subject: [PATCH 34/63] various fixes --- core/desugarDatatypes.ml | 4 ++-- core/desugarEffects.ml | 45 +++++++++++++++++++++++++++++++++++++--- core/errors.ml | 1 + core/errors.mli | 1 + core/types.ml | 17 --------------- 5 files changed, 46 insertions(+), 22 deletions(-) diff --git a/core/desugarDatatypes.ml b/core/desugarDatatypes.ml index 8a42cc9a5..a3ade2ac6 100644 --- a/core/desugarDatatypes.ml +++ b/core/desugarDatatypes.ml @@ -149,7 +149,7 @@ module Desugar = struct raise (TypeApplicationArityMismatch { pos; name = tycon; expected = qn; provided = tn }) in begin match SEnv.find_opt tycon alias_env with - | None -> raise (UnboundTyCon (pos, tycon)) + | None -> raise (unbound_tycon pos tycon) | Some (`Alias (k, qs, _dt)) -> if k = pk_type then let ts = match_quantifiers snd qs in @@ -244,7 +244,7 @@ module Desugar = struct raise (TypeApplicationArityMismatch { pos = node.pos; name = name; expected = qn; provided = tn }) in begin match SEnv.find_opt name alias_env with - | None -> raise (UnboundTyCon (node.pos, name)) + | None -> raise (unbound_tycon node.pos name) | Some (`Alias (k, qs, _r)) -> if k = pk_row then let ts = match_quantifiers snd qs in diff --git a/core/desugarEffects.ml b/core/desugarEffects.ml index aee008524..2d7449bbf 100644 --- a/core/desugarEffects.ml +++ b/core/desugarEffects.ml @@ -713,7 +713,46 @@ let gather_operations (tycon_env : simple_tycon_env) allow_fresh dt = method! row_var = let open Datatype in function - | EffectApplication _ (* TODO(rj) should I do semething there ? *) + | EffectApplication (name, ts) -> (* TODO(rj) should I do semething there ? *) + let tycon_info = SEnv.find_opt name tycon_env in + let rec go o = + (* We don't know if the arities match up yet, so we handle + mismatches, assuming spare rows are effects. *) + function + | _, [] -> o + | (PrimaryKind.Row, (_, Restriction.Effect)) :: qs, Row t :: ts -> + go (o#effect_row t) (qs, ts) + | (([] as qs) | _ :: qs), t :: ts -> go (o#type_arg t) (qs, ts) + in + begin match tycon_info with + | Some (params, _has_implict_eff, internal_type) -> + let self = go self (params, ts) in + let ops = match internal_type with + | None -> RowVarMap.empty + | Some internal_type -> + gather_operation_of_type internal_type + in + let operations = + RowVarMap.fold + (fun vid sset acc -> + RowVarMap.update vid + (function + | None -> Some sset + | Some opset -> Some (StringSet.union opset sset)) + acc) + ops self#operations + in + let self = match RowVarMap.find_raw_opt (-1) ops with + | None -> self + | Some hide_ops -> + StringSet.fold + (fun label acc -> + acc#add_hidden_op name label) + hide_ops self + in + self#with_operations operations + | None -> raise (Errors.unbound_tycon SourceCode.Position.dummy name) + end | Closed | Open _ -> self @@ -854,7 +893,7 @@ class main_traversal simple_tycon_env = type applications. This must be done in later passes. *) let pos = SourceCode.Position.dummy in match SEnv.find_opt tycon tycon_env with - | None -> raise (Errors.UnboundTyCon (pos, tycon)) + | None -> raise (Errors.unbound_tycon pos tycon) | Some (params, _has_implicit_eff, _internal_type) -> let qn = List.length params in let tn = List.length ts in @@ -977,7 +1016,7 @@ class main_traversal simple_tycon_env = let module D = Datatype in let o, rv = match rv with - | D.EffectApplication _ -> super#row_var rv (* TODO(rj) do i need to do something there ? *) + | D.EffectApplication _ -> super#row_var rv | D.Closed -> (o, rv) | D.Open stv when (not (SugarTypeVar.is_resolved stv)) diff --git a/core/errors.ml b/core/errors.ml index 0bc3df9aa..3e8947475 100644 --- a/core/errors.ml +++ b/core/errors.ml @@ -257,3 +257,4 @@ let type_application_kind_mismatch pos name tyarg_number expected provided = TypeApplicationKindMismatch { pos; name; tyarg_number; expected; provided } let type_application_global_kind_mismatch pos name expected provided = TypeApplicationGlobalKindMismatch { pos; name; expected; provided } +let unbound_tycon pos message = UnboundTyCon (pos, message) diff --git a/core/errors.mli b/core/errors.mli index 6ec154c65..e5e4bc6f0 100644 --- a/core/errors.mli +++ b/core/errors.mli @@ -68,3 +68,4 @@ val cannot_open_file : string -> string -> exn val object_file_write_error : string -> string -> exn val type_application_kind_mismatch : Position.t -> string -> int -> string -> string -> exn val type_application_global_kind_mismatch : Position.t -> string -> string -> string -> exn +val unbound_tycon : Position.t -> string -> exn diff --git a/core/types.ml b/core/types.ml index 571bf7a2c..0af7a28f8 100644 --- a/core/types.ml +++ b/core/types.ml @@ -2729,23 +2729,6 @@ struct | `Mutual _ -> "mutual" | `Abstract _ -> "abstract" - let effect_spec ({ bound_vars; _ } as context) p = - let bound_vars tyvars = - List.fold_left - (fun bound_vars tyvar -> - TypeVarSet.add (Quantifier.to_var tyvar) bound_vars) - bound_vars tyvars - in function - | `Alias (_, tyvars, body) -> - let ctx = { context with bound_vars = bound_vars tyvars } in - begin - match tyvars with - | [] -> datatype ctx p body - | _ -> mapstrcat "," (quantifier p) tyvars ^"."^ row "," ctx p body - end - | `Mutual _ -> "mutual" - | `Abstract _ -> "abstract" - let string_of_datatype policy names ty = let ctxt = context_with_shared_effect policy (fun o -> o#typ ty) in datatype ctxt (policy, names) ty From e118c0e6cf4e63f56ca4563adcd1e1e28dbe48eb Mon Sep 17 00:00:00 2001 From: RJ Date: Thu, 16 Jun 2022 11:48:42 +0100 Subject: [PATCH 35/63] short type in effectname + short fun non desugar --- core/desugarEffects.ml | 77 +++++++++++++++++++----------- tests/effectname/nested-decl.links | 2 +- 2 files changed, 51 insertions(+), 28 deletions(-) diff --git a/core/desugarEffects.ml b/core/desugarEffects.ml index 2d7449bbf..5d76f7023 100644 --- a/core/desugarEffects.ml +++ b/core/desugarEffects.ml @@ -110,21 +110,22 @@ module SEnv = Env.String - bool = whether tycon has implicit shared effect - Types.typ option = the actual type inside the alias, if it exists (None for abstract types) - this is used to propagate operations, sometimes the type behind an alias will have some - operations labels hidden inside it *) -type tycon_info = Kind.t list * bool * Types.typ option + operations labels hidden inside it + - bool = whether tycon is a function type *) +type tycon_info = Kind.t list * bool * Types.typ option * bool type simple_tycon_env = tycon_info SEnv.t let simplify_tycon_env (tycon_env : Types.tycon_environment) : simple_tycon_env = let simplify_tycon name tycon simpl_env = - let param_kinds, internal_type = + let param_kinds, internal_type, is_fun = match tycon with - | `Alias (_, qs, tp) -> List.map Quantifier.to_kind qs, Some tp - | `Abstract abs -> Types.Abstype.arity abs, None + | `Alias (_, qs, tp) -> List.map Quantifier.to_kind qs, Some tp, (match tp with Types.Function _ -> true | _ -> false) + | `Abstract abs -> Types.Abstype.arity abs, None, false | `Mutual _ -> raise (internal_error "Found `Mutual in global tycon env") in - SEnv.bind name (param_kinds, false, internal_type) simpl_env + SEnv.bind name (param_kinds, false, internal_type, is_fun) simpl_env in SEnv.fold simplify_tycon tycon_env SEnv.empty @@ -253,10 +254,10 @@ let may_have_shared_eff (tycon_env : simple_tycon_env) dt = | Lolli _ -> Some `Arrow | TypeApplication (tycon, _) -> ( - let param_kinds, _has_implicit_effect, _internal_type = + let param_kinds, _has_implicit_effect, _internal_type, _is_fun = try SEnv.find tycon tycon_env - with NotFound _ -> raise (Errors.UnboundTyCon (SourceCode.WithPos.pos dt, tycon)) + with NotFound _ -> raise (Errors.unbound_tycon (SourceCode.WithPos.pos dt) tycon) in match ListUtils.last_opt param_kinds with | Some (PrimaryKind.Row, (_, Restriction.Effect)) -> Some `Alias @@ -264,6 +265,11 @@ let may_have_shared_eff (tycon_env : simple_tycon_env) dt = (* TODO: in the original version, this was true for every tycon with a Row var with restriction effect as the last param *) | _ -> None +let is_function_type_alias tycon tycon_env = + match SEnv.find_opt tycon tycon_env with + | Some (_, _ , _, true ) -> true + | _ -> false + (** Perform some initial desugaring of effect rows, to make them more amenable to later analysis. - Elaborate operations in effect rows, converting from the various sugared @@ -322,7 +328,7 @@ let cleanup_effects tycon_env = let tycon_info = try SEnv.find_opt name tycon_env - with NotFound _ -> raise (Errors.UnboundTyCon (pos, name)) + with NotFound _ -> raise (Errors.unbound_tycon pos name) in let rec go = (* We don't know if the arities match up yet (nor the final arities @@ -343,18 +349,17 @@ let cleanup_effects tycon_env = in let ts = match tycon_info with - | Some (params, _, _) -> go (params, ts) - | None -> raise (Errors.UnboundTyCon (pos, name)) + | Some (params, _, _, _) -> go (params, ts) + | None -> raise (Errors.unbound_tycon pos name) in TypeApplication (name, ts) + | Effect e -> + let e = self#effect_row ~allow_shared:`Disallow e in + Effect e | _ -> super#datatypenode t in SourceCode.WithPos.with_node dt res_t - method! aliasbody a = match a with - | Typename _ -> super#aliasbody a - | Effectname (r, r') -> Debug.print "bang" ; Effectname (self#effect_row ~allow_shared:`Disallow r, r') - method effect_row ~allow_shared (fields, var) = let open Datatype in let open SourceCode.WithPos in @@ -377,8 +382,10 @@ let cleanup_effects tycon_env = (SourceCode.WithPos.make ~pos (Function (domain, ([], Closed), codomain))) ) | _, _ -> raise (unexpected_effects_on_abstract_op pos name) ) + (* Elaborates `Op : a' to `Op : () {}-> a' *) + | _, Present { node = TypeApplication (tycon, _) ; _ } as x when is_function_type_alias tycon tycon_env -> + x | name, Present node when not (TypeUtils.is_builtin_effect name) -> - (* Elaborates `Op : a' to `Op : () {}-> a' *) ( name, Present (SourceCode.WithPos.make ~pos:node.pos @@ -475,7 +482,7 @@ let gather_mutual_info (tycon_env : simple_tycon_env) = let tycon_info = SEnv.find_opt name tycon_env in let self = self#list (fun o ta -> o#type_arg ta) ts in match tycon_info with - | Some (param_kinds, _other_has_implicit, _internal_type) + | Some (param_kinds, _other_has_implicit, _internal_type, _is_fun) when List.length param_kinds = List.length ts + 1 -> let poss_with_implicit = match ListUtils.last param_kinds with @@ -485,7 +492,7 @@ let gather_mutual_info (tycon_env : simple_tycon_env) = in poss_with_implicit#with_used_type name | Some _ -> self#with_used_type name - | None -> raise (Errors.UnboundTyCon (pos, name)) ) + | None -> raise (Errors.unbound_tycon pos name) ) | _ -> self end) #datatype @@ -674,7 +681,7 @@ let gather_operations (tycon_env : simple_tycon_env) allow_fresh dt = | (([] as qs) | _ :: qs), t :: ts -> go (o#type_arg t) (qs, ts) in match tycon_info with - | Some (params, _has_implict_eff, internal_type) -> + | Some (params, _has_implict_eff, internal_type, _is_fun) -> let self = go self (params, ts) in let ops = match internal_type with | None -> RowVarMap.empty @@ -700,7 +707,7 @@ let gather_operations (tycon_env : simple_tycon_env) allow_fresh dt = hide_ops self in self#with_operations operations - | None -> raise (Errors.UnboundTyCon (pos, name)) ) + | None -> raise (Errors.unbound_tycon pos name) ) | Mu (v, t) -> let mtv = SugarTypeVar.get_resolved_type_exn v in let var, (_, sk) = unpack_var_id (Unionfind.find mtv) in @@ -713,7 +720,7 @@ let gather_operations (tycon_env : simple_tycon_env) allow_fresh dt = method! row_var = let open Datatype in function - | EffectApplication (name, ts) -> (* TODO(rj) should I do semething there ? *) + | EffectApplication (name, ts) -> let tycon_info = SEnv.find_opt name tycon_env in let rec go o = (* We don't know if the arities match up yet, so we handle @@ -725,7 +732,7 @@ let gather_operations (tycon_env : simple_tycon_env) allow_fresh dt = | (([] as qs) | _ :: qs), t :: ts -> go (o#type_arg t) (qs, ts) in begin match tycon_info with - | Some (params, _has_implict_eff, internal_type) -> + | Some (params, _has_implict_eff, internal_type, _is_fun) -> let self = go self (params, ts) in let ops = match internal_type with | None -> RowVarMap.empty @@ -894,7 +901,7 @@ class main_traversal simple_tycon_env = let pos = SourceCode.Position.dummy in match SEnv.find_opt tycon tycon_env with | None -> raise (Errors.unbound_tycon pos tycon) - | Some (params, _has_implicit_eff, _internal_type) -> + | Some (params, _has_implicit_eff, _internal_type, _is_fun) -> let qn = List.length params in let tn = List.length ts in let arity_err () = @@ -1016,7 +1023,7 @@ class main_traversal simple_tycon_env = let module D = Datatype in let o, rv = match rv with - | D.EffectApplication _ -> super#row_var rv + | D.EffectApplication _ -> super#row_var rv (* maybe we should do as for TypeApplication and not just visit the node *) | D.Closed -> (o, rv) | D.Open stv when (not (SugarTypeVar.is_resolved stv)) @@ -1094,6 +1101,17 @@ class main_traversal simple_tycon_env = let o, (fields, rv) = o#row (fields, rv) in (o, (fields, rv)) + method! aliasbody = + let open Sugartypes.Datatype in + let module WP = SourceCode.WithPos in + function + | Typename _ as t -> super#aliasbody t + | Effectname (r, _) -> + let wp = cleanup_effects tycon_env (WP.dummy (Effect r)) in + match WP.node wp with + | Effect r -> (o, Effectname(r, None)) + | _ -> assert false + method! bindingnode = function | Val (_pat, (_qs, _body), _loc, signature) as b -> @@ -1108,9 +1126,14 @@ class main_traversal simple_tycon_env = (o, b) | Aliases ts -> let open SourceCode.WithPos in + let is_fun = function + | Typename ({ node = Datatype.Function _ ; _ }, _) + | Typename (_, Some (Types.Function _)) -> true + | _ -> false + in let tycon_env, tycons = List.fold_left - (fun (alias_env, tycons) { node = t, args, _; _ } -> + (fun (alias_env, tycons) { node = t, args, b; _ } -> let params = List.map (SugarQuantifier.get_resolved_exn ->- Quantifier.to_kind) @@ -1118,7 +1141,7 @@ class main_traversal simple_tycon_env = in (* initially pretend that no type needs an implict parameter *) (* TODO vvvv ??? *) - let env' = SEnv.bind t (params, false, None) alias_env in + let env' = SEnv.bind t (params, false, None, is_fun b) alias_env in let tycons' = StringSet.add t tycons in (env', tycons')) (tycon_env, StringSet.empty) @@ -1191,7 +1214,7 @@ class main_traversal simple_tycon_env = in (* TODO maybe this is already bound, take the type from inside vvvv *) - let tycon_env = SEnv.bind t (env_args, true, None) tycon_env in + let tycon_env = SEnv.bind t (env_args, true, None, is_fun b) tycon_env in let shared_effect_var : Types.meta_row_var Lazy.t = lazy (Unionfind.fresh (Types.Var (var, (PrimaryKind.Row, (lin_unl, res_effect)), `Rigid))) diff --git a/tests/effectname/nested-decl.links b/tests/effectname/nested-decl.links index 0c2ec0920..dab7e7f87 100755 --- a/tests/effectname/nested-decl.links +++ b/tests/effectname/nested-decl.links @@ -1,6 +1,6 @@ effectname A = {} ; effectname B(a,e::Eff) = { E: () -e-> a | A } ; -effectname C = { E': (Int) -A-> () | B(Int, { | A }) } ; +effectname C = { E': (Int) -> () | B(Int, { | A }) } ; sig f : () -C-> () fun f () { do E'(do E()) } From 109ca660ae76490b883f741acb9fa84dbc3f85fb Mon Sep 17 00:00:00 2001 From: RJ Date: Thu, 16 Jun 2022 12:05:28 +0100 Subject: [PATCH 36/63] comment --- core/desugarEffects.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/desugarEffects.ml b/core/desugarEffects.ml index 5d76f7023..13c12e390 100644 --- a/core/desugarEffects.ml +++ b/core/desugarEffects.ml @@ -1106,7 +1106,7 @@ class main_traversal simple_tycon_env = let module WP = SourceCode.WithPos in function | Typename _ as t -> super#aliasbody t - | Effectname (r, _) -> + | Effectname (r, _) -> (* hack to cleanup the row and desugar properly *) let wp = cleanup_effects tycon_env (WP.dummy (Effect r)) in match WP.node wp with | Effect r -> (o, Effectname(r, None)) From dc0682f98721c9776c76283b2a7cb96f290bb410 Mon Sep 17 00:00:00 2001 From: RJ Date: Thu, 16 Jun 2022 13:43:40 +0100 Subject: [PATCH 37/63] always desugar op type with type application --- core/desugarEffects.ml | 45 +++++++++++++++--------------------------- 1 file changed, 16 insertions(+), 29 deletions(-) diff --git a/core/desugarEffects.ml b/core/desugarEffects.ml index 13c12e390..ce948024e 100644 --- a/core/desugarEffects.ml +++ b/core/desugarEffects.ml @@ -110,22 +110,21 @@ module SEnv = Env.String - bool = whether tycon has implicit shared effect - Types.typ option = the actual type inside the alias, if it exists (None for abstract types) - this is used to propagate operations, sometimes the type behind an alias will have some - operations labels hidden inside it - - bool = whether tycon is a function type *) -type tycon_info = Kind.t list * bool * Types.typ option * bool + operations labels hidden inside it *) +type tycon_info = Kind.t list * bool * Types.typ option type simple_tycon_env = tycon_info SEnv.t let simplify_tycon_env (tycon_env : Types.tycon_environment) : simple_tycon_env = let simplify_tycon name tycon simpl_env = - let param_kinds, internal_type, is_fun = + let param_kinds, internal_type = match tycon with - | `Alias (_, qs, tp) -> List.map Quantifier.to_kind qs, Some tp, (match tp with Types.Function _ -> true | _ -> false) - | `Abstract abs -> Types.Abstype.arity abs, None, false + | `Alias (_, qs, tp) -> List.map Quantifier.to_kind qs, Some tp + | `Abstract abs -> Types.Abstype.arity abs, None | `Mutual _ -> raise (internal_error "Found `Mutual in global tycon env") in - SEnv.bind name (param_kinds, false, internal_type, is_fun) simpl_env + SEnv.bind name (param_kinds, false, internal_type) simpl_env in SEnv.fold simplify_tycon tycon_env SEnv.empty @@ -254,7 +253,7 @@ let may_have_shared_eff (tycon_env : simple_tycon_env) dt = | Lolli _ -> Some `Arrow | TypeApplication (tycon, _) -> ( - let param_kinds, _has_implicit_effect, _internal_type, _is_fun = + let param_kinds, _has_implicit_effect, _internal_type = try SEnv.find tycon tycon_env with NotFound _ -> raise (Errors.unbound_tycon (SourceCode.WithPos.pos dt) tycon) @@ -265,11 +264,6 @@ let may_have_shared_eff (tycon_env : simple_tycon_env) dt = (* TODO: in the original version, this was true for every tycon with a Row var with restriction effect as the last param *) | _ -> None -let is_function_type_alias tycon tycon_env = - match SEnv.find_opt tycon tycon_env with - | Some (_, _ , _, true ) -> true - | _ -> false - (** Perform some initial desugaring of effect rows, to make them more amenable to later analysis. - Elaborate operations in effect rows, converting from the various sugared @@ -349,7 +343,7 @@ let cleanup_effects tycon_env = in let ts = match tycon_info with - | Some (params, _, _, _) -> go (params, ts) + | Some (params, _, _) -> go (params, ts) | None -> raise (Errors.unbound_tycon pos name) in TypeApplication (name, ts) @@ -382,10 +376,8 @@ let cleanup_effects tycon_env = (SourceCode.WithPos.make ~pos (Function (domain, ([], Closed), codomain))) ) | _, _ -> raise (unexpected_effects_on_abstract_op pos name) ) - (* Elaborates `Op : a' to `Op : () {}-> a' *) - | _, Present { node = TypeApplication (tycon, _) ; _ } as x when is_function_type_alias tycon tycon_env -> - x | name, Present node when not (TypeUtils.is_builtin_effect name) -> + (* Elaborates `Op : a' to `Op : () {}-> a' *) ( name, Present (SourceCode.WithPos.make ~pos:node.pos @@ -482,7 +474,7 @@ let gather_mutual_info (tycon_env : simple_tycon_env) = let tycon_info = SEnv.find_opt name tycon_env in let self = self#list (fun o ta -> o#type_arg ta) ts in match tycon_info with - | Some (param_kinds, _other_has_implicit, _internal_type, _is_fun) + | Some (param_kinds, _other_has_implicit, _internal_type) when List.length param_kinds = List.length ts + 1 -> let poss_with_implicit = match ListUtils.last param_kinds with @@ -681,7 +673,7 @@ let gather_operations (tycon_env : simple_tycon_env) allow_fresh dt = | (([] as qs) | _ :: qs), t :: ts -> go (o#type_arg t) (qs, ts) in match tycon_info with - | Some (params, _has_implict_eff, internal_type, _is_fun) -> + | Some (params, _has_implict_eff, internal_type) -> let self = go self (params, ts) in let ops = match internal_type with | None -> RowVarMap.empty @@ -732,7 +724,7 @@ let gather_operations (tycon_env : simple_tycon_env) allow_fresh dt = | (([] as qs) | _ :: qs), t :: ts -> go (o#type_arg t) (qs, ts) in begin match tycon_info with - | Some (params, _has_implict_eff, internal_type, _is_fun) -> + | Some (params, _has_implict_eff, internal_type) -> let self = go self (params, ts) in let ops = match internal_type with | None -> RowVarMap.empty @@ -901,7 +893,7 @@ class main_traversal simple_tycon_env = let pos = SourceCode.Position.dummy in match SEnv.find_opt tycon tycon_env with | None -> raise (Errors.unbound_tycon pos tycon) - | Some (params, _has_implicit_eff, _internal_type, _is_fun) -> + | Some (params, _has_implicit_eff, _internal_type) -> let qn = List.length params in let tn = List.length ts in let arity_err () = @@ -1126,14 +1118,9 @@ class main_traversal simple_tycon_env = (o, b) | Aliases ts -> let open SourceCode.WithPos in - let is_fun = function - | Typename ({ node = Datatype.Function _ ; _ }, _) - | Typename (_, Some (Types.Function _)) -> true - | _ -> false - in let tycon_env, tycons = List.fold_left - (fun (alias_env, tycons) { node = t, args, b; _ } -> + (fun (alias_env, tycons) { node = t, args, _; _ } -> let params = List.map (SugarQuantifier.get_resolved_exn ->- Quantifier.to_kind) @@ -1141,7 +1128,7 @@ class main_traversal simple_tycon_env = in (* initially pretend that no type needs an implict parameter *) (* TODO vvvv ??? *) - let env' = SEnv.bind t (params, false, None, is_fun b) alias_env in + let env' = SEnv.bind t (params, false, None) alias_env in let tycons' = StringSet.add t tycons in (env', tycons')) (tycon_env, StringSet.empty) @@ -1214,7 +1201,7 @@ class main_traversal simple_tycon_env = in (* TODO maybe this is already bound, take the type from inside vvvv *) - let tycon_env = SEnv.bind t (env_args, true, None, is_fun b) tycon_env in + let tycon_env = SEnv.bind t (env_args, true, None) tycon_env in let shared_effect_var : Types.meta_row_var Lazy.t = lazy (Unionfind.fresh (Types.Var (var, (PrimaryKind.Row, (lin_unl, res_effect)), `Rigid))) From 01d9a09d2fe1fc6e4f68136bd9246963fee20f8d Mon Sep 17 00:00:00 2001 From: RJ Date: Thu, 16 Jun 2022 13:58:14 +0100 Subject: [PATCH 38/63] correction tests --- tests/effectname/typenames.links | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/effectname/typenames.links b/tests/effectname/typenames.links index 9330ff991..85d1a5304 100755 --- a/tests/effectname/typenames.links +++ b/tests/effectname/typenames.links @@ -1,12 +1,12 @@ -typename T(e::Eff) = (Int) -e-> Int ; +typename T = forall e::Eff. (Int) -e-> Int ; -effectname A(a,e::Eff) = { E1: T({}), E2: (Int) {}-> a | e } ; +effectname A(a,e::Eff) = { E1: T, E2: (Int) {}-> a | e } ; typename T'(a,b,e::Eff) = (a) { E: (a) {}-> Int | A(b,{ |e}) }-> b ; sig f : T'(Bool, Int, {}) fun f (x) { - do E2( do E1( do E(x) ) ) + do E2( (do E1 ()) (do E(x)) ) } f From 56ac19bb3c29f287fbf21baf3d0da665febc2e1e Mon Sep 17 00:00:00 2001 From: RJ Date: Mon, 20 Jun 2022 15:16:17 +0100 Subject: [PATCH 39/63] erase local labels out of scope (err when nested) --- core/label.ml | 4 +- core/label.mli | 3 +- core/typeSugar.ml | 95 ++++++++++++++++++++++++++++- core/typeUtils.ml | 6 +- core/types.mli | 2 +- tests/labels.tests | 4 +- tests/labels/handler.links | 2 +- tests/labels/nested-pollution.links | 13 ++-- tests/labels/nested.links | 3 + tests/labels/pollution.links | 2 +- 10 files changed, 116 insertions(+), 18 deletions(-) diff --git a/core/label.ml b/core/label.ml index c759b67ff..8c0643203 100644 --- a/core/label.ml +++ b/core/label.ml @@ -90,7 +90,9 @@ module Label = struct let eq lbl lbl' = compare lbl lbl' = 0 - let eq_name lbl name = eq lbl (mk_global name) + let eq_name lbl lbl' = String.compare (name lbl) (name lbl') = 0 + + let name_is lbl name' = String.compare (name lbl) name' = 0 let is_local = function | Lcl _ -> true diff --git a/core/label.mli b/core/label.mli index 1ea8deca5..d0c130fcf 100644 --- a/core/label.mli +++ b/core/label.mli @@ -26,7 +26,8 @@ val name : t -> Name.t val compare : t -> t -> int val eq : t -> t -> bool -val eq_name : t -> Name.t -> bool +val eq_name : t -> t -> bool +val name_is : t -> Name.t -> bool val is_local : t -> bool val is_global : t -> bool diff --git a/core/typeSugar.ml b/core/typeSugar.ml index beb4ea4fd..af7b88f49 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -1670,6 +1670,7 @@ let empty_context eff desugared = let bind_var context (v, t) = {context with var_env = Env.bind v t context.var_env} let unbind_var context v = {context with var_env = Env.unbind v context.var_env} let bind_alias context (v, t) = {context with tycon_env = Env.bind v t context.tycon_env} +let unbind_alias context v = {context with tycon_env = Env.unbind v context.tycon_env} let bind_effects context r = {context with effect_row = r} let extend context context' = (* this might not be super smart *) @@ -2541,6 +2542,90 @@ let resolve_type_annotation : Binder.with_pos -> Sugartypes.datatype' option -> with sufficiently effect-polymorphic operations). *) +(* erase the erasable occurences of local labels from the types in the context *) +(* and remove the bindings with non erasable occurences of local labels *) +exception CannotErase +let erase_local_labels_from_type labels dt = + let open Types in + let rec e dt = + let e_arg (pk, t) = (pk, e t) in + let e_args = List.map e_arg in + let e_point p = + let t = Unionfind.find p in + Unionfind.change p (e t) ; + p + in + match dt with + | Row (fields, rv, b) -> + let fields = Label.Map.fold (fun k v f -> + if List.mem k labels then (Debug.print ("remove " ^ Label.show k) ; + match v with + | Absent | Present (Var _) -> f + | Meta p when (match Unionfind.find p with Var _ -> true | _ -> false) -> f + | _ -> Debug.print ("presence: " ^ show_field_spec v) ; raise CannotErase) + else (Debug.print ("not remove " ^ Label.show k ) ; + Label.Map.add k (e v) f) + ) fields Label.Map.empty in + Row (fields, e_point rv, b) + | Recursive (id, k, t) -> Recursive (id, k, e t) + | Alias (pk, (name, ks, targs, b) , t) -> Alias (pk, (name, ks, e_args targs, b) , e t) + | Application (abs, targs) -> Application (abs, e_args targs) + | RecursiveApplication r -> RecursiveApplication { r with r_args = e_args r.r_args } + | Meta p -> Meta (e_point p) + | Function (t, t', t'') -> Function (e t, e t', e t'') + | Lolli (t, t', t'') -> Lolli (e t, e t', e t'') + | Record t -> Record (e t) + | Variant t -> Variant (e t) + | Table (temp, t, t', t'') -> Table (temp, e t, e t', e t'') + | ForAll (qs, t) -> ForAll (qs, e t) + | Effect t -> Effect (e t) + | Present t -> Present (e t) + | Input (t,t') -> Input (e t, e t') + | Output (t,t') -> Output (e t, e t') + | Select t -> Select (e t) + | Choice t -> Choice (e t) + | Dual t -> Dual (e t) + | _ -> dt + in + e dt + +let rec erase_local_labels labels decls ctx = + let erase_fun ctx name =Debug.print ("pouf " ^ name) ; + try + let t = Env.find name ctx.var_env in + let t = erase_local_labels_from_type labels t in + Debug.print ("fun: " ^ Types.show t) ; + bind_var ctx (name, t) + with CannotErase -> Debug.print ("et boum " ^ name) ; unbind_var ctx name + | NotFound _ -> Debug.print ("déjà boumed " ^name) ; ctx + in + List.fold_left (fun ctx d -> match WithPos.node d with + | Fun { fun_binder ; _ } -> erase_fun ctx (Binder.to_name fun_binder) + | Funs rfuns -> List.fold_left + (fun ctx rfun -> + let name = Binder.to_name (WithPos.node rfun).rec_binder in + erase_fun ctx name + ) ctx rfuns + | Aliases ts -> List.fold_left (fun ctx { node=(name, _, _); _} -> + try + let pk, vars, dt = match Env.find name ctx.tycon_env with + | `Alias (pk, vars, dt) -> pk, vars, dt | _ -> assert false in + let dt = erase_local_labels_from_type labels dt in + bind_alias ctx (name, `Alias (pk, vars, dt)) + with CannotErase -> unbind_alias ctx name + | NotFound _ -> ctx + ) ctx ts + | FreshLabel (labels', decls') -> erase_local_labels (labels @ labels') decls' ctx + | Val _ + | Infix _ + | Exp _ + | Foreign _ -> ctx + | Import _ + | Open _ + | Module _ + | AlienBlock _ -> assert false + ) ctx decls + let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = fun context {node=expr; pos} -> let _UNKNOWN_POS_ = "" in @@ -4863,7 +4948,7 @@ and type_binding : context -> binding -> binding * context * Usage.t = bind_alias env (name, `Alias (pk_type, List.map (SugarQuantifier.get_resolved_exn) vars, dt)) | Effectname (_, Some dt) -> bind_alias env (name, `Alias (pk_row , List.map (SugarQuantifier.get_resolved_exn) vars, dt)) - | _ -> raise (internal_error "typeSugar.ml: unannotated type") + | _ -> raise (internal_error "unannotated type") ) empty_context ts in (Aliases ts, env, Usage.empty) | Infix def -> Infix def, empty_context, Usage.empty @@ -4874,8 +4959,12 @@ and type_binding : context -> binding -> binding * context * Usage.t = Exp (erase e), empty_context, usages e | FreshLabel(labels, decls) -> let ctx, decls = List.fold_left_map - (fun ctx d -> let d', ctx', _ = type_binding ctx d in extend ctx ctx', d') context decls in - (FreshLabel(labels, decls), ctx, Usage.empty) + (fun ctx d -> + let d, ctx', _ = type_binding ctx d in + extend ctx ctx', d + ) context decls in + let context = erase_local_labels labels decls ctx in + (FreshLabel(labels, decls), context, Usage.empty) | Import _ | Open _ | AlienBlock _ diff --git a/core/typeUtils.ml b/core/typeUtils.ml index 3c57bd82e..8b2898c71 100644 --- a/core/typeUtils.ml +++ b/core/typeUtils.ml @@ -56,10 +56,10 @@ let rec project_type ?(overstep_quantifiers=true) label t = match (concrete_type t | (Application (absty, [PrimaryKind.Type, typ]), _) when (Abstype.name absty) = "TransactionTime" || (Abstype.name absty = "ValidTime") -> - if Label.eq_name label TemporalField.data_field then typ + if Label.name_is label TemporalField.data_field then typ else if - Label.eq_name label TemporalField.from_field || - Label.eq_name label TemporalField.to_field then + Label.name_is label TemporalField.from_field || + Label.name_is label TemporalField.to_field then Primitive (Primitive.DateTime) else error ("Trying to project " ^ Label.show label ^ " from temporal metadata: " ^ string_of_datatype t) diff --git a/core/types.mli b/core/types.mli index 09bf3e1a0..a1eaa06ac 100644 --- a/core/types.mli +++ b/core/types.mli @@ -171,7 +171,7 @@ and meta_presence_var = typ point and row = typ and row' = field_spec_map * row_var * bool and row_var = meta_row_var - +[@@deriving show] val is_type_body : typ -> bool val is_row_body : row -> bool diff --git a/tests/labels.tests b/tests/labels.tests index 4e1e85205..a31f0549c 100644 --- a/tests/labels.tests +++ b/tests/labels.tests @@ -22,7 +22,7 @@ stdout : () : () Handler for local effect ./tests/labels/handler.links filemode : true -stdout : 0 : Int +stdout : 42 : Int args : --enable-handlers Nested label bindings @@ -40,7 +40,7 @@ args : --enable-handlers Avoiding pollution [1] ./tests/labels/pollution.links filemode : true -stdout : (Just(42), Nothing, Just(Just(-1))) : (Maybe (Int), Maybe (Int), Maybe (Maybint)) +stdout : (Just(42), Nothing, Just(-1)) : (Maybe (Int), Maybe (Int), Maybint) args : --enable-handlers Avoiding pollution [2] diff --git a/tests/labels/handler.links b/tests/labels/handler.links index 9d7b01b3a..ca2f5aabe 100644 --- a/tests/labels/handler.links +++ b/tests/labels/handler.links @@ -21,4 +21,4 @@ fresh `Ask { } -h_ask (f) () - res () +res () diff --git a/tests/labels/nested-pollution.links b/tests/labels/nested-pollution.links index 656c0ab17..ccda92ca5 100644 --- a/tests/labels/nested-pollution.links +++ b/tests/labels/nested-pollution.links @@ -6,6 +6,8 @@ fresh `A { } } + fun double (x) { do `A(x) } + fresh `A { fun h_a' (m) () { @@ -16,12 +18,13 @@ fresh `A { fun triple (x) { do `A(x) } - } + fun sextuple (x) () {triple(double(x)) } - fun double (x) { do `A(x) } + sig times_six : (Int) ~> Int + fun times_six (x) { h_a (h_a' (sextuple (x))) () } -} + } -fun sextuple (x) () { triple(double(x)) } +} -h_a ( h_a' ( sextuple (7) ) ) () +times_six (7) diff --git a/tests/labels/nested.links b/tests/labels/nested.links index 5fc5e20ec..73af6752b 100644 --- a/tests/labels/nested.links +++ b/tests/labels/nested.links @@ -5,6 +5,9 @@ fresh `A { sig f : () {`A:(), `B:Bool}-> Bool fun f () { do `A ; do `B } + sig f' : () {`A:Int}-> Int + fun f' () { do `A * 42 } + } fresh `C, `B, `A { diff --git a/tests/labels/pollution.links b/tests/labels/pollution.links index 2d906b2fa..d2967813b 100644 --- a/tests/labels/pollution.links +++ b/tests/labels/pollution.links @@ -53,5 +53,5 @@ fun res (h) () { ( withtwo21s( f ) () , withtwo21s( g ) () , - maybe (res(withtwo21s(h))) () + res(withtwo21s(h)) () ) From 7a9a4379a9618766d23356b94bccb19db9b32ff8 Mon Sep 17 00:00:00 2001 From: RJ Date: Wed, 22 Jun 2022 15:22:53 +0100 Subject: [PATCH 40/63] nested fresh label --- core/desugarLabels.ml | 28 +++------- core/label.ml | 35 +++++++++++- core/label.mli | 19 +++++++ core/typeSugar.ml | 83 +++++++++++++++++++++-------- core/types.mli | 2 +- tests/labels/nested-pollution.links | 25 +++++++-- 6 files changed, 141 insertions(+), 51 deletions(-) diff --git a/core/desugarLabels.ml b/core/desugarLabels.ml index 40d31f27c..100e61609 100644 --- a/core/desugarLabels.ml +++ b/core/desugarLabels.ml @@ -1,44 +1,30 @@ open Utility open Sugartypes -module Env = Utility.StringMap +module Env = Label.Env let visitor = object (self) inherit SugarTraversals.map as super - val mutable label_env : (Label.t list) Env.t = Env.empty - - method bind_labels = List.iter (fun l -> - let old_ls = match Env.find_opt (Label.name l) label_env with - | None -> [] - | Some ls -> ls in - label_env <- Env.add (Label.name l) (l::old_ls) label_env - ) - - method unbind_labels = List.iter (fun l -> - match Env.find_opt (Label.name l) label_env with - | None -> () - | Some [] | Some [_] -> label_env <- Env.remove (Label.name l) label_env - | Some (_::ls) -> label_env <- Env.add (Label.name l) ls label_env - ) + val mutable label_env : Env.t = Env.empty method! label lbl = if Label.is_global lbl || not (Label.is_free lbl) then lbl else - let bind_with = match Env.find_opt (Label.name lbl) label_env with - | Some (bw :: _) -> bw - | _ -> failwith ("The local label " ^ Label.show lbl ^ " is not bound") + let bind_with = match Env.find_homonyms lbl label_env with + | bw :: _ -> bw + | _ -> failwith ("The local label " ^ Label.show lbl ^ " is not bound") in Label.bind_local ~bind_with lbl method! bindingnode = function | FreshLabel (labels, decls) -> let labels = List.map Label.bind_local labels in - self#bind_labels labels ; + label_env <- Env.bind_labels labels label_env ; let decls = List.map self#binding decls in - self#unbind_labels labels ; + label_env <- Env.unbind_labels labels label_env ; FreshLabel(labels, decls) | b -> super#bindingnode b diff --git a/core/label.ml b/core/label.ml index 8c0643203..f3d7bef94 100644 --- a/core/label.ml +++ b/core/label.ml @@ -41,15 +41,16 @@ module Label = struct | Lcl of local | Gbl of global (* | Unr of unresolved *) + type label = t let show = function - | Lcl (name, id) -> "`" ^ name ^ "(" ^ Uid.show id ^ ")" + | Lcl (name, id) -> "`" ^ name ^ "<" ^ Uid.show id ^ ">" | Gbl name -> name (* | Unr name -> "`?" ^ name *) let pp f l = Format.pp_print_string f begin match l with - | Lcl (name, _) -> "`"^name + | Lcl (name, id) -> "`"^name ^ "<" ^ Uid.show id ^ ">" | Gbl name -> name (* | Unr name -> "`?" ^ name *) end @@ -163,3 +164,33 @@ let label_to_string_set m = Set.fold (fun k m -> Utility.StringSet.add (Label.name k) m) m Utility.StringSet.empty + + +module Env = struct + module M = Utility.StringMap + + type t = (Label.t list) M.t + + let empty = M.empty + + let extend = M.superimpose + + let bind env label = + let old_ls = match M.find_opt (name label) env with + | None -> [] + | Some ls -> ls in + M.add (name label) (label::old_ls) env + + let unbind env label = + match M.find_opt (name label) env with + | None -> env + | Some [] | Some [_] -> M.remove (name label) env + | Some (_::ls) -> M.add (name label) ls env + + let bind_labels labels env = List.fold_left bind env labels + let unbind_labels labels env = List.fold_left unbind env labels + + let find_homonyms l env = match M.find_opt (name l) env with + | Some ls -> ls + | None -> [] +end diff --git a/core/label.mli b/core/label.mli index d0c130fcf..61de4b706 100644 --- a/core/label.mli +++ b/core/label.mli @@ -14,6 +14,7 @@ type t = (* | Unr of unresolved *) (* type t = string *) [@@deriving show] +type label = t val mk_local : Name.t -> t val mk_global : Name.t -> t @@ -56,3 +57,21 @@ val string_to_label_map : 'a Utility.StringMap.t -> 'a Map.t val label_to_string_map : 'a Map.t -> 'a Utility.StringMap.t val string_to_label_set : Utility.StringSet.t -> Set.t val label_to_string_set : Set.t -> Utility.StringSet.t + +module Env : sig + module M = Utility.StringMap + + type t = (label list) M.t + + val empty : t + + val extend : t -> t -> t + + val bind : t -> label -> t + val unbind : t -> label -> t + + val bind_labels : label list -> t -> t + val unbind_labels : label list -> t -> t + + val find_homonyms : label -> t -> label list +end diff --git a/core/typeSugar.ml b/core/typeSugar.ml index af7b88f49..2ab17fcad 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -2545,26 +2545,41 @@ let resolve_type_annotation : Binder.with_pos -> Sugartypes.datatype' option -> (* erase the erasable occurences of local labels from the types in the context *) (* and remove the bindings with non erasable occurences of local labels *) exception CannotErase -let erase_local_labels_from_type labels dt = +let erase_local_labels_from_type ?(exact=true) pos labels dt = let open Types in let rec e dt = let e_arg (pk, t) = (pk, e t) in let e_args = List.map e_arg in let e_point p = - let t = Unionfind.find p in - Unionfind.change p (e t) ; + (* let t = Unionfind.find p in Unionfind.change p (e t) ; *) (* TODO: This causes stack overflow, is it right to not have it ? *) p in match dt with | Row (fields, rv, b) -> let fields = Label.Map.fold (fun k v f -> - if List.mem k labels then (Debug.print ("remove " ^ Label.show k) ; - match v with - | Absent | Present (Var _) -> f - | Meta p when (match Unionfind.find p with Var _ -> true | _ -> false) -> f - | _ -> Debug.print ("presence: " ^ show_field_spec v) ; raise CannotErase) - else (Debug.print ("not remove " ^ Label.show k ) ; - Label.Map.add k (e v) f) + let keep () = Label.Map.add k (e v) f in + let remove () = Debug.print ("remove " ^ Label.show k) ; f in + let to_remove k = + if exact then List.mem k labels + else List.filter (Label.eq_name k) labels <> [] + in + let is_shadowed k = + if exact then List.filter (Label.eq_name k) labels <> [] + else false + in + if Label.is_global k then keep () + else + let _ = Debug.print ("field " ^ Label.show k ^ ":" ^ show_datatype v) in + if to_remove k then + let _ = match v with + | Absent | Present (Var _) -> () + | Meta p when (match Unionfind.find p with Var _ -> true | _ -> false) -> () + | _ -> Debug.print "present : cannot erase" ; raise CannotErase + in remove () + else if is_shadowed k then + Gripers.die pos ("Label " ^ Label.show k ^ " is shadowed in this scope") + else + keep () ) fields Label.Map.empty in Row (fields, e_point rv, b) | Recursive (id, k, t) -> Recursive (id, k, e t) @@ -2589,34 +2604,52 @@ let erase_local_labels_from_type labels dt = in e dt -let rec erase_local_labels labels decls ctx = - let erase_fun ctx name =Debug.print ("pouf " ^ name) ; +let rec erase_local_labels pos labels decls ctx = + let erase_binder binder ctx = + let name = Binder.to_name binder in + Debug.print ("erasing " ^ name) ; try let t = Env.find name ctx.var_env in - let t = erase_local_labels_from_type labels t in - Debug.print ("fun: " ^ Types.show t) ; + let t = erase_local_labels_from_type pos labels t in + Debug.print ("of type: " ^ Types.show t) ; bind_var ctx (name, t) - with CannotErase -> Debug.print ("et boum " ^ name) ; unbind_var ctx name - | NotFound _ -> Debug.print ("déjà boumed " ^name) ; ctx + with CannotErase -> Debug.print ("cannot erase : unbinding " ^ name) ; unbind_var ctx name + | NotFound _ -> Debug.print ("already unbound " ^name) ; ctx + in + let rec erase_pat pat ctx = + let e = erase_pat in + let e_list ps ctx = List.fold_left (fun ctx p -> e p ctx) ctx ps in + let e_opt p_opt ctx = match p_opt with None -> ctx | Some p -> e p ctx in + let open Pattern in + match WithPos.node pat with + | Cons (p,p') -> ctx |> e p |> e p' + | List ps -> ctx |> e_list ps + | Variant (_, p_opt) -> ctx |> e_opt p_opt + | Effect (_, ps, p) -> ctx |> e_list ps |> e p + | Record (lps, p_opt) -> ctx |> e_list (snd (List.split lps)) |> e_opt p_opt + | Tuple ps -> ctx |> e_list ps + | Variable b -> ctx |> erase_binder b + | As (b, p) -> ctx |> erase_binder b |> e p + | HasType (p,_) -> ctx |> e p + | _ -> ctx in List.fold_left (fun ctx d -> match WithPos.node d with - | Fun { fun_binder ; _ } -> erase_fun ctx (Binder.to_name fun_binder) + | Fun { fun_binder ; _ } -> erase_binder fun_binder ctx | Funs rfuns -> List.fold_left (fun ctx rfun -> - let name = Binder.to_name (WithPos.node rfun).rec_binder in - erase_fun ctx name + erase_binder (WithPos.node rfun).rec_binder ctx ) ctx rfuns | Aliases ts -> List.fold_left (fun ctx { node=(name, _, _); _} -> try let pk, vars, dt = match Env.find name ctx.tycon_env with | `Alias (pk, vars, dt) -> pk, vars, dt | _ -> assert false in - let dt = erase_local_labels_from_type labels dt in + let dt = erase_local_labels_from_type pos labels dt in bind_alias ctx (name, `Alias (pk, vars, dt)) with CannotErase -> unbind_alias ctx name | NotFound _ -> ctx ) ctx ts - | FreshLabel (labels', decls') -> erase_local_labels (labels @ labels') decls' ctx - | Val _ + | Val (pat, _, _, _) -> erase_pat pat ctx + | FreshLabel (_, decls') -> erase_local_labels pos labels decls' ctx | Infix _ | Exp _ | Foreign _ -> ctx @@ -4958,12 +4991,16 @@ and type_binding : context -> binding -> binding * context * Usage.t = (pos_and_typ e, no_pos Types.unit_type) in Exp (erase e), empty_context, usages e | FreshLabel(labels, decls) -> + let context = { context with var_env = Env.fold (fun k v env -> + try Env.bind k (erase_local_labels_from_type ~exact:false pos labels v) env + with CannotErase -> env + ) context.var_env Env.empty } in let ctx, decls = List.fold_left_map (fun ctx d -> let d, ctx', _ = type_binding ctx d in extend ctx ctx', d ) context decls in - let context = erase_local_labels labels decls ctx in + let context = erase_local_labels pos labels decls ctx in (FreshLabel(labels, decls), context, Usage.empty) | Import _ | Open _ diff --git a/core/types.mli b/core/types.mli index a1eaa06ac..38d06066d 100644 --- a/core/types.mli +++ b/core/types.mli @@ -222,7 +222,7 @@ type typing_environment = { var_env : environment ; rec_vars : Utility.StringSet.t ; tycon_env : tycon_environment ; effect_row : row ; - desugared : bool } + desugared : bool } val empty_typing_environment : typing_environment diff --git a/tests/labels/nested-pollution.links b/tests/labels/nested-pollution.links index ccda92ca5..8e49d684e 100644 --- a/tests/labels/nested-pollution.links +++ b/tests/labels/nested-pollution.links @@ -1,30 +1,47 @@ fresh `A { + sig h_a : (Comp(a,{`A:(Int)->Int|e})) -> Comp(a, {`A{_}|e}) fun h_a (m) () { handle (m ()) { case `A(x, k) -> k (2*x) } } + sig double : (Int) {`A:(Int)-> Int|e}-> Int fun double (x) { do `A(x) } + sig times_two : (Int) -> Comp(Int, {`A{_}|_}) + fun times_two (x) { h_a ( fun () { double(x) } ) } + + sig times_two' : (Int) {`A{_}|_}~> Int + fun times_two' (x) { times_two (x) () } + fresh `A { + sig h_a' : (Comp(a,{`A:(Int)->Int|e})) -> Comp(a, {`A{_}|e}) fun h_a' (m) () { handle (m()) { case `A(x, k) -> k (3*x) } } + sig triple : (Int) {`A:(Int)-> Int|e}-> Int fun triple (x) { do `A(x) } - fun sextuple (x) () {triple(double(x)) } + sig sextuple : (Int) {`A:(Int)-> Int|e}~> Int + fun sextuple (x) { triple( times_two'(x) ) } - sig times_six : (Int) ~> Int - fun times_six (x) { h_a (h_a' (sextuple (x))) () } + sig times_six : (Int) -> Comp(Int, {`A{_}|_}) + fun times_six (x) { h_a' (fun () { sextuple (x) }) } + + sig times_six' : (Int) {`A{_}|_}~> Int + fun times_six' (x) { times_six (x) () } } + var fun_xlii = times_two( 21+21 ) ; + + var xlii = fun_xlii () ; } -times_six (7) +xlii - times_six' (7) From 4b6d3f9d55a39e79b6c448084bdd3b5eddaa4b0d Mon Sep 17 00:00:00 2001 From: RJ Date: Wed, 22 Jun 2022 17:11:28 +0100 Subject: [PATCH 41/63] fix stack overflow w/ points + clean debug --- core/typeSugar.ml | 26 +++++++++++++++++--------- 1 file changed, 17 insertions(+), 9 deletions(-) diff --git a/core/typeSugar.ml b/core/typeSugar.ml index 2ab17fcad..dc6188697 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -2545,20 +2545,31 @@ let resolve_type_annotation : Binder.with_pos -> Sugartypes.datatype' option -> (* erase the erasable occurences of local labels from the types in the context *) (* and remove the bindings with non erasable occurences of local labels *) exception CannotErase + +(* remember which points are erased in order not to loop *) +let erased_points = ref [] +let push_erased_point x = erased_points := x :: !erased_points +let is_erased_point x = List.filter (Unionfind.equivalent x) !erased_points <> [] + let erase_local_labels_from_type ?(exact=true) pos labels dt = let open Types in let rec e dt = let e_arg (pk, t) = (pk, e t) in let e_args = List.map e_arg in let e_point p = - (* let t = Unionfind.find p in Unionfind.change p (e t) ; *) (* TODO: This causes stack overflow, is it right to not have it ? *) - p + if is_erased_point p then p + else begin + push_erased_point p ; + let t = Unionfind.find p in + Unionfind.change p (e t) ; + p + end in match dt with | Row (fields, rv, b) -> let fields = Label.Map.fold (fun k v f -> let keep () = Label.Map.add k (e v) f in - let remove () = Debug.print ("remove " ^ Label.show k) ; f in + let remove () = f in let to_remove k = if exact then List.mem k labels else List.filter (Label.eq_name k) labels <> [] @@ -2569,12 +2580,11 @@ let erase_local_labels_from_type ?(exact=true) pos labels dt = in if Label.is_global k then keep () else - let _ = Debug.print ("field " ^ Label.show k ^ ":" ^ show_datatype v) in if to_remove k then let _ = match v with | Absent | Present (Var _) -> () | Meta p when (match Unionfind.find p with Var _ -> true | _ -> false) -> () - | _ -> Debug.print "present : cannot erase" ; raise CannotErase + | _ -> raise CannotErase in remove () else if is_shadowed k then Gripers.die pos ("Label " ^ Label.show k ^ " is shadowed in this scope") @@ -2607,14 +2617,12 @@ let erase_local_labels_from_type ?(exact=true) pos labels dt = let rec erase_local_labels pos labels decls ctx = let erase_binder binder ctx = let name = Binder.to_name binder in - Debug.print ("erasing " ^ name) ; try let t = Env.find name ctx.var_env in let t = erase_local_labels_from_type pos labels t in - Debug.print ("of type: " ^ Types.show t) ; bind_var ctx (name, t) - with CannotErase -> Debug.print ("cannot erase : unbinding " ^ name) ; unbind_var ctx name - | NotFound _ -> Debug.print ("already unbound " ^name) ; ctx + with CannotErase -> unbind_var ctx name + | NotFound _ -> ctx in let rec erase_pat pat ctx = let e = erase_pat in From fd52e083c7d227d7708b3279012419585fa7e0a6 Mon Sep 17 00:00:00 2001 From: RJ Date: Thu, 23 Jun 2022 15:10:11 +0100 Subject: [PATCH 42/63] alias stuff --- core/typeSugar.ml | 86 +++++++++++++++++++++++++++++++++++++++++----- tests/labels.tests | 8 ++++- 2 files changed, 85 insertions(+), 9 deletions(-) diff --git a/core/typeSugar.ml b/core/typeSugar.ml index dc6188697..8f9c75f0e 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -2614,6 +2614,25 @@ let erase_local_labels_from_type ?(exact=true) pos labels dt = in e dt +let erase_local_labels_from_tycon ?(exact=true) pos labels tycon = + match tycon with + | `Alias (pk, vars, dt) -> + let dt = erase_local_labels_from_type ~exact pos labels dt in + `Alias (pk, vars, dt) + | `Abstract abs -> `Abstract abs + | `Mutual (qs, tygroup) -> + let open Utility.StringMap in + let open Types in + tygroup := { !tygroup with + type_map = fold (fun k (qs,v) m -> + try + let v = erase_local_labels_from_type ~exact pos labels v in + add k (qs,v) m + with CannotErase -> m + ) !tygroup.type_map empty + } ; + `Mutual (qs, tygroup) + let rec erase_local_labels pos labels decls ctx = let erase_binder binder ctx = let name = Binder.to_name binder in @@ -2649,10 +2668,8 @@ let rec erase_local_labels pos labels decls ctx = ) ctx rfuns | Aliases ts -> List.fold_left (fun ctx { node=(name, _, _); _} -> try - let pk, vars, dt = match Env.find name ctx.tycon_env with - | `Alias (pk, vars, dt) -> pk, vars, dt | _ -> assert false in - let dt = erase_local_labels_from_type pos labels dt in - bind_alias ctx (name, `Alias (pk, vars, dt)) + let tycon = erase_local_labels_from_tycon pos labels (Env.find name ctx.tycon_env) in + bind_alias ctx (name, tycon) with CannotErase -> unbind_alias ctx name | NotFound _ -> ctx ) ctx ts @@ -2667,6 +2684,47 @@ let rec erase_local_labels pos labels decls ctx = | AlienBlock _ -> assert false ) ctx decls +let check_tycon pos dt ctx = + let checked_points = ref [] in + let push_checked_point x = checked_points := x :: !checked_points in + let is_checked_point x = List.filter (Unionfind.equivalent x) !checked_points <> [] in + let open Types in + let rec ct dt = + let ct_name name = + if not (Env.has name ctx.tycon_env) then raise (Errors.UnboundTyCon (pos, name)) in + let ct_arg (_, t) = ct t in + let ct_args = List.iter ct_arg in + let ct_point p = + if not (is_checked_point p) then begin + push_checked_point p ; + ct (Unionfind.find p) + end + in + match dt with + | Row (fields, rv, _) -> Label.Map.iter (fun _ v -> ct v) fields ; ct_point rv + | Alias (_, (name, _, targs, _) , t) -> ct_name name ; ct_args targs ; ct t + | Application (abs, targs) -> ct_name (Abstype.name abs) ; ct_args targs + | RecursiveApplication { r_name ; r_args ; _ } -> ct_name r_name ; ct_args r_args + | Meta p -> ct_point p + | Recursive (_, _, t) + | Record t + | Variant t + | ForAll (_, t) + | Effect t + | Present t + | Select t + | Choice t + | Dual t -> ct t + | Input (t,t') + | Output (t,t') -> ct t ; ct t' + | Function (t, t', t'') + | Lolli (t, t', t'') + | Table (_, t, t', t'') -> ct t ; ct t' ; ct t'' + | _ -> () + in + ct dt + + let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = fun context {node=expr; pos} -> let _UNKNOWN_POS_ = "" in @@ -4551,6 +4609,7 @@ and type_binding : context -> binding -> binding * context * Usage.t = let bt = match datatype with | Some (_, Some t) -> + let _ = check_tycon pos t context in unify pos ~handle:Gripers.bind_val_annotation (no_pos (typ body), no_pos t); t | _ -> typ body in @@ -4606,6 +4665,7 @@ and type_binding : context -> binding -> binding * context * Usage.t = | Some ft -> (* Debug.print ("t: " ^ Types.string_of_datatype ft); *) (* make sure the annotation has the right shape *) + let _ = check_tycon pos ft context in let shape = make_ft lin pats effects return_type in let quantifiers, ft_mono = TypeUtils.split_quantified_type ft in @@ -4785,6 +4845,7 @@ and type_binding : context -> binding -> binding * context * Usage.t = make_ft_poly_curry lin pats (fresh_tame ()) (Types.fresh_type_variable (lin_any, res_any)) | Some t -> (* Debug.print ("t: " ^ Types.string_of_datatype t); *) + let _ = check_tycon pos t context in let shape = make_ft lin pats (fresh_tame ()) (Types.fresh_type_variable (lin_any, res_any)) in let ft = match t with | T.ForAll _ -> t @@ -4976,6 +5037,7 @@ and type_binding : context -> binding -> binding * context * Usage.t = ignore (if String.contains (Binder.to_name binder) '\'' then raise (Errors.prime_alien pos)); (* Ensure that we quantify FTVs *) + let _ = check_tycon pos datatype context in let (_tyvars, _args), datatype = Utils.generalise context.var_env datatype in let datatype = Instantiate.freshen_quantifiers datatype in let binder = Binder.set_type binder datatype in @@ -4986,8 +5048,10 @@ and type_binding : context -> binding -> binding * context * Usage.t = let env = List.fold_left (fun env {node=(name, vars, b); _} -> match b with | Typename (_, Some dt) -> + let _ = check_tycon pos dt context in bind_alias env (name, `Alias (pk_type, List.map (SugarQuantifier.get_resolved_exn) vars, dt)) | Effectname (_, Some dt) -> + let _ = check_tycon pos dt context in bind_alias env (name, `Alias (pk_row , List.map (SugarQuantifier.get_resolved_exn) vars, dt)) | _ -> raise (internal_error "unannotated type") ) empty_context ts in @@ -4999,10 +5063,16 @@ and type_binding : context -> binding -> binding * context * Usage.t = (pos_and_typ e, no_pos Types.unit_type) in Exp (erase e), empty_context, usages e | FreshLabel(labels, decls) -> - let context = { context with var_env = Env.fold (fun k v env -> - try Env.bind k (erase_local_labels_from_type ~exact:false pos labels v) env - with CannotErase -> env - ) context.var_env Env.empty } in + let context = { context with + var_env = Env.fold (fun k v env -> + try Env.bind k (erase_local_labels_from_type ~exact:false pos labels v) env + with CannotErase -> env + ) context.var_env Env.empty ; + tycon_env = Env.fold (fun k v env -> + try Env.bind k (erase_local_labels_from_tycon ~exact:false pos labels v) env + with CannotErase -> env + ) context.tycon_env Env.empty + } in let ctx, decls = List.fold_left_map (fun ctx d -> let d, ctx', _ = type_binding ctx d in diff --git a/tests/labels.tests b/tests/labels.tests index a31f0549c..245fe860a 100644 --- a/tests/labels.tests +++ b/tests/labels.tests @@ -25,11 +25,17 @@ filemode : true stdout : 42 : Int args : --enable-handlers -Nested label bindings +Nested label bindings [1] ./tests/labels/nested.links filemode : true stdout : () : () +Nested label bindings [2] +./tests/labels/nested-names.links +filemode : true +stderr : @.* +exit : 1 + Wrong local handler ./tests/labels/wrong-handler.links filemode : true From aa7372796a06f8ae0db46b347ca89e50e4ac595f Mon Sep 17 00:00:00 2001 From: RJ Date: Fri, 24 Jun 2022 14:49:14 +0100 Subject: [PATCH 43/63] functional --- core/desugarLabels.ml | 8 +- core/label.ml | 5 +- core/label.mli | 18 +--- core/lib.ml | 1 + core/typeSugar.ml | 159 +++++++++++++++----------------- core/types.ml | 7 +- core/types.mli | 2 +- tests/labels/nested-names.links | 17 ++++ 8 files changed, 110 insertions(+), 107 deletions(-) create mode 100644 tests/labels/nested-names.links diff --git a/core/desugarLabels.ml b/core/desugarLabels.ml index 100e61609..1e03f4090 100644 --- a/core/desugarLabels.ml +++ b/core/desugarLabels.ml @@ -13,11 +13,9 @@ let visitor = if Label.is_global lbl || not (Label.is_free lbl) then lbl else - let bind_with = match Env.find_homonyms lbl label_env with - | bw :: _ -> bw - | _ -> failwith ("The local label " ^ Label.show lbl ^ " is not bound") - in - Label.bind_local ~bind_with lbl + match Env.find_homonyms lbl label_env with + | bind_with :: _ -> Label.bind_local ~bind_with lbl + | _ -> failwith ("The local label " ^ Label.show lbl ^ " is not bound") method! bindingnode = function | FreshLabel (labels, decls) -> diff --git a/core/label.ml b/core/label.ml index f3d7bef94..69a30ec58 100644 --- a/core/label.ml +++ b/core/label.ml @@ -165,11 +165,12 @@ let label_to_string_set m = (fun k m -> Utility.StringSet.add (Label.name k) m) m Utility.StringSet.empty - module Env = struct module M = Utility.StringMap - type t = (Label.t list) M.t + type t = (label list) M.t + + let pp = M.pp (Format.pp_print_list Label.pp) let empty = M.empty diff --git a/core/label.mli b/core/label.mli index 61de4b706..f3fd46d35 100644 --- a/core/label.mli +++ b/core/label.mli @@ -6,19 +6,15 @@ end type local = Name.t * Uid.t type global = Name.t -(* type unresolved = Name.t *) type t = - | Lcl of local - | Gbl of global - (* | Unr of unresolved *) -(* type t = string *) - [@@deriving show] + | Lcl of local + | Gbl of global + [@@deriving show] type label = t val mk_local : Name.t -> t val mk_global : Name.t -> t -(* val mk_unresolved : Name.t -> t *) val make : ?local:bool -> Name.t -> t val mk_int : Int.t -> t @@ -33,7 +29,6 @@ val name_is : t -> Name.t -> bool val is_local : t -> bool val is_global : t -> bool val is_free : t -> bool -(* val is_resolved : t -> bool *) val uid : t -> Uid.t val bind_local : ?bind_with:t -> t -> t @@ -43,9 +38,6 @@ val one : t val two : t val return : t -(* val resolve_local : t -> t *) -(* val resolve_global : t -> t *) - module type LABELMAP = Utility.Map with type key = t module Map : LABELMAP @@ -59,9 +51,9 @@ val string_to_label_set : Utility.StringSet.t -> Set.t val label_to_string_set : Set.t -> Utility.StringSet.t module Env : sig - module M = Utility.StringMap + type t - type t = (label list) M.t + val pp : Format.formatter -> t -> unit val empty : t diff --git a/core/lib.ml b/core/lib.ml index 7df8d0762..b0e880674 100644 --- a/core/lib.ml +++ b/core/lib.ml @@ -1726,6 +1726,7 @@ let type_env : Types.environment = let typing_env = {Types.var_env = type_env; Types.rec_vars = StringSet.empty; tycon_env = alias_env; + label_env = Label.Env.empty; Types.effect_row = Types.closed_wild_row; Types.desugared = false } diff --git a/core/typeSugar.ml b/core/typeSugar.ml index 8f9c75f0e..01cbae403 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -1652,6 +1652,9 @@ type context = Types.typing_environment = { and "Formlet". *) tycon_env : Types.tycon_environment; + (* local labels *) + label_env : Label.Env.t; + (* the current effects *) effect_row : Types.row; @@ -1664,21 +1667,19 @@ let empty_context eff desugared = { var_env = Env.empty; rec_vars = StringSet.empty; tycon_env = Env.empty; + label_env = Label.Env.empty; effect_row = eff; desugared } let bind_var context (v, t) = {context with var_env = Env.bind v t context.var_env} let unbind_var context v = {context with var_env = Env.unbind v context.var_env} let bind_alias context (v, t) = {context with tycon_env = Env.bind v t context.tycon_env} -let unbind_alias context v = {context with tycon_env = Env.unbind v context.tycon_env} +(* let unbind_alias context v = {context with tycon_env = Env.unbind v context.tycon_env} *) +let bind_labels context ls = {context with label_env = Label.Env.bind_labels ls context.label_env} +let unbind_labels context ls = {context with label_env = Label.Env.unbind_labels ls context.label_env} let bind_effects context r = {context with effect_row = r} -let extend context context' = (* this might not be super smart *) - { var_env = Env.extend context.var_env context'.var_env ; - rec_vars = StringSet.union context.rec_vars context'.rec_vars; - tycon_env = Env.extend context.tycon_env context'.tycon_env ; - effect_row = context.effect_row ; - desugared = context.desugared && context'.desugared } +let extend = Types.extend_typing_environment (* TODO(dhil): I have extracted the Usage abstraction from my name hygiene/compilation unit patch. The below module is a compatibility @@ -2542,24 +2543,27 @@ let resolve_type_annotation : Binder.with_pos -> Sugartypes.datatype' option -> with sufficiently effect-polymorphic operations). *) -(* erase the erasable occurences of local labels from the types in the context *) -(* and remove the bindings with non erasable occurences of local labels *) -exception CannotErase +(** erase the erasable occurences of local labels from the types in the context *) +(** and remove the bindings with non erasable occurences of local labels *) -(* remember which points are erased in order not to loop *) -let erased_points = ref [] -let push_erased_point x = erased_points := x :: !erased_points -let is_erased_point x = List.filter (Unionfind.equivalent x) !erased_points <> [] +(* remember which points are visited in order not to loop *) +class visit_points = object + val points : Types.datatype Unionfind.point list ref = ref [] + method visit x = points := x :: !points + method visited x = List.filter (Unionfind.equivalent x) !points <> [] +end let erase_local_labels_from_type ?(exact=true) pos labels dt = + let exception CannotErase in let open Types in + let erased_points = new visit_points in let rec e dt = let e_arg (pk, t) = (pk, e t) in let e_args = List.map e_arg in let e_point p = - if is_erased_point p then p + if erased_points#visited p then p else begin - push_erased_point p ; + erased_points#visit p ; let t = Unionfind.find p in Unionfind.change p (e t) ; p @@ -2581,11 +2585,10 @@ let erase_local_labels_from_type ?(exact=true) pos labels dt = if Label.is_global k then keep () else if to_remove k then - let _ = match v with - | Absent | Present (Var _) -> () - | Meta p when (match Unionfind.find p with Var _ -> true | _ -> false) -> () + match v with + | Absent | Present (Var _) -> remove () + | Meta p when (match Unionfind.find p with Var _ -> true | _ -> false) -> remove () | _ -> raise CannotErase - in remove () else if is_shadowed k then Gripers.die pos ("Label " ^ Label.show k ^ " is shadowed in this scope") else @@ -2612,42 +2615,23 @@ let erase_local_labels_from_type ?(exact=true) pos labels dt = | Dual t -> Dual (e t) | _ -> dt in - e dt - -let erase_local_labels_from_tycon ?(exact=true) pos labels tycon = - match tycon with - | `Alias (pk, vars, dt) -> - let dt = erase_local_labels_from_type ~exact pos labels dt in - `Alias (pk, vars, dt) - | `Abstract abs -> `Abstract abs - | `Mutual (qs, tygroup) -> - let open Utility.StringMap in - let open Types in - tygroup := { !tygroup with - type_map = fold (fun k (qs,v) m -> - try - let v = erase_local_labels_from_type ~exact pos labels v in - add k (qs,v) m - with CannotErase -> m - ) !tygroup.type_map empty - } ; - `Mutual (qs, tygroup) - -let rec erase_local_labels pos labels decls ctx = - let erase_binder binder ctx = + try Some (e dt) + with CannotErase -> None + +let rec erase_local_labels labels decls ctx = + let erase_binder pos binder ctx = let name = Binder.to_name binder in - try - let t = Env.find name ctx.var_env in - let t = erase_local_labels_from_type pos labels t in - bind_var ctx (name, t) - with CannotErase -> unbind_var ctx name - | NotFound _ -> ctx + let t' = Env.find_opt name ctx.var_env in + match OptionUtils.opt_bind (erase_local_labels_from_type pos labels) t' with + | Some t -> bind_var ctx (name, t) + | None -> unbind_var ctx name in let rec erase_pat pat ctx = let e = erase_pat in let e_list ps ctx = List.fold_left (fun ctx p -> e p ctx) ctx ps in let e_opt p_opt ctx = match p_opt with None -> ctx | Some p -> e p ctx in let open Pattern in + let pos = WithPos.pos pat in match WithPos.node pat with | Cons (p,p') -> ctx |> e p |> e p' | List ps -> ctx |> e_list ps @@ -2655,26 +2639,22 @@ let rec erase_local_labels pos labels decls ctx = | Effect (_, ps, p) -> ctx |> e_list ps |> e p | Record (lps, p_opt) -> ctx |> e_list (snd (List.split lps)) |> e_opt p_opt | Tuple ps -> ctx |> e_list ps - | Variable b -> ctx |> erase_binder b - | As (b, p) -> ctx |> erase_binder b |> e p + | Variable b -> ctx |> erase_binder pos b + | As (b, p) -> ctx |> erase_binder pos b |> e p | HasType (p,_) -> ctx |> e p | _ -> ctx in - List.fold_left (fun ctx d -> match WithPos.node d with - | Fun { fun_binder ; _ } -> erase_binder fun_binder ctx + List.fold_left (fun ctx d -> + let pos = WithPos.pos d in + match WithPos.node d with + | Fun { fun_binder ; _ } -> erase_binder pos fun_binder ctx | Funs rfuns -> List.fold_left (fun ctx rfun -> - erase_binder (WithPos.node rfun).rec_binder ctx + erase_binder (WithPos.pos rfun) (WithPos.node rfun).rec_binder ctx ) ctx rfuns - | Aliases ts -> List.fold_left (fun ctx { node=(name, _, _); _} -> - try - let tycon = erase_local_labels_from_tycon pos labels (Env.find name ctx.tycon_env) in - bind_alias ctx (name, tycon) - with CannotErase -> unbind_alias ctx name - | NotFound _ -> ctx - ) ctx ts | Val (pat, _, _, _) -> erase_pat pat ctx - | FreshLabel (_, decls') -> erase_local_labels pos labels decls' ctx + | FreshLabel (_, decls') -> erase_local_labels labels decls' ctx + | Aliases _ | Infix _ | Exp _ | Foreign _ -> ctx @@ -2684,10 +2664,9 @@ let rec erase_local_labels pos labels decls ctx = | AlienBlock _ -> assert false ) ctx decls -let check_tycon pos dt ctx = - let checked_points = ref [] in - let push_checked_point x = checked_points := x :: !checked_points in - let is_checked_point x = List.filter (Unionfind.equivalent x) !checked_points <> [] in +(** Check if all local labels in that type are bound and not shadowed **) +let check_labels pos dt ctx = + let checked_points = new visit_points in let open Types in let rec ct dt = let ct_name name = @@ -2695,13 +2674,26 @@ let check_tycon pos dt ctx = let ct_arg (_, t) = ct t in let ct_args = List.iter ct_arg in let ct_point p = - if not (is_checked_point p) then begin - push_checked_point p ; + if not (checked_points#visited p) then begin + checked_points#visit p ; ct (Unionfind.find p) end in match dt with - | Row (fields, rv, _) -> Label.Map.iter (fun _ v -> ct v) fields ; ct_point rv + | Row (fields, rv, _) -> + Label.Map.iter (fun k v -> + let ok () = () in + let unbound () = (*Gripers.die pos ("The local label " ^ Label.show k ^ " is not bound") *) assert false in + let shadowed () = Gripers.die pos ("Label " ^ Label.show k ^ " is shadowed in this scope") in + if Label.is_global k then ok () + else + match Label.Env.find_homonyms k ctx.label_env with + | [] -> unbound () + | k' :: _ when Label.eq k k' -> ok () + | _ -> ignore (shadowed ()) (* without the ignore we get a warning ?? *) + ; ct v + ) fields ; + ct_point rv | Alias (_, (name, _, targs, _) , t) -> ct_name name ; ct_args targs ; ct t | Application (abs, targs) -> ct_name (Abstype.name abs) ; ct_args targs | RecursiveApplication { r_name ; r_args ; _ } -> ct_name r_name ; ct_args r_args @@ -4609,7 +4601,7 @@ and type_binding : context -> binding -> binding * context * Usage.t = let bt = match datatype with | Some (_, Some t) -> - let _ = check_tycon pos t context in + let _ = check_labels pos t context in unify pos ~handle:Gripers.bind_val_annotation (no_pos (typ body), no_pos t); t | _ -> typ body in @@ -4665,7 +4657,7 @@ and type_binding : context -> binding -> binding * context * Usage.t = | Some ft -> (* Debug.print ("t: " ^ Types.string_of_datatype ft); *) (* make sure the annotation has the right shape *) - let _ = check_tycon pos ft context in + let _ = check_labels pos ft context in let shape = make_ft lin pats effects return_type in let quantifiers, ft_mono = TypeUtils.split_quantified_type ft in @@ -4845,7 +4837,7 @@ and type_binding : context -> binding -> binding * context * Usage.t = make_ft_poly_curry lin pats (fresh_tame ()) (Types.fresh_type_variable (lin_any, res_any)) | Some t -> (* Debug.print ("t: " ^ Types.string_of_datatype t); *) - let _ = check_tycon pos t context in + let _ = check_labels pos t context in let shape = make_ft lin pats (fresh_tame ()) (Types.fresh_type_variable (lin_any, res_any)) in let ft = match t with | T.ForAll _ -> t @@ -5037,7 +5029,7 @@ and type_binding : context -> binding -> binding * context * Usage.t = ignore (if String.contains (Binder.to_name binder) '\'' then raise (Errors.prime_alien pos)); (* Ensure that we quantify FTVs *) - let _ = check_tycon pos datatype context in + let _ = check_labels pos datatype context in let (_tyvars, _args), datatype = Utils.generalise context.var_env datatype in let datatype = Instantiate.freshen_quantifiers datatype in let binder = Binder.set_type binder datatype in @@ -5048,10 +5040,10 @@ and type_binding : context -> binding -> binding * context * Usage.t = let env = List.fold_left (fun env {node=(name, vars, b); _} -> match b with | Typename (_, Some dt) -> - let _ = check_tycon pos dt context in + let _ = check_labels pos dt context in bind_alias env (name, `Alias (pk_type, List.map (SugarQuantifier.get_resolved_exn) vars, dt)) | Effectname (_, Some dt) -> - let _ = check_tycon pos dt context in + let _ = check_labels pos dt context in bind_alias env (name, `Alias (pk_row , List.map (SugarQuantifier.get_resolved_exn) vars, dt)) | _ -> raise (internal_error "unannotated type") ) empty_context ts in @@ -5065,20 +5057,19 @@ and type_binding : context -> binding -> binding * context * Usage.t = | FreshLabel(labels, decls) -> let context = { context with var_env = Env.fold (fun k v env -> - try Env.bind k (erase_local_labels_from_type ~exact:false pos labels v) env - with CannotErase -> env - ) context.var_env Env.empty ; - tycon_env = Env.fold (fun k v env -> - try Env.bind k (erase_local_labels_from_tycon ~exact:false pos labels v) env - with CannotErase -> env - ) context.tycon_env Env.empty + match erase_local_labels_from_type ~exact:false pos labels v with + | Some v -> Env.bind k v env + | None -> env + ) context.var_env Env.empty } in - let ctx, decls = List.fold_left_map + let context = bind_labels context labels in + let context, decls = List.fold_left_map (fun ctx d -> let d, ctx', _ = type_binding ctx d in extend ctx ctx', d ) context decls in - let context = erase_local_labels pos labels decls ctx in + let context = erase_local_labels labels decls context in + let context = unbind_labels context labels in (FreshLabel(labels, decls), context, Usage.empty) | Import _ | Open _ diff --git a/core/types.ml b/core/types.ml index 15123e60d..a9d793dd0 100644 --- a/core/types.ml +++ b/core/types.ml @@ -4214,6 +4214,7 @@ type tycon_environment = tycon_spec Env.t type typing_environment = { var_env : environment ; rec_vars : StringSet.t ; tycon_env : tycon_environment ; + label_env : Label.Env.t; effect_row : row; desugared : bool } [@@deriving show] @@ -4221,6 +4222,7 @@ type typing_environment = { var_env : environment ; let empty_typing_environment = { var_env = Env.empty; rec_vars = StringSet.empty; tycon_env = Env.empty; + label_env = Label.Env.empty; effect_row = make_empty_closed_row (); desugared = false } @@ -4347,11 +4349,12 @@ let normalise_typing_environment env = (* Functions on environments *) let extend_typing_environment - {var_env = l; rec_vars = lvars; tycon_env = al; effect_row = _; desugared = _; } - {var_env = r; rec_vars = rvars; tycon_env = ar; effect_row = er; desugared = dr } : typing_environment = + {var_env = l; rec_vars = lvars; tycon_env = al; label_env = ll; effect_row = _; desugared = _; } + {var_env = r; rec_vars = rvars; tycon_env = ar; label_env = lr; effect_row = er; desugared = dr } : typing_environment = { var_env = Env.extend l r ; rec_vars = StringSet.union lvars rvars ; tycon_env = Env.extend al ar + ; label_env = Label.Env.extend ll lr ; effect_row = er ; desugared = dr } diff --git a/core/types.mli b/core/types.mli index 38d06066d..00f3bd8d7 100644 --- a/core/types.mli +++ b/core/types.mli @@ -171,7 +171,6 @@ and meta_presence_var = typ point and row = typ and row' = field_spec_map * row_var * bool and row_var = meta_row_var -[@@deriving show] val is_type_body : typ -> bool val is_row_body : row -> bool @@ -221,6 +220,7 @@ type tycon_environment = tycon_spec Env.String.t type typing_environment = { var_env : environment ; rec_vars : Utility.StringSet.t ; tycon_env : tycon_environment ; + label_env : Label.Env.t; effect_row : row ; desugared : bool } diff --git a/tests/labels/nested-names.links b/tests/labels/nested-names.links new file mode 100644 index 000000000..9e2425b64 --- /dev/null +++ b/tests/labels/nested-names.links @@ -0,0 +1,17 @@ +fresh `A, `B { + + effectname E = { `A:() {}-> Int } ; + typename T = () {`B:Bool | E}-> Bool ; + + sig f : T + fun f () { do `B && (do `A > 42) } + + fresh `A { + + sig f' : () -E-> Bool + fun f' () { (do `A > 42) } + + + } + +} From 99c0878dcbba6f33b9a54233f09485083e343fd3 Mon Sep 17 00:00:00 2001 From: RJ Date: Fri, 24 Jun 2022 15:22:59 +0100 Subject: [PATCH 44/63] remove wrong UnboundTyCon error --- core/typeSugar.ml | 8 +++----- tests/labels/nested-names.links | 2 +- 2 files changed, 4 insertions(+), 6 deletions(-) diff --git a/core/typeSugar.ml b/core/typeSugar.ml index 01cbae403..964a3e312 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -2669,8 +2669,6 @@ let check_labels pos dt ctx = let checked_points = new visit_points in let open Types in let rec ct dt = - let ct_name name = - if not (Env.has name ctx.tycon_env) then raise (Errors.UnboundTyCon (pos, name)) in let ct_arg (_, t) = ct t in let ct_args = List.iter ct_arg in let ct_point p = @@ -2694,9 +2692,9 @@ let check_labels pos dt ctx = ; ct v ) fields ; ct_point rv - | Alias (_, (name, _, targs, _) , t) -> ct_name name ; ct_args targs ; ct t - | Application (abs, targs) -> ct_name (Abstype.name abs) ; ct_args targs - | RecursiveApplication { r_name ; r_args ; _ } -> ct_name r_name ; ct_args r_args + | Alias (_, (_, _, targs, _) , t) -> ct_args targs ; ct t + | Application (_, targs) -> ct_args targs + | RecursiveApplication { r_args ; _ } -> ct_args r_args | Meta p -> ct_point p | Recursive (_, _, t) | Record t diff --git a/tests/labels/nested-names.links b/tests/labels/nested-names.links index 9e2425b64..8d4131dd2 100644 --- a/tests/labels/nested-names.links +++ b/tests/labels/nested-names.links @@ -8,7 +8,7 @@ fresh `A, `B { fresh `A { - sig f' : () -E-> Bool + sig f' : T fun f' () { (do `A > 42) } From 6d907e769c1016ea6821338b393176f815daeaa5 Mon Sep 17 00:00:00 2001 From: RJ Date: Fri, 24 Jun 2022 15:35:20 +0100 Subject: [PATCH 45/63] default arg in repl --- core/parser.mly | 1 + 1 file changed, 1 insertion(+) diff --git a/core/parser.mly b/core/parser.mly index 1d923d458..5d0a0cd5b 100644 --- a/core/parser.mly +++ b/core/parser.mly @@ -416,6 +416,7 @@ arg: | UFLOAT { string_of_float' $1 } | TRUE { "true" } | FALSE { "false" } +| DEFAULT { "default" } var: | VARIABLE { with_pos $loc $1 } From 82641fc193048afd3a7ea7a584fbee63bd65e083 Mon Sep 17 00:00:00 2001 From: RJ Date: Fri, 24 Jun 2022 17:32:55 +0100 Subject: [PATCH 46/63] alias stuff + context management --- core/typeSugar.ml | 58 ++++++++++++++++++++++++++------- tests/labels/nested-names.links | 4 ++- 2 files changed, 49 insertions(+), 13 deletions(-) diff --git a/core/typeSugar.ml b/core/typeSugar.ml index 964a3e312..30b935ebf 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -1674,9 +1674,9 @@ let empty_context eff desugared = let bind_var context (v, t) = {context with var_env = Env.bind v t context.var_env} let unbind_var context v = {context with var_env = Env.unbind v context.var_env} let bind_alias context (v, t) = {context with tycon_env = Env.bind v t context.tycon_env} -(* let unbind_alias context v = {context with tycon_env = Env.unbind v context.tycon_env} *) +let unbind_alias context v = {context with tycon_env = Env.unbind v context.tycon_env} let bind_labels context ls = {context with label_env = Label.Env.bind_labels ls context.label_env} -let unbind_labels context ls = {context with label_env = Label.Env.unbind_labels ls context.label_env} +(* let unbind_labels context ls = {context with label_env = Label.Env.unbind_labels ls context.label_env} *) let bind_effects context r = {context with effect_row = r} let extend = Types.extend_typing_environment @@ -2618,6 +2618,26 @@ let erase_local_labels_from_type ?(exact=true) pos labels dt = try Some (e dt) with CannotErase -> None +let erase_local_labels_from_tycon ?(exact=true) pos labels tycon = + match tycon with + | `Alias (pk, vars, dt) -> + begin match erase_local_labels_from_type ~exact pos labels dt with + | Some dt -> Some (`Alias (pk, vars, dt)) + | None -> None + end + | `Abstract abs -> Some (`Abstract abs) + | `Mutual (qs, tygroup) -> + let open Utility.StringMap in + let open Types in + tygroup := { !tygroup with + type_map = fold (fun k (qs,v) m -> + match erase_local_labels_from_type ~exact pos labels v with + | Some v -> add k (qs,v) m + | None -> m + ) !tygroup.type_map empty + } ; + Some (`Mutual (qs, tygroup)) + let rec erase_local_labels labels decls ctx = let erase_binder pos binder ctx = let name = Binder.to_name binder in @@ -2626,6 +2646,12 @@ let rec erase_local_labels labels decls ctx = | Some t -> bind_var ctx (name, t) | None -> unbind_var ctx name in + let erase_alias pos name ctx = + let tycon' = Env.find_opt name ctx.tycon_env in + match OptionUtils.opt_bind (erase_local_labels_from_tycon pos labels) tycon' with + | Some tycon -> bind_alias ctx (name, tycon) + | None -> unbind_alias ctx name + in let rec erase_pat pat ctx = let e = erase_pat in let e_list ps ctx = List.fold_left (fun ctx p -> e p ctx) ctx ps in @@ -2654,7 +2680,7 @@ let rec erase_local_labels labels decls ctx = ) ctx rfuns | Val (pat, _, _, _) -> erase_pat pat ctx | FreshLabel (_, decls') -> erase_local_labels labels decls' ctx - | Aliases _ + | Aliases ts -> List.fold_left (fun ctx { node=(name, _, _); _} -> erase_alias pos name ctx) ctx ts | Infix _ | Exp _ | Foreign _ -> ctx @@ -2677,11 +2703,14 @@ let check_labels pos dt ctx = ct (Unionfind.find p) end in + let ct_name name = + if not (Env.has name ctx.tycon_env) then raise (Errors.UnboundTyCon (pos, name)) + in match dt with | Row (fields, rv, _) -> Label.Map.iter (fun k v -> let ok () = () in - let unbound () = (*Gripers.die pos ("The local label " ^ Label.show k ^ " is not bound") *) assert false in + let unbound () = Gripers.die pos ("The local label " ^ Label.show k ^ " is not bound") in (* could happen since effectnames are inlined before typecheck *) let shadowed () = Gripers.die pos ("Label " ^ Label.show k ^ " is shadowed in this scope") in if Label.is_global k then ok () else @@ -2692,7 +2721,7 @@ let check_labels pos dt ctx = ; ct v ) fields ; ct_point rv - | Alias (_, (_, _, targs, _) , t) -> ct_args targs ; ct t + | Alias (_, (name, _, targs, _) , t) -> ct_name name ; ct_args targs ; ct t | Application (_, targs) -> ct_args targs | RecursiveApplication { r_args ; _ } -> ct_args r_args | Meta p -> ct_point p @@ -5058,16 +5087,21 @@ and type_binding : context -> binding -> binding * context * Usage.t = match erase_local_labels_from_type ~exact:false pos labels v with | Some v -> Env.bind k v env | None -> env - ) context.var_env Env.empty + ) context.var_env Env.empty ; + tycon_env = Env.fold (fun k v env -> + match erase_local_labels_from_tycon ~exact:false pos labels v with + | Some v -> Env.bind k v env + | None -> env + ) context.tycon_env Env.empty } in let context = bind_labels context labels in - let context, decls = List.fold_left_map - (fun ctx d -> - let d, ctx', _ = type_binding ctx d in - extend ctx ctx', d - ) context decls in + let (context,_), decls = List.fold_left_map + (fun (ctx, loc_ctx) d -> + let d, ctx', _ = type_binding loc_ctx d in + (extend ctx ctx', extend loc_ctx ctx'), d + ) (empty_context, context) decls in let context = erase_local_labels labels decls context in - let context = unbind_labels context labels in + (* let context = unbind_labels context labels in *) (FreshLabel(labels, decls), context, Usage.empty) | Import _ | Open _ diff --git a/tests/labels/nested-names.links b/tests/labels/nested-names.links index 8d4131dd2..e09075852 100644 --- a/tests/labels/nested-names.links +++ b/tests/labels/nested-names.links @@ -9,7 +9,9 @@ fresh `A, `B { fresh `A { sig f' : T - fun f' () { (do `A > 42) } + fun f' () { + do `A > 42 + } } From b9e25e68855223f9b12113ce65e958da1e96db87 Mon Sep 17 00:00:00 2001 From: RJ Date: Mon, 27 Jun 2022 14:23:40 +0100 Subject: [PATCH 47/63] wip --- core/desugarEffects.ml | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/core/desugarEffects.ml b/core/desugarEffects.ml index ce948024e..813abd2b8 100644 --- a/core/desugarEffects.ml +++ b/core/desugarEffects.ml @@ -356,7 +356,8 @@ let cleanup_effects tycon_env = method effect_row ~allow_shared (fields, var) = let open Datatype in - let open SourceCode.WithPos in + let open SourceCode in + let open WithPos in let fields = List.map (function @@ -373,15 +374,17 @@ let cleanup_effects tycon_env = (* might need an extra check on recursive rows *) ( name, Present - (SourceCode.WithPos.make ~pos + (WithPos.make ~pos (Function (domain, ([], Closed), codomain))) ) | _, _ -> raise (unexpected_effects_on_abstract_op pos name) ) - | name, Present node when not (TypeUtils.is_builtin_effect name) -> + | name, Present ({ node ; pos } as node') when not (TypeUtils.is_builtin_effect name) -> (* Elaborates `Op : a' to `Op : () {}-> a' *) + let node = match node with + | Forall (qs, node') -> Forall (qs, WithPos.make ~pos (Function ([], ([], Closed), node'))) + | _ -> Function ([], ([], Closed), node') + in ( name, - Present - (SourceCode.WithPos.make ~pos:node.pos - (Function ([], ([], Closed), node))) ) + Present (WithPos.make ~pos node) ) | x -> x) fields in From 38f7f3e6ad68090df4268efd6129e6330153c168 Mon Sep 17 00:00:00 2001 From: RJ Date: Mon, 27 Jun 2022 17:12:34 +0100 Subject: [PATCH 48/63] fold_left_map in ListUtils (not in Ocaml < 4.11) --- core/transformSugar.ml | 2 +- core/typeSugar.ml | 2 +- core/utility.ml | 8 ++++++++ 3 files changed, 10 insertions(+), 2 deletions(-) diff --git a/core/transformSugar.ml b/core/transformSugar.ml index 793316712..d1a0225f4 100644 --- a/core/transformSugar.ml +++ b/core/transformSugar.ml @@ -907,7 +907,7 @@ class transform (env : Types.typing_environment) = | Exp e -> let (o, e, _) = o#phrase e in (o, Exp e) | FreshLabel(labels, decls) -> (* do we wanna do something with labels ? *) - let o, decls = List.fold_left_map + let o, decls = ListUtils.fold_left_map (fun o d -> o#binding d) o decls in (o, FreshLabel(labels, decls)) | AlienBlock _ -> assert false diff --git a/core/typeSugar.ml b/core/typeSugar.ml index 30b935ebf..fd6f79c67 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -5095,7 +5095,7 @@ and type_binding : context -> binding -> binding * context * Usage.t = ) context.tycon_env Env.empty } in let context = bind_labels context labels in - let (context,_), decls = List.fold_left_map + let (context,_), decls = ListUtils.fold_left_map (fun (ctx, loc_ctx) d -> let d, ctx', _ = type_binding loc_ctx d in (extend ctx ctx', extend loc_ctx ctx'), d diff --git a/core/utility.ml b/core/utility.ml index 072d3e7a4..707bfbfde 100644 --- a/core/utility.ml +++ b/core/utility.ml @@ -600,6 +600,14 @@ struct | [] :: xss -> transpose xss | (x :: xs) :: xss -> (x :: (List.map List.hd xss)) :: transpose (xs :: List.map List.tl xss) + + let fold_left_map f accu l = + let rec aux accu l_accu = function + | [] -> accu, List.rev l_accu + | x :: l -> + let accu, x = f accu x in + aux accu (x :: l_accu) l in + aux accu [] l end include ListUtils From 6a5e7da0aa97e7dc6cc5aae1c05c91df8f347f46 Mon Sep 17 00:00:00 2001 From: RJ Date: Mon, 27 Jun 2022 17:37:47 +0100 Subject: [PATCH 49/63] fix in test --- tests/unit/ir/schinks.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/unit/ir/schinks.ml b/tests/unit/ir/schinks.ml index 376186879..306113062 100644 --- a/tests/unit/ir/schinks.ml +++ b/tests/unit/ir/schinks.ml @@ -195,7 +195,7 @@ let ( |--> ) = fun_ct let wild_fun_ct parameters codomain = let effects = State.return - (Types.make_singleton_closed_row ("wild", Types.Present Types.unit_type)) + (Types.make_singleton_closed_row (Types.wild, Types.Present Types.unit_type)) |> State.return in fun_t ~effects parameters codomain From 310ebb4b2ea654dc7217fdb3205ed928b7d696a3 Mon Sep 17 00:00:00 2001 From: RJ Date: Mon, 27 Jun 2022 18:10:09 +0100 Subject: [PATCH 50/63] fixes rule-check ocamlformat --- core/lens_ir_conv.ml | 4 +++- core/lens_type_conv.ml | 1 - tests/unit/ir/schinks.ml | 3 ++- tests/unit/lens/unitTestsLensPrimitives.ml | 18 ++++++++++++------ 4 files changed, 17 insertions(+), 9 deletions(-) diff --git a/core/lens_ir_conv.ml b/core/lens_ir_conv.ml index 7e6c09a60..13c3e6743 100644 --- a/core/lens_ir_conv.ml +++ b/core/lens_ir_conv.ml @@ -348,7 +348,9 @@ let lens_sugar_phrase_of_ir p env = | I.Extend (ext_fields, r) -> let r = Option.map ~f:(links_value env) r in Option.value r ~default:(`Record [] |> Result.return) >>= fun r -> - let fields = StringMap.to_alist (Label.label_to_string_map ext_fields) in + let fields = + StringMap.to_alist (Label.label_to_string_map ext_fields) + in List.map_result ~f:(fun (k, v) -> links_value env v >>| fun v -> (k, v)) fields diff --git a/core/lens_type_conv.ml b/core/lens_type_conv.ml index c9ff1f251..95968dc24 100644 --- a/core/lens_type_conv.ml +++ b/core/lens_type_conv.ml @@ -16,7 +16,6 @@ let to_string_map m = (fun k v m -> String.Map.add (Label.name k) v m) m String.Map.empty - let lookup_alias context ~alias = match Env.String.find_opt alias context with | Some (`Alias (k, _, body)) -> diff --git a/tests/unit/ir/schinks.ml b/tests/unit/ir/schinks.ml index 306113062..02339942e 100644 --- a/tests/unit/ir/schinks.ml +++ b/tests/unit/ir/schinks.ml @@ -195,7 +195,8 @@ let ( |--> ) = fun_ct let wild_fun_ct parameters codomain = let effects = State.return - (Types.make_singleton_closed_row (Types.wild, Types.Present Types.unit_type)) + (Types.make_singleton_closed_row + (Types.wild, Types.Present Types.unit_type)) |> State.return in fun_t ~effects parameters codomain diff --git a/tests/unit/lens/unitTestsLensPrimitives.ml b/tests/unit/lens/unitTestsLensPrimitives.ml index 003c59a69..1a032b47d 100644 --- a/tests/unit/lens/unitTestsLensPrimitives.ml +++ b/tests/unit/lens/unitTestsLensPrimitives.ml @@ -189,7 +189,8 @@ let test_select_lens_2 n test_ctx = in let l2 = H.drop_create_populate_table test_ctx db "t2" "b -> d" "b d" - [ `Seq; `RandTo upto ] upto + [ `Seq; `RandTo upto ] + upto in let l3 = H.join_lens_dl l1 l2 [ ("b", "b", "b") ] in let l4 = @@ -217,7 +218,8 @@ let test_select_lens_3 n test_ctx = in let l2 = H.drop_create_populate_table test_ctx db "t2" "b -> d" "b d" - [ `Seq; `RandTo upto ] upto + [ `Seq; `RandTo upto ] + upto in let l3 = H.join_lens_dl l1 l2 [ ("b", "b", "b") ] in let l4 = @@ -253,7 +255,8 @@ let test_get_delta test_ctx = in let l2 = H.drop_create_populate_table test_ctx db "t2" "b -> d" "b d" - [ `Seq; `RandTo upto ] upto + [ `Seq; `RandTo upto ] + upto in let l3 = H.join_lens_dl l1 l2 [ ("b", "b", "b") ] in let res = @@ -363,7 +366,8 @@ let test_join_lens_1 n test_ctx = in let l2 = H.drop_create_populate_table test_ctx db "t2" "b -> d" "b d" - [ `Seq; `RandTo upto ] upto + [ `Seq; `RandTo upto ] + upto in let l3 = H.join_lens_dl l1 l2 [ ("b", "b", "b") ] in let res = @@ -397,7 +401,8 @@ let test_join_lens_2 n test_ctx = in let l2 = H.drop_create_populate_table test_ctx db "t2" "b -> d" "b d" - [ `Seq; `RandTo 40 ] upto + [ `Seq; `RandTo 40 ] + upto in let l3 = H.join_lens_dl l1 l2 [ ("b", "b", "b") ] in let res = @@ -429,7 +434,8 @@ let test_join_lens_dr_2 n test_ctx = in let l2 = H.drop_create_populate_table test_ctx db "t2" "b -> d" "b d" - [ `Seq; `RandTo 40 ] 50 + [ `Seq; `RandTo 40 ] + 50 in let l3 = H.join_lens_dr l1 l2 [ ("b", "b", "b") ] in let res = From 152b59afd434c9d3a41b1998f46388eade28d7e4 Mon Sep 17 00:00:00 2001 From: RJ Date: Mon, 27 Jun 2022 18:19:07 +0100 Subject: [PATCH 51/63] fixes rule-check ocamlformat bis --- tests/unit/lens/unitTestsLensPrimitives.ml | 18 ++++++------------ 1 file changed, 6 insertions(+), 12 deletions(-) diff --git a/tests/unit/lens/unitTestsLensPrimitives.ml b/tests/unit/lens/unitTestsLensPrimitives.ml index 1a032b47d..003c59a69 100644 --- a/tests/unit/lens/unitTestsLensPrimitives.ml +++ b/tests/unit/lens/unitTestsLensPrimitives.ml @@ -189,8 +189,7 @@ let test_select_lens_2 n test_ctx = in let l2 = H.drop_create_populate_table test_ctx db "t2" "b -> d" "b d" - [ `Seq; `RandTo upto ] - upto + [ `Seq; `RandTo upto ] upto in let l3 = H.join_lens_dl l1 l2 [ ("b", "b", "b") ] in let l4 = @@ -218,8 +217,7 @@ let test_select_lens_3 n test_ctx = in let l2 = H.drop_create_populate_table test_ctx db "t2" "b -> d" "b d" - [ `Seq; `RandTo upto ] - upto + [ `Seq; `RandTo upto ] upto in let l3 = H.join_lens_dl l1 l2 [ ("b", "b", "b") ] in let l4 = @@ -255,8 +253,7 @@ let test_get_delta test_ctx = in let l2 = H.drop_create_populate_table test_ctx db "t2" "b -> d" "b d" - [ `Seq; `RandTo upto ] - upto + [ `Seq; `RandTo upto ] upto in let l3 = H.join_lens_dl l1 l2 [ ("b", "b", "b") ] in let res = @@ -366,8 +363,7 @@ let test_join_lens_1 n test_ctx = in let l2 = H.drop_create_populate_table test_ctx db "t2" "b -> d" "b d" - [ `Seq; `RandTo upto ] - upto + [ `Seq; `RandTo upto ] upto in let l3 = H.join_lens_dl l1 l2 [ ("b", "b", "b") ] in let res = @@ -401,8 +397,7 @@ let test_join_lens_2 n test_ctx = in let l2 = H.drop_create_populate_table test_ctx db "t2" "b -> d" "b d" - [ `Seq; `RandTo 40 ] - upto + [ `Seq; `RandTo 40 ] upto in let l3 = H.join_lens_dl l1 l2 [ ("b", "b", "b") ] in let res = @@ -434,8 +429,7 @@ let test_join_lens_dr_2 n test_ctx = in let l2 = H.drop_create_populate_table test_ctx db "t2" "b -> d" "b d" - [ `Seq; `RandTo 40 ] - 50 + [ `Seq; `RandTo 40 ] 50 in let l3 = H.join_lens_dr l1 l2 [ ("b", "b", "b") ] in let res = From de0962635d334d24c8fe716a5e6754fca2e2f380 Mon Sep 17 00:00:00 2001 From: RJ Date: Mon, 27 Jun 2022 20:41:13 +0100 Subject: [PATCH 52/63] fix tests unit labels --- tests/unit/ir/schinks.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/unit/ir/schinks.ml b/tests/unit/ir/schinks.ml index 02339942e..f73b40964 100644 --- a/tests/unit/ir/schinks.ml +++ b/tests/unit/ir/schinks.ml @@ -211,7 +211,7 @@ let record_t ?row_var assoc = in check_assoc_list_for_duplicates assoc "record type"; helper_tuple1 assoc row_var (fun assoc row_var -> - let map = StringMap.from_alist assoc in + let map = Label.Map.from_alist assoc in Types.Record (Types.Row (map, row_var, false))) let variant ?row_var assoc = @@ -222,7 +222,7 @@ let variant ?row_var assoc = | None -> Unionfind.fresh Types.Closed |> State.return |> State.return in helper_tuple1 assoc row_var (fun assoc row_var -> - let map = StringMap.from_alist assoc in + let map = Label.Map.from_alist assoc in Types.Variant (Types.Row (map, row_var, false))) (* Rows *) From 667a8862303b21d048b6e6f11a39df03d123b3a2 Mon Sep 17 00:00:00 2001 From: RJ Date: Tue, 28 Jun 2022 10:32:12 +0100 Subject: [PATCH 53/63] fix Labels in tests --- tests/unit/ir/schinks.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/tests/unit/ir/schinks.ml b/tests/unit/ir/schinks.ml index f73b40964..a47272b32 100644 --- a/tests/unit/ir/schinks.ml +++ b/tests/unit/ir/schinks.ml @@ -29,8 +29,8 @@ let check_assoc_list_for_duplicates assoc description = let has_duplicates = List.fold_left (fun (seen, dupls) (key, _) -> - (StringSet.add key seen, dupls && StringSet.mem key seen)) - (StringSet.empty, [] <> assoc) + (Label.Set.add key seen, dupls && Label.Set.mem key seen)) + (Label.Set.empty, [] <> assoc) assoc |> snd in @@ -236,7 +236,7 @@ let row_var rv = let row assoc rv = let mk_row assoc rv = - let map = StringMap.from_alist assoc in + let map = Label.Map.from_alist assoc in Types.Row (map, rv, false) in check_assoc_list_for_duplicates assoc "row"; @@ -348,8 +348,8 @@ let build_record (extendee : Ir.value t option) let _, has_duplicates = List.fold_left (fun (seen, dupls) (key, _) -> - (StringSet.add key seen, dupls && StringSet.mem key seen)) - (StringSet.empty, [] <> assoc) + (Label.Set.add key seen, dupls && Label.Set.mem key seen)) + (Label.Set.empty, [] <> assoc) assoc in let stage2 (extendee : Ir.value lookup option) @@ -361,7 +361,7 @@ let build_record (extendee : Ir.value t option) (x, y)) assoc in - let map = StringMap.from_alist assoc in + let map = Label.Map.from_alist assoc in let finalize e = if has_duplicates then raise (SchinksError "Duplicate fields in record!") else Ir.Extend (map, e) @@ -443,7 +443,7 @@ let case (v : Ir.value t) ?(default : (Ir.binder t * Ir.computation t) option) let+ cases = State.List.map ~f:g cases in let assoc = List.map (fun (a, b, c) -> (a, (b, c))) cases in check_assoc_list_for_duplicates assoc "variants of case"; - let case_map = StringMap.from_alist assoc in + let case_map = Label.Map.from_alist assoc in Ir.Case (v, case_map, default) (* From 61ad66273310e0f7ea7a7a9d72e2c338c8ea5eeb Mon Sep 17 00:00:00 2001 From: RJ Date: Tue, 28 Jun 2022 11:03:24 +0100 Subject: [PATCH 54/63] fix Labels tests --- tests/unit/ir/schinks.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/tests/unit/ir/schinks.ml b/tests/unit/ir/schinks.ml index a47272b32..16cc6279f 100644 --- a/tests/unit/ir/schinks.ml +++ b/tests/unit/ir/schinks.ml @@ -344,7 +344,7 @@ let wi_binder ?(scope = Var.Scope.Local) id ty = stage2 let build_record (extendee : Ir.value t option) - (assoc : (string * Ir.value t) list) : Ir.value t = + (assoc : (Label.t * Ir.value t) list) : Ir.value t = let _, has_duplicates = List.fold_left (fun (seen, dupls) (key, _) -> @@ -353,7 +353,7 @@ let build_record (extendee : Ir.value t option) assoc in let stage2 (extendee : Ir.value lookup option) - (assoc : (string * Ir.value Repr.lookup) list) : Ir.value lookup = + (assoc : (Label.t * Ir.value Repr.lookup) list) : Ir.value lookup = let* assoc = State.List.map ~f:(fun (x, y) -> @@ -372,14 +372,14 @@ let build_record (extendee : Ir.value t option) let+ e = e in finalize (Some e) in - let assoc : (string * Ir.value lookup) list stage1 = + let assoc : (Label.t * Ir.value lookup) list stage1 = State.List.map ~f:(fun (x, y) -> let+ y = y in (x, y)) assoc in - let* (assoc : (string * Ir.value lookup) list) = assoc in + let* (assoc : (Label.t * Ir.value lookup) list) = assoc in match extendee with | Some (e : Ir.value t) -> let+ (e : Ir.value lookup) = e in @@ -423,7 +423,7 @@ let apply f args = stage2 let case (v : Ir.value t) ?(default : (Ir.binder t * Ir.computation t) option) - (cases : (string * Ir.binder t * Ir.computation t) list) : + (cases : (Label.t * Ir.binder t * Ir.computation t) list) : Ir.tail_computation t = let* v = v in let f (x, y) = From 589a7db63c87849bb80f9b2c0787514286e23ead Mon Sep 17 00:00:00 2001 From: RJ Date: Tue, 28 Jun 2022 11:28:54 +0100 Subject: [PATCH 55/63] fix labels tests --- tests/unit/ir/schinks.mli | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/tests/unit/ir/schinks.mli b/tests/unit/ir/schinks.mli index c60ba604e..a8f135da6 100644 --- a/tests/unit/ir/schinks.mli +++ b/tests/unit/ir/schinks.mli @@ -98,7 +98,7 @@ val closed : Types.row_var t val row_var : string -> Types.row_var t -val row : (string * Types.field_spec t) list -> Types.row_var t -> Types.row t +val row : (Label.t * Types.field_spec t) list -> Types.row_var t -> Types.row t (* Presence info *) @@ -120,10 +120,10 @@ val q_row : ?sk:CT.Subkind.t -> string -> CT.Quantifier.t t val wi_q : ?pk:CT.PrimaryKind.t -> ?sk:CT.Subkind.t -> int -> CT.Quantifier.t t val record_t : - ?row_var:Types.row_var t -> (string * Types.field_spec t) list -> Types.typ t + ?row_var:Types.row_var t -> (Label.t * Types.field_spec t) list -> Types.typ t val variant : - ?row_var:Types.row_var t -> (string * Types.t t) list -> Types.typ t + ?row_var:Types.row_var t -> (Label.t * Types.t t) list -> Types.typ t (** Lifts a type into t, marking all quantifiers and type variable ids therein as reserved. *) @@ -160,9 +160,9 @@ val wi_var : int -> Ir.value t val closure : string -> Ir.tyarg t list -> Ir.value t -> Ir.value t -val record : (string * Ir.value t) list -> Ir.value t +val record : (Label.t * Ir.value t) list -> Ir.value t -val extend_record : Ir.value t -> (string * Ir.value t) list -> Ir.value t +val extend_record : Ir.value t -> (Label.t * Ir.value t) list -> Ir.value t val unit : Ir.value t @@ -188,7 +188,7 @@ val apply : Ir.value t -> Ir.value t list -> Ir.tail_computation t val case : Ir.value t -> ?default:Ir.binder t * Ir.computation t -> - (string * Ir.binder t * Ir.computation t) list -> + (Label.t * Ir.binder t * Ir.computation t) list -> Ir.tail_computation t (* From 3ea8ddf98352baadba3e0673ec8eecdccfeebfe2 Mon Sep 17 00:00:00 2001 From: RJ Date: Tue, 28 Jun 2022 12:21:46 +0100 Subject: [PATCH 56/63] fix labels tests --- tests/unit/ir/schinks.ml | 9 +++++++-- tests/unit/ir/schinks.mli | 12 ++++++------ 2 files changed, 13 insertions(+), 8 deletions(-) diff --git a/tests/unit/ir/schinks.ml b/tests/unit/ir/schinks.ml index 16cc6279f..41ce1bb01 100644 --- a/tests/unit/ir/schinks.ml +++ b/tests/unit/ir/schinks.ml @@ -204,6 +204,7 @@ let wild_fun_ct parameters codomain = let ( |~~> ) = wild_fun_ct let record_t ?row_var assoc = + let assoc = List.map (fun (x,y) -> (Label.make x, y)) assoc in let row_var = match row_var with | Some rv -> rv @@ -215,6 +216,7 @@ let record_t ?row_var assoc = Types.Record (Types.Row (map, row_var, false))) let variant ?row_var assoc = + let assoc = List.map (fun (x,y) -> (Label.make x, y)) assoc in check_assoc_list_for_duplicates assoc "variant type"; let row_var = match row_var with @@ -235,6 +237,7 @@ let row_var rv = Unionfind.fresh (Types.Var (id, (CT.PrimaryKind.Row, sk), `Rigid)) let row assoc rv = + let assoc = List.map (fun (x,y) -> (Label.make x, y)) assoc in let mk_row assoc rv = let map = Label.Map.from_alist assoc in Types.Row (map, rv, false) @@ -344,7 +347,8 @@ let wi_binder ?(scope = Var.Scope.Local) id ty = stage2 let build_record (extendee : Ir.value t option) - (assoc : (Label.t * Ir.value t) list) : Ir.value t = + (assoc : (string * Ir.value t) list) : Ir.value t = + let assoc = List.map (fun (x,y) -> (Label.make x, y)) assoc in let _, has_duplicates = List.fold_left (fun (seen, dupls) (key, _) -> @@ -423,8 +427,9 @@ let apply f args = stage2 let case (v : Ir.value t) ?(default : (Ir.binder t * Ir.computation t) option) - (cases : (Label.t * Ir.binder t * Ir.computation t) list) : + (cases : (string * Ir.binder t * Ir.computation t) list) : Ir.tail_computation t = + let cases = List.map (fun (x,y,y) -> (Label.make x, y, z)) cases in let* v = v in let f (x, y) = let* x = x in diff --git a/tests/unit/ir/schinks.mli b/tests/unit/ir/schinks.mli index a8f135da6..c60ba604e 100644 --- a/tests/unit/ir/schinks.mli +++ b/tests/unit/ir/schinks.mli @@ -98,7 +98,7 @@ val closed : Types.row_var t val row_var : string -> Types.row_var t -val row : (Label.t * Types.field_spec t) list -> Types.row_var t -> Types.row t +val row : (string * Types.field_spec t) list -> Types.row_var t -> Types.row t (* Presence info *) @@ -120,10 +120,10 @@ val q_row : ?sk:CT.Subkind.t -> string -> CT.Quantifier.t t val wi_q : ?pk:CT.PrimaryKind.t -> ?sk:CT.Subkind.t -> int -> CT.Quantifier.t t val record_t : - ?row_var:Types.row_var t -> (Label.t * Types.field_spec t) list -> Types.typ t + ?row_var:Types.row_var t -> (string * Types.field_spec t) list -> Types.typ t val variant : - ?row_var:Types.row_var t -> (Label.t * Types.t t) list -> Types.typ t + ?row_var:Types.row_var t -> (string * Types.t t) list -> Types.typ t (** Lifts a type into t, marking all quantifiers and type variable ids therein as reserved. *) @@ -160,9 +160,9 @@ val wi_var : int -> Ir.value t val closure : string -> Ir.tyarg t list -> Ir.value t -> Ir.value t -val record : (Label.t * Ir.value t) list -> Ir.value t +val record : (string * Ir.value t) list -> Ir.value t -val extend_record : Ir.value t -> (Label.t * Ir.value t) list -> Ir.value t +val extend_record : Ir.value t -> (string * Ir.value t) list -> Ir.value t val unit : Ir.value t @@ -188,7 +188,7 @@ val apply : Ir.value t -> Ir.value t list -> Ir.tail_computation t val case : Ir.value t -> ?default:Ir.binder t * Ir.computation t -> - (Label.t * Ir.binder t * Ir.computation t) list -> + (string * Ir.binder t * Ir.computation t) list -> Ir.tail_computation t (* From ab3ab861cd013f6266bca63c68689159b1bf8219 Mon Sep 17 00:00:00 2001 From: RJ Date: Tue, 28 Jun 2022 12:32:52 +0100 Subject: [PATCH 57/63] fix labels tests --- tests/unit/ir/schinks.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/tests/unit/ir/schinks.ml b/tests/unit/ir/schinks.ml index 41ce1bb01..3dfe63355 100644 --- a/tests/unit/ir/schinks.ml +++ b/tests/unit/ir/schinks.ml @@ -204,7 +204,7 @@ let wild_fun_ct parameters codomain = let ( |~~> ) = wild_fun_ct let record_t ?row_var assoc = - let assoc = List.map (fun (x,y) -> (Label.make x, y)) assoc in + let assoc = List.map (fun (x, y) -> (Label.make x, y)) assoc in let row_var = match row_var with | Some rv -> rv @@ -216,7 +216,7 @@ let record_t ?row_var assoc = Types.Record (Types.Row (map, row_var, false))) let variant ?row_var assoc = - let assoc = List.map (fun (x,y) -> (Label.make x, y)) assoc in + let assoc = List.map (fun (x, y) -> (Label.make x, y)) assoc in check_assoc_list_for_duplicates assoc "variant type"; let row_var = match row_var with @@ -237,7 +237,7 @@ let row_var rv = Unionfind.fresh (Types.Var (id, (CT.PrimaryKind.Row, sk), `Rigid)) let row assoc rv = - let assoc = List.map (fun (x,y) -> (Label.make x, y)) assoc in + let assoc = List.map (fun (x, y) -> (Label.make x, y)) assoc in let mk_row assoc rv = let map = Label.Map.from_alist assoc in Types.Row (map, rv, false) @@ -348,7 +348,7 @@ let wi_binder ?(scope = Var.Scope.Local) id ty = let build_record (extendee : Ir.value t option) (assoc : (string * Ir.value t) list) : Ir.value t = - let assoc = List.map (fun (x,y) -> (Label.make x, y)) assoc in + let assoc = List.map (fun (x, y) -> (Label.make x, y)) assoc in let _, has_duplicates = List.fold_left (fun (seen, dupls) (key, _) -> @@ -429,7 +429,7 @@ let apply f args = let case (v : Ir.value t) ?(default : (Ir.binder t * Ir.computation t) option) (cases : (string * Ir.binder t * Ir.computation t) list) : Ir.tail_computation t = - let cases = List.map (fun (x,y,y) -> (Label.make x, y, z)) cases in + let cases = List.map (fun (x, y, z) -> (Label.make x, y, z)) cases in let* v = v in let f (x, y) = let* x = x in From 5e5dae651c0567a879a54f0eedcd2c3dda3bdb15 Mon Sep 17 00:00:00 2001 From: RJ Date: Fri, 22 Jul 2022 15:02:54 +0100 Subject: [PATCH 58/63] change pollution test --- tests/labels.tests | 2 +- tests/labels/pollution.links | 67 ++++++++++++++++++++++-------------- 2 files changed, 43 insertions(+), 26 deletions(-) diff --git a/tests/labels.tests b/tests/labels.tests index 245fe860a..6168bd75c 100644 --- a/tests/labels.tests +++ b/tests/labels.tests @@ -46,7 +46,7 @@ args : --enable-handlers Avoiding pollution [1] ./tests/labels/pollution.links filemode : true -stdout : (Just(42), Nothing, Just(-1)) : (Maybe (Int), Maybe (Int), Maybint) +stdout : (Just(42), Nothing, Just(-1)) : (Maybint, Maybint, Maybint) args : --enable-handlers Avoiding pollution [2] diff --git a/tests/labels/pollution.links b/tests/labels/pollution.links index d2967813b..572cebbe8 100644 --- a/tests/labels/pollution.links +++ b/tests/labels/pollution.links @@ -1,35 +1,52 @@ -fresh `Abort { +effectname A(e::Eff) = { Abort: () {}-> Zero | e } ; +fun aborting () { switch (do Abort) {} } - effectname A(e::Eff) = { `Abort: () {}-> Zero | e } ; - fun aborting () { switch (do `Abort) {} } +typename Maybint = Maybe(Int) ; - typename Maybint = Maybe(Int) ; +sig maybe : ( Comp(a, { |A({ |e})} ) ) -> Comp (Maybe(a), {Abort{_}|e}) +fun maybe (h) () { + handle (h()) { + case Return(x) -> Just(x) + case Abort(k) -> Nothing + } +} - sig maybe : ( Comp(a, { |A({ |e})} ) ) -> Comp (Maybe(a), {`Abort{_}|e}) - fun maybe (h) () { - handle (h()) { - case Return(x) -> Just(x) - case `Abort(k) -> Nothing +effectname R(s,e::Eff) = { Receive : () {} -> s | e } ; + +sig receives : ([s]) -> ( Comp(a, { |A({ |R(s, { |e})})}) ) -> Comp(a , {Receive{_}|A({ |e})}) +fun receives (ss) (h) () { + handle (h()) (ss<-ss) { + case Receive(k) -> switch (ss) { + case [] -> aborting() + case h::t -> k(h,t) } } +} - effectname R(s,e::Eff) = { Receive : () {} -> s | e } ; +fresh `Abort { - sig receives : ( Comp(a, { |A({ |R(s, { |e})})}) ) -> ([s]) -> Comp(a , {Receive{_}|A({ |e})}) - fun receives (h) (ss) () { - handle (h()) (ss<-ss) { - case Receive(k) -> switch (ss) { - case [] -> aborting() - case h::t -> k(h,t) - } + sig protect : (Comp(a, {`Abort:Zero, Abort:Zero | e})) -> Comp(a, {Abort{_}, `Abort:Zero|e}) + fun protect (m) () { + handle (m()) { + case Abort(k) -> k (do `Abort) } } - effectname AR(s,e::Eff) = {`Abort:() {}-> Zero, Receive:(){}->s|e} ; - effectname NAR(s,e::Eff) = {`Abort-, Receive:(){}->s|e} ; + sig unprotect : (Comp(a, {`Abort:Zero, Abort:Zero | e})) -> Comp(a, {`Abort{_}, Abort:Zero|e}) + fun unprotect (m) () { + handle (m()) { + case `Abort(k) -> k (do Abort) + } + } + + + typename CA(a,e::Eff) = Comp(a, {Abort:Zero|e}) ; + typename CNAR(a,s,e::Eff) = Comp(a, {Receive:s, Abort:Zero, `Abort- |e}) ; + typename CAR(a,s,e::Eff) = Comp(a, {Receive:s, Abort:Zero, `Abort:Zero|e}) ; - sig withtwo21s : ( () ~NAR(Int,{ |e})~> a ) -> Comp(Maybe(a), {Receive{_}, `Abort{_}|e}) - fun withtwo21s (h) () { maybe( receives( h:( () ~AR(Int,{ |e})~> a ) <- ( () ~NAR(Int,{ |e})~> a) ) ([21,21]) ) () } + sig withtwo21s : (CNAR(a,Int,{ |e})) -> CA(Maybe(a), {Receive{_}, `Abort{_} |e}) + fun withtwo21s (h) { unprotect ( maybe( receives ([21,21]) ( protect ( h : CAR(a,Int,{ |e}) <- (CNAR(a,Int,{ |e})) + ) ) ) ) } } @@ -39,7 +56,7 @@ typename CRI(e::Eff) = Comp(Int, { |R(Int,{ |e})}) ; sig f : CRI({ |e}) fun f () { do Receive + do Receive } sig g : CRI({ |e}) fun g () { do Receive + do Receive + do Receive } -fun h () { if (do Receive < 42) {switch (do Abort) {}} else 0 } +fun h () { if (do Receive < 42) switch (do Abort) {} else 0 } sig res : ( Comp(Maybint, {Abort:Zero |e}) ) -> Comp(Maybint, {Abort{_}|e}) fun res (h) () { @@ -51,7 +68,7 @@ fun res (h) () { # return values ############################################################### ( - withtwo21s( f ) () , - withtwo21s( g ) () , - res(withtwo21s(h)) () + res(withtwo21s( f )) () , + res(withtwo21s( g )) () , + res(withtwo21s( h )) () ) From 066af32d771249f4a7f4caaa77dd810f45cf959c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Hillerstr=C3=B6m?= Date: Tue, 31 Jan 2023 19:11:50 +0100 Subject: [PATCH 59/63] Refactor --- core/closures.ml | 8 ++-- core/compilePatterns.ml | 6 +-- core/desugarDatatypes.ml | 2 +- core/irtojs.ml | 4 +- core/label.ml | 97 +++++++++++++++------------------------- core/label.mli | 15 ++++--- core/parser.mly | 4 +- core/sugarTraversals.ml | 28 ++++++------ core/sugartoir.ml | 2 +- core/typeSugar.ml | 16 +++---- core/types.ml | 6 +-- core/value.ml | 4 +- 12 files changed, 86 insertions(+), 106 deletions(-) diff --git a/core/closures.ml b/core/closures.ml index 18980bfce..2a07ca9e0 100644 --- a/core/closures.ml +++ b/core/closures.ml @@ -456,7 +456,7 @@ struct if IntSet.mem x cvars then (* We cannot return t as the type of the result here. If x refers to a hoisted function that was generalised, then t has additional quantifiers that are not present in the corresponding type of projecting x from parent_env *) - let projected_t = TypeUtils.project_type (Label.mk_int x) (thd3 (o#var parent_env)) in + let projected_t = TypeUtils.project_type (Label.of_int x) (thd3 (o#var parent_env)) in Project (string_of_int x, Variable parent_env), projected_t else if IntMap.mem x fenv then let zs = (IntMap.find x fenv).termvars in @@ -476,7 +476,7 @@ struct (fun b -> let z = Var.var_of_binder b in let v = fst (var_val z) in - (Label.mk_int z, v)) + (Label.of_int z, v)) zs in close x zs tyargs, overall_type @@ -539,7 +539,7 @@ struct (fun fields b -> let x = Var.var_of_binder b in let xt = Var.type_of_binder b in - Label.Map.add (Label.mk_int x) xt fields) + Label.Map.add (Label.of_int x) xt fields) Label.Map.empty zs)) in @@ -615,7 +615,7 @@ struct (fun fields b -> let x = Var.var_of_binder b in let xt = Var.type_of_binder b in - Label.Map.add (Label.mk_int x) xt fields) + Label.Map.add (Label.of_int x) xt fields) Label.Map.empty zs)) in diff --git a/core/compilePatterns.ml b/core/compilePatterns.ml index 117482b84..c76a1c812 100644 --- a/core/compilePatterns.ml +++ b/core/compilePatterns.ml @@ -156,7 +156,7 @@ let rec desugar_pattern : Types.row -> Sugartypes.Pattern.with_pos -> Pattern.t in Pattern.Record (bs, p), env | Tuple ps -> - let bs = mapIndex (fun p i -> (Label.mk_int (i+1), p)) ps in + let bs = mapIndex (fun p i -> (Label.of_int (i+1), p)) ps in desugar_pattern (WithPos.make ~pos (Record (bs, None))) | Constant constant -> Pattern.Constant constant, empty @@ -986,7 +986,7 @@ let compile_handle_cases let (fields, _, _) = TypeUtils.extract_row domain |> TypeUtils.extract_row_parts in let arity = Label.Map.size fields in if arity = 1 then - match Label.Map.find (Label.make "1") fields with + match Label.Map.find Label.one fields with | Types.Present t -> t | _ -> assert false else @@ -1031,7 +1031,7 @@ let compile_handle_cases | [Pattern.Operation (name, ps, _)] -> let packaged_args = let fields = - List.mapi (fun i p -> (Label.mk_int (i+1), p)) ps + List.mapi (fun i p -> (Label.of_int (i+1), p)) ps in Pattern.Record (Label.Map.from_alist fields, None) in diff --git a/core/desugarDatatypes.ml b/core/desugarDatatypes.ml index 059d1e0f5..3c28b6d16 100644 --- a/core/desugarDatatypes.ml +++ b/core/desugarDatatypes.ml @@ -105,7 +105,7 @@ module Desugar = struct ForAll (qs, t) | Unit -> Types.unit_type | Tuple ks -> - let labels = map Label.mk_int (Utility.fromTo 1 (1 + length ks)) in + let labels = map Label.of_int (Utility.fromTo 1 (1 + length ks)) in let unit = Types.make_empty_closed_row () in let present (s, x) = (s, Types.Present x) in diff --git a/core/irtojs.ml b/core/irtojs.ml index 641655ae6..6e5471509 100644 --- a/core/irtojs.ml +++ b/core/irtojs.ml @@ -1200,7 +1200,7 @@ end = functor (K : CONTINUATION) -> struct * environment passed as an argument already) need to be compiled specially *) let op = if (session_exceptions_enabled && - L.eq name Value.session_exception_operation && + L.equal name Value.session_exception_operation && List.length args = 0) then let affected_variables = VariableInspection.get_affected_variables (K.reify kappa) in @@ -1242,7 +1242,7 @@ end = functor (K : CONTINUATION) -> struct let name_map = List.fold_left (fun box (i, _, initial_value) -> - L.Map.add (L.mk_int i) initial_value box) + L.Map.add (L.of_int i) initial_value box) L.Map.empty params in (Ir.Let (param_ptr_binder, ([], Ir.Return (Ir.Extend (name_map, None)))) :: bs, tc) diff --git a/core/label.ml b/core/label.ml index 69a30ec58..8e5f3ed64 100644 --- a/core/label.ml +++ b/core/label.ml @@ -35,106 +35,83 @@ end module Label = struct type local = Name.t * Uid.t type global = Name.t - (* type unresolved = Name.t *) type t = - | Lcl of local - | Gbl of global - (* | Unr of unresolved *) + | Local of local + | Global of global + | Number of int type label = t let show = function - | Lcl (name, id) -> "`" ^ name ^ "<" ^ Uid.show id ^ ">" - | Gbl name -> name - (* | Unr name -> "`?" ^ name *) + | Local (name, id) -> "`" ^ name ^ "<" ^ Uid.show id ^ ">" + | Global name -> name + | Number n -> string_of_int n let pp f l = Format.pp_print_string f begin match l with - | Lcl (name, id) -> "`"^name ^ "<" ^ Uid.show id ^ ">" - | Gbl name -> name - (* | Unr name -> "`?" ^ name *) + | Local (name, id) -> "`"^name ^ "<" ^ Uid.show id ^ ">" + | Global name -> name + | Number n -> string_of_int n end - let mk_local name = Lcl (name, Uid.Free) + let make_local ?(uid=Uid.Free) name = Local (name, uid) - let mk_global name = Gbl name - - (* let mk_unresolved name = Unr name *) + let make_global name = Global name let make ?(local=false) name = - if local then - mk_local name - else - mk_global name + if local + then make_local name + else make_global name - let mk_int i = mk_global (string_of_int i) + let of_int i = Number i let to_int = function - | Gbl g -> int_of_string g + | Number n -> n | l -> raise (local_error show l) let name = function - (* | Gbl name | Lcl (name,_) | Unr name -> name *) - | Lcl (name,_) -> "`"^name - | Gbl name -> name - (* | Unr name -> name *) - + | Local (name,_) -> "`"^name + | Global name -> name + | Number n -> string_of_int n let compare lbl lbl' = match lbl,lbl' with - | Lcl(name, Uid.Free), Lcl(name', Uid.Free) -> String.compare name name' - | Lcl(_, uid), Lcl(_, uid') -> Uid.compare uid uid' - | Gbl g, Gbl g' -> String.compare g g' - (* | Unr u, Unr u' -> String.compare u u' *) - (* | Unr _, _ *) - | Lcl _, Gbl _ -> 1 + | Local (name, Uid.Free), Local (name', Uid.Free) -> String.compare name name' + | Local (_, uid), Local (_, uid') -> Uid.compare uid uid' + | Global g, Global g' -> String.compare g g' + | Local _, Global _ -> 1 + | Number n, Number n' -> Int.compare n n' + | Local _, Number _ -> 1 | _, _ -> -1 - let eq lbl lbl' = compare lbl lbl' = 0 + let equal lbl lbl' = compare lbl lbl' = 0 - let eq_name lbl lbl' = String.compare (name lbl) (name lbl') = 0 + let textual_equal lbl lbl' = String.compare (name lbl) (name lbl') = 0 let name_is lbl name' = String.compare (name lbl) name' = 0 let is_local = function - | Lcl _ -> true + | Local _ -> true | _ -> false - let is_global = function - | Gbl _ -> true - | _ -> false + let is_global l = not (is_local l) let is_free = function - | Lcl (_, uid) -> Uid.is_free uid + | Local (_, uid) -> Uid.is_free uid | l -> raise (not_local_error show l) let uid = function - | Lcl (_, uid) -> uid + | Local (_, uid) -> uid | l -> raise (not_local_error show l) let bind_local ?bind_with lbl = match bind_with, lbl with - | Some bind_lbl, Lcl (name, Uid.Free) -> Lcl (name, uid bind_lbl) - | Some _ , Lcl _ -> raise (not_free_error show lbl) - | None , Lcl (name, _) -> Lcl (name, Uid.new_uid ()) + | Some bind_lbl, Local (name, Uid.Free) -> Local (name, uid bind_lbl) + | Some _ , Local _ -> raise (not_free_error show lbl) + | None , Local (name, _) -> Local (name, Uid.new_uid ()) | _ -> raise (not_local_error show lbl) - - (* let is_resolved = function *) - (* | Unr _ -> false *) - (* | _ -> true *) - - - let one = mk_global "1" - let two = mk_global "2" - let return = mk_global "Return" - - - (* let resolve_global = function *) - (* | Unr name -> Gbl name *) - (* | _ -> failwith "already resolved" *) - - (* let resolve_local = function *) - (* | Unr name -> mk_local name *) - (* | _ -> failwith "already resolved" *) + let one = Number 1 + let two = Number 2 + let return = make_global "return" end include Label diff --git a/core/label.mli b/core/label.mli index f3fd46d35..4f60e61f6 100644 --- a/core/label.mli +++ b/core/label.mli @@ -8,22 +8,23 @@ type local = Name.t * Uid.t type global = Name.t type t = - | Lcl of local - | Gbl of global + | Local of local + | Global of global + | Number of int [@@deriving show] type label = t -val mk_local : Name.t -> t -val mk_global : Name.t -> t +val make_local : ?uid:Uid.t -> Name.t -> t +val make_global : Name.t -> t val make : ?local:bool -> Name.t -> t -val mk_int : Int.t -> t +val of_int : Int.t -> t val to_int : t -> Int.t val name : t -> Name.t val compare : t -> t -> int -val eq : t -> t -> bool -val eq_name : t -> t -> bool +val equal : t -> t -> bool +val textual_equal : t -> t -> bool val name_is : t -> Name.t -> bool val is_local : t -> bool diff --git a/core/parser.mly b/core/parser.mly index a0e4b874f..5f85169bf 100644 --- a/core/parser.mly +++ b/core/parser.mly @@ -299,8 +299,8 @@ let parse_foreign_language pos lang = (pos, Printf.sprintf "Unrecognised foreign language '%s'." lang)) let any = any_pat dp -let local_label = Label.mk_local -let label = Label.mk_global +let local_label = Label.make_local +let label = Label.make_global %} %token EOF diff --git a/core/sugarTraversals.ml b/core/sugarTraversals.ml index abf0aeaef..7c2a05189 100644 --- a/core/sugarTraversals.ml +++ b/core/sugarTraversals.ml @@ -641,12 +641,12 @@ class map = method label : Datatype.label -> Datatype.label = let open Label in function - (* | Unr _x -> let _x = o#name _x in Unr _x *) - | Gbl _x -> let _x = o#name _x in Gbl _x - | Lcl (_x, _x_i1) -> + | Global _x -> let _x = o#name _x in Global _x + | Local (_x, _x_i1) -> let _x = o#name _x in let _x_i1 = o#uid _x_i1 in - Lcl (_x, _x_i1) + Local (_x, _x_i1) + | Number n -> let n = o#int n in Number n method uid : Label.Uid.t -> Label.Uid.t = let open Label.Uid in function @@ -1443,12 +1443,12 @@ class fold = method label : Datatype.label -> 'self_type = let open Label in function - (* | Unr _x -> let o = o#name _x in o *) - | Gbl _x -> let o = o#name _x in o - | Lcl (_x, _x_i1) -> + | Global _x -> let o = o#name _x in o + | Local (_x, _x_i1) -> let o = o#name _x in let o = o#uid _x_i1 in o + | Number n -> o#int n method uid : Label.Uid.t -> 'self_type = let open Label.Uid in function @@ -2358,12 +2358,14 @@ class fold_map = method label : Datatype.label -> ('self_type * Datatype.label) = let open Label in function - (* | Unr _x -> let (o,_x) = o#name _x in (o, Unr _x) *) - | Gbl _x -> let (o,_x) = o#name _x in (o, Gbl _x) - | Lcl (_x, _x_i1) -> - let (o, _x) = o#name _x in - let (o, _x_i1) = o#uid _x_i1 in - (o, Lcl (_x, _x_i1)) + | Global _x -> let (o,_x) = o#name _x in (o, Global _x) + | Local (_x, _x_i1) -> + let (o, _x) = o#name _x in + let (o, _x_i1) = o#uid _x_i1 in + (o, Local (_x, _x_i1)) + | Number n -> + let (o, n) = o#int n in + (o, Number n) method uid : Label.Uid.t -> ('self_type * Label.Uid.t) = let open Label.Uid in function diff --git a/core/sugartoir.ml b/core/sugartoir.ml index 5f8df8638..8f0e0400f 100644 --- a/core/sugartoir.ml +++ b/core/sugartoir.ml @@ -960,7 +960,7 @@ struct *) ec e | TupleLit es -> - let fields = mapIndex (fun e i -> (Label.mk_int (i+1), ev e)) es in + let fields = mapIndex (fun e i -> (Label.of_int (i+1), ev e)) es in cofv (I.record (fields, None)) | RecordLit (fields, rest) -> cofv diff --git a/core/typeSugar.ml b/core/typeSugar.ml index e764dd391..9a035bec8 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -2007,9 +2007,9 @@ let close_pattern_type : Pattern.with_pos list -> Types.datatype -> Types.dataty match p.node with | Variable _ | Any -> [ with_pos p.pos Pattern.Any ] | As (_, p) | HasType (p, _) -> unwrap_at name p - | Variant (name', None) when Label.eq name name' -> + | Variant (name', None) when Label.equal name name' -> [with_pos p.pos (Pattern.Record ([], None))] - | Variant (name', Some p) when Label.eq name name' -> [p] + | Variant (name', Some p) when Label.equal name name' -> [p] | Variant _ -> [] | Negative names when List.mem name names -> [] | Negative _ -> [ with_pos p.pos Pattern.Any ] @@ -2056,7 +2056,7 @@ let close_pattern_type : Pattern.with_pos list -> Types.datatype -> Types.dataty let unwrap_at : Label.t -> Pattern.with_pos -> Pattern.with_pos list = fun name p -> let open Pattern in match p.node with - | Operation (name', ps, _) when Label.eq name name' -> ps + | Operation (name', ps, _) when Label.equal name name' -> ps | Operation _ -> [] | Variable _ | Any | As _ | HasType _ | Negative _ | Nil | Cons _ | List _ | Tuple _ | Record _ | Variant _ | Constant _ -> assert false in @@ -2606,10 +2606,10 @@ let erase_local_labels_from_type ?(exact=true) pos labels dt = let remove () = f in let to_remove k = if exact then List.mem k labels - else List.filter (Label.eq_name k) labels <> [] + else List.filter (Label.textual_equal k) labels <> [] in let is_shadowed k = - if exact then List.filter (Label.eq_name k) labels <> [] + if exact then List.filter (Label.textual_equal k) labels <> [] else false in if Label.is_global k then keep () @@ -2746,7 +2746,7 @@ let check_labels pos dt ctx = else match Label.Env.find_homonyms k ctx.label_env with | [] -> unbound () - | k' :: _ when Label.eq k k' -> ok () + | k' :: _ when Label.equal k k' -> ok () | _ -> ignore (shadowed ()) (* without the ignore we get a warning ?? *) ; ct v ) fields ; @@ -4281,7 +4281,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = ((uexp_pos pat, effrow), no_pos (T.Effect inner_eff)); let pat, kpat = let rec find_effect_type eff = function - | (eff', t) :: _ when Label.eq eff eff' -> + | (eff', t) :: _ when Label.equal eff eff' -> begin match t with | T.Present t -> t | _ -> assert false @@ -4520,7 +4520,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = in doop, rettyp, usage | Operation name -> - if Label.eq name Value.session_exception_operation && not context.desugared then + if Label.equal name Value.session_exception_operation && not context.desugared then Gripers.die pos "The session failure effect SessionFail is not directly invocable (use `raise` instead)" else let t = match lookup_effect context name with diff --git a/core/types.ml b/core/types.ml index 0a83d8163..db16eb657 100644 --- a/core/types.ml +++ b/core/types.ml @@ -1701,7 +1701,7 @@ let wild_present = (wild, Present unit_type) let hear_present t = (hear, Present t) let is_builtin_effect lbl = - Label.eq lbl wild || Label.eq lbl hear + Label.equal lbl wild || Label.equal lbl hear (* precondition: the row is unwrapped *) @@ -1719,7 +1719,7 @@ let is_tuple ?(allow_onetuples=false) row = n = 0 || (List.for_all (fun i -> - let name = Label.mk_int i in + let name = Label.of_int i in FieldEnv.mem name field_env && (match FieldEnv.find name field_env with | Present _ -> true @@ -4616,7 +4616,7 @@ let make_tuple_type (ts : datatype list) : datatype = Record (snd (List.fold_left - (fun (n, row) t -> n+1, row_with (Label.mk_int n, Present t) row) + (fun (n, row) t -> n+1, row_with (Label.of_int n, Present t) row) (1, make_empty_closed_row ()) ts)) diff --git a/core/value.ml b/core/value.ml index 39825d70c..3ae9e5ea8 100644 --- a/core/value.ml +++ b/core/value.ml @@ -667,7 +667,7 @@ module Eff_Handler_Continuation = struct | ((User_defined h, pk) :: k) -> begin match Label.Map.lookup opname h.cases with | Some (b, _, comp) - when session_exn_enabled && Label.eq session_exception_operation opname -> + when session_exn_enabled && Label.equal session_exception_operation opname -> let var = Var.var_of_binder b in let continuation_thunk = fun () -> E.computation (Env.bind var (arg, Scope.Local) h.env) k comp @@ -693,7 +693,7 @@ module Eff_Handler_Continuation = struct | None -> handle ((User_defined h, pk) :: k') k end | (identity, pk) :: k -> handle ((identity, pk) :: k') k - | [] when session_exn_enabled && Label.eq session_exception_operation opname -> + | [] when session_exn_enabled && Label.equal session_exception_operation opname -> (* If this is a session exception operation, we need to gather all * of the computations in the pure continuation stack, so we can inspect * their free variables. *) From 478c2a2e0e695e000717857c0408bdb3cc082969 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Hillerstr=C3=B6m?= Date: Tue, 31 Jan 2023 22:56:33 +0100 Subject: [PATCH 60/63] Fix bug and generalise. This commit fixes a regression introduced by the previous commit, wherein numeric labels wouldn't get looked up correctly in `Label.{Map,Set}`. This commit also generalises `fresh` such that it can be used locally within a binding context. Furthermore, it changes the syntax such that it no longer introduces encloses a list of bindings, but instead uses the standard block-structured scope of Links. --- core/desugarLabels.ml | 16 ++-- core/label.ml | 45 ++++++---- core/label.mli | 16 ++-- core/parser.mly | 8 +- core/sugarTraversals.ml | 19 ++--- core/sugartoir.ml | 3 +- core/sugartypes.ml | 10 +-- core/transformSugar.ml | 6 +- core/typeSugar.ml | 125 +++++++++++++--------------- tests/labels/handler.links | 32 ++++--- tests/labels/multiple.links | 17 ++-- tests/labels/nested-names.links | 23 ++--- tests/labels/nested-pollution.links | 64 +++++++------- tests/labels/nested.links | 29 +++---- tests/labels/pollution.links | 36 ++++---- tests/labels/simple-names.links | 13 ++- tests/labels/simple.links | 7 +- tests/labels/wrong-handler.links | 37 ++++---- 18 files changed, 234 insertions(+), 272 deletions(-) diff --git a/core/desugarLabels.ml b/core/desugarLabels.ml index 1e03f4090..333fa1cee 100644 --- a/core/desugarLabels.ml +++ b/core/desugarLabels.ml @@ -4,7 +4,7 @@ open Sugartypes module Env = Label.Env let visitor = - object (self) + object (_self) inherit SugarTraversals.map as super val mutable label_env : Env.t = Env.empty @@ -18,12 +18,10 @@ let visitor = | _ -> failwith ("The local label " ^ Label.show lbl ^ " is not bound") method! bindingnode = function - | FreshLabel (labels, decls) -> + | FreshLabel labels -> let labels = List.map Label.bind_local labels in label_env <- Env.bind_labels labels label_env ; - let decls = List.map self#binding decls in - label_env <- Env.unbind_labels labels label_env ; - FreshLabel(labels, decls) + FreshLabel labels | b -> super#bindingnode b end @@ -33,9 +31,11 @@ let program p = visitor#program p let sentence = function | Definitions bs -> let bs' = visitor#list (fun o b -> o#binding b) bs in - Definitions bs' - | Expression p -> Expression p - | Directive d -> Directive d + Definitions bs' + | Expression p -> + let p' = visitor#phrase p in + Expression p' + | Directive d -> Directive d module Untyped = struct open Transform.Untyped diff --git a/core/label.ml b/core/label.ml index 8e5f3ed64..381585d4a 100644 --- a/core/label.ml +++ b/core/label.ml @@ -1,6 +1,13 @@ open Utility open CommonTypes +let show_unique_labels_idents = + Settings.(flag ~default:false "show_unique_labels_idents" + |> privilege `User + |> synopsis "Show the internal numeric identifier for each unique label" + |> convert parse_bool + |> sync) + let internal_error message = Errors.internal_error ~filename:"label.ml" ~message let local_error show lbl = @@ -43,7 +50,10 @@ module Label = struct type label = t let show = function - | Local (name, id) -> "`" ^ name ^ "<" ^ Uid.show id ^ ">" + | Local (name, id) -> + if Settings.get show_unique_labels_idents + then Printf.sprintf "`%s<%s>" name (Uid.show id) + else Printf.sprintf "`%s" name | Global name -> name | Number n -> string_of_int n @@ -54,21 +64,25 @@ module Label = struct | Number n -> string_of_int n end - let make_local ?(uid=Uid.Free) name = Local (name, uid) - - let make_global name = Global name - - let make ?(local=false) name = - if local - then make_local name - else make_global name - let of_int i = Number i let to_int = function | Number n -> n + | Global i -> int_of_string i | l -> raise (local_error show l) + let make_local ?(uid=Uid.Free) name = Local (name, uid) + + let make_global name = Global name + + let make textual_name = + let is_digit ch = + Char.code ch >= 48 && Char.code ch <= 57 + in + if String.for_all is_digit textual_name + then of_int (int_of_string textual_name) + else make_global textual_name + let name = function | Local (name,_) -> "`"^name | Global name -> name @@ -79,9 +93,12 @@ module Label = struct | Local (_, uid), Local (_, uid') -> Uid.compare uid uid' | Global g, Global g' -> String.compare g g' | Local _, Global _ -> 1 - | Number n, Number n' -> Int.compare n n' | Local _, Number _ -> 1 - | _, _ -> -1 + | Global _, Number _ -> 1 + | Number _, Global _ -> -1 + | Number _, Local _ -> -1 + | Global _, Local _ -> -1 + | Number n, Number m -> Int.compare n m let equal lbl lbl' = compare lbl lbl' = 0 @@ -109,8 +126,8 @@ module Label = struct | None , Local (name, _) -> Local (name, Uid.new_uid ()) | _ -> raise (not_local_error show lbl) - let one = Number 1 - let two = Number 2 + let one = of_int 1 + let two = of_int 2 let return = make_global "return" end diff --git a/core/label.mli b/core/label.mli index 4f60e61f6..0c014ebbc 100644 --- a/core/label.mli +++ b/core/label.mli @@ -1,11 +1,11 @@ -open CommonTypes +val show_unique_labels_idents : bool Settings.setting module Uid : sig type t = Id of Int.t | Free end -type local = Name.t * Uid.t -type global = Name.t +type local = string * Uid.t +type global = string type t = | Local of local @@ -14,18 +14,18 @@ type t = [@@deriving show] type label = t -val make_local : ?uid:Uid.t -> Name.t -> t -val make_global : Name.t -> t -val make : ?local:bool -> Name.t -> t +val make_local : ?uid:Uid.t -> string -> t +val make_global : string -> t +val make : string -> t val of_int : Int.t -> t val to_int : t -> Int.t -val name : t -> Name.t +val name : t -> string val compare : t -> t -> int val equal : t -> t -> bool val textual_equal : t -> t -> bool -val name_is : t -> Name.t -> bool +val name_is : t -> string -> bool val is_local : t -> bool val is_global : t -> bool diff --git a/core/parser.mly b/core/parser.mly index 5f85169bf..d7f7be57b 100644 --- a/core/parser.mly +++ b/core/parser.mly @@ -300,7 +300,7 @@ let parse_foreign_language pos lang = let any = any_pat dp let local_label = Label.make_local -let label = Label.make_global +let label = Label.make %} %token EOF @@ -456,8 +456,7 @@ nofun_declaration: | typedecl SEMICOLON { $1 } | links_module | links_open SEMICOLON { $1 } | pollute = boption(OPEN) IMPORT CONSTRUCTOR SEMICOLON { import ~ppos:$loc($2) ~pollute [$3] } -| FRESH separated_nonempty_list(COMMA, BTCONSTRUCTOR) - LBRACE declarations RBRACE { with_pos $loc (FreshLabel(List.map local_label $2, $4))} +| FRESH separated_nonempty_list(COMMA, BTCONSTRUCTOR) SEMICOLON { with_pos $loc (FreshLabel (List.map local_label $2))} alien_datatype: | VARIABLE COLON datatype SEMICOLON { (binder ~ppos:$loc($1) $1, datatype $3) } @@ -983,6 +982,7 @@ binding: | fun_kind VARIABLE arg_lists perhaps_location switch_funlit_body { switch_fun_binding ~ppos:$loc None ($1, $2, $3, $4, $5) } | typedecl SEMICOLON | links_module | links_open SEMICOLON { $1 } +| FRESH separated_nonempty_list(COMMA, BTCONSTRUCTOR) SEMICOLON { with_pos $loc (FreshLabel (List.map local_label $2))} mutual_binding_block: | MUTUAL LBRACE mutual_bindings RBRACE { MutualBindings.flatten $3 } @@ -1189,7 +1189,7 @@ field_label: | CONSTRUCTOR { label $1 } | VARIABLE { label $1 } | STRING { label $1 } -| UINTEGER { label (string_of_int $1) } +| UINTEGER { Label.Number $1 } rfields: | fields_def(rfield, COMMA, row_var, kinded_row_var) { $1 } diff --git a/core/sugarTraversals.ml b/core/sugarTraversals.ml index 7c2a05189..27a836b51 100644 --- a/core/sugarTraversals.ml +++ b/core/sugarTraversals.ml @@ -805,10 +805,9 @@ class map = in let language = o#foreign_language (Alien.language alien) in AlienBlock (Alien.modify ~language ~declarations alien) - | FreshLabel(_x, _x_i1) -> - let _x = o#list (fun o -> o#label) _x in - let _x_i1 = o#list (fun o -> o#binding) _x_i1 in - FreshLabel(_x,_x_i1) + | FreshLabel ls -> + let ls = o#list (fun o -> o#label) ls in + FreshLabel ls method binding : binding -> binding = fun p -> @@ -1594,9 +1593,8 @@ class fold = let o = o#binder b in o#datatype' dt) (Alien.declarations alien) - | FreshLabel(_x, _x_i1) -> - let o = o#list (fun o -> o#label) _x in - let o = o#list (fun o -> o#binding) _x_i1 in + | FreshLabel ls -> + let o = o#list (fun o -> o#label) ls in o method binding : binding -> 'self_type = @@ -2551,10 +2549,9 @@ class fold_map = (Alien.declarations alien) in o, AlienBlock (Alien.modify ~language:lang ~declarations alien) - | FreshLabel(_x, _x_i1) -> - let o, _x = o#list (fun o -> o#label) _x in - let o, _x_i1 = o#list (fun o -> o#binding) _x_i1 in - o, FreshLabel(_x,_x_i1) + | FreshLabel ls -> + let (o, ls) = o#list (fun o -> o#label) ls in + (o, FreshLabel ls) method binding : binding -> ('self_type * binding) = diff --git a/core/sugartoir.ml b/core/sugartoir.ml index 8f0e0400f..5972d263a 100644 --- a/core/sugartoir.ml +++ b/core/sugartoir.ml @@ -1334,8 +1334,7 @@ struct let xt = Binder.to_type binder in I.alien (Var.make_info xt x scope, Alien.object_name alien, Alien.language alien, fun v -> eval_bindings scope (extend [x] [(v, xt)] env) bs e) - | FreshLabel (_, decls) -> (* TODO: is that right ? ignore local labels *) - eval_bindings scope env (decls @ bs) e + | FreshLabel _ -> eval_bindings scope env bs e (* TODO: is that right ? ignore local labels *) | Aliases _ | Infix _ -> (* Ignore type alias and infix declarations - they diff --git a/core/sugartypes.ml b/core/sugartypes.ml index 3e8296e1b..48dd4e9c5 100644 --- a/core/sugartypes.ml +++ b/core/sugartypes.ml @@ -244,7 +244,6 @@ module Pattern = struct | Cons of with_pos * with_pos | List of with_pos list | Variant of Label.t * with_pos option - (* | Effect of Label.t * with_pos list * with_pos *) | Operation of Label.t * with_pos list * with_pos | Negative of Label.t list | Record of (Label.t * with_pos) list * with_pos option @@ -535,7 +534,7 @@ and bindingnode = | Exp of phrase | Module of { binder: Binder.with_pos; members: binding list } | AlienBlock of Alien.multi Alien.t - | FreshLabel of Label.t list * binding list + | FreshLabel of Label.t list and binding = bindingnode WithPos.t and block_body = binding list * phrase and cp_phrasenode = @@ -818,12 +817,7 @@ struct | Import _ | Open _ | Aliases _ -> empty, empty - | FreshLabel (_, decls) -> - List.fold_left - (fun (b,f) decl -> let b', f' = binding decl in - StringSet.union b b', StringSet.union f f') - (StringSet.empty, StringSet.empty) - decls + | FreshLabel _ -> empty, empty (* This is technically a declaration, thus the name should probably be treated as bound rather than free. *) | Infix { name; _ } -> empty, singleton name diff --git a/core/transformSugar.ml b/core/transformSugar.ml index 9b2ef2f37..22b89bcec 100644 --- a/core/transformSugar.ml +++ b/core/transformSugar.ml @@ -905,11 +905,9 @@ class transform (env : Types.typing_environment) = | (Infix _) as node -> (o, node) | Exp e -> let (o, e, _) = o#phrase e in (o, Exp e) - | FreshLabel(labels, decls) -> + | FreshLabel ls -> (* do we wanna do something with labels ? *) - let o, decls = ListUtils.fold_left_map - (fun o d -> o#binding d) o decls in - (o, FreshLabel(labels, decls)) + (o, FreshLabel ls) | AlienBlock _ -> assert false | Module _ -> assert false | Import _ -> assert false diff --git a/core/typeSugar.ml b/core/typeSugar.ml index 9a035bec8..aa2bcda7f 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -1695,11 +1695,11 @@ let lookup_effect context name = end | _ -> raise (internal_error "Effect row in the context is not a row") -let unbind_alias context v = {context with tycon_env = Env.unbind v context.tycon_env} +(* let unbind_alias context v = {context with tycon_env = Env.unbind v context.tycon_env} *) let bind_labels context ls = {context with label_env = Label.Env.bind_labels ls context.label_env} (* let unbind_labels context ls = {context with label_env = Label.Env.unbind_labels ls context.label_env} *) -let extend = Types.extend_typing_environment +(* let extend = Types.extend_typing_environment *) (* TODO(dhil): I have extracted the Usage abstraction from my name hygiene/compilation unit patch. The below module is a compatibility @@ -2668,57 +2668,57 @@ let erase_local_labels_from_tycon ?(exact=true) pos labels tycon = } ; Some (`Mutual (qs, tygroup)) -let rec erase_local_labels labels decls ctx = - let erase_binder pos binder ctx = - let name = Binder.to_name binder in - let t' = Env.find_opt name ctx.var_env in - match OptionUtils.opt_bind (erase_local_labels_from_type pos labels) t' with - | Some t -> bind_var ctx (name, t) - | None -> unbind_var ctx name - in - let erase_alias pos name ctx = - let tycon' = Env.find_opt name ctx.tycon_env in - match OptionUtils.opt_bind (erase_local_labels_from_tycon pos labels) tycon' with - | Some tycon -> bind_alias ctx (name, tycon) - | None -> unbind_alias ctx name - in - let rec erase_pat pat ctx = - let e = erase_pat in - let e_list ps ctx = List.fold_left (fun ctx p -> e p ctx) ctx ps in - let e_opt p_opt ctx = match p_opt with None -> ctx | Some p -> e p ctx in - let open Pattern in - let pos = WithPos.pos pat in - match WithPos.node pat with - | Cons (p,p') -> ctx |> e p |> e p' - | List ps -> ctx |> e_list ps - | Variant (_, p_opt) -> ctx |> e_opt p_opt - | Operation (_, ps, p) -> ctx |> e_list ps |> e p - | Record (lps, p_opt) -> ctx |> e_list (snd (List.split lps)) |> e_opt p_opt - | Tuple ps -> ctx |> e_list ps - | Variable b -> ctx |> erase_binder pos b - | As (b, p) -> ctx |> erase_binder pos b |> e p - | HasType (p,_) -> ctx |> e p - | _ -> ctx - in - List.fold_left (fun ctx d -> - let pos = WithPos.pos d in - match WithPos.node d with - | Fun { fun_binder ; _ } -> erase_binder pos fun_binder ctx - | Funs rfuns -> List.fold_left - (fun ctx rfun -> - erase_binder (WithPos.pos rfun) (WithPos.node rfun).rec_binder ctx - ) ctx rfuns - | Val (pat, _, _, _) -> erase_pat pat ctx - | FreshLabel (_, decls') -> erase_local_labels labels decls' ctx - | Aliases ts -> List.fold_left (fun ctx { node=(name, _, _); _} -> erase_alias pos name ctx) ctx ts - | Infix _ - | Exp _ - | Foreign _ -> ctx - | Import _ - | Open _ - | Module _ - | AlienBlock _ -> assert false - ) ctx decls +(* let erase_local_labels labels decls ctx = *) +(* let erase_binder pos binder ctx = *) +(* let name = Binder.to_name binder in *) +(* let t' = Env.find_opt name ctx.var_env in *) +(* match OptionUtils.opt_bind (erase_local_labels_from_type pos labels) t' with *) +(* | Some t -> bind_var ctx (name, t) *) +(* | None -> unbind_var ctx name *) +(* in *) +(* let erase_alias pos name ctx = *) +(* let tycon' = Env.find_opt name ctx.tycon_env in *) +(* match OptionUtils.opt_bind (erase_local_labels_from_tycon pos labels) tycon' with *) +(* | Some tycon -> bind_alias ctx (name, tycon) *) +(* | None -> unbind_alias ctx name *) +(* in *) +(* let rec erase_pat pat ctx = *) +(* let e = erase_pat in *) +(* let e_list ps ctx = List.fold_left (fun ctx p -> e p ctx) ctx ps in *) +(* let e_opt p_opt ctx = match p_opt with None -> ctx | Some p -> e p ctx in *) +(* let open Pattern in *) +(* let pos = WithPos.pos pat in *) +(* match WithPos.node pat with *) +(* | Cons (p,p') -> ctx |> e p |> e p' *) +(* | List ps -> ctx |> e_list ps *) +(* | Variant (_, p_opt) -> ctx |> e_opt p_opt *) +(* | Operation (_, ps, p) -> ctx |> e_list ps |> e p *) +(* | Record (lps, p_opt) -> ctx |> e_list (snd (List.split lps)) |> e_opt p_opt *) +(* | Tuple ps -> ctx |> e_list ps *) +(* | Variable b -> ctx |> erase_binder pos b *) +(* | As (b, p) -> ctx |> erase_binder pos b |> e p *) +(* | HasType (p,_) -> ctx |> e p *) +(* | _ -> ctx *) +(* in *) +(* List.fold_left (fun ctx d -> *) +(* let pos = WithPos.pos d in *) +(* match WithPos.node d with *) +(* | Fun { fun_binder ; _ } -> erase_binder pos fun_binder ctx *) +(* | Funs rfuns -> List.fold_left *) +(* (fun ctx rfun -> *) +(* erase_binder (WithPos.pos rfun) (WithPos.node rfun).rec_binder ctx *) +(* ) ctx rfuns *) +(* | Val (pat, _, _, _) -> erase_pat pat ctx *) +(* | FreshLabel _ -> ctx *) +(* | Aliases ts -> List.fold_left (fun ctx { node=(name, _, _); _} -> erase_alias pos name ctx) ctx ts *) +(* | Infix _ *) +(* | Exp _ *) +(* | Foreign _ -> ctx *) +(* | Import _ *) +(* | Open _ *) +(* | Module _ *) +(* | AlienBlock _ -> assert false *) +(* ) ctx decls *) (** Check if all local labels in that type are bound and not shadowed **) let check_labels pos dt ctx = @@ -5127,34 +5127,27 @@ and type_binding : context -> binding -> binding * context * Usage.t = let () = unify pos ~handle:Gripers.bind_exp (pos_and_typ e, no_pos Types.unit_type) in Exp (erase e), empty_context, usages e - | FreshLabel(labels, decls) -> + | FreshLabel ls -> let context = { context with var_env = Env.fold (fun k v env -> - match erase_local_labels_from_type ~exact:false pos labels v with + match erase_local_labels_from_type ~exact:false pos ls v with | Some v -> Env.bind k v env | None -> env ) context.var_env Env.empty ; tycon_env = Env.fold (fun k v env -> - match erase_local_labels_from_tycon ~exact:false pos labels v with + match erase_local_labels_from_tycon ~exact:false pos ls v with | Some v -> Env.bind k v env | None -> env ) context.tycon_env Env.empty } in - let context = bind_labels context labels in - let (context,_), decls = ListUtils.fold_left_map - (fun (ctx, loc_ctx) d -> - let d, ctx', _ = type_binding loc_ctx d in - (extend ctx ctx', extend loc_ctx ctx'), d - ) (empty_context, context) decls in - let context = erase_local_labels labels decls context in - (* let context = unbind_labels context labels in *) - (FreshLabel(labels, decls), context, Usage.empty) + let context = bind_labels context ls in + (FreshLabel ls, context, Usage.empty) | Import _ | Open _ | AlienBlock _ | Module _ -> assert false in - WithPos.make ~pos typed, ctxt, usage + WithPos.make ~pos typed, ctxt, usage and type_regex typing_env : regex -> regex = fun m -> let erase (e, _, _) = e in diff --git a/tests/labels/handler.links b/tests/labels/handler.links index 3f9ff62ac..d8bfbc847 100644 --- a/tests/labels/handler.links +++ b/tests/labels/handler.links @@ -1,24 +1,22 @@ -fresh `Ask { +fresh `Ask; - effectname A(e::Eff) = {`Ask:() => Int|e} ; +effectname A(e::Eff) = {`Ask:() => Int|e} ; - sig h_ask : (Comp(a, { |A({ |e})})) -> Comp(a, {`Ask{_}|e}) - fun h_ask (m) () { - handle (m()) { - case <`Ask => k> -> k(41) - } - } - - sig f : () -A({ |e})-> Int - fun f () { - do `Ask + 1 - } +sig h_ask : (Comp(a, { |A({ |e})})) -> Comp(a, {`Ask{_}|e}) +fun h_ask (m) () { + handle (m()) { + case <`Ask => k> -> k(41) + } +} - sig res : () {`Ask{_}|_}~> Int - fun res () { - h_ask(f)() - } +sig f : () -A({ |e})-> Int +fun f () { + do `Ask + 1 +} +sig res : () {`Ask{_}|_}~> Int +fun res () { + h_ask(f)() } res () diff --git a/tests/labels/multiple.links b/tests/labels/multiple.links index 44542fada..72448a27c 100644 --- a/tests/labels/multiple.links +++ b/tests/labels/multiple.links @@ -1,12 +1,9 @@ -fresh `A, `B, `C { +fresh `A, `B, `C; +sig f : () {`A:(), `B:Bool}-> Bool +fun f () { do `A ; do `B } - sig f : () {`A:(), `B:Bool}-> Bool - fun f () { do `A ; do `B } +sig g : () {`C:Int, `B:Bool}-> Int +fun g () { if (do `B) 1 else do `C } - sig g : () {`C:Int, `B:Bool}-> Int - fun g () { if (do `B) 1 else do `C } - - sig h : () {`C:Int, `A:()}-> Int - fun h () { do `A ; do `C } - -} +sig h : () {`C:Int, `A:()}-> Int +fun h () { do `A ; do `C } diff --git a/tests/labels/nested-names.links b/tests/labels/nested-names.links index e09075852..df3a23ef4 100644 --- a/tests/labels/nested-names.links +++ b/tests/labels/nested-names.links @@ -1,19 +1,14 @@ -fresh `A, `B { +fresh `A, `B; - effectname E = { `A:() {}-> Int } ; - typename T = () {`B:Bool | E}-> Bool ; +effectname E = { `A:() {}-> Int } ; +typename T = () {`B:Bool | E}-> Bool ; - sig f : T - fun f () { do `B && (do `A > 42) } +sig f : T +fun f () { do `B && (do `A > 42) } - fresh `A { - - sig f' : T - fun f' () { - do `A > 42 - } - - - } +fresh `A; +sig f' : T +fun f' () { + do `A > 42 } diff --git a/tests/labels/nested-pollution.links b/tests/labels/nested-pollution.links index 86a284bae..9401757e9 100644 --- a/tests/labels/nested-pollution.links +++ b/tests/labels/nested-pollution.links @@ -1,47 +1,43 @@ -fresh `A { - - sig h_a : (Comp(a,{`A:(Int) => Int|e})) -> Comp(a, {`A{_}|e}) - fun h_a (m) () { - handle (m ()) { - case <`A(x) => k> -> k (2*x) - } - } - - sig double : (Int) {`A:(Int) => Int|e}-> Int - fun double (x) { do `A(x) } +fresh `A; +sig h_a : (Comp(a,{`A:(Int) => Int|e})) -> Comp(a, {`A{_}|e}) +fun h_a (m) () { + handle (m ()) { + case <`A(x) => k> -> k (2*x) + } +} - sig times_two : (Int) -> Comp(Int, {`A{_}|_}) - fun times_two (x) { h_a ( fun () { double(x) } ) } +sig double : (Int) {`A:(Int) => Int|e}-> Int +fun double (x) { do `A(x) } - sig times_two' : (Int) {`A{_}|_}~> Int - fun times_two' (x) { times_two (x) () } +sig times_two : (Int) -> Comp(Int, {`A{_}|_}) +fun times_two (x) { h_a ( fun () { double(x) } ) } - fresh `A { +sig times_two' : (Int) {`A{_}|_}~> Int +fun times_two' (x) { times_two (x) () } - sig h_a' : (Comp(a,{`A:(Int) => Int|e})) -> Comp(a, {`A{_}|e}) - fun h_a' (m) () { - handle (m()) { - case <`A(x) => k> -> k (3*x) - } - } +fresh `A; - sig triple : (Int) {`A:(Int) => Int|e}-> Int - fun triple (x) { do `A(x) } +sig h_a' : (Comp(a,{`A:(Int) => Int|e})) -> Comp(a, {`A{_}|e}) +fun h_a' (m) () { + handle (m()) { + case <`A(x) => k> -> k (3*x) + } +} - sig sextuple : (Int) {`A:(Int) => Int|e}~> Int - fun sextuple (x) { triple( times_two'(x) ) } +sig triple : (Int) {`A:(Int) => Int|e}-> Int +fun triple (x) { do `A(x) } - sig times_six : (Int) -> Comp(Int, {`A{_}|_}) - fun times_six (x) { h_a' (fun () { sextuple (x) }) } +sig sextuple : (Int) {`A:(Int) => Int|e}~> Int +fun sextuple (x) { triple( times_two'(x) ) } - sig times_six' : (Int) {`A{_}|_}~> Int - fun times_six' (x) { times_six (x) () } +sig times_six : (Int) -> Comp(Int, {`A{_}|_}) +fun times_six (x) { h_a' (fun () { sextuple (x) }) } - } +sig times_six' : (Int) {`A{_}|_}~> Int +fun times_six' (x) { times_six (x) () } - var fun_xlii = times_two( 21+21 ) ; +var fun_xlii = times_two( 21+21 ) ; - var xlii = fun_xlii () ; -} +var xlii = fun_xlii () ; xlii - times_six' (7) diff --git a/tests/labels/nested.links b/tests/labels/nested.links index 73af6752b..701465bf0 100644 --- a/tests/labels/nested.links +++ b/tests/labels/nested.links @@ -1,23 +1,16 @@ -fresh `A { +fresh `A; +fresh `B; - fresh `B { +sig f : () {`A:(), `B:Bool}-> Bool +fun f () { do `A ; do `B } - sig f : () {`A:(), `B:Bool}-> Bool - fun f () { do `A ; do `B } +sig f' : () {`A:Int}-> Int +fun f' () { do `A * 42 } - sig f' : () {`A:Int}-> Int - fun f' () { do `A * 42 } +fresh `C, `B, `A; - } +sig g : () {`C:Int, `B:Bool}-> Int +fun g () { if (do `B) 1 else do `C } - fresh `C, `B, `A { - - sig g : () {`C:Int, `B:Bool}-> Int - fun g () { if (do `B) 1 else do `C } - - sig h : () {`C:Int, `A:()}-> Int - fun h () { do `A ; do `C } - - } - -} +sig h : () {`C:Int, `A:()}-> Int +fun h () { do `A ; do `C } diff --git a/tests/labels/pollution.links b/tests/labels/pollution.links index ec6bc8154..f1fb84bb3 100644 --- a/tests/labels/pollution.links +++ b/tests/labels/pollution.links @@ -23,32 +23,30 @@ fun receives (ss) (h) () { } } -fresh `Abort { +fresh `Abort; - sig protect : (Comp(a, {`Abort:Zero, Abort:Zero | e})) -> Comp(a, {Abort{_}, `Abort:Zero|e}) - fun protect (m) () { - handle (m()) { - case k> -> k (do `Abort) - } +sig protect : (Comp(a, {`Abort:Zero, Abort:Zero | e})) -> Comp(a, {Abort{_}, `Abort:Zero|e}) +fun protect (m) () { + handle (m()) { + case k> -> k (do `Abort) } +} - sig unprotect : (Comp(a, {`Abort:Zero, Abort:Zero | e})) -> Comp(a, {`Abort{_}, Abort:Zero|e}) - fun unprotect (m) () { - handle (m()) { - case <`Abort => k> -> k (do Abort) - } +sig unprotect : (Comp(a, {`Abort:Zero, Abort:Zero | e})) -> Comp(a, {`Abort{_}, Abort:Zero|e}) +fun unprotect (m) () { + handle (m()) { + case <`Abort => k> -> k (do Abort) } +} - typename CA(a,e::Eff) = Comp(a, {Abort:Zero|e}) ; - typename CNAR(a,s,e::Eff) = Comp(a, {Receive:s, Abort:Zero, `Abort- |e}) ; - typename CAR(a,s,e::Eff) = Comp(a, {Receive:s, Abort:Zero, `Abort:Zero|e}) ; - - sig withtwo21s : (CNAR(a,Int,{ |e})) -> CA(Maybe(a), {Receive{_}, `Abort{_} |e}) - fun withtwo21s (h) { unprotect ( maybe( receives ([21,21]) ( protect ( h : CAR(a,Int,{ |e}) <- (CNAR(a,Int,{ |e})) - ) ) ) ) } +typename CA(a,e::Eff) = Comp(a, {Abort:Zero|e}) ; +typename CNAR(a,s,e::Eff) = Comp(a, {Receive:s, Abort:Zero, `Abort- |e}) ; +typename CAR(a,s,e::Eff) = Comp(a, {Receive:s, Abort:Zero, `Abort:Zero|e}) ; -} +sig withtwo21s : (CNAR(a,Int,{ |e})) -> CA(Maybe(a), {Receive{_}, `Abort{_} |e}) +fun withtwo21s (h) { unprotect ( maybe( receives ([21,21]) ( protect ( h : CAR(a,Int,{ |e}) <- (CNAR(a,Int,{ |e})) + ) ) ) ) } typename CRI(e::Eff) = Comp(Int, { |R(Int,{ |e})}) ; diff --git a/tests/labels/simple-names.links b/tests/labels/simple-names.links index 9ead05437..df34f18ed 100644 --- a/tests/labels/simple-names.links +++ b/tests/labels/simple-names.links @@ -1,9 +1,6 @@ -fresh `A { +fresh `A; +effectname E = { `A:() => () } ; +typename T = () -E-> () ; - effectname E = { `A:() => () } ; - typename T = () -E-> () ; - - sig f : T - fun f () { do `A } - -} +sig f : T +fun f () { do `A } diff --git a/tests/labels/simple.links b/tests/labels/simple.links index aa9688651..05ab3fad5 100644 --- a/tests/labels/simple.links +++ b/tests/labels/simple.links @@ -1,5 +1,2 @@ -fresh `A { - - fun f () { do `A } - -} +fresh `A; +fun f () { do `A } diff --git a/tests/labels/wrong-handler.links b/tests/labels/wrong-handler.links index 71473b7e7..cb2ffcab6 100755 --- a/tests/labels/wrong-handler.links +++ b/tests/labels/wrong-handler.links @@ -1,29 +1,22 @@ -fresh `Ask { - - sig h_ask : (Comp(a, {`Ask:Int|e})) -> Comp(a, {`Ask{_}|e}) - fun h_ask (m) () { - handle (m()) { - case <`Ask => k> -> k(42) - } - } - - sig f : () {`Ask:Int|_} -> Int - fun f () { - do `Ask + 1 - } - +fresh `Ask; +sig h_ask : (Comp(a, {`Ask:Int|e})) -> Comp(a, {`Ask{_}|e}) +fun h_ask (m) () { + handle (m()) { + case <`Ask => k> -> k(42) + } } +sig f : () {`Ask:Int|_} -> Int +fun f () { + do `Ask + 1 +} -fresh `Ask { - - sig h_ask' : (Comp(a, {`Ask:Int|e})) -> Comp(a, {`Ask{_}|e}) - fun h_ask' (m) () { - handle (m()) { - case <`Ask => k> -> k(666) - } - } +fresh `Ask; +sig h_ask' : (Comp(a, {`Ask:Int|e})) -> Comp(a, {`Ask{_}|e}) +fun h_ask' (m) () { + handle (m()) { + case <`Ask => k> -> k(666) } h_ask'(f) () From 717eba0ad519bb7ff46814c02d60a61748777486 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Hillerstr=C3=B6m?= Date: Tue, 31 Jan 2023 23:06:03 +0100 Subject: [PATCH 61/63] Fix unique label resolution --- core/desugarLabels.ml | 12 ++++++++++-- tests/labels.tests | 9 +++++++++ 2 files changed, 19 insertions(+), 2 deletions(-) diff --git a/core/desugarLabels.ml b/core/desugarLabels.ml index 333fa1cee..9b1fd3a50 100644 --- a/core/desugarLabels.ml +++ b/core/desugarLabels.ml @@ -4,7 +4,7 @@ open Sugartypes module Env = Label.Env let visitor = - object (_self) + object (self) inherit SugarTraversals.map as super val mutable label_env : Env.t = Env.empty @@ -24,7 +24,15 @@ let visitor = FreshLabel labels | b -> super#bindingnode b - end + method! phrasenode = function + | Block (bs, e) -> + let env = label_env in + let bs = self#list (fun o -> o#binding) bs in + let e = self#phrase e in + label_env <- env; + Block (bs, e) + | e -> super#phrasenode e + end let program p = visitor#program p diff --git a/tests/labels.tests b/tests/labels.tests index 6168bd75c..61162a4c9 100644 --- a/tests/labels.tests +++ b/tests/labels.tests @@ -54,3 +54,12 @@ Avoiding pollution [2] filemode : true stdout : 42 : Int args : --enable-handlers + +Lexical scoping [1] +fun() { var x = { fresh `A; 42 }; do `A } +stderr : @.* +exit : 1 + +Lexical scoping [2] +fun() { var x = { fresh `A; ignore(42); fun() { do `A } }; x } +stdout : fun : () -> () {`A:() => b|_}-> b \ No newline at end of file From ec9218108e64f4f8968bbabdb7c18f4f58f69a0f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Hillerstr=C3=B6m?= Date: Tue, 31 Jan 2023 23:10:27 +0100 Subject: [PATCH 62/63] Fix session exceptions regression --- core/desugarSessionExceptions.ml | 3 ++- core/typeSugar.ml | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/core/desugarSessionExceptions.ml b/core/desugarSessionExceptions.ml index ab962521b..0943aaff5 100644 --- a/core/desugarSessionExceptions.ml +++ b/core/desugarSessionExceptions.ml @@ -108,7 +108,8 @@ object (o : 'self_type) let outer_effects = o#lookup_effects in let fail_cont_ty = - Types.make_pure_function_type [] (Types.empty_type) in + Types.make_operation_type [] Types.empty_type + in let inner_effects = effect_row diff --git a/core/typeSugar.ml b/core/typeSugar.ml index aa2bcda7f..a1e59c58f 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -4544,7 +4544,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = (T.Row (Label.Map.empty, rho, false)) in let try_effects = Types.row_with - (Value.session_exception_operation, T.Present (Types.make_pure_function_type [] Types.empty_type)) + (Value.session_exception_operation, T.Present (Types.make_operation_type [] Types.empty_type)) (T.Row (Label.Map.empty, rho, false)) in unify ~handle:Gripers.try_effect From 192c437e95c51d289e0f6a7a8a2abfe0040116ff Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Hillerstr=C3=B6m?= Date: Tue, 31 Jan 2023 23:24:53 +0100 Subject: [PATCH 63/63] Slight hack to make unique labels work properly with elaborated modules. --- bin/repl.ml | 2 +- core/desugarLabels.ml | 11 ++++++++--- core/desugarModules.ml | 5 +++++ tests/labels.tests | 11 ++++++++++- 4 files changed, 24 insertions(+), 5 deletions(-) diff --git a/bin/repl.ml b/bin/repl.ml index 4364a3ee3..9c7727086 100644 --- a/bin/repl.ml +++ b/bin/repl.ml @@ -185,7 +185,7 @@ let rec directives : (string * ((Context.t -> string list -> Context.t) * string else (Module_hacks.Name.prettify name) in Printf.fprintf stderr " %-16s : %s\n" - name ty) + name ty) (* TODO(dhil): should really "prettify" ty here too as it may contain unique labels that have been expanded. *) nenv (); context), "display the current value environment"); diff --git a/core/desugarLabels.ml b/core/desugarLabels.ml index 9b1fd3a50..8f059f271 100644 --- a/core/desugarLabels.ml +++ b/core/desugarLabels.ml @@ -19,9 +19,14 @@ let visitor = method! bindingnode = function | FreshLabel labels -> - let labels = List.map Label.bind_local labels in - label_env <- Env.bind_labels labels label_env ; - FreshLabel labels + let labels = List.map Label.bind_local labels in + label_env <- Env.bind_labels labels label_env ; + FreshLabel labels + | Module { binder; members } -> + let env = label_env in + let members = self#list (fun o -> o#binding) members in + label_env <- env; + Module { binder; members } | b -> super#bindingnode b method! phrasenode = function diff --git a/core/desugarModules.ml b/core/desugarModules.ml index c2a481ea7..1a0f0a439 100644 --- a/core/desugarModules.ml +++ b/core/desugarModules.ml @@ -514,6 +514,11 @@ and desugar ?(toplevel=false) (renamer' : Epithet.t) (scope' : Scope.t) = let b = self#binding b in b :: self#bindings bs + method! label = function + | Label.Local (textual_name, uid) -> + Label.Local (Epithet.expand renamer textual_name, uid) + | l -> l + method! program (bs, exp) = (* It is crucial that we enforce left-to-right evaluation of [bs] and [exp]. Note that OCaml uses right-to-left evaluation diff --git a/tests/labels.tests b/tests/labels.tests index 61162a4c9..277b2a90f 100644 --- a/tests/labels.tests +++ b/tests/labels.tests @@ -62,4 +62,13 @@ exit : 1 Lexical scoping [2] fun() { var x = { fresh `A; ignore(42); fun() { do `A } }; x } -stdout : fun : () -> () {`A:() => b|_}-> b \ No newline at end of file +stdout : fun : () -> () {`A:() => b|_}-> b + +Lexical scoping [3] +{ module T { fresh `A; } fun() { do `A } } +stderr : @.* +exit : 1 + +Lexical scoping [4] +module T { fresh `A; fun f() { do `A } } +stdout : () : () \ No newline at end of file