From aa60c5bb3c395fa99a8e1044eccc3e0832cf963e Mon Sep 17 00:00:00 2001 From: Jan Stolarek Date: Tue, 19 Feb 2019 10:24:20 +0000 Subject: [PATCH 01/28] Don't define recursive Sugartypes unless necessary --- core/sugartypes.ml | 30 +++++++++++++++++++++--------- 1 file changed, 21 insertions(+), 9 deletions(-) diff --git a/core/sugartypes.ml b/core/sugartypes.ml index 219f2ea53..6d9856fe2 100644 --- a/core/sugartypes.ml +++ b/core/sugartypes.ml @@ -198,6 +198,18 @@ and pattern = patternnode with_pos type spawn_kind = Angel | Demon | Wait [@@deriving show] +type sec = [`Minus | `FloatMinus | `Project of name | `Name of name] + [@@deriving show] + +type declared_linearity = [ `Lin | `Unl ] + [@@deriving show] + +type fn_dep = string * string + [@@deriving show] + +type handler_depth = Deep | Shallow + [@@deriving show] + type replace_rhs = [ | `Literal of string | `Splice of phrase @@ -221,7 +233,6 @@ and regex = | Replace of (regex * replace_rhs) and clause = pattern * phrase and funlit = pattern list list * phrase -and handler_depth = Deep | Shallow and handlerlit = handler_depth * pattern * clause list * pattern list list option (* computation arg, cases, parameters *) and handler = { sh_expr: phrase; @@ -243,9 +254,6 @@ and iterpatt = [ | `List of pattern * phrase | `Table of pattern * phrase ] -and sec = [`Minus | `FloatMinus | `Project of name | `Name of name] -and declared_linearity = [ `Lin | `Unl ] -and fn_dep = string * string and phrasenode = [ | `Constant of constant | `Var of name @@ -329,11 +337,6 @@ and bindingnode = [ ] and binding = bindingnode with_pos and block_body = binding list * phrase -and directive = string * string list -and sentence = -| Definitions of binding list -| Expression of phrase -| Directive of directive and cp_phrasenode = | Unquote of (binding list * phrase) | Grab of (string * (Types.datatype * tyarg list) option) * binder option * cp_phrase @@ -346,6 +349,15 @@ and cp_phrasenode = and cp_phrase = cp_phrasenode with_pos [@@deriving show] +type directive = string * string list + [@@deriving show] + +type sentence = +| Definitions of binding list +| Expression of phrase +| Directive of directive + [@@deriving show] + type program = binding list * phrase option [@@deriving show] From 25e9ff56183d121ac4845b1399c6c0e32f217ad9 Mon Sep 17 00:00:00 2001 From: Jan Stolarek Date: Tue, 19 Feb 2019 11:32:17 +0000 Subject: [PATCH 02/28] Redefine patterns as an ordinary variant datatype --- core/compilePatterns.ml | 61 +++--- core/desugarCP.ml | 7 +- core/desugarDatatypes.ml | 4 +- core/desugarFormlets.ml | 4 +- core/desugarFors.ml | 10 +- core/desugarHandlers.ml | 125 ++++++------ core/desugarModules.ml | 4 +- core/desugarSessionExceptions.ml | 8 +- core/moduleUtils.ml | 13 +- core/parser.mly | 30 +-- core/sugarConstructors.ml | 8 +- core/sugarConstructorsIntf.ml | 18 +- core/sugarTraversals.ml | 125 ++++++------ core/sugarTraversals.mli | 12 +- core/sugartoir.ml | 2 +- core/sugartypes.ml | 98 ++++----- core/transformSugar.ml | 47 ++--- core/transformSugar.mli | 6 +- core/typeSugar.ml | 332 ++++++++++++++++--------------- 19 files changed, 475 insertions(+), 439 deletions(-) diff --git a/core/compilePatterns.ml b/core/compilePatterns.ml index b152ad105..d6c673df1 100644 --- a/core/compilePatterns.ml +++ b/core/compilePatterns.ml @@ -74,9 +74,9 @@ let lookup_name name (nenv, _tenv, _eff, _penv) = let lookup_effects (_nenv, _tenv, eff, _penv) = eff -let rec desugar_pattern : Ir.scope -> Sugartypes.pattern -> pattern * raw_env = +let rec desugar_pattern : Ir.scope -> Sugartypes.Pattern.t -> pattern * raw_env = fun scope {Sugartypes.node=p; Sugartypes.pos} -> - let pp = desugar_pattern scope in + let desugar_pat = desugar_pattern scope in let empty = (NEnv.empty, TEnv.empty, Types.make_empty_open_row (`Any, `Any)) in let (++) (nenv, tenv, _) (nenv', tenv', eff') = (NEnv.extend nenv nenv', TEnv.extend tenv tenv', eff') in let fresh_binder (nenv, tenv, eff) bndr = @@ -86,38 +86,39 @@ let rec desugar_pattern : Ir.scope -> Sugartypes.pattern -> pattern * raw_env = let xb, x = Var.fresh_var (t, name, scope) in xb, (NEnv.bind nenv (name, x), TEnv.bind tenv (x, t), eff) in + let open Sugartypes.Pattern in match p with - | `Any -> `Any, empty - | `Nil -> `Nil, empty - | `Cons (p, ps) -> - let p, env = pp p in - let ps, env' = pp ps in + | Any -> `Any, empty + | Nil -> `Nil, empty + | Cons (p, ps) -> + let p, env = desugar_pat p in + let ps, env' = desugar_pat ps in `Cons (p, ps), env ++ env' - | `List [] -> pp (Sugartypes.with_pos pos `Nil) - | `List (p::ps) -> - let p, env = pp p in - let ps, env' = pp (Sugartypes.with_pos pos (`List ps)) in + | List [] -> desugar_pat (Sugartypes.with_pos pos Nil) + | List (p::ps) -> + let p, env = desugar_pat p in + let ps, env' = desugar_pat (Sugartypes.with_pos pos (List ps)) in `Cons (p, ps), env ++ env' - | `Variant (name, None) -> `Variant (name, `Any), empty - | `Variant (name, Some p) -> - let p, env = pp p in + | Variant (name, None) -> `Variant (name, `Any), empty + | Variant (name, Some p) -> + let p, env = desugar_pat p in `Variant (name, p), env - | `Effect (name, ps, k) -> + | Effect (name, ps, k) -> let ps, env = List.fold_right (fun p (ps, env) -> - let p', env' = pp p in + let p', env' = desugar_pat p in (p' :: ps, env ++ env')) ps ([], empty) in - let k, env' = pp k in + let k, env' = desugar_pat k in `Effect (name, ps, k), env ++ env' - | `Negative names -> `Negative (StringSet.from_list names), empty - | `Record (bs, p) -> + | Negative names -> `Negative (StringSet.from_list names), empty + | Record (bs, p) -> let bs, env = List.fold_right (fun (name, p) (bs, env) -> - let p, env' = pp p in + let p, env' = desugar_pat p in StringMap.add name p bs, env ++ env') bs (StringMap.empty, empty) in @@ -125,26 +126,26 @@ let rec desugar_pattern : Ir.scope -> Sugartypes.pattern -> pattern * raw_env = match p with | None -> None, env | Some p -> - let p, env' = pp p in + let p, env' = desugar_pat p in Some p, env ++ env' in `Record (bs, p), env - | `Tuple ps -> + | Tuple ps -> let bs = mapIndex (fun p i -> (string_of_int (i+1), p)) ps in - pp (Sugartypes.with_pos pos (`Record (bs, None))) - | `Constant constant -> + desugar_pat (Sugartypes.with_pos pos (Record (bs, None))) + | Constant constant -> `Constant constant, empty - | `Variable b -> + | Variable b -> let xb, env = fresh_binder empty b in `Variable xb, env - | `As (b, p) -> + | As (b, p) -> let xb, env = fresh_binder empty b in - let p, env' = pp p in + let p, env' = desugar_pat p in `As (xb, p), env ++ env' - | `HasType (p, (_, Some t)) -> - let p, env = pp p in + | HasType (p, (_, Some t)) -> + let p, env = desugar_pat p in `HasType (p, t), env - | `HasType (_, (_, None)) -> assert false + | HasType (_, (_, None)) -> assert false type raw_bound_computation = raw_env -> computation type bound_computation = env -> computation diff --git a/core/desugarCP.ml b/core/desugarCP.ml index 3d60b262b..bc19c3d13 100644 --- a/core/desugarCP.ml +++ b/core/desugarCP.ml @@ -41,8 +41,9 @@ object (o : 'self_type) let (o, e, t) = desugar_cp o p in let o = o#restore_envs envs in o, block_node - ([val_binding (with_dummy_pos (`Record ([("1", variable_pat ~ty:u x); - ("2", variable_pat ~ty:s c)], None))) + ([val_binding (with_dummy_pos ( + Pattern.Record ([("1", variable_pat ~ty:u x); + ("2", variable_pat ~ty:s c)], None))) (fn_appl receive_str grab_tyargs [var c])], with_dummy_pos e), t | Give ((c, _), None, p) -> @@ -76,7 +77,7 @@ object (o : 'self_type) let envs = o#backup_envs in let o = {< var_env = TyEnv.bind (o#get_var_env ()) (c, TypeUtils.choice_at label s) >} in let (o, p, t) = desugar_cp o p in - let pat : pattern = with_dummy_pos (`Variant (label, + let pat : Pattern.t = with_dummy_pos (Pattern.Variant (label, 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 diff --git a/core/desugarDatatypes.ml b/core/desugarDatatypes.ml index f48405e33..0b13f2aeb 100644 --- a/core/desugarDatatypes.ml +++ b/core/desugarDatatypes.ml @@ -445,9 +445,9 @@ object (self) val alias_env = initial_alias_env method! patternnode = function - | `HasType (pat, dt) -> + | Pattern.HasType (pat, dt) -> let o, pat = self#pattern pat in - o, `HasType (pat, Desugar.datatype' map alias_env dt) + o, Pattern.HasType (pat, Desugar.datatype' map alias_env dt) | p -> super#patternnode p diff --git a/core/desugarFormlets.ml b/core/desugarFormlets.ml index c4da2d60c..fb545ed12 100644 --- a/core/desugarFormlets.ml +++ b/core/desugarFormlets.ml @@ -33,7 +33,7 @@ object (o : 'self_type) (this roughly corresponds to the dagger transformation) *) - method formlet_patterns : Sugartypes.phrase -> (Sugartypes.pattern list * Sugartypes.phrase list * Types.datatype list) = + method formlet_patterns : Sugartypes.phrase -> (Sugartypes.Pattern.t list * Sugartypes.phrase list * Types.datatype list) = fun ph -> match ph.node with | _ when is_raw ph -> @@ -46,7 +46,7 @@ object (o : 'self_type) (ft, Instantiate.alias "Formlet" [`Type t] tycon_env) in let name = Utility.gensym ~prefix:"_formlet_" () in let (xb, x) = (binder name ~ty:t, var name) in - [with_dummy_pos (`As (xb, p))], [x], [t] + [with_dummy_pos (Pattern.As (xb, p))], [x], [t] | `Xml (_, _, _, [node]) -> o#formlet_patterns node | `Xml (_, _, _, contents) -> diff --git a/core/desugarFors.ml b/core/desugarFors.ml index 0d016a7e3..487e06efe 100644 --- a/core/desugarFors.ml +++ b/core/desugarFors.ml @@ -61,7 +61,7 @@ let results : Types.row -> let qt = t in let qst = Types.make_tuple_type ts in - let ((qsb, qs) : Sugartypes.pattern list * Sugartypes.phrase list) = + let ((qsb, qs) : Sugartypes.Pattern.t list * Sugartypes.phrase list) = List.split (List.map2 (fun x t -> (variable_pat ~ty:t x, var x)) xs ts) in let qb, q = (variable_pat ~ty:t x, var x) in @@ -100,7 +100,7 @@ object (o : 'self_type) *) method qualifiers : Sugartypes.iterpatt list -> 'self_type * - (Sugartypes.phrase list * Sugartypes.pattern list * Sugartypes.name list * + (Sugartypes.phrase list * Sugartypes.Pattern.t list * Sugartypes.name list * Types.datatype list) = fun qs -> let o, (es, ps, xs, ts) = @@ -115,7 +115,8 @@ object (o : 'self_type) let var = Utility.gensym ~prefix:"_for_" () in let xb = binder ~ty:t var in - o, (e::es, with_dummy_pos (`As (xb, p))::ps, var::xs, element_type::ts) + o, (e::es, with_dummy_pos (Pattern.As (xb, p))::ps, + var::xs, element_type::ts) | `Table (p, e) -> let (o, e, t) = o#phrase e in let (o, p) = o#pattern p in @@ -130,7 +131,8 @@ object (o : 'self_type) let e = fn_appl "AsList" [r; w; n; eff] [e] in let var = Utility.gensym ~prefix:"_for_" () in let xb = binder ~ty:t var in - o, (e::es, with_dummy_pos (`As (xb, p))::ps, var::xs, element_type::ts)) + o, (e::es, with_dummy_pos (Pattern.As (xb, p))::ps, + var::xs, element_type::ts)) (o, ([], [], [], [])) qs in diff --git a/core/desugarHandlers.ml b/core/desugarHandlers.ml index acadeb3c3..7fa2eb986 100644 --- a/core/desugarHandlers.ml +++ b/core/desugarHandlers.ml @@ -20,47 +20,49 @@ open SugarConstructors.Make (* Computes the set of names in a given pattern *) -let rec names : pattern -> string list +let rec names : Pattern.t -> string list = fun pat -> + let open Pattern in match pat.node with - `Variant (_,pat_opt) -> opt_app names [] pat_opt - | `Record (name_pats,pat_opt) -> + Variant (_,pat_opt) -> opt_app names [] pat_opt + | Record (name_pats,pat_opt) -> let optns = opt_app names [] pat_opt in (List.fold_left (fun ns p -> (names p) @ ns) [] (List.map snd name_pats)) @ optns - | `Variable bndr -> [name_of_binder bndr] - | `Cons (pat,pat') -> (names pat) @ (names pat') - | `Tuple pats - | `List pats -> List.fold_left (fun ns pat -> (names pat) @ ns ) [] pats - | `Negative ns' -> List.fold_left (fun ns n -> n :: ns) [] ns' - | `As (bndr,pat) -> [name_of_binder bndr] @ (names pat) - | `HasType (pat,_) -> names pat - | _ -> [] + | Variable bndr -> [name_of_binder bndr] + | Cons (pat,pat') -> (names pat) @ (names pat') + | Tuple pats + | List pats -> List.fold_left (fun ns pat -> (names pat) @ ns ) [] pats + | Negative ns' -> List.fold_left (fun ns n -> n :: ns) [] ns' + | As (bndr,pat) -> [name_of_binder bndr] @ (names pat) + | HasType (pat,_) -> names pat + | _ -> [] (* This function resolves name conflicts in a given pattern p. The conflict resolution is simple: Given a set of conflicting names ns, then for every name n if (n \in p && n \in ns) then n gets rewritten as _. *) -let resolve_name_conflicts : pattern -> stringset -> pattern +let resolve_name_conflicts : Pattern.t -> stringset -> Pattern.t = fun pat conflicts -> - let rec hide_names : pattern -> pattern + let rec hide_names : Pattern.t -> Pattern.t = fun pat -> with_dummy_pos begin + let open Pattern in match pat.node with - | `Variant (label, pat_opt) -> `Variant (label, opt_map hide_names pat_opt) - | `Record (name_pats, pat_opt) -> `Record (List.map (fun (label, pat) -> (label, hide_names pat)) name_pats, opt_map hide_names pat_opt) - | `Variable bndr -> + | Variant (label, pat_opt) -> Variant (label, opt_map hide_names pat_opt) + | Record (name_pats, pat_opt) -> Record (List.map (fun (label, pat) -> (label, hide_names pat)) name_pats, opt_map hide_names pat_opt) + | Variable bndr -> if StringSet.mem (name_of_binder bndr) conflicts - then `Any + then Pattern.Any else pat.node - | `Cons (pat, pat') -> `Cons (hide_names pat, hide_names pat') - | `Tuple pats -> `Tuple (List.map hide_names pats) - | `List pats -> `List (List.map hide_names pats) - | `Negative _ -> failwith "desugarHandlers.ml: hide_names `Negative not yet implemented" - | `As (bndr,pat) -> let {node;_} as pat = hide_names pat in + | Cons (pat, pat') -> Cons (hide_names pat, hide_names pat') + | Tuple pats -> Tuple (List.map hide_names pats) + | List pats -> List (List.map hide_names pats) + | Negative _ -> failwith "desugarHandlers.ml: hide_names Negative not yet implemented" + | As (bndr,pat) -> let {node;_} as pat = hide_names pat in if StringSet.mem (name_of_binder bndr) conflicts then node - else `As (bndr, pat) - | `HasType (pat, t) -> `HasType (hide_names pat, t) + else As (bndr, pat) + | HasType (pat, t) -> HasType (hide_names pat, t) | _ -> pat.node end in hide_names pat @@ -82,7 +84,7 @@ let resolve_name_conflicts : pattern -> stringset -> pattern and the parameters of the introduced functions which encompass clause bodies. Currently, the clause-parameters shadow the introduced function parameters. *) -let parameterize : (pattern * phrase) list -> pattern list list option -> (pattern * phrase) list +let parameterize : (Pattern.t * phrase) list -> Pattern.t list list option -> (Pattern.t * phrase) list = fun cases params -> match params with None @@ -100,44 +102,46 @@ let parameterize : (pattern * phrase) list -> pattern list list option -> (patte (* This function assigns fresh names to `Any (_) *) -let rec deanonymize : pattern -> pattern +let rec deanonymize : Pattern.t -> Pattern.t = fun pat -> with_dummy_pos begin + let open Pattern in match pat.node with - `Any -> `Variable (binder (Utility.gensym ~prefix:"dsh" ())) - | `Nil -> `Nil - | `Cons (p, p') -> `Cons (deanonymize p, deanonymize p') - | `List ps -> `List (List.map deanonymize ps) - | `Effect (name, ps, kpat) -> `Effect (name, List.map deanonymize ps, deanonymize kpat) - | `Variant (name, pat_opt) -> `Variant (name, opt_map deanonymize pat_opt) - | `Negative ns -> `Negative ns - | `Record (name_pats, pat_opt) -> `Record (List.map (fun (n,p) -> (n, deanonymize p)) name_pats, opt_map deanonymize pat_opt) - | `Tuple ps -> `Tuple (List.map deanonymize ps) - | `Constant c -> `Constant c - | `Variable b -> `Variable b - | `As (b,p) -> `As (b, deanonymize p) - | `HasType (p,t) -> `HasType (deanonymize p, t) + | Any -> Variable (binder (Utility.gensym ~prefix:"dsh" ())) + | Nil -> Nil + | Cons (p, p') -> Cons (deanonymize p, deanonymize p') + | List ps -> List (List.map deanonymize ps) + | Effect (name, ps, kpat) -> Effect (name, List.map deanonymize ps, deanonymize kpat) + | Variant (name, pat_opt) -> Variant (name, opt_map deanonymize pat_opt) + | Negative ns -> Negative ns + | Record (name_pats, pat_opt) -> Record (List.map (fun (n,p) -> (n, deanonymize p)) name_pats, opt_map deanonymize pat_opt) + | Tuple ps -> Tuple (List.map deanonymize ps) + | Constant c -> Constant c + | Variable b -> Variable b + | As (b,p) -> As (b, deanonymize p) + | HasType (p,t) -> HasType (deanonymize p, t) end (* This function translates a pattern into a phrase. It assumes that the given pattern has been deanonymised. *) -let rec phrase_of_pattern : pattern -> phrase +let rec phrase_of_pattern : Pattern.t -> phrase = fun pat -> begin + let open Pattern in match pat.node with - `Any -> assert false (* can never happen after the fresh name generation pass *) - | `Nil -> list [] - | `Cons (hd, tl) -> infix_appl' (phrase_of_pattern hd) `Cons (phrase_of_pattern tl) - | `List ps -> list (List.map phrase_of_pattern ps) - | `Effect _ -> assert false - | `Variant (name, pat_opt) -> constructor name ?body:(opt_map phrase_of_pattern pat_opt) - | `Negative _ -> failwith "desugarHandlers.ml: phrase_of_pattern case for `Negative not yet implemented!" - | `Record (name_pats, pat_opt) -> record (List.map (fun (n,p) -> (n, phrase_of_pattern p)) name_pats) - ?exp:(opt_map phrase_of_pattern pat_opt) - | `Tuple ps -> tuple (List.map phrase_of_pattern ps) - | `Constant c -> constant c - | `Variable b -> var (name_of_binder b) - | `As (b,_) -> var (name_of_binder b) - | `HasType (p,t) -> with_dummy_pos (`TypeAnnotation (phrase_of_pattern p, t)) + Any -> assert false (* can never happen after the fresh name generation pass *) + | Nil -> list [] + | Cons (hd, tl) -> infix_appl' (phrase_of_pattern hd) `Cons (phrase_of_pattern tl) + | List ps -> list (List.map phrase_of_pattern ps) + | Effect _ -> assert false + | Variant (name, pat_opt) -> constructor name ?body:(opt_map phrase_of_pattern pat_opt) + | Negative _ -> failwith "desugarHandlers.ml: phrase_of_pattern case for `Negative not yet implemented!" + | Record (name_pats, pat_opt) -> record (List.map (fun (n,p) -> (n, phrase_of_pattern p)) name_pats) + ?exp:(opt_map phrase_of_pattern pat_opt) + | Tuple ps -> tuple (List.map phrase_of_pattern ps) + | Constant c -> constant c + | Variable b -> var (name_of_binder b) + | As (b,_) -> var (name_of_binder b) + | HasType (p,t) -> with_dummy_pos (`TypeAnnotation (phrase_of_pattern p, t)) end (* This function applies the list of parameters to the generated handle. *) @@ -145,15 +149,18 @@ let apply_params : phrase -> phrase list list -> phrase = fun h pss -> List.fold_right (fun ps acc -> with_dummy_pos (`FnAppl (acc, ps)) ) (List.rev pss) h -let split_handler_cases : (pattern * phrase) list -> (pattern * phrase) list * (pattern * phrase) list +let split_handler_cases : (Pattern.t * phrase) list -> (Pattern.t * phrase) list * (Pattern.t * phrase) list = fun cases -> let ret, ops = List.fold_left (fun (val_cases, eff_cases) (pat, body) -> match pat.node with - | `Variant ("Return", None) -> failwith "Improper pattern-matching on return value" - | `Variant ("Return", Some pat) -> (pat, body) :: val_cases, eff_cases - | _ -> val_cases, (pat, body) :: eff_cases) + | Pattern.Variant ("Return", None) -> + failwith "Improper pattern-matching on return value" + | Pattern.Variant ("Return", Some pat) -> + (pat, body) :: val_cases, eff_cases + | _ -> + val_cases, (pat, body) :: eff_cases) ([], []) cases in match ret with @@ -179,7 +186,7 @@ let funlit_of_handlerlit : Sugartypes.handlerlit -> Sugartypes.funlit let params = List.map (List.map phrase_of_pattern) params in apply_params handle params in - let fnparams : pattern list list = [[]] in + let fnparams : Pattern.t list list = [[]] in let fnparams = match params with Some params -> params @ ([m] :: fnparams) diff --git a/core/desugarModules.ml b/core/desugarModules.ml index 1b4ff2990..eb4907f3f 100644 --- a/core/desugarModules.ml +++ b/core/desugarModules.ml @@ -192,10 +192,10 @@ and perform_renaming module_table path term_ht type_ht = (self#bind_shadow_term n fqn, set_binder_name bndr fqn) method! patternnode = function - | `Variant (n, p_opt) -> + | Pattern.Variant (n, p_opt) -> let fqn = resolve n term_shadow_table in let (o, p_opt') = self#option (fun o -> o#pattern) p_opt in - (o, `Variant (fqn, p_opt')) + (o, Pattern.Variant (fqn, p_opt')) | p -> super#patternnode p method! row = function diff --git a/core/desugarSessionExceptions.ml b/core/desugarSessionExceptions.ml index afae3ae83..7c63e9522 100644 --- a/core/desugarSessionExceptions.ml +++ b/core/desugarSessionExceptions.ml @@ -69,8 +69,8 @@ object (o : 'self_type) * continuation argument. *) let cont_pat = variable_pat ~ty:`Not_typed (Utility.gensym ~prefix:"dsh" ()) in - let otherwise_pat : Sugartypes.pattern = - with_dummy_pos (`Effect (failure_op_name, [], cont_pat)) in + let otherwise_pat : Sugartypes.Pattern.t = + with_dummy_pos (Pattern.Effect (failure_op_name, [], cont_pat)) in let otherwise_clause = (otherwise_pat, otherwise_phr) in @@ -172,8 +172,8 @@ let wrap_linear_handlers prog = constructor ~body:(var fresh_var) "Just", constructor "Nothing", dtopt)), [ - (with_dummy_pos (`Variant ("Just", (Some x))), super#phrase m); - (with_dummy_pos (`Variant ("Nothing", None)), super#phrase n) + (with_dummy_pos (Pattern.Variant ("Just", (Some x))), super#phrase m); + (with_dummy_pos (Pattern.Variant ("Nothing", None)), super#phrase n) ], None)) | p -> super#phrase p end diff --git a/core/moduleUtils.ml b/core/moduleUtils.ml index 6388c2ecc..48f7305f9 100644 --- a/core/moduleUtils.ml +++ b/core/moduleUtils.ml @@ -94,13 +94,14 @@ let get_pat_vars () = method get_bindings = bindings (* Order doesn't matter *) method! patternnode = function - | `Variant (_n, p_opt) -> - self#option (fun o p -> o#pattern p) p_opt + | Pattern.Variant (_n, p_opt) -> + self#option (fun o p -> o#pattern p) p_opt (* | `Negative ns -> self#list (fun o p -> o#add_binding p) ns *) - | `Record (ls, p_opt) -> - let o1 = self#list (fun o (_, p) -> o#pattern p) ls in - o1#option (fun o p -> o#pattern p) p_opt - | `Variable bndr -> self#add_binding (Sugartypes.name_of_binder bndr) + | Pattern.Record (ls, p_opt) -> + let o1 = self#list (fun o (_, p) -> o#pattern p) ls in + o1#option (fun o p -> o#pattern p) p_opt + | Pattern.Variable bndr -> + self#add_binding (Sugartypes.name_of_binder bndr) | p -> super#patternnode p end diff --git a/core/parser.mly b/core/parser.mly index 23bd8be1e..7a34281a6 100644 --- a/core/parser.mly +++ b/core/parser.mly @@ -240,9 +240,9 @@ let parseRegexFlags f = %type regex_pattern_alternate %type regex_pattern %type regex_pattern_sequence -%type pattern +%type pattern %type tlfunbinding %type postfix_expression %type primary_expression @@ -338,7 +338,7 @@ typed_handler_binding: handler_parameterization { ($3, hnlit_arg $1 $2 $4) } optional_computation_parameter: -| /* empty */ { with_pos $sloc `Any } +| /* empty */ { with_pos $sloc Pattern.Any } | LBRACKET pattern RBRACKET { $2 } perhaps_uinteger: @@ -1139,40 +1139,40 @@ regex_pattern_sequence: */ pattern: | typed_pattern { $1 } -| typed_pattern COLON primary_datatype_pos { with_pos $loc (`HasType ($1, datatype $3)) } +| typed_pattern COLON primary_datatype_pos { with_pos $loc (Pattern.HasType ($1, datatype $3)) } typed_pattern: | cons_pattern { $1 } -| cons_pattern AS VARIABLE { with_pos $loc (`As (binder ~ppos:$loc($3) $3, $1)) } +| cons_pattern AS VARIABLE { with_pos $loc (Pattern.As (binder ~ppos:$loc($3) $3, $1)) } cons_pattern: | constructor_pattern { $1 } -| constructor_pattern COLONCOLON cons_pattern { with_pos $loc (`Cons ($1, $3)) } +| constructor_pattern COLONCOLON cons_pattern { with_pos $loc (Pattern.Cons ($1, $3)) } constructor_pattern: | negative_pattern { $1 } -| CONSTRUCTOR parenthesized_pattern? { with_pos $loc (`Variant ($1, $2)) } +| CONSTRUCTOR parenthesized_pattern? { with_pos $loc (Pattern.Variant ($1, $2)) } constructors: | separated_nonempty_list(COMMA, CONSTRUCTOR) { $1 } negative_pattern: | primary_pattern { $1 } -| MINUS CONSTRUCTOR { with_pos $loc (`Negative [$2]) } -| MINUS LPAREN constructors RPAREN { with_pos $loc (`Negative $3) } +| MINUS CONSTRUCTOR { with_pos $loc (Pattern.Negative [$2]) } +| MINUS LPAREN constructors RPAREN { with_pos $loc (Pattern.Negative $3) } parenthesized_pattern: -| LPAREN RPAREN { with_pos $loc (`Tuple []) } +| LPAREN RPAREN { with_pos $loc (Pattern.Tuple []) } | LPAREN pattern RPAREN { $2 } -| LPAREN pattern COMMA patterns RPAREN { with_pos $loc (`Tuple ($2 :: $4)) } -| LPAREN labeled_patterns preceded(VBAR, pattern)? RPAREN { with_pos $loc (`Record ($2, $3)) } +| LPAREN pattern COMMA patterns RPAREN { with_pos $loc (Pattern.Tuple ($2 :: $4)) } +| LPAREN labeled_patterns preceded(VBAR, pattern)? RPAREN { with_pos $loc (Pattern.Record ($2, $3)) } primary_pattern: | VARIABLE { variable_pat ~ppos:$loc $1 } | UNDERSCORE { any_pat $loc } -| constant { with_pos $loc (`Constant $1) } -| LBRACKET RBRACKET { with_pos $loc `Nil } -| LBRACKET patterns RBRACKET { with_pos $loc (`List $2) } +| constant { with_pos $loc (Pattern.Constant $1) } +| LBRACKET RBRACKET { with_pos $loc Pattern.Nil } +| LBRACKET patterns RBRACKET { with_pos $loc (Pattern.List $2) } | parenthesized_pattern { $1 } patterns: diff --git a/core/sugarConstructors.ml b/core/sugarConstructors.ml index fd9657df3..2f737f19d 100644 --- a/core/sugarConstructors.ml +++ b/core/sugarConstructors.ml @@ -51,7 +51,7 @@ module SugarConstructors (Position : Pos) (* Stores either a name of variable to be used in a binding pattern or the pattern itself. Used for passing an argument to val_binding. *) - type name_or_pat = Name of name | Pat of pattern + type name_or_pat = Name of name | Pat of Pattern.t (* Optionally stores a datatype signature. Isomporphic to Option. *) type signature = Sig of (name with_pos * datatype') with_pos | NoSig @@ -117,13 +117,13 @@ module SugarConstructors (Position : Pos) (* Create a variable pattern with a given name. *) let variable_pat ?(ppos=dp) ?ty name = - with_pos ppos (`Variable (binder ~ppos ?ty name)) + with_pos ppos (Pattern.Variable (binder ~ppos ?ty name)) (* Create a tuple pattern. *) let tuple_pat ?(ppos=dp) pats = - with_pos ppos (`Tuple pats) + with_pos ppos (Pattern.Tuple pats) - let any_pat ppos = with_pos ppos `Any + let any_pat ppos = with_pos ppos Pattern.Any (** Fieldspec *) diff --git a/core/sugarConstructorsIntf.ml b/core/sugarConstructorsIntf.ml index 86cfc783e..e17eeca7d 100644 --- a/core/sugarConstructorsIntf.ml +++ b/core/sugarConstructorsIntf.ml @@ -47,7 +47,7 @@ module type SugarConstructorsSig = sig (* Helper data types and functions for passing arguments to smart constructors. *) type name_or_pat = Name of name - | Pat of pattern + | Pat of Pattern.t type signature = Sig of (name with_pos * datatype') with_pos | NoSig @@ -76,9 +76,9 @@ module type SugarConstructorsSig = sig val binder : ?ppos:t -> ?ty:Types.datatype -> name -> binder (* Patterns *) - val variable_pat : ?ppos:t -> ?ty:Types.datatype -> name -> pattern - val tuple_pat : ?ppos:t -> pattern list -> pattern - val any_pat : t -> pattern + val variable_pat : ?ppos:t -> ?ty:Types.datatype -> name -> Pattern.t + val tuple_pat : ?ppos:t -> Pattern.t list -> Pattern.t + val any_pat : t -> Pattern.t (* Fieldspec *) val present : fieldspec @@ -91,10 +91,10 @@ module type SugarConstructorsSig = sig (* Various phrases *) val fun_lit : ?ppos:t -> ?args:((Types.datatype * Types.row) list) - -> ?location:location -> declared_linearity -> pattern list list -> phrase + -> ?location:location -> declared_linearity -> Pattern.t list list -> phrase -> phrase val hnlit_arg - : handler_depth -> pattern -> clause list * pattern list list option + : handler_depth -> Pattern.t -> clause list * Pattern.t list list option -> handlerlit val handler_lit : ?ppos:t -> handlerlit -> phrase @@ -112,7 +112,7 @@ module type SugarConstructorsSig = sig (* Bindings *) val fun_binding : ?ppos:t -> signature - -> (declared_linearity * name * pattern list list * location * phrase) + -> (declared_linearity * name * Pattern.t list list * location * phrase) -> binding val fun_binding' : ?ppos:t -> ?linearity:declared_linearity -> ?tyvars:tyvar list @@ -125,7 +125,7 @@ module type SugarConstructorsSig = sig : ?ppos:t -> signature -> (name_or_pat * phrase * location) -> binding val val_binding - : ?ppos:t -> pattern -> phrase + : ?ppos:t -> Pattern.t -> phrase -> binding (* Database queries *) @@ -150,7 +150,7 @@ module type SugarConstructorsSig = sig (* Handlers *) val untyped_handler - : ?val_cases:(clause list) -> ?parameters:((phrase * pattern) list) + : ?val_cases:(clause list) -> ?parameters:((phrase * Pattern.t) list) -> phrase -> clause list -> handler_depth -> handler end diff --git a/core/sugarTraversals.ml b/core/sugarTraversals.ml index 1d090b438..475e762d4 100644 --- a/core/sugarTraversals.ml +++ b/core/sugarTraversals.ml @@ -449,27 +449,28 @@ class map = method cp_phrase : cp_phrase -> cp_phrase = fun {node; pos} -> with_pos (o#position pos) (o#cp_phrasenode node) - method patternnode : patternnode -> patternnode = + method patternnode : Pattern.node -> Pattern.node = + let open Pattern in function - | `Any -> `Any - | `Nil -> `Nil - | `Cons ((_x, _x_i1)) -> + | Any -> Any + | Nil -> Nil + | Cons ((_x, _x_i1)) -> let _x = o#pattern _x in - 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_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_i1 = o#option (fun o -> o#pattern) _x_i1 - in `Variant ((_x, _x_i1)) - | `Effect (name, ps, k) -> + in Variant ((_x, _x_i1)) + | Effect (name, ps, k) -> let name = o#name name in let ps = o#list (fun o -> o#pattern) ps in let k = o#pattern k in - `Effect (name, ps, k) - | `Negative _x -> + Effect (name, ps, k) + | Negative _x -> let _x = o#list (fun o -> o#name) _x - in `Negative _x - | `Record ((_x, _x_i1)) -> + in Negative _x + | Record ((_x, _x_i1)) -> let _x = o#list (fun o (_x, _x_i1) -> @@ -477,18 +478,18 @@ class map = let _x_i1 = o#pattern _x_i1 in (_x, _x_i1)) _x in let _x_i1 = o#option (fun o -> o#pattern) _x_i1 - in `Record ((_x, _x_i1)) - | `Tuple _x -> let _x = o#list (fun o -> o#pattern) _x in `Tuple _x - | `Constant _x -> let _x = o#constant _x in `Constant _x - | `Variable _x -> let _x = o#binder _x in `Variable _x - | `As ((_x, _x_i1)) -> + in Record ((_x, _x_i1)) + | Tuple _x -> let _x = o#list (fun o -> o#pattern) _x in Tuple _x + | Constant _x -> let _x = o#constant _x in Constant _x + | Variable _x -> let _x = o#binder _x in Variable _x + | As ((_x, _x_i1)) -> let _x = o#binder _x in - let _x_i1 = o#pattern _x_i1 in `As ((_x, _x_i1)) - | `HasType ((_x, _x_i1)) -> + let _x_i1 = o#pattern _x_i1 in As ((_x, _x_i1)) + | HasType ((_x, _x_i1)) -> let _x = o#pattern _x in - let _x_i1 = o#datatype' _x_i1 in `HasType ((_x, _x_i1)) + let _x_i1 = o#datatype' _x_i1 in HasType ((_x, _x_i1)) - method pattern : pattern -> pattern = + method pattern : Pattern.t -> Pattern.t = fun {node; pos} -> let node = o#patternnode node in let pos = o#position pos in {node; pos} @@ -1124,39 +1125,40 @@ class fold = method cp_phrase : cp_phrase -> 'self_node = fun {node; pos} -> (o#cp_phrasenode node)#position pos - method patternnode : patternnode -> 'self_type = + method patternnode : Pattern.node -> 'self_type = + let open Pattern in function - | `Any -> o - | `Nil -> o - | `Cons ((_x, _x_i1)) -> + | Any -> o + | Nil -> o + | Cons ((_x, _x_i1)) -> 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)) -> + | 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#option (fun o -> o#pattern) _x_i1 in o - | `Effect (name, ps, k) -> + | Effect (name, ps, k) -> let o = o#name name in let o = o#list (fun o -> o#pattern) ps in let o = o#pattern k in o - | `Negative _x -> + | Negative _x -> let o = o#list (fun o -> o#name) _x in o - | `Record ((_x, _x_i1)) -> + | 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) _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 - | `Constant _x -> let o = o#constant _x in o - | `Variable _x -> let o = o#binder _x in o - | `As ((_x, _x_i1)) -> + | Tuple _x -> let o = o#list (fun o -> o#pattern) _x in o + | Constant _x -> let o = o#constant _x in o + | Variable _x -> let o = o#binder _x in o + | As ((_x, _x_i1)) -> let o = o#binder _x in let o = o#pattern _x_i1 in o - | `HasType ((_x, _x_i1)) -> + | HasType ((_x, _x_i1)) -> let o = o#pattern _x in let o = o#datatype' _x_i1 in o - method pattern : pattern -> 'self_type = + method pattern : Pattern.t -> 'self_type = fun {node; pos} -> let o = o#patternnode node in let o = o#position pos in @@ -1873,27 +1875,28 @@ class fold_map = let o, pos = o#position pos in o, {node; pos} - method patternnode : patternnode -> ('self_type * patternnode) = + method patternnode : Pattern.node -> ('self_type * Pattern.node) = + let open Pattern in function - | `Any -> (o, `Any) - | `Nil -> (o, `Nil) - | `Cons ((_x, _x_i1)) -> + | Any -> (o, Any) + | Nil -> (o, Nil) + | Cons ((_x, _x_i1)) -> let (o, _x) = o#pattern _x in - let (o, _x_i1) = o#pattern _x_i1 in (o, (`Cons ((_x, _x_i1)))) - | `List _x -> - let (o, _x) = o#list (fun o -> o#pattern) _x in (o, (`List _x)) - | `Variant ((_x, _x_i1)) -> + let (o, _x_i1) = o#pattern _x_i1 in (o, (Cons ((_x, _x_i1)))) + | 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_i1) = o#option (fun o -> o#pattern) _x_i1 - in (o, (`Variant ((_x, _x_i1)))) - | `Effect (name, ps, k) -> + in (o, (Variant ((_x, _x_i1)))) + | Effect (name, ps, k) -> let (o, name) = o#name 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)) - | `Record ((_x, _x_i1)) -> + (o, Effect (name, ps, k)) + | Negative _x -> + let (o, _x) = o#list (fun o -> o#name) _x in (o, (Negative _x)) + | Record ((_x, _x_i1)) -> let (o, _x) = o#list (fun o (_x, _x_i1) -> @@ -1901,19 +1904,19 @@ class fold_map = 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 - in (o, (`Record ((_x, _x_i1)))) - | `Tuple _x -> - let (o, _x) = o#list (fun o -> o#pattern) _x in (o, (`Tuple _x)) - | `Constant _x -> let (o, _x) = o#constant _x in (o, (`Constant _x)) - | `Variable _x -> let (o, _x) = o#binder _x in (o, (`Variable _x)) - | `As ((_x, _x_i1)) -> + in (o, (Record ((_x, _x_i1)))) + | Tuple _x -> + let (o, _x) = o#list (fun o -> o#pattern) _x in (o, (Tuple _x)) + | Constant _x -> let (o, _x) = o#constant _x in (o, (Constant _x)) + | Variable _x -> let (o, _x) = o#binder _x in (o, (Variable _x)) + | As ((_x, _x_i1)) -> let (o, _x) = o#binder _x in - let (o, _x_i1) = o#pattern _x_i1 in (o, (`As ((_x, _x_i1)))) - | `HasType ((_x, _x_i1)) -> + let (o, _x_i1) = o#pattern _x_i1 in (o, (As ((_x, _x_i1)))) + | HasType ((_x, _x_i1)) -> let (o, _x) = o#pattern _x in - let (o, _x_i1) = o#datatype' _x_i1 in (o, (`HasType ((_x, _x_i1)))) + let (o, _x_i1) = o#datatype' _x_i1 in (o, (HasType ((_x, _x_i1)))) - method pattern : pattern -> ('self_type * pattern) = + method pattern : Pattern.t -> ('self_type * Pattern.t) = fun {node; pos} -> let (o, node) = o#patternnode node in let (o, pos ) = o#position pos in diff --git a/core/sugarTraversals.mli b/core/sugarTraversals.mli index 5b8f12ba1..75b7969b6 100644 --- a/core/sugarTraversals.mli +++ b/core/sugarTraversals.mli @@ -43,8 +43,8 @@ class map : method phrase : phrase -> phrase method cp_phrasenode : cp_phrasenode -> cp_phrasenode method cp_phrase : cp_phrase -> cp_phrase - method patternnode : patternnode -> patternnode - method pattern : pattern -> pattern + method patternnode : Pattern.node -> Pattern.node + method pattern : Pattern.t -> Pattern.t method name : name -> name method logical_binop : logical_binop -> logical_binop method location : location -> location @@ -113,8 +113,8 @@ class fold : method phrase : phrase -> 'self method cp_phrasenode : cp_phrasenode -> 'self method cp_phrase : cp_phrase -> 'self - method patternnode : patternnode -> 'self - method pattern : pattern -> 'self + method patternnode : Pattern.node -> 'self + method pattern : Pattern.t -> 'self method name : name -> 'self method logical_binop : logical_binop -> 'self method location : location -> 'self @@ -178,8 +178,8 @@ object ('self) method logical_binop : logical_binop -> 'self * logical_binop method name : name -> 'self * name method option : 'a . ('self -> 'a -> 'self * 'a) -> 'a option -> 'self * 'a option - method patternnode : patternnode -> 'self * patternnode - method pattern : pattern -> 'self * pattern + method patternnode : Pattern.node -> 'self * Pattern.node + method pattern : Pattern.t -> 'self * Pattern.t method phrase : phrase -> 'self * phrase method given_spawn_location : given_spawn_location -> 'self * given_spawn_location method phrasenode : phrasenode -> 'self * phrasenode diff --git a/core/sugartoir.ml b/core/sugartoir.ml index a04f472d6..d52ad1cfd 100644 --- a/core/sugartoir.ml +++ b/core/sugartoir.ml @@ -1066,7 +1066,7 @@ struct | { Sugartypes.node = b; _ }::bs -> begin match b with - | `Val ({Sugartypes.node=`Variable bndr; _}, (_, body), _, _) + | `Val ({Sugartypes.node=Sugartypes.Pattern.Variable bndr; _}, (_, body), _, _) when Sugartypes.binder_has_type bndr -> let x = Sugartypes.name_of_binder bndr in let xt = Sugartypes.type_of_binder_exn bndr in diff --git a/core/sugartypes.ml b/core/sugartypes.ml index 6d9856fe2..cd9ea6ccc 100644 --- a/core/sugartypes.ml +++ b/core/sugartypes.ml @@ -177,23 +177,25 @@ type datatype' = datatype * Types.datatype option type constant = Constant.constant [@@deriving show] -type patternnode = [ -| `Any -| `Nil -| `Cons of pattern * pattern -| `List of pattern list -| `Variant of name * pattern option -| `Effect of name * pattern list * pattern -| `Negative of name list -| `Record of (name * pattern) list * pattern option -| `Tuple of pattern list -| `Constant of constant -| `Variable of binder -| `As of binder * pattern -| `HasType of pattern * datatype' -] -and pattern = patternnode with_pos - [@@deriving show] +module Pattern = struct + type node = + | Any + | Nil + | Cons of t * t + | List of t list + | Variant of name * t option + | Effect of name * t list * t + | Negative of name list + | Record of (name * t) list * t option + | Tuple of t list + | Constant of constant + | Variable of binder + | As of binder * t + | HasType of t * datatype' + [@@deriving show] + and t = node with_pos + [@@deriving show] +end type spawn_kind = Angel | Demon | Wait [@@deriving show] @@ -231,9 +233,9 @@ and regex = | Repeat of (Regex.repeat * regex) | Splice of phrase | Replace of (regex * replace_rhs) -and clause = pattern * phrase -and funlit = pattern list list * phrase -and handlerlit = handler_depth * pattern * clause list * pattern list list option (* computation arg, cases, parameters *) +and clause = Pattern.t * phrase +and funlit = Pattern.t list list * phrase +and handlerlit = handler_depth * Pattern.t * clause list * Pattern.t list list option (* computation arg, cases, parameters *) and handler = { sh_expr: phrase; sh_effect_cases: clause list; @@ -247,12 +249,12 @@ and handler_descriptor = { shd_params: handler_parameterisation option } and handler_parameterisation = { - shp_bindings: (phrase * pattern) list; + shp_bindings: (phrase * Pattern.t) list; shp_types: Types.datatype list } and iterpatt = [ -| `List of pattern * phrase -| `Table of pattern * phrase +| `List of Pattern.t * phrase +| `Table of Pattern.t * phrase ] and phrasenode = [ | `Constant of constant @@ -287,14 +289,14 @@ and phrasenode = [ | `ConstructorLit of name * phrase option * Types.datatype option | `DoOperation of name * phrase list * Types.datatype option | `Handle of handler -| `Switch of phrase * (pattern * phrase) list * Types.datatype option -| `Receive of (pattern * phrase) list * Types.datatype option +| `Switch of phrase * (Pattern.t * phrase) list * Types.datatype option +| `Receive of (Pattern.t * phrase) list * Types.datatype option | `DatabaseLit of phrase * (phrase option * phrase option) (* | `TableLit of phrase * (datatype * (Types.datatype * Types.datatype * Types.datatype) option) * (name * fieldconstraint list) list * phrase *) | `TableLit of phrase * (datatype * (Types.datatype * Types.datatype * Types.datatype) option) * (name * fieldconstraint list) list * phrase * phrase -| `DBDelete of pattern * phrase * phrase option +| `DBDelete of Pattern.t * phrase * phrase option | `DBInsert of phrase * name list * phrase * phrase option -| `DBUpdate of pattern * phrase * phrase option * (name * phrase) list +| `DBUpdate of Pattern.t * phrase * phrase option * (name * phrase) list | `LensLit of phrase * Types.lens_sort 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 *) @@ -311,19 +313,19 @@ and phrasenode = [ | `Page of phrase | `FormletPlacement of phrase * phrase * phrase | `PagePlacement of phrase -| `FormBinding of phrase * pattern +| `FormBinding of phrase * Pattern.t (* choose *) | `Select of name * phrase (* choice *) -| `Offer of phrase * (pattern * phrase) list * Types.datatype option +| `Offer of phrase * (Pattern.t * phrase) list * Types.datatype option (* | `Fork of binder * phrase *) | `CP of cp_phrase -| `TryInOtherwise of (phrase * pattern * phrase * phrase * Types.datatype option) +| `TryInOtherwise of (phrase * Pattern.t * phrase * phrase * Types.datatype option) | `Raise ] and phrase = phrasenode with_pos and bindingnode = [ -| `Val of pattern * (tyvar list * phrase) * location * datatype' option +| `Val of Pattern.t * (tyvar list * phrase) * location * datatype' option | `Fun of binder * declared_linearity * (tyvar list * funlit) * location * datatype' option | `Funs of (binder * declared_linearity * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * location * datatype' option * position) list | `Handler of binder * handlerlit * datatype' option @@ -389,22 +391,24 @@ struct let union_map f = union_all -<- List.map f let option_map f = opt_app f empty - let rec pattern ({node; _} : pattern) : StringSet.t = match node with - | `Any - | `Nil - | `Constant _ - | `Negative _ -> empty - | `Tuple ps - | `List ps -> union_map pattern ps - | `Cons (p1, p2) -> union (pattern p1) (pattern p2) - | `Variant (_, popt) -> option_map pattern popt - | `Effect (_, ps, kopt) -> union (union_map pattern ps) (pattern kopt) - | `Record (fields, popt) -> - union (option_map pattern popt) - (union_map (snd ->- pattern) fields) - | `Variable bndr -> singleton (name_of_binder bndr) - | `As (bndr, pat) -> add (name_of_binder bndr) (pattern pat) - | `HasType (pat, _) -> pattern pat + let rec pattern ({node; _} : Pattern.t) : StringSet.t = + let open Pattern in + match node with + | Any + | Nil + | Constant _ + | Negative _ -> empty + | Tuple ps + | List ps -> union_map pattern ps + | Cons (p1, p2) -> union (pattern p1) (pattern p2) + | Variant (_, popt) -> option_map pattern popt + | Effect (_, ps, kopt) -> union (union_map pattern ps) (pattern kopt) + | Record (fields, popt) -> + union (option_map pattern popt) + (union_map (snd ->- pattern) fields) + | Variable bndr -> singleton (name_of_binder bndr) + | As (bndr, pat) -> add (name_of_binder bndr) (pattern pat) + | HasType (pat, _) -> pattern pat let rec formlet_bound ({node; _} : phrase) : StringSet.t = match node with diff --git a/core/transformSugar.ml b/core/transformSugar.ml index e908fd70a..a8964f653 100644 --- a/core/transformSugar.ml +++ b/core/transformSugar.ml @@ -622,42 +622,43 @@ class transform (env : Types.typing_environment) = let (o, node, t) = o#phrasenode node in (o, {node;pos}, t) - method patternnode : patternnode -> ('self_type * patternnode) = + method patternnode : Pattern.node -> ('self_type * Pattern.node) = + let open Pattern in function - | `Any -> (o, `Any) - | `Nil -> (o, `Nil) - | `Cons (p, ps) -> + | Any -> (o, Any) + | Nil -> (o, Nil) + | Cons (p, ps) -> let (o, p) = o#pattern p in - let (o, ps) = o#pattern ps in (o, `Cons (p, ps)) - | `List p -> - let (o, p) = listu o (fun o -> o#pattern) p in (o, `List p) - | `Variant (name, p) -> + let (o, ps) = o#pattern ps in (o, Cons (p, ps)) + | List p -> + let (o, p) = listu o (fun o -> o#pattern) p in (o, List p) + | Variant (name, p) -> let (o, p) = optionu o (fun o -> o#pattern) p - in (o, `Variant (name, p)) - | `Effect (name, ps, k) -> + in (o, Variant (name, p)) + | Effect (name, ps, k) -> let (o, ps) = listu o (fun o -> o#pattern) ps in let (o, k) = o#pattern k in - (o, `Effect (name, ps, k)) - | `Negative name -> (o, `Negative name) - | `Record (fields, rest) -> + (o, Effect (name, ps, k)) + | Negative name -> (o, Negative name) + | Record (fields, rest) -> let (o, fields) = listu o (fun o (name, p) -> let (o, p) = o#pattern p in (o, (name, p))) fields in let (o, rest) = optionu o (fun o -> o#pattern) rest - in (o, `Record (fields, rest)) - | `Tuple ps -> - let (o, ps) = listu o (fun o -> o#pattern) ps in (o, `Tuple ps) - | `Constant c -> let (o, c, _) = o#constant c in (o, `Constant c) - | `Variable x -> let (o, x) = o#binder x in (o, `Variable x) - | `As (x, p) -> + in (o, Record (fields, rest)) + | Tuple ps -> + let (o, ps) = listu o (fun o -> o#pattern) ps in (o, Tuple ps) + | Constant c -> let (o, c, _) = o#constant c in (o, Constant c) + | Variable x -> let (o, x) = o#binder x in (o, Variable x) + | As (x, p) -> let (o, x) = o#binder x in - let (o, p) = o#pattern p in (o, (`As (x, p))) - | `HasType (p, t) -> - let (o, p) = o#pattern p in (o, (`HasType (p, t))) + let (o, p) = o#pattern p in (o, (As (x, p))) + | HasType (p, t) -> + let (o, p) = o#pattern p in (o, (HasType (p, t))) - method pattern : pattern -> ('self_type * pattern) = + method pattern : Pattern.t -> ('self_type * Pattern.t) = fun {node; pos} -> let (o, node) = o#patternnode node in (o, {node; pos}) diff --git a/core/transformSugar.mli b/core/transformSugar.mli index 942bc9050..fa28c0516 100644 --- a/core/transformSugar.mli +++ b/core/transformSugar.mli @@ -77,8 +77,8 @@ object ('self) method lens_sort : Types.lens_sort -> 'self * Types.lens_sort method row : Types.row -> 'self * Types.row - method patternnode : patternnode -> 'self * patternnode - method pattern : pattern -> 'self * pattern + method patternnode : Pattern.node -> 'self * Pattern.node + method pattern : Pattern.t -> 'self * Pattern.t method phrase : phrase -> 'self * phrase * Types.datatype method given_spawn_location : given_spawn_location -> 'self * given_spawn_location method phrasenode : phrasenode -> 'self * phrasenode * Types.datatype @@ -95,4 +95,4 @@ object ('self) method unary_op : unary_op -> 'self * unary_op * Types.datatype end -val fun_effects : Types.datatype -> Sugartypes.pattern list list -> Types.row +val fun_effects : Types.datatype -> Sugartypes.Pattern.t list list -> Types.row diff --git a/core/typeSugar.ml b/core/typeSugar.ml index b8dee8b7f..794223735 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -118,24 +118,25 @@ struct | `Exp p -> is_pure p | `Val (pat, (_, rhs), _, _) -> is_safe_pattern pat && is_pure rhs - and is_safe_pattern {node = pat; _} = match pat with + and is_safe_pattern {node = pat; _} = let open Pattern in + match pat with (* safe patterns cannot fail *) - | `Nil - | `Cons _ - | `List _ - | `Constant _ -> false + | Nil + | Cons _ + | List _ + | Constant _ -> false (* NOTE: variant assigment is typed such that it must always succeed *) - | `Variant (_, None) -> true - | `Variant (_, Some p) -> is_safe_pattern p - | `Negative _ -> true - | `Any - | `Variable _ -> true - | `Record (ps, None) -> List.for_all (snd ->- is_safe_pattern) ps - | `Record (ps, Some p) -> List.for_all (snd ->- is_safe_pattern) ps && is_safe_pattern p - | `Tuple ps -> List.for_all is_safe_pattern ps - | `HasType (p, _) - | `As (_, p) -> is_safe_pattern p - | `Effect (_, ps, k) -> + | Variant (_, None) -> true + | Variant (_, Some p) -> is_safe_pattern p + | Negative _ -> true + | Any + | Variable _ -> true + | Record (ps, None) -> List.for_all (snd ->- is_safe_pattern) ps + | Record (ps, Some p) -> List.for_all (snd ->- is_safe_pattern) ps && is_safe_pattern p + | Tuple ps -> List.for_all is_safe_pattern ps + | HasType (p, _) + | As (_, p) -> is_safe_pattern p + | Effect (_, ps, k) -> List.for_all is_safe_pattern ps && is_safe_pattern k and is_pure_regex = function (* don't check whether it can fail; just check whether it @@ -1447,22 +1448,23 @@ let type_binary_op ctxt = If there are no _ or variable patterns at a variant type, then that variant will be closed. *) -let close_pattern_type : pattern list -> Types.datatype -> Types.datatype = fun pats t -> +let close_pattern_type : Pattern.t list -> Types.datatype -> Types.datatype = fun pats t -> (* We use a table to keep track of encountered recursive variables in order to avert non-termination. *) let rec_vars_seen = Hashtbl.create 8 in - let rec cpt : pattern list -> Types.datatype -> Types.datatype = fun pats t -> + let rec cpt : Pattern.t list -> Types.datatype -> Types.datatype = fun pats t -> match t with | `Alias (alias, t) -> `Alias (alias, cpt pats t) | `Record row when Types.is_tuple row-> let fields, row_var, dual = fst (Types.unwrap_row row) in let rec unwrap_at i p = + let open Pattern in match p.node with - | `Variable _ | `Any | `Constant _ -> p - | `As (_, p) | `HasType (p, _) -> unwrap_at i p - | `Tuple ps -> + | Variable _ | Any | Constant _ -> p + | As (_, p) | HasType (p, _) -> unwrap_at i p + | Tuple ps -> List.nth ps i - | `Nil | `Cons _ | `List _ | `Record _ | `Variant _ | `Negative _ | `Effect _ -> assert false in + | Nil | Cons _ | List _ | Record _ | Variant _ | Negative _ | Effect _ -> assert false in let fields = StringMap.fold(* true if the row variable is dualised *) @@ -1479,10 +1481,11 @@ let close_pattern_type : pattern list -> Types.datatype -> Types.datatype = fun let fields, row_var, lr = fst (Types.unwrap_row row) in assert (not lr); let rec unwrap_at name p = + let open Pattern in match p.node with - | `Variable _ | `Any | `Constant _ -> p - | `As (_, p) | `HasType (p, _) -> unwrap_at name p - | `Record (ps, default) -> + | Variable _ | Any | Constant _ -> p + | As (_, p) | HasType (p, _) -> unwrap_at name p + | Record (ps, default) -> if List.mem_assoc name ps then List.assoc name ps else @@ -1491,7 +1494,7 @@ let close_pattern_type : pattern list -> Types.datatype -> Types.datatype = fun | None -> assert false | Some p -> unwrap_at name p end - | `Nil | `Cons _ | `List _ | `Tuple _ | `Variant _ | `Negative _ | `Effect _ -> assert false in + | Nil | Cons _ | List _ | Tuple _ | Variant _ | Negative _ | Effect _ -> assert false in let fields = StringMap.fold (fun name -> @@ -1516,24 +1519,26 @@ let close_pattern_type : pattern list -> Types.datatype -> Types.datatype = fun *) (end_pos, end_pos, buf) in - let rec unwrap_at : string -> pattern -> pattern list = fun name p -> + let rec unwrap_at : string -> Pattern.t -> Pattern.t list = fun name p -> + let open Pattern in match p.node with - | `Variable _ | `Any -> [ with_pos (end_pos p) `Any ] - | `As (_, p) | `HasType (p, _) -> unwrap_at name p - | `Variant (name', None) when name=name' -> - [with_pos (end_pos p) (`Record ([], None))] - | `Variant (name', Some p) when name=name' -> [p] - | `Variant _ -> [] - | `Negative names when List.mem name names -> [] - | `Negative _ -> [ with_pos (end_pos p) `Any ] - | `Nil | `Cons _ | `List _ | `Tuple _ | `Record _ | `Constant _ | `Effect _ -> assert false in - let rec are_open : pattern list -> bool = + | Variable _ | Any -> [ with_pos (end_pos p) Pattern.Any ] + | As (_, p) | HasType (p, _) -> unwrap_at name p + | Variant (name', None) when name=name' -> + [with_pos (end_pos p) (Record ([], None))] + | Variant (name', Some p) when name=name' -> [p] + | Variant _ -> [] + | Negative names when List.mem name names -> [] + | Negative _ -> [ with_pos (end_pos p) Pattern.Any ] + | Nil | Cons _ | List _ | Tuple _ | Record _ | Constant _ | Effect _ -> assert false in + let rec are_open : Pattern.t list -> bool = + let open Pattern in function | [] -> false - | {node = (`Variable _ | `Any | `Negative _); _} :: _ -> true - | {node = (`As (_, p) | `HasType (p, _)); _} :: ps -> are_open (p :: ps) - | {node = (`Variant _); _} :: ps -> are_open ps - | {node = (`Nil | `Cons _ | `List _ | `Tuple _ | `Record _ | `Constant _ | `Effect _); _} :: _ -> assert false in + | {node = (Variable _ | Any | Negative _); _} :: _ -> true + | {node = (As (_, p) | HasType (p, _)); _} :: ps -> are_open (p :: ps) + | {node = (Variant _); _} :: ps -> are_open ps + | {node = (Nil | Cons _ | List _ | Tuple _ | Record _ | Constant _ | Effect _); _} :: _ -> assert false in let fields = StringMap.fold (fun name field_spec env -> @@ -1566,12 +1571,13 @@ let close_pattern_type : pattern list -> Types.datatype -> Types.datatype = fun let fields, row_var, lr = fst (Types.unwrap_row row) in assert (not lr); - let unwrap_at : string -> pattern -> pattern list = fun name p -> + let unwrap_at : string -> Pattern.t -> Pattern.t list = fun name p -> + let open Pattern in match p.node with - | `Effect (name', ps, _) when name=name' -> ps - | `Effect _ -> [] - | `Variable _ | `Any | `As _ | `HasType _ | `Negative _ - | `Nil | `Cons _ | `List _ | `Tuple _ | `Record _ | `Variant _ | `Constant _ -> assert false in + | Effect (name', ps, _) when name=name' -> ps + | Effect _ -> [] + | Variable _ | Any | As _ | HasType _ | Negative _ + | Nil | Cons _ | List _ | Tuple _ | Record _ | Variant _ | Constant _ -> assert false in let fields = StringMap.fold (fun name field_spec env -> @@ -1590,7 +1596,7 @@ let close_pattern_type : pattern list -> Types.datatype -> Types.datatype = fun (* Construct an p x n matrix (i.e. the transposition of p x n matrix as it is easier to map column-wise) *) - let pmat : pattern list list = + let pmat : Pattern.t list list = let non_empty ps = ps <> [] in let rows = map_filter @@ -1632,14 +1638,15 @@ let close_pattern_type : pattern list -> Types.datatype -> Types.datatype = fun `Effect row | `Application (l, [`Type t]) when Types.Abstype.equal l Types.list -> - let rec unwrap p : pattern list = + let rec unwrap p : Pattern.t list = + let open Pattern in match p.node with - | `Variable _ | `Any -> [p] - | `Constant _ | `Nil -> [] - | `Cons (p1, p2) -> p1 :: unwrap p2 - | `List ps -> ps - | `As (_, p) | `HasType (p, _) -> unwrap p - | `Variant _ | `Negative _ | `Record _ | `Tuple _ | `Effect _ -> assert false in + | Variable _ | Any -> [p] + | Constant _ | Nil -> [] + | Cons (p1, p2) -> p1 :: unwrap p2 + | List ps -> ps + | As (_, p) | HasType (p, _) -> unwrap p + | Variant _ | Negative _ | Record _ | Tuple _ | Effect _ -> assert false in let pats = concat_map unwrap pats in `Application (Types.list, [`Type (cpt pats t)]) | `ForAll (qs, t) -> `ForAll (qs, cpt pats t) @@ -1703,7 +1710,7 @@ let unify_or ~(handle:Gripers.griper) ~pos ((_, ltype1), (_, rtype1)) (** check for duplicate names in a list of pattern *) -let check_for_duplicate_names : Sugartypes.position -> pattern list -> string list = fun pos ps -> +let check_for_duplicate_names : Sugartypes.position -> Pattern.t list -> string list = fun pos ps -> let add name binder binderss = if StringMap.mem name binderss then let (count, binders) = StringMap.find name binderss in @@ -1711,34 +1718,35 @@ let check_for_duplicate_names : Sugartypes.position -> pattern list -> string li else StringMap.add name (1, [binder]) binderss in - let rec gather binderss { node = (p : patternnode); _} = - match p with - | `Any -> binderss - | `Nil -> binderss - | `Cons (p, q) -> + let rec gather binderss {node; _} = + let open Pattern in + match node with + | Nil -> binderss + | Any -> binderss + | Cons (p, q) -> let binderss = gather binderss p in gather binderss q - | `List ps -> + | List ps -> List.fold_right (fun p binderss -> gather binderss p) ps binderss - | `Variant (_, p) -> + | Variant (_, p) -> opt_app (fun p -> gather binderss p) binderss p - | `Effect (_, ps, k) -> + | Effect (_, ps, k) -> let binderss' = List.fold_right (fun p binderss -> gather binderss p) ps binderss in gather binderss' k - | `Negative _ -> binderss - | `Record (ps, p) -> + | Negative _ -> binderss + | Record (ps, p) -> let binderss = List.fold_right (fun (_, p) binderss -> gather binderss p) ps binderss in opt_app (fun p -> gather binderss p) binderss p - | `Tuple ps -> + | Tuple ps -> List.fold_right (fun p binderss -> gather binderss p) ps binderss - | `Constant _ -> binderss - | `Variable bndr -> + | Constant _ -> binderss + | Variable bndr -> add (name_of_binder bndr) bndr binderss - | `As (bndr, p) -> + | As (bndr, p) -> let binderss = gather binderss p in add (name_of_binder bndr) bndr binderss - | `HasType (p, _) -> gather binderss p in + | HasType (p, _) -> gather binderss p in let binderss = List.fold_left gather StringMap.empty ps in @@ -1748,7 +1756,7 @@ let check_for_duplicate_names : Sugartypes.position -> pattern list -> string li else List.map fst (StringMap.bindings binderss) -let type_pattern closed : pattern -> pattern * Types.environment * Types.datatype = +let type_pattern closed : Pattern.t -> Pattern.t * Types.environment * Types.datatype = let make_singleton_row = match closed with | `Closed -> Types.make_singleton_closed_row @@ -1764,7 +1772,7 @@ let type_pattern closed : pattern -> pattern * Types.environment * Types.datatyp using types from the inner type. *) - let rec type_pattern {node = pattern; pos = pos'} : pattern * Types.environment * (Types.datatype * Types.datatype) = + let rec type_pattern {node = pattern; pos = pos'} : Pattern.t * Types.environment * (Types.datatype * Types.datatype) = let _UNKNOWN_POS_ = "" in let tp = type_pattern in let unify (l, r) = unify_or_raise ~pos:pos' (l, r) @@ -1775,31 +1783,32 @@ let type_pattern closed : pattern -> pattern * Types.environment * Types.datatyp and pos ({pos = p;_},_,_) = let (_,_,p) = SourceCode.resolve_pos p in p and (++) = Env.extend in let (p, env, (outer_type, inner_type)) : - patternnode * Types.environment * (Types.datatype * Types.datatype) = + Pattern.node * Types.environment * (Types.datatype * Types.datatype) = + let open Pattern in match pattern with - | `Any -> - let t = Types.fresh_type_variable (`Unl, `Any) in - `Any, Env.empty, (t, t) - | `Nil -> + | Nil -> let t = Types.make_list_type (Types.fresh_type_variable (`Any, `Any)) in - `Nil, Env.empty, (t, t) - | `Constant c as c' -> + Nil, Env.empty, (t, t) + | Any -> + let t = Types.fresh_type_variable (`Unl, `Any) in + Any, Env.empty, (t, t) + | Constant c as c' -> let t = Constant.constant_type c in c', Env.empty, (t, t) - | `Variable bndr -> + | Variable bndr -> let xtype = Types.fresh_type_variable (`Any, `Any) in - (`Variable (set_binder_type bndr xtype), + (Variable (set_binder_type bndr xtype), Env.bind Env.empty (name_of_binder bndr, xtype), (xtype, xtype)) - | `Cons (p1, p2) -> + | Cons (p1, p2) -> let p1 = tp p1 and p2 = tp p2 in let () = unify ~handle:Gripers.cons_pattern ((pos p1, Types.make_list_type (ot p1)), (pos p2, ot p2)) in let () = unify ~handle:Gripers.cons_pattern ((pos p1, Types.make_list_type (it p1)), (pos p2, it p2)) in - `Cons (erase p1, erase p2), env p1 ++ env p2, (ot p2, it p2) - | `List ps -> + Cons (erase p1, erase p2), env p1 ++ env p2, (ot p2, it p2) + | List ps -> let ps' = List.map tp ps in let env' = List.fold_right (env ->- (++)) ps' Env.empty in let list_type p ps typ = @@ -1812,17 +1821,17 @@ let type_pattern closed : pattern -> pattern * Types.environment * Types.datatyp | p::ps -> list_type p ps ot, list_type p ps it in - `List (List.map erase ps'), env', ts - | `Variant (name, None) -> + List (List.map erase ps'), env', ts + | Variant (name, None) -> let vtype () = `Variant (make_singleton_row (name, `Present Types.unit_type)) in - `Variant (name, None), Env.empty, (vtype (), vtype ()) - | `Variant (name, Some p) -> + Variant (name, None), Env.empty, (vtype (), vtype ()) + | Variant (name, Some p) -> let p = tp p in let vtype typ = `Variant (make_singleton_row (name, `Present (typ p))) in - `Variant (name, Some (erase p)), env p, (vtype ot, vtype it) - | `Effect (name, ps, k) -> + Variant (name, Some (erase p)), env p, (vtype ot, vtype it) + | Effect (name, ps, k) -> (* Auxiliary machinery for typing effect patterns *) - let rec type_resumption_pat (kpat : pattern) : pattern * Types.environment * (Types.datatype * Types.datatype) = + let rec type_resumption_pat (kpat : Pattern.t) : Pattern.t * Types.environment * (Types.datatype * Types.datatype) = let fresh_resumption_type () = let domain = Types.fresh_type_variable (`Unl, `Any) in let codomain = Types.fresh_type_variable (`Unl, `Any) in @@ -1830,19 +1839,20 @@ let type_pattern closed : pattern -> pattern * Types.environment * Types.datatyp Types.make_function_type [domain] effrow codomain in let pos' = kpat.pos in + let open Pattern in match kpat.node with - | `Any -> + | Any -> let t = fresh_resumption_type () in - with_pos pos' `Any, Env.empty, (t, t) - | `Variable bndr -> + with_pos pos' Pattern.Any, Env.empty, (t, t) + | Variable bndr -> let xtype = fresh_resumption_type () in - ( with_pos pos' (`Variable (set_binder_type bndr xtype)) + ( with_pos pos' (Variable (set_binder_type bndr xtype)) , Env.bind Env.empty (name_of_binder bndr, xtype), (xtype, xtype)) - | `As (bndr, pat') -> + | As (bndr, pat') -> let p = type_resumption_pat pat' in let env' = Env.bind (env p) (name_of_binder bndr, it p) in - with_pos pos' (`As ((set_binder_type bndr (it p), erase p))), env', (ot p, it p) - | `HasType (p, (_, Some t)) -> + with_pos pos' (As ((set_binder_type bndr (it p), erase p))), env', (ot p, it p) + | HasType (p, (_, Some t)) -> let p = type_resumption_pat p in let () = unify ~handle:Gripers.type_resumption_with_annotation ((pos p, it p), (_UNKNOWN_POS_, t)) in erase p, env p, (ot p, t) @@ -1876,8 +1886,8 @@ let type_pattern closed : pattern -> pattern * Types.environment * Types.datatyp let kenv = env k in penv ++ kenv in - `Effect (name, List.map erase ps, erase k), env, (eff ot, eff it) - | `Negative names -> + Effect (name, List.map erase ps, erase k), env, (eff ot, eff it) + | Negative names -> let row_var = Types.fresh_row_variable (`Any, `Any) in let positive, negative = @@ -1890,8 +1900,8 @@ let type_pattern closed : pattern -> pattern * Types.environment * Types.datatyp let outer_type = `Variant (positive, row_var, false) in let inner_type = `Variant (negative, row_var, false) in - `Negative names, Env.empty, (outer_type, inner_type) - | `Record (ps, default) -> + Negative names, Env.empty, (outer_type, inner_type) + | Record (ps, default) -> let ps = alistmap tp ps in let default = opt_map tp default in let initial_outer, initial_inner, denv = @@ -1919,23 +1929,23 @@ let type_pattern closed : pattern -> pattern * Types.environment * Types.datatyp let penv = List.fold_right (snd ->- env ->- (++)) ps Env.empty in - (`Record (alistmap erase ps, opt_map erase default), + (Record (alistmap erase ps, opt_map erase default), penv ++ denv, (rtype ot initial_outer, rtype it initial_inner)) - | `Tuple ps -> + | Tuple ps -> let ps' = List.map tp ps in let env' = List.fold_right (env ->- (++)) ps' Env.empty in let make_tuple typ = Types.make_tuple_type (List.map typ ps') in - `Tuple (List.map erase ps'), env', (make_tuple ot, make_tuple it) - | `As (bndr, p) -> + Tuple (List.map erase ps'), env', (make_tuple ot, make_tuple it) + | As (bndr, p) -> let p = tp p in let env' = Env.bind (env p) (name_of_binder bndr, it p) in - `As (set_binder_type bndr (it p), erase p), env', (ot p, it p) - | `HasType (p, (_,Some t as t')) -> + As (set_binder_type bndr (it p), erase p), env', (ot p, it p) + | HasType (p, (_,Some t as t')) -> let p = tp p in let () = unify ~handle:Gripers.pattern_annotation ((pos p, it p), (_UNKNOWN_POS_, t)) in - `HasType (erase p, t'), env p, (ot p, t) - | `HasType _ -> assert false in + HasType (erase p, t'), env p, (ot p, t) + | HasType _ -> assert false in with_pos pos' p, env, (outer_type, inner_type) in fun pattern -> @@ -1943,44 +1953,46 @@ let type_pattern closed : pattern -> pattern * Types.environment * Types.datatyp let pos, env, (outer_type, _) = type_pattern pattern in pos, env, outer_type -let rec pattern_env : pattern -> Types.datatype Env.t = - fun { node = p; _} -> match p with - | `Any - | `Nil - | `Constant _ -> Env.empty - - | `HasType (p,_) -> pattern_env p - | `Variant (_, Some p) -> pattern_env p - | `Variant (_, None) -> Env.empty - | `Effect (_, ps, k) -> - let env = List.fold_right (pattern_env ->- Env.extend) ps Env.empty in - Env.extend env (pattern_env k) - | `Negative _ -> Env.empty - | `Record (ps, Some p) -> - List.fold_right (snd ->- pattern_env ->- Env.extend) ps (pattern_env p) - | `Record (ps, None) -> - List.fold_right (snd ->- pattern_env ->- Env.extend) ps Env.empty - | `Cons (h,t) -> Env.extend (pattern_env h) (pattern_env t) - | `List ps - | `Tuple ps -> List.fold_right (pattern_env ->- Env.extend) ps Env.empty - | `Variable {node=v, Some t; _} -> Env.bind Env.empty (v, t) - | `Variable {node=_, None; _} -> assert false - | `As ({node=v, Some t; _}, p) -> Env.bind (pattern_env p) (v, t) - | `As ({node=_, None; _}, _) -> assert false +let rec pattern_env : Pattern.t -> Types.datatype Env.t = + fun { node = p; _} -> let open Pattern in + match p with + | Any + | Nil + | Constant _ -> Env.empty + + | HasType (p,_) -> pattern_env p + | Variant (_, Some p) -> pattern_env p + | Variant (_, None) -> Env.empty + | Effect (_, ps, k) -> + let env = List.fold_right (pattern_env ->- Env.extend) ps Env.empty in + Env.extend env (pattern_env k) + | Negative _ -> Env.empty + | Record (ps, Some p) -> + List.fold_right (snd ->- pattern_env ->- Env.extend) ps (pattern_env p) + | Record (ps, None) -> + List.fold_right (snd ->- pattern_env ->- Env.extend) ps Env.empty + | Cons (h,t) -> Env.extend (pattern_env h) (pattern_env t) + | List ps + | Tuple ps -> List.fold_right (pattern_env ->- Env.extend) ps Env.empty + | Variable {node=v, Some t; _} -> Env.bind Env.empty (v, t) + | Variable {node=_, None; _} -> assert false + | As ({node=v, Some t; _}, p) -> Env.bind (pattern_env p) (v, t) + | As ({node=_, None; _}, _) -> assert false let update_pattern_vars env = (object (self) inherit SugarTraversals.map as super - method! patternnode : patternnode -> patternnode = + method! patternnode : Pattern.node -> Pattern.node = fun n -> + let open Pattern in let update bndr = let ty = Env.lookup env (name_of_binder bndr) in set_binder_type bndr ty in match n with - | `Variable b -> `Variable (update b) - | `As (b, p) -> `As (update b, self#pattern p) + | Variable b -> Variable (update b) + | As (b, p) -> As (update b, self#pattern p) | _ -> super#patternnode n end)#pattern @@ -3171,15 +3183,17 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (** returns a pair of lists whose first component is the value clauses, while the second component is the operation clauses *) - let split_handler_cases : (pattern * phrase) list -> (pattern * phrase) list * (pattern * phrase) list + let split_handler_cases : (Pattern.t * phrase) list -> (Pattern.t * phrase) list * (Pattern.t * phrase) list = fun cases -> let ret, ops = List.fold_left (fun (val_cases, eff_cases) (pat, body) -> match pat.node with - | `Variant ("Return", None) -> Gripers.die pat.pos "Improper pattern-matching on return value" - | `Variant ("Return", Some pat) -> (pat, body) :: val_cases, eff_cases - | _ -> val_cases, (pat, body) :: eff_cases) + | Pattern.Variant ("Return", None) -> + Gripers.die pat.pos "Improper pattern-matching on return value" + | Pattern.Variant ("Return", Some pat) -> + (pat, body) :: val_cases, eff_cases + | _ -> val_cases, (pat, body) :: eff_cases) ([], []) cases in List.rev ret, List.rev ops @@ -3239,19 +3253,19 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = List.fold_right (fun (pat, body) cases -> let pat = + let open Pattern in match pat with - | { node = `Variant (opname, Some pat'); pos } -> + | { node = Variant (opname, Some pat'); pos } -> begin match pat'.node with - | `Tuple [] -> - with_pos pos (`Effect (opname, [], with_dummy_pos `Any)) - | `Tuple ps -> + | Tuple [] -> + with_pos pos (Effect (opname, [], with_dummy_pos Pattern.Any)) + | Tuple ps -> let kpat, pats = pop_last ps in - let eff = `Effect (opname, pats, kpat) in - with_pos pos eff - | _ -> with_pos pos (`Effect (opname, [], pat')) + with_pos pos (Effect (opname, pats, kpat)) + | _ -> with_pos pos (Effect (opname, [], pat')) end - | { node = `Variant (opname, None); pos } -> - with_pos pos (`Effect (opname, [], with_dummy_pos `Any)) + | { node = Variant (opname, None); pos } -> + with_pos pos (Effect (opname, [], with_dummy_pos Pattern.Any)) | {pos;_} -> Gripers.die pos "Improper pattern matching" in let pat = tpo pat in @@ -3267,7 +3281,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let (pat, env, effrow) = pat in let effname, kpat = match pat.node with - | `Effect (name, _, kpat) -> name, kpat + | Pattern.Effect (name, _, kpat) -> name, kpat | _ -> assert false in let pat, kpat = @@ -3283,8 +3297,9 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = match descr.shd_params with | Some params when descr.shd_depth = Deep -> let handler_params = params.shp_types in + let open Pattern in begin match kpat.node with - | `Any -> + | Any -> let kt = let domain = (Types.fresh_type_variable (`Unl, `Any)) :: handler_params @@ -3294,8 +3309,8 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = Types.make_function_type domain effects codomain in (pat, env, effrow), (kpat, Env.empty, kt) - | `As (bndr,_) - | `Variable bndr -> + | As (bndr,_) + | Variable bndr -> let kname = name_of_binder bndr in let kt = let (fields,_,_) = TypeUtils.extract_row effrow in @@ -3316,9 +3331,10 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = | _ -> assert false end | _ -> + let open Pattern in match kpat.node with - | `As (bndr,_) - | `Variable bndr -> + | As (bndr,_) + | Variable bndr -> let kname = name_of_binder bndr in let kt = match Env.find env kname with @@ -3327,7 +3343,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = in let env' = Env.bind Env.empty (kname, kt) in (pat, env, effrow), (kpat, env', kt) - | `Any -> + | Any -> let kt = Types.make_function_type [Types.fresh_type_variable (`Unl, `Any)] @@ -3358,7 +3374,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (* Type operation clause bodies and resumptions *) let eff_cases = List.fold_right - (fun (pat, (kpat : pattern * Types.datatype Env.t * Types.datatype), body) cases -> + (fun (pat, (kpat : Pattern.t * Types.datatype Env.t * Types.datatype), body) cases -> let body = type_check (henv ++ pattern_env pat) body in let () = unify ~handle:Gripers.handle_branches (pos_and_typ body, no_pos bt) From 9b45f315bc1af4215fff8232b4992aa52877efe0 Mon Sep 17 00:00:00 2001 From: Jan Stolarek Date: Wed, 20 Feb 2019 11:44:02 +0000 Subject: [PATCH 03/28] Rename types inside Pattern module Pattern.t is now Pattern.with_pos, Pattern.node is now Pattern.t --- core/compilePatterns.ml | 2 +- core/desugarCP.ml | 2 +- core/desugarFormlets.ml | 2 +- core/desugarFors.ml | 4 +-- core/desugarHandlers.ml | 16 +++++----- core/desugarSessionExceptions.ml | 2 +- core/parser.mly | 4 +-- core/sugarConstructors.ml | 2 +- core/sugarConstructorsIntf.ml | 18 +++++------ core/sugarTraversals.ml | 12 +++---- core/sugarTraversals.mli | 12 +++---- core/sugartypes.ml | 55 +++++++++++++++++--------------- core/transformSugar.ml | 4 +-- core/transformSugar.mli | 6 ++-- core/typeSugar.ml | 34 ++++++++++---------- 15 files changed, 90 insertions(+), 85 deletions(-) diff --git a/core/compilePatterns.ml b/core/compilePatterns.ml index d6c673df1..c7df0d6ec 100644 --- a/core/compilePatterns.ml +++ b/core/compilePatterns.ml @@ -74,7 +74,7 @@ let lookup_name name (nenv, _tenv, _eff, _penv) = let lookup_effects (_nenv, _tenv, eff, _penv) = eff -let rec desugar_pattern : Ir.scope -> Sugartypes.Pattern.t -> pattern * raw_env = +let rec desugar_pattern : Ir.scope -> Sugartypes.Pattern.with_pos -> pattern * raw_env = fun scope {Sugartypes.node=p; Sugartypes.pos} -> let desugar_pat = desugar_pattern scope in let empty = (NEnv.empty, TEnv.empty, Types.make_empty_open_row (`Any, `Any)) in diff --git a/core/desugarCP.ml b/core/desugarCP.ml index bc19c3d13..2e864b5b1 100644 --- a/core/desugarCP.ml +++ b/core/desugarCP.ml @@ -77,7 +77,7 @@ object (o : 'self_type) let envs = o#backup_envs in let o = {< var_env = TyEnv.bind (o#get_var_env ()) (c, TypeUtils.choice_at label s) >} in let (o, p, t) = desugar_cp o p in - let pat : Pattern.t = with_dummy_pos (Pattern.Variant (label, + let pat : Pattern.with_pos = with_dummy_pos (Pattern.Variant (label, 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 diff --git a/core/desugarFormlets.ml b/core/desugarFormlets.ml index fb545ed12..bc34a085e 100644 --- a/core/desugarFormlets.ml +++ b/core/desugarFormlets.ml @@ -33,7 +33,7 @@ object (o : 'self_type) (this roughly corresponds to the dagger transformation) *) - method formlet_patterns : Sugartypes.phrase -> (Sugartypes.Pattern.t list * Sugartypes.phrase list * Types.datatype list) = + method formlet_patterns : Sugartypes.phrase -> (Sugartypes.Pattern.with_pos list * Sugartypes.phrase list * Types.datatype list) = fun ph -> match ph.node with | _ when is_raw ph -> diff --git a/core/desugarFors.ml b/core/desugarFors.ml index 487e06efe..23a48eb1e 100644 --- a/core/desugarFors.ml +++ b/core/desugarFors.ml @@ -61,7 +61,7 @@ let results : Types.row -> let qt = t in let qst = Types.make_tuple_type ts in - let ((qsb, qs) : Sugartypes.Pattern.t list * Sugartypes.phrase list) = + let ((qsb, qs) : Sugartypes.Pattern.with_pos list * Sugartypes.phrase list) = List.split (List.map2 (fun x t -> (variable_pat ~ty:t x, var x)) xs ts) in let qb, q = (variable_pat ~ty:t x, var x) in @@ -100,7 +100,7 @@ object (o : 'self_type) *) method qualifiers : Sugartypes.iterpatt list -> 'self_type * - (Sugartypes.phrase list * Sugartypes.Pattern.t list * Sugartypes.name list * + (Sugartypes.phrase list * Sugartypes.Pattern.with_pos list * Sugartypes.name list * Types.datatype list) = fun qs -> let o, (es, ps, xs, ts) = diff --git a/core/desugarHandlers.ml b/core/desugarHandlers.ml index 7fa2eb986..3aa93bdcf 100644 --- a/core/desugarHandlers.ml +++ b/core/desugarHandlers.ml @@ -20,7 +20,7 @@ open SugarConstructors.Make (* Computes the set of names in a given pattern *) -let rec names : Pattern.t -> string list +let rec names : Pattern.with_pos -> string list = fun pat -> let open Pattern in match pat.node with @@ -41,9 +41,9 @@ let rec names : Pattern.t -> string list The conflict resolution is simple: Given a set of conflicting names ns, then for every name n if (n \in p && n \in ns) then n gets rewritten as _. *) -let resolve_name_conflicts : Pattern.t -> stringset -> Pattern.t +let resolve_name_conflicts : Pattern.with_pos -> stringset -> Pattern.with_pos = fun pat conflicts -> - let rec hide_names : Pattern.t -> Pattern.t + let rec hide_names : Pattern.with_pos -> Pattern.with_pos = fun pat -> with_dummy_pos begin let open Pattern in @@ -84,7 +84,7 @@ let resolve_name_conflicts : Pattern.t -> stringset -> Pattern.t and the parameters of the introduced functions which encompass clause bodies. Currently, the clause-parameters shadow the introduced function parameters. *) -let parameterize : (Pattern.t * phrase) list -> Pattern.t list list option -> (Pattern.t * phrase) list +let parameterize : (Pattern.with_pos * phrase) list -> Pattern.with_pos list list option -> (Pattern.with_pos * phrase) list = fun cases params -> match params with None @@ -102,7 +102,7 @@ let parameterize : (Pattern.t * phrase) list -> Pattern.t list list option -> (P (* This function assigns fresh names to `Any (_) *) -let rec deanonymize : Pattern.t -> Pattern.t +let rec deanonymize : Pattern.with_pos -> Pattern.with_pos = fun pat -> with_dummy_pos begin let open Pattern in @@ -123,7 +123,7 @@ let rec deanonymize : Pattern.t -> Pattern.t end (* This function translates a pattern into a phrase. It assumes that the given pattern has been deanonymised. *) -let rec phrase_of_pattern : Pattern.t -> phrase +let rec phrase_of_pattern : Pattern.with_pos -> phrase = fun pat -> begin let open Pattern in @@ -149,7 +149,7 @@ let apply_params : phrase -> phrase list list -> phrase = fun h pss -> List.fold_right (fun ps acc -> with_dummy_pos (`FnAppl (acc, ps)) ) (List.rev pss) h -let split_handler_cases : (Pattern.t * phrase) list -> (Pattern.t * phrase) list * (Pattern.t * phrase) list +let split_handler_cases : (Pattern.with_pos * phrase) list -> (Pattern.with_pos * phrase) list * (Pattern.with_pos * phrase) list = fun cases -> let ret, ops = List.fold_left @@ -186,7 +186,7 @@ let funlit_of_handlerlit : Sugartypes.handlerlit -> Sugartypes.funlit let params = List.map (List.map phrase_of_pattern) params in apply_params handle params in - let fnparams : Pattern.t list list = [[]] in + let fnparams : Pattern.with_pos list list = [[]] in let fnparams = match params with Some params -> params @ ([m] :: fnparams) diff --git a/core/desugarSessionExceptions.ml b/core/desugarSessionExceptions.ml index 7c63e9522..e3f0df7f6 100644 --- a/core/desugarSessionExceptions.ml +++ b/core/desugarSessionExceptions.ml @@ -69,7 +69,7 @@ object (o : 'self_type) * continuation argument. *) let cont_pat = variable_pat ~ty:`Not_typed (Utility.gensym ~prefix:"dsh" ()) in - let otherwise_pat : Sugartypes.Pattern.t = + let otherwise_pat : Sugartypes.Pattern.with_pos = with_dummy_pos (Pattern.Effect (failure_op_name, [], cont_pat)) in let otherwise_clause = (otherwise_pat, otherwise_phr) in diff --git a/core/parser.mly b/core/parser.mly index 7a34281a6..31e439239 100644 --- a/core/parser.mly +++ b/core/parser.mly @@ -240,9 +240,9 @@ let parseRegexFlags f = %type regex_pattern_alternate %type regex_pattern %type regex_pattern_sequence -%type pattern +%type pattern %type tlfunbinding %type postfix_expression %type primary_expression diff --git a/core/sugarConstructors.ml b/core/sugarConstructors.ml index 2f737f19d..f017b2705 100644 --- a/core/sugarConstructors.ml +++ b/core/sugarConstructors.ml @@ -51,7 +51,7 @@ module SugarConstructors (Position : Pos) (* Stores either a name of variable to be used in a binding pattern or the pattern itself. Used for passing an argument to val_binding. *) - type name_or_pat = Name of name | Pat of Pattern.t + type name_or_pat = Name of name | Pat of Pattern.with_pos (* Optionally stores a datatype signature. Isomporphic to Option. *) type signature = Sig of (name with_pos * datatype') with_pos | NoSig diff --git a/core/sugarConstructorsIntf.ml b/core/sugarConstructorsIntf.ml index e17eeca7d..25d8382c5 100644 --- a/core/sugarConstructorsIntf.ml +++ b/core/sugarConstructorsIntf.ml @@ -47,7 +47,7 @@ module type SugarConstructorsSig = sig (* Helper data types and functions for passing arguments to smart constructors. *) type name_or_pat = Name of name - | Pat of Pattern.t + | Pat of Pattern.with_pos type signature = Sig of (name with_pos * datatype') with_pos | NoSig @@ -76,9 +76,9 @@ module type SugarConstructorsSig = sig val binder : ?ppos:t -> ?ty:Types.datatype -> name -> binder (* Patterns *) - val variable_pat : ?ppos:t -> ?ty:Types.datatype -> name -> Pattern.t - val tuple_pat : ?ppos:t -> Pattern.t list -> Pattern.t - val any_pat : t -> Pattern.t + val variable_pat : ?ppos:t -> ?ty:Types.datatype -> name -> Pattern.with_pos + val tuple_pat : ?ppos:t -> Pattern.with_pos list -> Pattern.with_pos + val any_pat : t -> Pattern.with_pos (* Fieldspec *) val present : fieldspec @@ -91,10 +91,10 @@ module type SugarConstructorsSig = sig (* Various phrases *) val fun_lit : ?ppos:t -> ?args:((Types.datatype * Types.row) list) - -> ?location:location -> declared_linearity -> Pattern.t list list -> phrase + -> ?location:location -> declared_linearity -> Pattern.with_pos list list -> phrase -> phrase val hnlit_arg - : handler_depth -> Pattern.t -> clause list * Pattern.t list list option + : handler_depth -> Pattern.with_pos -> clause list * Pattern.with_pos list list option -> handlerlit val handler_lit : ?ppos:t -> handlerlit -> phrase @@ -112,7 +112,7 @@ module type SugarConstructorsSig = sig (* Bindings *) val fun_binding : ?ppos:t -> signature - -> (declared_linearity * name * Pattern.t list list * location * phrase) + -> (declared_linearity * name * Pattern.with_pos list list * location * phrase) -> binding val fun_binding' : ?ppos:t -> ?linearity:declared_linearity -> ?tyvars:tyvar list @@ -125,7 +125,7 @@ module type SugarConstructorsSig = sig : ?ppos:t -> signature -> (name_or_pat * phrase * location) -> binding val val_binding - : ?ppos:t -> Pattern.t -> phrase + : ?ppos:t -> Pattern.with_pos -> phrase -> binding (* Database queries *) @@ -150,7 +150,7 @@ module type SugarConstructorsSig = sig (* Handlers *) val untyped_handler - : ?val_cases:(clause list) -> ?parameters:((phrase * Pattern.t) list) + : ?val_cases:(clause list) -> ?parameters:((phrase * Pattern.with_pos) list) -> phrase -> clause list -> handler_depth -> handler end diff --git a/core/sugarTraversals.ml b/core/sugarTraversals.ml index 475e762d4..6810022f2 100644 --- a/core/sugarTraversals.ml +++ b/core/sugarTraversals.ml @@ -449,7 +449,7 @@ class map = method cp_phrase : cp_phrase -> cp_phrase = fun {node; pos} -> with_pos (o#position pos) (o#cp_phrasenode node) - method patternnode : Pattern.node -> Pattern.node = + method patternnode : Pattern.t -> Pattern.t = let open Pattern in function | Any -> Any @@ -489,7 +489,7 @@ class map = let _x = o#pattern _x in let _x_i1 = o#datatype' _x_i1 in HasType ((_x, _x_i1)) - method pattern : Pattern.t -> Pattern.t = + method pattern : Pattern.with_pos -> Pattern.with_pos = fun {node; pos} -> let node = o#patternnode node in let pos = o#position pos in {node; pos} @@ -1125,7 +1125,7 @@ class fold = method cp_phrase : cp_phrase -> 'self_node = fun {node; pos} -> (o#cp_phrasenode node)#position pos - method patternnode : Pattern.node -> 'self_type = + method patternnode : Pattern.t -> 'self_type = let open Pattern in function | Any -> o @@ -1158,7 +1158,7 @@ class fold = | HasType ((_x, _x_i1)) -> let o = o#pattern _x in let o = o#datatype' _x_i1 in o - method pattern : Pattern.t -> 'self_type = + method pattern : Pattern.with_pos -> 'self_type = fun {node; pos} -> let o = o#patternnode node in let o = o#position pos in @@ -1875,7 +1875,7 @@ class fold_map = let o, pos = o#position pos in o, {node; pos} - method patternnode : Pattern.node -> ('self_type * Pattern.node) = + method patternnode : Pattern.t -> ('self_type * Pattern.t) = let open Pattern in function | Any -> (o, Any) @@ -1916,7 +1916,7 @@ class fold_map = let (o, _x) = o#pattern _x in let (o, _x_i1) = o#datatype' _x_i1 in (o, (HasType ((_x, _x_i1)))) - method pattern : Pattern.t -> ('self_type * Pattern.t) = + method pattern : Pattern.with_pos -> ('self_type * Pattern.with_pos) = fun {node; pos} -> let (o, node) = o#patternnode node in let (o, pos ) = o#position pos in diff --git a/core/sugarTraversals.mli b/core/sugarTraversals.mli index 75b7969b6..edf0256c1 100644 --- a/core/sugarTraversals.mli +++ b/core/sugarTraversals.mli @@ -43,8 +43,8 @@ class map : method phrase : phrase -> phrase method cp_phrasenode : cp_phrasenode -> cp_phrasenode method cp_phrase : cp_phrase -> cp_phrase - method patternnode : Pattern.node -> Pattern.node - method pattern : Pattern.t -> Pattern.t + method patternnode : Pattern.t -> Pattern.t + method pattern : Pattern.with_pos -> Pattern.with_pos method name : name -> name method logical_binop : logical_binop -> logical_binop method location : location -> location @@ -113,8 +113,8 @@ class fold : method phrase : phrase -> 'self method cp_phrasenode : cp_phrasenode -> 'self method cp_phrase : cp_phrase -> 'self - method patternnode : Pattern.node -> 'self - method pattern : Pattern.t -> 'self + method patternnode : Pattern.t -> 'self + method pattern : Pattern.with_pos -> 'self method name : name -> 'self method logical_binop : logical_binop -> 'self method location : location -> 'self @@ -178,8 +178,8 @@ object ('self) method logical_binop : logical_binop -> 'self * logical_binop method name : name -> 'self * name method option : 'a . ('self -> 'a -> 'self * 'a) -> 'a option -> 'self * 'a option - method patternnode : Pattern.node -> 'self * Pattern.node - method pattern : Pattern.t -> 'self * Pattern.t + method patternnode : Pattern.t -> 'self * Pattern.t + method pattern : Pattern.with_pos -> 'self * Pattern.with_pos method phrase : phrase -> 'self * phrase method given_spawn_location : given_spawn_location -> 'self * given_spawn_location method phrasenode : phrasenode -> 'self * phrasenode diff --git a/core/sugartypes.ml b/core/sugartypes.ml index cd9ea6ccc..6f87c72e7 100644 --- a/core/sugartypes.ml +++ b/core/sugartypes.ml @@ -63,6 +63,11 @@ type 'a with_pos = { node : 'a let with_pos pos node = { node; pos } let with_dummy_pos node = { node; pos = dummy_position } +(* JSTOLAREK: document *) +module WithPos = struct + type 'a t = 'a with_pos [@@deriving show] +end + type binder = (name * Types.datatype option) with_pos [@@deriving show] @@ -178,22 +183,22 @@ type constant = Constant.constant [@@deriving show] module Pattern = struct - type node = + type t = | Any | Nil - | Cons of t * t - | List of t list - | Variant of name * t option - | Effect of name * t list * t + | Cons of with_pos * with_pos + | List of with_pos list + | Variant of name * with_pos option + | Effect of name * with_pos list * with_pos | Negative of name list - | Record of (name * t) list * t option - | Tuple of t list + | Record of (name * with_pos) list * with_pos option + | Tuple of with_pos list | Constant of constant | Variable of binder - | As of binder * t - | HasType of t * datatype' + | As of binder * with_pos + | HasType of with_pos * datatype' [@@deriving show] - and t = node with_pos + and with_pos = t WithPos.t [@@deriving show] end @@ -233,9 +238,9 @@ and regex = | Repeat of (Regex.repeat * regex) | Splice of phrase | Replace of (regex * replace_rhs) -and clause = Pattern.t * phrase -and funlit = Pattern.t list list * phrase -and handlerlit = handler_depth * Pattern.t * clause list * Pattern.t list list option (* computation arg, cases, parameters *) +and clause = Pattern.with_pos * phrase +and funlit = Pattern.with_pos list list * phrase +and handlerlit = handler_depth * Pattern.with_pos * clause list * Pattern.with_pos list list option (* computation arg, cases, parameters *) and handler = { sh_expr: phrase; sh_effect_cases: clause list; @@ -249,12 +254,12 @@ and handler_descriptor = { shd_params: handler_parameterisation option } and handler_parameterisation = { - shp_bindings: (phrase * Pattern.t) list; + shp_bindings: (phrase * Pattern.with_pos) list; shp_types: Types.datatype list } and iterpatt = [ -| `List of Pattern.t * phrase -| `Table of Pattern.t * phrase +| `List of Pattern.with_pos * phrase +| `Table of Pattern.with_pos * phrase ] and phrasenode = [ | `Constant of constant @@ -289,14 +294,14 @@ and phrasenode = [ | `ConstructorLit of name * phrase option * Types.datatype option | `DoOperation of name * phrase list * Types.datatype option | `Handle of handler -| `Switch of phrase * (Pattern.t * phrase) list * Types.datatype option -| `Receive of (Pattern.t * phrase) list * Types.datatype option +| `Switch of phrase * (Pattern.with_pos * phrase) list * Types.datatype option +| `Receive of (Pattern.with_pos * phrase) list * Types.datatype option | `DatabaseLit of phrase * (phrase option * phrase option) (* | `TableLit of phrase * (datatype * (Types.datatype * Types.datatype * Types.datatype) option) * (name * fieldconstraint list) list * phrase *) | `TableLit of phrase * (datatype * (Types.datatype * Types.datatype * Types.datatype) option) * (name * fieldconstraint list) list * phrase * phrase -| `DBDelete of Pattern.t * phrase * phrase option +| `DBDelete of Pattern.with_pos * phrase * phrase option | `DBInsert of phrase * name list * phrase * phrase option -| `DBUpdate of Pattern.t * phrase * phrase option * (name * phrase) list +| `DBUpdate of Pattern.with_pos * phrase * phrase option * (name * phrase) list | `LensLit of phrase * Types.lens_sort 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 *) @@ -313,19 +318,19 @@ and phrasenode = [ | `Page of phrase | `FormletPlacement of phrase * phrase * phrase | `PagePlacement of phrase -| `FormBinding of phrase * Pattern.t +| `FormBinding of phrase * Pattern.with_pos (* choose *) | `Select of name * phrase (* choice *) -| `Offer of phrase * (Pattern.t * phrase) list * Types.datatype option +| `Offer of phrase * (Pattern.with_pos * phrase) list * Types.datatype option (* | `Fork of binder * phrase *) | `CP of cp_phrase -| `TryInOtherwise of (phrase * Pattern.t * phrase * phrase * Types.datatype option) +| `TryInOtherwise of (phrase * Pattern.with_pos * phrase * phrase * Types.datatype option) | `Raise ] and phrase = phrasenode with_pos and bindingnode = [ -| `Val of Pattern.t * (tyvar list * phrase) * location * datatype' option +| `Val of Pattern.with_pos * (tyvar list * phrase) * location * datatype' option | `Fun of binder * declared_linearity * (tyvar list * funlit) * location * datatype' option | `Funs of (binder * declared_linearity * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * location * datatype' option * position) list | `Handler of binder * handlerlit * datatype' option @@ -391,7 +396,7 @@ struct let union_map f = union_all -<- List.map f let option_map f = opt_app f empty - let rec pattern ({node; _} : Pattern.t) : StringSet.t = + let rec pattern ({node; _} : Pattern.with_pos) : StringSet.t = let open Pattern in match node with | Any diff --git a/core/transformSugar.ml b/core/transformSugar.ml index a8964f653..8ceba670f 100644 --- a/core/transformSugar.ml +++ b/core/transformSugar.ml @@ -622,7 +622,7 @@ class transform (env : Types.typing_environment) = let (o, node, t) = o#phrasenode node in (o, {node;pos}, t) - method patternnode : Pattern.node -> ('self_type * Pattern.node) = + method patternnode : Pattern.t -> ('self_type * Pattern.t) = let open Pattern in function | Any -> (o, Any) @@ -658,7 +658,7 @@ class transform (env : Types.typing_environment) = | HasType (p, t) -> let (o, p) = o#pattern p in (o, (HasType (p, t))) - method pattern : Pattern.t -> ('self_type * Pattern.t) = + method pattern : Pattern.with_pos -> ('self_type * Pattern.with_pos) = fun {node; pos} -> let (o, node) = o#patternnode node in (o, {node; pos}) diff --git a/core/transformSugar.mli b/core/transformSugar.mli index fa28c0516..2caeb6b5f 100644 --- a/core/transformSugar.mli +++ b/core/transformSugar.mli @@ -77,8 +77,8 @@ object ('self) method lens_sort : Types.lens_sort -> 'self * Types.lens_sort method row : Types.row -> 'self * Types.row - method patternnode : Pattern.node -> 'self * Pattern.node - method pattern : Pattern.t -> 'self * Pattern.t + method patternnode : Pattern.t -> 'self * Pattern.t + method pattern : Pattern.with_pos -> 'self * Pattern.with_pos method phrase : phrase -> 'self * phrase * Types.datatype method given_spawn_location : given_spawn_location -> 'self * given_spawn_location method phrasenode : phrasenode -> 'self * phrasenode * Types.datatype @@ -95,4 +95,4 @@ object ('self) method unary_op : unary_op -> 'self * unary_op * Types.datatype end -val fun_effects : Types.datatype -> Sugartypes.Pattern.t list list -> Types.row +val fun_effects : Types.datatype -> Sugartypes.Pattern.with_pos list list -> Types.row diff --git a/core/typeSugar.ml b/core/typeSugar.ml index 794223735..48f76eddc 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -1448,11 +1448,11 @@ let type_binary_op ctxt = If there are no _ or variable patterns at a variant type, then that variant will be closed. *) -let close_pattern_type : Pattern.t list -> Types.datatype -> Types.datatype = fun pats t -> +let close_pattern_type : Pattern.with_pos list -> Types.datatype -> Types.datatype = fun pats t -> (* We use a table to keep track of encountered recursive variables in order to avert non-termination. *) let rec_vars_seen = Hashtbl.create 8 in - let rec cpt : Pattern.t list -> Types.datatype -> Types.datatype = fun pats t -> + 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) | `Record row when Types.is_tuple row-> @@ -1519,7 +1519,7 @@ let close_pattern_type : Pattern.t list -> Types.datatype -> Types.datatype = fu *) (end_pos, end_pos, buf) in - let rec unwrap_at : string -> Pattern.t -> Pattern.t list = fun name p -> + let rec unwrap_at : string -> Pattern.with_pos -> Pattern.with_pos list = fun name p -> let open Pattern in match p.node with | Variable _ | Any -> [ with_pos (end_pos p) Pattern.Any ] @@ -1531,7 +1531,7 @@ let close_pattern_type : Pattern.t list -> Types.datatype -> Types.datatype = fu | Negative names when List.mem name names -> [] | Negative _ -> [ with_pos (end_pos p) Pattern.Any ] | Nil | Cons _ | List _ | Tuple _ | Record _ | Constant _ | Effect _ -> assert false in - let rec are_open : Pattern.t list -> bool = + let rec are_open : Pattern.with_pos list -> bool = let open Pattern in function | [] -> false @@ -1571,7 +1571,7 @@ let close_pattern_type : Pattern.t list -> Types.datatype -> Types.datatype = fu let fields, row_var, lr = fst (Types.unwrap_row row) in assert (not lr); - let unwrap_at : string -> Pattern.t -> Pattern.t list = fun name p -> + let unwrap_at : string -> 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 @@ -1596,7 +1596,7 @@ let close_pattern_type : Pattern.t list -> Types.datatype -> Types.datatype = fu (* Construct an p x n matrix (i.e. the transposition of p x n matrix as it is easier to map column-wise) *) - let pmat : Pattern.t list list = + let pmat : Pattern.with_pos list list = let non_empty ps = ps <> [] in let rows = map_filter @@ -1638,7 +1638,7 @@ let close_pattern_type : Pattern.t list -> Types.datatype -> Types.datatype = fu `Effect row | `Application (l, [`Type t]) when Types.Abstype.equal l Types.list -> - let rec unwrap p : Pattern.t list = + let rec unwrap p : Pattern.with_pos list = let open Pattern in match p.node with | Variable _ | Any -> [p] @@ -1710,7 +1710,7 @@ let unify_or ~(handle:Gripers.griper) ~pos ((_, ltype1), (_, rtype1)) (** check for duplicate names in a list of pattern *) -let check_for_duplicate_names : Sugartypes.position -> Pattern.t list -> string list = fun pos ps -> +let check_for_duplicate_names : Sugartypes.position -> Pattern.with_pos list -> string list = fun pos ps -> let add name binder binderss = if StringMap.mem name binderss then let (count, binders) = StringMap.find name binderss in @@ -1756,7 +1756,7 @@ let check_for_duplicate_names : Sugartypes.position -> Pattern.t list -> string else List.map fst (StringMap.bindings binderss) -let type_pattern closed : Pattern.t -> Pattern.t * Types.environment * Types.datatype = +let type_pattern closed : Pattern.with_pos -> Pattern.with_pos * Types.environment * Types.datatype = let make_singleton_row = match closed with | `Closed -> Types.make_singleton_closed_row @@ -1772,7 +1772,7 @@ let type_pattern closed : Pattern.t -> Pattern.t * Types.environment * Types.dat using types from the inner type. *) - let rec type_pattern {node = pattern; pos = pos'} : Pattern.t * Types.environment * (Types.datatype * Types.datatype) = + let rec type_pattern {node = pattern; pos = pos'} : Pattern.with_pos * Types.environment * (Types.datatype * Types.datatype) = let _UNKNOWN_POS_ = "" in let tp = type_pattern in let unify (l, r) = unify_or_raise ~pos:pos' (l, r) @@ -1783,7 +1783,7 @@ let type_pattern closed : Pattern.t -> Pattern.t * Types.environment * Types.dat and pos ({pos = p;_},_,_) = let (_,_,p) = SourceCode.resolve_pos p in p and (++) = Env.extend in let (p, env, (outer_type, inner_type)) : - Pattern.node * Types.environment * (Types.datatype * Types.datatype) = + Pattern.t * Types.environment * (Types.datatype * Types.datatype) = let open Pattern in match pattern with | Nil -> @@ -1831,7 +1831,7 @@ let type_pattern closed : Pattern.t -> Pattern.t * Types.environment * Types.dat Variant (name, Some (erase p)), env p, (vtype ot, vtype it) | Effect (name, ps, k) -> (* Auxiliary machinery for typing effect patterns *) - let rec type_resumption_pat (kpat : Pattern.t) : Pattern.t * Types.environment * (Types.datatype * Types.datatype) = + let rec type_resumption_pat (kpat : Pattern.with_pos) : Pattern.with_pos * Types.environment * (Types.datatype * Types.datatype) = let fresh_resumption_type () = let domain = Types.fresh_type_variable (`Unl, `Any) in let codomain = Types.fresh_type_variable (`Unl, `Any) in @@ -1953,7 +1953,7 @@ let type_pattern closed : Pattern.t -> Pattern.t * Types.environment * Types.dat let pos, env, (outer_type, _) = type_pattern pattern in pos, env, outer_type -let rec pattern_env : Pattern.t -> Types.datatype Env.t = +let rec pattern_env : Pattern.with_pos -> Types.datatype Env.t = fun { node = p; _} -> let open Pattern in match p with | Any @@ -1984,7 +1984,7 @@ let update_pattern_vars env = (object (self) inherit SugarTraversals.map as super - method! patternnode : Pattern.node -> Pattern.node = + method! patternnode : Pattern.t -> Pattern.t = fun n -> let open Pattern in let update bndr = @@ -3183,7 +3183,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (** returns a pair of lists whose first component is the value clauses, while the second component is the operation clauses *) - let split_handler_cases : (Pattern.t * phrase) list -> (Pattern.t * phrase) list * (Pattern.t * phrase) list + let split_handler_cases : (Pattern.with_pos * phrase) list -> (Pattern.with_pos * phrase) list * (Pattern.with_pos * phrase) list = fun cases -> let ret, ops = List.fold_left @@ -3374,7 +3374,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (* Type operation clause bodies and resumptions *) let eff_cases = List.fold_right - (fun (pat, (kpat : Pattern.t * Types.datatype Env.t * Types.datatype), body) cases -> + (fun (pat, (kpat : Pattern.with_pos * Types.datatype Env.t * Types.datatype), body) cases -> let body = type_check (henv ++ pattern_env pat) body in let () = unify ~handle:Gripers.handle_branches (pos_and_typ body, no_pos bt) @@ -3491,7 +3491,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = | `TryInOtherwise (try_phrase, pat, in_phrase, unless_phrase, _) -> let try_phrase = tc try_phrase in - (* Pattern type variable *) + (* Pattern.with_posype variable *) let pat = tpc pat in (* Check whether pattern corresponds to try_phrase *) From b0f24283fbaa11831e95fde4af1140dd93f081fd Mon Sep 17 00:00:00 2001 From: Jan Stolarek Date: Wed, 20 Feb 2019 11:49:24 +0000 Subject: [PATCH 04/28] Redefine iterpatt as an ordinary variant --- core/desugarFors.ml | 4 ++-- core/parser.mly | 4 ++-- core/sugarTraversals.ml | 20 ++++++++++---------- core/sugartypes.ml | 23 +++++++---------------- core/transformSugar.ml | 8 ++++---- core/typeSugar.ml | 12 ++++++------ 6 files changed, 31 insertions(+), 40 deletions(-) diff --git a/core/desugarFors.ml b/core/desugarFors.ml index 23a48eb1e..7b5816678 100644 --- a/core/desugarFors.ml +++ b/core/desugarFors.ml @@ -107,7 +107,7 @@ object (o : 'self_type) List.fold_left (fun (o, (es, ps, xs, ts)) q -> match q with - | `List (p, e) -> + | List (p, e) -> let (o, e, t) = o#phrase e in let (o, p) = o#pattern p in @@ -117,7 +117,7 @@ object (o : 'self_type) let xb = binder ~ty:t var in o, (e::es, with_dummy_pos (Pattern.As (xb, p))::ps, var::xs, element_type::ts) - | `Table (p, e) -> + | Table (p, e) -> let (o, e, t) = o#phrase e in let (o, p) = o#pattern p in diff --git a/core/parser.mly b/core/parser.mly index 31e439239..2b3274c05 100644 --- a/core/parser.mly +++ b/core/parser.mly @@ -735,8 +735,8 @@ perhaps_generators: | separated_list(COMMA, generator) { $1 } generator: -| list_generator { `List $1 } -| table_generator { `Table $1 } +| list_generator { List $1 } +| table_generator { Table $1 } list_generator: | pattern LARROW exp { ($1, $3) } diff --git a/core/sugarTraversals.ml b/core/sugarTraversals.ml index 6810022f2..d87ae6b85 100644 --- a/core/sugarTraversals.ml +++ b/core/sugarTraversals.ml @@ -503,12 +503,12 @@ class map = method iterpatt : iterpatt -> iterpatt = function - | `List ((_x, _x_i1)) -> + | List ((_x, _x_i1)) -> let _x = o#pattern _x in - let _x_i1 = o#phrase _x_i1 in `List ((_x, _x_i1)) - | `Table ((_x, _x_i1)) -> + let _x_i1 = o#phrase _x_i1 in List ((_x, _x_i1)) + | Table ((_x, _x_i1)) -> let _x = o#pattern _x in - let _x_i1 = o#phrase _x_i1 in `Table ((_x, _x_i1)) + let _x_i1 = o#phrase _x_i1 in Table ((_x, _x_i1)) method funlit : funlit -> funlit = fun (_x, _x_i1) -> @@ -1173,9 +1173,9 @@ class fold = method iterpatt : iterpatt -> 'self_type = function - | `List ((_x, _x_i1)) -> + | List ((_x, _x_i1)) -> let o = o#pattern _x in let o = o#phrase _x_i1 in o - | `Table ((_x, _x_i1)) -> + | Table ((_x, _x_i1)) -> let o = o#pattern _x in let o = o#phrase _x_i1 in o method funlit : funlit -> 'self_type = @@ -1931,12 +1931,12 @@ class fold_map = method iterpatt : iterpatt -> ('self_type * iterpatt) = function - | `List ((_x, _x_i1)) -> + | List ((_x, _x_i1)) -> let (o, _x) = o#pattern _x in - let (o, _x_i1) = o#phrase _x_i1 in (o, (`List ((_x, _x_i1)))) - | `Table ((_x, _x_i1)) -> + let (o, _x_i1) = o#phrase _x_i1 in (o, (List ((_x, _x_i1)))) + | Table ((_x, _x_i1)) -> let (o, _x) = o#pattern _x in - let (o, _x_i1) = o#phrase _x_i1 in (o, (`Table ((_x, _x_i1)))) + let (o, _x_i1) = o#phrase _x_i1 in (o, (Table ((_x, _x_i1)))) method funlit : funlit -> ('self_type * funlit) = fun (_x, _x_i1) -> diff --git a/core/sugartypes.ml b/core/sugartypes.ml index 6f87c72e7..e6d5eeefc 100644 --- a/core/sugartypes.ml +++ b/core/sugartypes.ml @@ -257,10 +257,9 @@ and handler_parameterisation = { shp_bindings: (phrase * Pattern.with_pos) list; shp_types: Types.datatype list } -and iterpatt = [ -| `List of Pattern.with_pos * phrase -| `Table of Pattern.with_pos * phrase -] +and iterpatt = +| List of (Pattern.with_pos * phrase) +| Table of (Pattern.with_pos * phrase) and phrasenode = [ | `Constant of constant | `Var of name @@ -297,7 +296,6 @@ and phrasenode = [ | `Switch of phrase * (Pattern.with_pos * phrase) list * Types.datatype option | `Receive of (Pattern.with_pos * phrase) list * Types.datatype option | `DatabaseLit of phrase * (phrase option * phrase option) -(* | `TableLit of phrase * (datatype * (Types.datatype * Types.datatype * Types.datatype) option) * (name * fieldconstraint list) list * phrase *) | `TableLit of phrase * (datatype * (Types.datatype * Types.datatype * Types.datatype) option) * (name * fieldconstraint list) list * phrase * phrase | `DBDelete of Pattern.with_pos * phrase * phrase option | `DBInsert of phrase * name list * phrase * phrase option @@ -493,22 +491,15 @@ struct | `FunLit (_, _, fnlit, _) -> funlit fnlit | `Iteration (generators, body, where, orderby) -> let xs = union_map (function - | `List (_, source) - | `Table (_, source) -> phrase source) generators in + | List (_, source) + | Table (_, source) -> phrase source) generators in let pat_bound = union_map (function - | `List (pat, _) - | `Table (pat, _) -> pattern pat) generators in + | List (pat, _) + | Table (pat, _) -> pattern pat) generators in union_all [xs; diff (phrase body) pat_bound; diff (option_map phrase where) pat_bound; diff (option_map phrase orderby) pat_bound] - (* | `Iteration (`List (pat, source), body, where, orderby) *) -(* | `Iteration (`Table (pat, source), body, where, orderby) -> *) -(* let pat_bound = pattern pat in *) -(* union_all [phrase source; *) -(* diff (phrase body) pat_bound; *) -(* diff (option_map phrase where) pat_bound; *) -(* diff (option_map phrase orderby) pat_bound] *) | `Handle { sh_expr = e; sh_effect_cases = eff_cases; sh_value_cases = val_cases; sh_descr = descr } -> let params_bound = option_map diff --git a/core/transformSugar.ml b/core/transformSugar.ml index 8ceba670f..450d976fb 100644 --- a/core/transformSugar.ml +++ b/core/transformSugar.ml @@ -664,14 +664,14 @@ class transform (env : Types.typing_environment) = method iterpatt : iterpatt -> ('self_type * iterpatt) = function - | `List (p, e) -> + | List (p, e) -> let (o, e, _) = o#phrase e in let (o, p) = o#pattern p in - (o, `List (p, e)) - | `Table (p, e) -> + (o, List (p, e)) + | Table (p, e) -> let (o, e, _) = o#phrase e in let (o, p) = o#pattern p in - (o, `Table (p, e)) + (o, Table (p, e)) method funlit : Types.row -> funlit -> ('self_type * funlit * Types.datatype) = fun inner_eff (pss, e) -> diff --git a/core/typeSugar.ml b/core/typeSugar.ml index 48f76eddc..b2fb34d5a 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -2915,8 +2915,8 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = | `Iteration (generators, body, where, orderby) -> let is_query = List.exists (function - | `List _ -> false - | `Table _ -> true) generators in + | List _ -> false + | Table _ -> true) generators in let context = if is_query then {context with effect_row = Types.make_empty_closed_row ()} @@ -2926,7 +2926,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = List.fold_left (fun (generators, generator_usages, environments) -> function - | `List (pattern, e) -> + | List (pattern, e) -> let a = Types.fresh_type_variable (`Any, `Any) in let lt = Types.make_list_type a in let pattern = tpc pattern in @@ -2934,17 +2934,17 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let () = unify ~handle:Gripers.iteration_list_body (pos_and_typ e, no_pos lt) in let () = unify ~handle:Gripers.iteration_list_pattern (ppos_and_typ pattern, (exp_pos e, a)) in - (`List (erase_pat pattern, erase e) :: generators, + (List (erase_pat pattern, erase e) :: generators, usages e :: generator_usages, pattern_env pattern :: environments) - | `Table (pattern, e) -> + | Table (pattern, e) -> let a = Types.fresh_type_variable (`Any, `Any) in let tt = Types.make_table_type (a, Types.fresh_type_variable (`Any, `Any), Types.fresh_type_variable (`Any, `Any)) in let pattern = tpc pattern in let e = tc e in let () = unify ~handle:Gripers.iteration_table_body (pos_and_typ e, no_pos tt) in let () = unify ~handle:Gripers.iteration_table_pattern (ppos_and_typ pattern, (exp_pos e, a)) in - (`Table (erase_pat pattern, erase e) :: generators, + (Table (erase_pat pattern, erase e) :: generators, usages e :: generator_usages, pattern_env pattern:: environments)) ([], [], []) generators in From ec20de290d4f1424e32acd1503d8a86f59e753b4 Mon Sep 17 00:00:00 2001 From: Jan Stolarek Date: Wed, 20 Feb 2019 12:06:59 +0000 Subject: [PATCH 05/28] Redefine binding node as a variant --- core/chaser.ml | 9 +-- core/desugarAlienBlocks.ml | 8 +-- core/desugarDatatypes.ml | 24 ++++---- core/desugarFuns.ml | 18 +++--- core/desugarHandlers.ml | 2 +- core/desugarInners.ml | 6 +- core/desugarModules.ml | 58 +++++++++---------- core/experimentalExtensions.ml | 4 +- core/moduleUtils.ml | 16 +++--- core/parser.mly | 18 +++--- core/refineBindings.ml | 64 ++++++++++----------- core/sugarConstructors.ml | 8 +-- core/sugarTraversals.ml | 102 ++++++++++++++++----------------- core/sugartoir.ml | 46 ++++++++------- core/sugartypes.ml | 49 ++++++++-------- core/transformSugar.ml | 34 +++++------ core/typeSugar.ml | 58 +++++++++---------- 17 files changed, 265 insertions(+), 259 deletions(-) diff --git a/core/chaser.ml b/core/chaser.ml index 3bc8fbb99..26606af8a 100644 --- a/core/chaser.ml +++ b/core/chaser.ml @@ -1,5 +1,6 @@ open Utility open ModuleUtils +open Sugartypes (* Helper functions *) (* Helper function: given top-level module name, maps to expected filename *) @@ -37,7 +38,7 @@ object(self) {< shadow_table = shadow_table >} method! bindingnode = function - | `QualifiedImport ns -> + | QualifiedImport ns -> (* Try to resolve the import; if not, add to ICs list *) let lookup_ref = List.hd ns in (try @@ -45,7 +46,7 @@ object(self) self with _ -> self#add_import_candidate lookup_ref) - | `Module (n, bs) -> + | Module (n, bs) -> let new_path = path @ [n] in let fqn = lst_to_path new_path in let o = self#bind_shadow n fqn in @@ -71,7 +72,7 @@ let rec add_module_bindings deps dep_map = | [module_name]::ys -> (try let (bindings, _) = StringMap.find module_name dep_map in - Sugartypes.with_dummy_pos (`Module (module_name, bindings)) :: (add_module_bindings ys dep_map) + with_dummy_pos (Module (module_name, bindings)) :: (add_module_bindings ys dep_map) with Notfound.NotFound _ -> (failwith (Printf.sprintf "Trying to find %s in dep map containing keys: %s\n" module_name (print_list (List.map fst (StringMap.bindings dep_map)))))); @@ -109,7 +110,7 @@ let add_dependencies module_prog = let sorted_deps = Graph.topo_sort_sccs deps in (* Each entry should be *precisely* one element (otherwise we have cycles) *) assert_no_cycles sorted_deps; - (* Now, build up binding list where each opened dependency is mapped to a `Module containing + (* Now, build up binding list where each opened dependency is mapped to a Module containing * its list of inner bindings. *) (* FIXME: This isn't reassigning positions! What we'll want is to retain the positions, but modify * the position data type to keep track of the module filename we're importing from. *) diff --git a/core/desugarAlienBlocks.ml b/core/desugarAlienBlocks.ml index 5f67b87ff..be32d8ad3 100644 --- a/core/desugarAlienBlocks.ml +++ b/core/desugarAlienBlocks.ml @@ -37,16 +37,16 @@ object(self) method get_bindings = List.rev bindings method! binding = function - | {node=`AlienBlock (lang, lib, decls); _} -> + | {node=AlienBlock (lang, lib, decls); _} -> self#list (fun o ((bnd, dt)) -> let name = name_of_binder bnd in - o#add_binding (with_dummy_pos (`Foreign (bnd, name, lang, lib, dt)))) decls - | {node=`Module (name, bindings); _} -> + o#add_binding (with_dummy_pos (Foreign (bnd, name, lang, lib, dt)))) decls + | {node=Module (name, bindings); _} -> let flattened_bindings = List.concat ( List.map (fun b -> ((flatten_bindings ())#binding b)#get_bindings) bindings ) in - self#add_binding (with_dummy_pos (`Module (name, flattened_bindings))) + self#add_binding (with_dummy_pos (Module (name, flattened_bindings))) | b -> self#add_binding ((flatten_simple ())#binding b) method! program = function diff --git a/core/desugarDatatypes.ml b/core/desugarDatatypes.ml index 0b13f2aeb..99b59909a 100644 --- a/core/desugarDatatypes.ml +++ b/core/desugarDatatypes.ml @@ -73,8 +73,8 @@ object (self) method! bindingnode = function (* type declarations bind variables; exclude those from the analysis. *) - | `Type _ -> self - | b -> super#bindingnode b + | Type _ -> self + | b -> super#bindingnode b method! datatypenode = function | `TypeVar (x, k, freedom) -> self#add (x, (`Type, k), freedom) @@ -479,7 +479,7 @@ object (self) | p -> super#phrasenode p method! bindingnode = function - | `Type (t, args, dt) -> + | Type (t, args, dt) -> let args, dt' = Desugar.typename alias_env t args dt in let (name, vars) = (t, args) in let (t, dt) = @@ -489,19 +489,19 @@ object (self) (* NB: type aliases are scoped; we allow shadowing. We also allow type aliases to shadow abstract types. *) ({< alias_env = SEnv.bind alias_env (name, `Alias (List.map (snd ->- val_of) vars, dt)) >}, - `Type (name, vars, (t, Some dt))) + Type (name, vars, (t, Some dt))) - | `Val (pat, (tyvars, p), loc, dt) -> + | Val (pat, (tyvars, p), loc, dt) -> let o, pat = self#pattern pat in let o, p = o#phrase p in let o, loc = o#location loc in - o, `Val (pat, (tyvars, p), loc, opt_map (Desugar.datatype' map alias_env) dt) - | `Fun (bind, lin, (tyvars, fl), loc, dt) -> + o, Val (pat, (tyvars, p), loc, opt_map (Desugar.datatype' map alias_env) dt) + | Fun (bind, lin, (tyvars, fl), loc, dt) -> let o, bind = self#binder bind in let o, fl = o#funlit fl in let o, loc = o#location loc in - o, `Fun (bind, lin, (tyvars, fl), loc, opt_map (Desugar.datatype' map alias_env) dt) - | `Funs binds -> + o, Fun (bind, lin, (tyvars, fl), loc, opt_map (Desugar.datatype' map alias_env) dt) + | Funs binds -> let o, binds = super#list (fun o (bind, lin, (tyvars, fl), loc, dt, pos) -> @@ -512,11 +512,11 @@ object (self) let o, pos = o#position pos in (o, (bind, lin, (tyvars, fl), loc, dt, pos))) binds - in o, `Funs binds - | `Foreign (bind, raw_name, lang, file, dt) -> + in o, Funs binds + | Foreign (bind, raw_name, lang, file, dt) -> let _, bind = self#binder bind in let dt' = Desugar.foreign alias_env dt in - self, `Foreign (bind, raw_name, lang, file, dt') + self, Foreign (bind, raw_name, lang, file, dt') | b -> super#bindingnode b method! sentence = diff --git a/core/desugarFuns.ml b/core/desugarFuns.ml index 7f2dd145f..acba1e8c9 100644 --- a/core/desugarFuns.ml +++ b/core/desugarFuns.ml @@ -77,8 +77,8 @@ object (o : 'self_type) let f = gensym ~prefix:"_fun_" () in let e = block_node - ([with_dummy_pos (`Fun (unwrap_def ( binder ~ty:ft f, lin, ([], lam) - , location, None)))], + ([with_dummy_pos (Fun (unwrap_def ( binder ~ty:ft f, lin, ([], lam) + , location, None)))], var f) in (o, e, ft) @@ -104,18 +104,18 @@ object (o : 'self_type) | e -> super#phrasenode e method! bindingnode = function - | `Fun _ as b -> + | Fun _ as b -> let (o, b) = super#bindingnode b in begin match b with - | `Fun r -> (o, `Fun (unwrap_def r)) + | Fun r -> (o, Fun (unwrap_def r)) | _ -> assert false end - | `Funs _ as b -> + | Funs _ as b -> let (o, b) = super#bindingnode b in begin match b with - | `Funs defs -> (o, `Funs (List.map unwrap_def_dp defs)) + | Funs defs -> (o, Funs (List.map unwrap_def_dp defs)) | _ -> assert false end | b -> super#bindingnode b @@ -135,10 +135,10 @@ object | e -> super#phrasenode e method! bindingnode = function - | `Fun (_f, _lin, (_tyvars, ([_ps], _body)), _location, _t) as b -> + | Fun (_f, _lin, (_tyvars, ([_ps], _body)), _location, _t) as b -> super#bindingnode b - | `Fun _ -> {< has_no_funs = false >} - | `Funs defs as b -> + | Fun _ -> {< has_no_funs = false >} + | Funs defs as b -> if List.exists (function diff --git a/core/desugarHandlers.ml b/core/desugarHandlers.ml index 3aa93bdcf..37b94efb7 100644 --- a/core/desugarHandlers.ml +++ b/core/desugarHandlers.ml @@ -213,7 +213,7 @@ object | _ -> super#phrase {node; pos} method! bindingnode = function - | `Handler (binder, hnlit, annotation) -> + | Handler (binder, hnlit, annotation) -> let fnlit = funlit_of_handlerlit hnlit in (fun_binding' ?annotation binder fnlit).node | b -> super#bindingnode b diff --git a/core/desugarInners.ml b/core/desugarInners.ml index 041f084a1..2073d1885 100644 --- a/core/desugarInners.ml +++ b/core/desugarInners.ml @@ -65,7 +65,7 @@ object (o : 'self_type) (o#with_extra_env extra_env, lam, t) method! bindingnode = function - | `Funs defs -> + | Funs defs -> (* put the outer bindings in the environment *) let o, defs = o#rec_activate_outer_bindings defs in @@ -109,7 +109,7 @@ object (o : 'self_type) o#unbind (name_of_binder bndr)) o defs in - (o, (`Funs defs)) + (o, (Funs defs)) | b -> super#bindingnode b method! binder : binder -> ('self_type * binder) = function @@ -129,7 +129,7 @@ object method satisfied = has_no_inners method! bindingnode = function - | `Funs defs -> + | Funs defs -> {< has_no_inners = List.for_all (fun (_f, _, ((_tyvars, dt_opt), _), _, _, _) -> diff --git a/core/desugarModules.ml b/core/desugarModules.ml index eb4907f3f..083983799 100644 --- a/core/desugarModules.ml +++ b/core/desugarModules.ml @@ -62,9 +62,9 @@ object(self) method get_bindings = List.rev bindings method! binding = function - | {node = `Module (_, bindings); _} -> + | {node = Module (_, bindings); _} -> self#list (fun o -> o#binding) bindings - | {node = `QualifiedImport _; _} -> self + | {node = QualifiedImport _; _} -> self | b -> self#add_binding ((flatten_simple ())#binding b) method! program = function @@ -93,7 +93,7 @@ let group_bindings : binding list -> binding list list = fun bindings -> let rec group_bindings_inner acc ret = function | [] when acc = [] -> List.rev ret | [] -> List.rev ((List.rev acc) :: ret) - | ({node=`Fun (_, _, _, _, _); _} as bnd) :: bs -> + | ({node=Fun (_, _, _, _, _); _} as bnd) :: bs -> group_bindings_inner (bnd :: acc) ret bs | b :: bs -> (* End block of functions, need to start a new scope *) @@ -132,30 +132,30 @@ let rec rename_binders_get_shadow_tbl module_table (self#bind_shadow_term n fqn, set_binder_name bndr fqn) method! bindingnode = function - | `Fun (bnd, lin, (tvs, fnlit), loc, dt_opt) -> + | Fun (bnd, lin, (tvs, fnlit), loc, dt_opt) -> let (o, bnd') = self#binder bnd in - (o, `Fun (bnd', lin, (tvs, fnlit), loc, dt_opt)) - | `Type t -> (self, `Type t) - | `Val v -> (self, `Val v) - | `Exp b -> (self, `Exp b) - | `Foreign (bnd, raw_name, lang, ext_file, dt) -> + (o, Fun (bnd', lin, (tvs, fnlit), loc, dt_opt)) + | Type t -> (self, Type t) + | Val v -> (self, Val v) + | Exp b -> (self, Exp b) + | Foreign (bnd, raw_name, lang, ext_file, dt) -> let (o, bnd') = self#binder bnd in - (o, `Foreign (bnd', raw_name, lang, ext_file, dt)) - | `AlienBlock (lang, lib, decls) -> + (o, Foreign (bnd', raw_name, lang, ext_file, dt)) + | AlienBlock (lang, lib, decls) -> let (o, decls') = self#list (fun o (bnd, dt) -> let (o, bnd') = o#binder bnd in (o, (bnd', dt))) decls in - (o, `AlienBlock (lang, lib, decls')) - | `QualifiedImport [] -> assert false - | `QualifiedImport ((hd :: tl) as ns) -> + (o, AlienBlock (lang, lib, decls')) + | QualifiedImport [] -> assert false + | QualifiedImport ((hd :: tl) as ns) -> (* Try to resolve head of PQN. This will either resolve to itself, or * to a prefix. Once we have the prefix, we can construct the FQN. *) (* Qualified names must (by parser construction) be of at least length 1. *) let final = List.hd (List.rev ns) in let prefix = resolve hd term_shadow_table in let fqn = String.concat module_sep (prefix :: tl) in - (self#bind_open final fqn, `QualifiedImport ns) - | `Module (n, bs) -> + (self#bind_open final fqn, QualifiedImport ns) + | Module (n, bs) -> let new_path = path @ [n] in let fqn = lst_to_path new_path in (* New FQN for module must shadow n *) @@ -166,9 +166,9 @@ let rec rename_binders_get_shadow_tbl module_table (* Recursively get *and rename* inner scope *) let (_, _, bindings') = process_binding_list bs module_table new_path o_term_ht o_type_ht in - (* Finally, return `Module with updated bindings. The module itself + (* Finally, return Module with updated bindings. The module itself * will be flattened out on the flattening pass. *) - (o, `Module (n, bindings')) + (o, Module (n, bindings')) | b -> super#bindingnode b end @@ -208,28 +208,28 @@ and perform_renaming module_table path term_ht type_ht = (self, (xs', rv')) method! bindingnode = function - | `Module (n, bs) -> - (self, `Module (n, bs)) - | `AlienBlock ab -> - (self, `AlienBlock ab) - | `Foreign f -> (self, `Foreign f) - | `Type (n, tvs, dt) -> + | Module (n, bs) -> + (self, Module (n, bs)) + | AlienBlock ab -> + (self, AlienBlock ab) + | Foreign f -> (self, Foreign f) + | Type (n, tvs, dt) -> (* Add type binding *) let fqn = make_path_string path n in let o = self#bind_shadow_type n fqn in let (o, dt') = o#datatype' dt in - (o, `Type (fqn, tvs, dt')) - | `Val (pat, (tvs, phr), loc, dt_opt) -> + (o, Type (fqn, tvs, dt')) + | Val (pat, (tvs, phr), loc, dt_opt) -> let (_, phr') = self#phrase phr in let (o, pat') = self#pattern pat in let (o, dt_opt') = o#option (fun o -> o#datatype') dt_opt in - (o, `Val (pat', (tvs, phr'), loc, dt_opt')) - | `Fun (bnd, lin, (tvs, fnlit), loc, dt_opt) -> + (o, Val (pat', (tvs, phr'), loc, dt_opt')) + | Fun (bnd, lin, (tvs, fnlit), loc, dt_opt) -> (* Binder will have been changed. We need to add the funlit pattern * to the env. *) let (_, fnlit') = self#funlit fnlit in let (o, dt_opt') = self#option (fun o -> o#datatype') dt_opt in - (o, `Fun (bnd, lin, (tvs, fnlit'), loc, dt_opt')) + (o, Fun (bnd, lin, (tvs, fnlit'), loc, dt_opt')) | b -> super#bindingnode b method! binop = function diff --git a/core/experimentalExtensions.ml b/core/experimentalExtensions.ml index a69544ca4..94bdb79f6 100644 --- a/core/experimentalExtensions.ml +++ b/core/experimentalExtensions.ml @@ -2,6 +2,8 @@ Check whether an experimental feature is enabled before use. **) +open Sugartypes + module BS = Basicsettings let get setting = Settings.get_value setting @@ -32,7 +34,7 @@ object | e -> super#phrasenode e method! bindingnode = function - | `Handler _ when not (get BS.Handlers.enabled) -> + | Handler _ when not (get BS.Handlers.enabled) -> failwith "Handlers are only allowed with setting enable_handlers set to true." | b -> super#bindingnode b end diff --git a/core/moduleUtils.ml b/core/moduleUtils.ml index 48f7305f9..7ad2d80f8 100644 --- a/core/moduleUtils.ml +++ b/core/moduleUtils.ml @@ -55,8 +55,8 @@ object method satisfied = has_no_modules method! bindingnode = function - | `QualifiedImport _ - | `Module _ -> {< has_no_modules = false >} + | QualifiedImport _ + | Module _ -> {< has_no_modules = false >} | b -> super#bindingnode b method! datatypenode = function @@ -72,7 +72,7 @@ end let separate_modules = List.fold_left (fun (mods, binds) b -> match b with - | {node = `Module _; _} as m -> (m :: mods, binds) + | {node = Module _; _} as m -> (m :: mods, binds) | b -> (mods, b :: binds)) ([], []) type module_info = { @@ -121,7 +121,7 @@ let get_ffi_files_obj = method get_filenames = List.rev filenames method! bindingnode = function - | `Foreign (_, _, _, filename, _) -> self#add_external_file filename + | Foreign (_, _, _, filename, _) -> self#add_external_file filename | x -> super#bindingnode x end @@ -159,7 +159,7 @@ let create_module_info_map program = (* Recursively traverse a list of modules *) let rec traverse_modules = function | [] -> [] - | {node=`Module (submodule_name, mod_bs);_} :: bs -> + | {node=Module (submodule_name, mod_bs);_} :: bs -> (* Recursively process *) let new_path = if name = "" then [] else parent_path @ [name] in create_and_add_module_info new_path submodule_name mod_bs; @@ -170,16 +170,16 @@ let create_module_info_map program = (* Getting binding names -- we're interested in function and value names *) let rec get_binding_names = function | [] -> [] - | {node = `Val (pat, _, _, _); _} :: bs -> + | {node = Val (pat, _, _, _); _} :: bs -> (get_pattern_variables pat) @ get_binding_names bs - | {node = `Fun (bndr, _, _, _, _); _} :: bs -> + | {node = Fun (bndr, _, _, _, _); _} :: bs -> Sugartypes.name_of_binder bndr :: (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 *) let rec get_type_names = function | [] -> [] - | { node = `Type (n, _, _); _} :: bs -> n :: (get_type_names bs) + | { node = Type (n, _, _); _} :: bs -> n :: (get_type_names bs) | _ :: bs -> get_type_names bs in (* Gets data constructors for variants *) diff --git a/core/parser.mly b/core/parser.mly index 2b3274c05..f1fa2ac1f 100644 --- a/core/parser.mly +++ b/core/parser.mly @@ -301,11 +301,11 @@ declaration: nofun_declaration: | alien_block { $1 } | ALIEN VARIABLE STRING VARIABLE COLON datatype SEMICOLON { with_pos $loc - (`Foreign (binder ~ppos:$loc($4) $4, + (Foreign (binder ~ppos:$loc($4) $4, $4, $2, $3, datatype $6)) } | fixity perhaps_uinteger op SEMICOLON { let assoc, set = $1 in set assoc (from_option default_fixity $2) ($3.node); - with_pos $loc `Infix } + with_pos $loc Infix } | signature? tlvarbinding SEMICOLON { val_binding' ~ppos:$loc($2) (sig_of_opt $1) $2 } | typedecl SEMICOLON | links_module | links_open SEMICOLON { $1 } @@ -316,10 +316,10 @@ alien_datatypes: | alien_datatype+ { $1 } links_module: -| MODULE module_name moduleblock { with_pos $loc($2) (`Module ($2, $3)) } +| MODULE module_name moduleblock { with_pos $loc($2) (Module ($2, $3)) } alien_block: -| ALIEN VARIABLE STRING LBRACE alien_datatypes RBRACE { with_pos $loc (`AlienBlock ($2, $3, $5)) } +| ALIEN VARIABLE STRING LBRACE alien_datatypes RBRACE { with_pos $loc (AlienBlock ($2, $3, $5)) } module_name: | CONSTRUCTOR { $1 } @@ -362,7 +362,7 @@ signature: | SIG op COLON datatype { with_pos $loc ($2, datatype $4) } typedecl: -| TYPENAME CONSTRUCTOR typeargs_opt EQ datatype { with_pos $loc (`Type ($2, $3, datatype $5)) } +| TYPENAME CONSTRUCTOR typeargs_opt EQ datatype { with_pos $loc (Type ($2, $3, datatype $5)) } typeargs_opt: | /* empty */ { [] } @@ -836,11 +836,11 @@ record_labels: | separated_list(COMMA, record_label) { $1 } links_open: -| OPEN separated_nonempty_list(DOT, CONSTRUCTOR) { with_pos $loc (`QualifiedImport $2) } +| OPEN separated_nonempty_list(DOT, CONSTRUCTOR) { with_pos $loc (QualifiedImport $2) } binding: | VAR pattern EQ exp SEMICOLON { val_binding ~ppos:$loc $2 $4 } -| exp SEMICOLON { with_pos $loc (`Exp $1) } +| exp SEMICOLON { with_pos $loc (Exp $1) } | signature linearity VARIABLE arg_lists block { fun_binding ~ppos:$loc (Sig $1) ($2, $3, $4, `Unknown, $5) } | linearity VARIABLE arg_lists block { fun_binding ~ppos:$loc NoSig ($1, $2, $3, `Unknown, $4) } | typed_handler_binding { handler_binding ~ppos:$loc NoSig $1 } @@ -857,10 +857,10 @@ block: | LBRACE block_contents RBRACE { block ~ppos:$loc $2 } block_contents: -| bindings exp SEMICOLON { ($1 @ [with_pos $loc($2) (`Exp $2)], +| bindings exp SEMICOLON { ($1 @ [with_pos $loc($2) (Exp $2)], record ~ppos:$loc []) } | bindings exp { ($1, $2) } -| exp SEMICOLON { ([with_pos $loc($1) (`Exp $1)], +| exp SEMICOLON { ([with_pos $loc($1) (Exp $1)], record ~ppos:$loc []) } | exp { ([], $1) } | SEMICOLON | /* empty */ { ([], with_pos $loc (`TupleLit [])) } diff --git a/core/refineBindings.ml b/core/refineBindings.ml index f4680c11c..f4f2b4219 100644 --- a/core/refineBindings.ml +++ b/core/refineBindings.ml @@ -28,22 +28,22 @@ let refine_bindings : binding list -> binding list = match binding with (* Modules & qualified imports will have been eliminated by now. Funs * aren't introduced yet. *) - | `Handler _ - | `Module _ - | `QualifiedImport _ - | `AlienBlock _ - | `Funs _ -> assert false - | `Exp _ - | `Foreign _ - | `Type _ - | `Val _ -> + | Handler _ + | Module _ + | QualifiedImport _ + | AlienBlock _ + | Funs _ -> assert false + | Exp _ + | Foreign _ + | Type _ + | Val _ -> (* collapse the group we're collecting, then start a new empty group *) ([], add [bind] (add thisgroup othergroups)) - | `Fun _ -> + | Fun _ -> (* Add binding to group *) (bind::thisgroup, othergroups) - | `Infix -> + | Infix -> (* discard binding *) (thisgroup, othergroups)) bindings ([], []) @@ -55,7 +55,7 @@ let refine_bindings : binding list -> binding list = = fun defs -> let defs = List.map (function - | {node=`Fun (bndr, _, (_, funlit), _, _); _} -> + | {node=Fun (bndr, _, (_, funlit), _, _); _} -> (name_of_binder bndr, funlit) | _ -> assert false) defs in let names = StringSet.from_list (List.map fst defs) in @@ -68,12 +68,12 @@ let refine_bindings : binding list -> binding list = let groupFuns pos (funs : binding list) : binding list = (* Unwrap from the bindingnode type *) let unFun = function - | {node = `Fun (b, lin, (_, funlit), location, dt); pos} -> + | {node = Fun (b, lin, (_, funlit), location, dt); pos} -> (b, lin, (([], None), funlit), location, dt, pos) | _ -> assert false in let find_fun name = List.find (function - | {node=`Fun (bndr, _, _, _, _); _} -> + | {node=Fun (bndr, _, _, _, _); _} -> name = name_of_binder bndr | _ -> false) funs in @@ -86,8 +86,8 @@ let refine_bindings : binding list -> binding list = | [(bndr, lin, ((tyvars, _), body), location, dt, pos)] when not (StringSet.mem (name_of_binder bndr) (Freevars.funlit body)) -> - with_pos pos (`Fun (bndr, lin, (tyvars, body), location, dt)) - | _ -> with_pos pos (`Funs (funs))) + with_pos pos (Fun (bndr, lin, (tyvars, body), location, dt)) + | _ -> with_pos pos (Funs (funs))) sccs in @@ -98,7 +98,7 @@ let refine_bindings : binding list -> binding list = Compute the position corresponding to the whole collection of functions. *) - | {node=`Fun _; _}::_ as funs -> groupFuns (Lexing.dummy_pos, Lexing.dummy_pos, None) funs + | {node=Fun _; _}::_ as funs -> groupFuns (Lexing.dummy_pos, Lexing.dummy_pos, None) funs | binds -> binds in concat_map groupBindings initial_groups @@ -263,19 +263,19 @@ module RefineTypeBindings = struct let group, groups = List.fold_right (fun ({node=binding; _} as bind) (currentGroup, otherGroups) -> match binding with - | `Handler _ (* Desugared at this point *) - | `Module _ - | `QualifiedImport _ - | `AlienBlock _ - | `Funs _ -> assert false - | `Fun _ - | `Foreign _ - | `Val _ - | `Exp _ - | `Infix -> + | Handler _ (* Desugared at this point *) + | Module _ + | QualifiedImport _ + | AlienBlock _ + | Funs _ -> assert false + | Fun _ + | Foreign _ + | Val _ + | Exp _ + | Infix -> (* Collapse and start a new group *) ([], add [bind] (add currentGroup otherGroups)) - | `Type _ -> + | Type _ -> (* Add to this group *) (bind :: currentGroup, otherGroups) ) bindings ([], []) @@ -315,7 +315,7 @@ module RefineTypeBindings = struct let ht = Hashtbl.create 30 in List.iter (fun {node = bind; pos} -> match bind with - | `Type (name, _, _ as tyTy) -> + | Type (name, _, _ as tyTy) -> let refs = typeReferences tyTy typeHt in let referencesSelf = refersToSelf tyTy refs in Hashtbl.add ht name (refs, referencesSelf, pos) @@ -390,11 +390,11 @@ module RefineTypeBindings = struct thd3 (Hashtbl.find ri name) in List.map (fun name -> let res = refineType (Hashtbl.find ht name) [] ht sccs ri in - with_pos (getPos name) (`Type res) + with_pos (getPos name) (Type res) ) sccs let isTypeGroup : binding list -> bool = function - | {node = `Type _; _} :: _xs -> true + | {node = Type _; _} :: _xs -> true | _ -> false (* Performs type refinement on a binding group. *) @@ -404,7 +404,7 @@ module RefineTypeBindings = struct let ht = Hashtbl.create 30 in List.iter (fun {node; _} -> match node with - | `Type (name, _, _ as tyTy) -> + | Type (name, _, _ as tyTy) -> Hashtbl.add ht name tyTy; | _ -> assert false; ) binds; diff --git a/core/sugarConstructors.ml b/core/sugarConstructors.ml index f017b2705..671b01715 100644 --- a/core/sugarConstructors.ml +++ b/core/sugarConstructors.ml @@ -173,18 +173,18 @@ module SugarConstructors (Position : Pos) (* Create a function binding. *) let fun_binding ?(ppos=dp) sig_opt (linearity, bndr, args, location, blk) = let datatype = datatype_opt_of_sig_opt sig_opt bndr in - with_pos ppos (`Fun (binder bndr, linearity, + with_pos ppos (Fun (binder bndr, linearity, ([], (args, blk)), location, datatype)) let fun_binding' ?(ppos=dp) ?(linearity=`Unl) ?(tyvars=[]) ?(location=`Unknown) ?annotation bndr fnlit = - with_pos ppos (`Fun (bndr, linearity, (tyvars, fnlit), location, annotation)) + with_pos ppos (Fun (bndr, linearity, (tyvars, fnlit), location, annotation)) (* Create a handler binding. *) let handler_binding ?(ppos=dp) sig_opt (name, handlerlit) = let datatype = datatype_opt_of_sig_opt sig_opt name in - with_pos ppos (`Handler (binder name, handlerlit, datatype)) + with_pos ppos (Handler (binder name, handlerlit, datatype)) (* Create a Val binding. This function takes either a name for a variable pattern or an already constructed pattern. In the latter case no signature @@ -198,7 +198,7 @@ module SugarConstructors (Position : Pos) | Pat pat -> assert (sig_opt = NoSig); (pat, None) in - with_pos ppos (`Val (pat, ([], phrase), location, datatype)) + with_pos ppos (Val (pat, ([], phrase), location, datatype)) (* A commonly used wrapper around val_binding *) let val_binding ?(ppos=dp) pat phrase = diff --git a/core/sugarTraversals.ml b/core/sugarTraversals.ml index d87ae6b85..92c760648 100644 --- a/core/sugarTraversals.ml +++ b/core/sugarTraversals.ml @@ -651,19 +651,19 @@ class map = method bindingnode : bindingnode -> bindingnode = function - | `Val ((_x, (_x_i1, _x_i2), _x_i3, _x_i4)) -> + | Val ((_x, (_x_i1, _x_i2), _x_i3, _x_i4)) -> let _x = o#pattern _x in let _x_i2 = o#phrase _x_i2 in let _x_i3 = o#location _x_i3 in let _x_i4 = o#option (fun o -> o#datatype') _x_i4 - in `Val ((_x, (_x_i1, _x_i2), _x_i3, _x_i4)) - | `Fun ((_x, _x1, (_x_i1, _x_i2), _x_i3, _x_i4)) -> + in Val ((_x, (_x_i1, _x_i2), _x_i3, _x_i4)) + | Fun ((_x, _x1, (_x_i1, _x_i2), _x_i3, _x_i4)) -> let _x = o#binder _x in let _x_i2 = o#funlit _x_i2 in let _x_i3 = o#location _x_i3 in let _x_i4 = o#option (fun o -> o#datatype') _x_i4 - in `Fun ((_x, _x1, (_x_i1, _x_i2), _x_i3, _x_i4)) - | `Funs _x -> + in Fun ((_x, _x1, (_x_i1, _x_i2), _x_i3, _x_i4)) + | Funs _x -> let _x = o#list (fun o (_x, _x1, (_x_i1, _x_i2), _x_i3, _x_i4, _x_i5) -> @@ -674,23 +674,23 @@ class map = let _x_i5 = o#position _x_i5 in (_x, _x1, (_x_i1, _x_i2), _x_i3, _x_i4, _x_i5)) _x - in `Funs _x - | `Handler (b, hnlit, t) -> + in Funs _x + | Handler (b, hnlit, t) -> let b = o#binder b in let hnlit = o#handlerlit hnlit in let t = o#option (fun o -> o#unknown) t in - `Handler (b, hnlit, t) - | `Foreign ((_x, _x_i1, _x_i2, _x_i3, _x_i4)) -> + Handler (b, hnlit, t) + | Foreign ((_x, _x_i1, _x_i2, _x_i3, _x_i4)) -> let _x = o#binder _x in let _x_i1 = o#name _x_i1 in let _x_i2 = o#name _x_i2 in let _x_i3 = o#name _x_i3 in let _x_i4 = o#datatype' _x_i4 in - `Foreign ((_x, _x_i1, _x_i2, _x_i3, _x_i4)) - | `QualifiedImport _xs -> + Foreign ((_x, _x_i1, _x_i2, _x_i3, _x_i4)) + | QualifiedImport _xs -> let _xs = o#list (fun o -> o#name) _xs in - `QualifiedImport _xs - | `Type ((_x, _x_i1, _x_i2)) -> + QualifiedImport _xs + | Type ((_x, _x_i1, _x_i2)) -> let _x = o#name _x in let _x_i1 = o#list @@ -699,21 +699,21 @@ class map = let _x_i1 = o#unknown _x_i1 in (_x, _x_i1)) _x_i1 - in let _x_i2 = o#datatype' _x_i2 in `Type ((_x, _x_i1, _x_i2)) - | `Infix -> `Infix - | `Exp _x -> let _x = o#phrase _x in `Exp _x - | `Module (n, bs) -> + in let _x_i2 = o#datatype' _x_i2 in Type ((_x, _x_i1, _x_i2)) + | Infix -> Infix + | Exp _x -> let _x = o#phrase _x in Exp _x + | Module (n, bs) -> let n = o#name n in let bs = o#list (fun o -> o#binding) bs in - `Module (n, bs) - | `AlienBlock (lang, lib, dts) -> + Module (n, bs) + | AlienBlock (lang, lib, dts) -> let lang = o#name lang in let lib = o#name lib in let dts = o#list (fun o (b, dt) -> let b = o#binder b in let dt = o#datatype' dt in (b, dt)) dts in - `AlienBlock (lang, lib, dts) + AlienBlock (lang, lib, dts) method binding : binding -> binding = fun {node; pos} -> @@ -1308,19 +1308,19 @@ class fold = method bindingnode : bindingnode -> 'self_type = function - | `Val ((_x, (_x_i1, _x_i2), _x_i3, _x_i4)) -> + | Val ((_x, (_x_i1, _x_i2), _x_i3, _x_i4)) -> let o = o#pattern _x in let o = o#list (fun o -> o#tyvar) _x_i1 in let o = o#phrase _x_i2 in let o = o#location _x_i3 in let o = o#option (fun o -> o#datatype') _x_i4 in o - | `Fun ((_x, _x1, (_x_i1, _x_i2), _x_i3, _x_i4)) -> + | Fun ((_x, _x1, (_x_i1, _x_i2), _x_i3, _x_i4)) -> let o = o#binder _x in let o = o#list (fun o -> o#tyvar) _x_i1 in let o = o#funlit _x_i2 in let o = o#location _x_i3 in let o = o#option (fun o -> o#datatype') _x_i4 in o - | `Funs _x -> + | Funs _x -> let o = o#list (fun o (_x, _x1, ((_x_i1, _), _x_i2), _x_i3, _x_i4, _x_i5) -> @@ -1332,20 +1332,20 @@ class fold = let o = o#position _x_i5 in o) _x in o - | `Handler (b, hnlit, t) -> + | Handler (b, hnlit, t) -> let o = o#binder b in let o = o#handlerlit hnlit in let o = o#option (fun o -> o#unknown) t in o - | `Foreign ((_x, _x_i1, _x_i2, _x_i3, _x_i4)) -> + | Foreign ((_x, _x_i1, _x_i2, _x_i3, _x_i4)) -> let o = o#binder _x in let o = o#name _x_i1 in let o = o#name _x_i2 in let o = o#name _x_i3 in let o = o#datatype' _x_i4 in o - | `QualifiedImport _xs -> + | QualifiedImport _xs -> let o = o#list (fun o -> o#name) _xs in o - | `Type ((_x, _x_i1, _x_i2)) -> + | Type ((_x, _x_i1, _x_i2)) -> let o = o#name _x in let o = o#list @@ -1355,13 +1355,13 @@ class fold = in o) _x_i1 in let o = o#datatype' _x_i2 in o - | `Infix -> o - | `Exp _x -> let o = o#phrase _x in o - | `Module (n, bs) -> + | Infix -> o + | Exp _x -> let o = o#phrase _x in o + | Module (n, bs) -> let o = o#name n in let o = o#list (fun o -> o#binding) bs in o - | `AlienBlock (lang, lib, dts) -> + | AlienBlock (lang, lib, dts) -> let o = o#name lang in let o = o#name lib in let o = o#list (fun o (b, dt)-> @@ -2091,19 +2091,19 @@ class fold_map = method bindingnode : bindingnode -> ('self_type * bindingnode) = function - | `Val ((_x, (_x_i1, _x_i2), _x_i3, _x_i4)) -> + | Val ((_x, (_x_i1, _x_i2), _x_i3, _x_i4)) -> let (o, _x ) = o#pattern _x in let (o, _x_i2) = o#phrase _x_i2 in let (o, _x_i3) = o#location _x_i3 in let (o, _x_i4) = o#option (fun o -> o#datatype') _x_i4 - in (o, (`Val ((_x, (_x_i1, _x_i2), _x_i3, _x_i4)))) - | `Fun ((_x, _x1, (_x_i1, _x_i2), _x_i3, _x_i4)) -> + in (o, (Val ((_x, (_x_i1, _x_i2), _x_i3, _x_i4)))) + | Fun ((_x, _x1, (_x_i1, _x_i2), _x_i3, _x_i4)) -> let (o, _x) = o#binder _x in let (o, _x_i2) = o#funlit _x_i2 in let (o, _x_i3) = o#location _x_i3 in let (o, _x_i4) = o#option (fun o -> o#datatype') _x_i4 - in (o, (`Fun ((_x, _x1, (_x_i1, _x_i2), _x_i3, _x_i4)))) - | `Funs _x -> + in (o, (Fun ((_x, _x1, (_x_i1, _x_i2), _x_i3, _x_i4)))) + | Funs _x -> let (o, _x) = o#list (fun o (_x, _x1, (_x_i1, _x_i2), _x_i3, _x_i4, _x_i5) -> @@ -2114,23 +2114,23 @@ class fold_map = let (o, _x_i5) = o#position _x_i5 in (o, (_x, _x1, (_x_i1, _x_i2), _x_i3, _x_i4, _x_i5))) _x - in (o, (`Funs _x)) - | `Handler (b, hnlit, t) -> + in (o, (Funs _x)) + | Handler (b, hnlit, t) -> let (o, b) = o#binder b in let (o, hnlit) = o#handlerlit hnlit in let (o, t) = o#option (fun o -> o#unknown) t in - (o, `Handler (b, hnlit, t)) - | `Foreign ((_x, _x_i1, _x_i2, _x_i3, _x_i4)) -> + (o, Handler (b, hnlit, t)) + | Foreign ((_x, _x_i1, _x_i2, _x_i3, _x_i4)) -> let (o, _x) = o#binder _x in let (o, _x_i1) = o#name _x_i1 in let (o, _x_i2) = o#name _x_i2 in let (o, _x_i3) = o#name _x_i3 in let (o, _x_i4) = o#datatype' _x_i4 - in (o, (`Foreign ((_x, _x_i1, _x_i2, _x_i3, _x_i4)))) - | `QualifiedImport _xs -> + in (o, (Foreign ((_x, _x_i1, _x_i2, _x_i3, _x_i4)))) + | QualifiedImport _xs -> let (o, _xs) = o#list (fun o n -> o#name n) _xs in - (o, `QualifiedImport _xs) - | `Type ((_x, _x_i1, _x_i2)) -> + (o, QualifiedImport _xs) + | Type ((_x, _x_i1, _x_i2)) -> let (o, _x) = o#name _x in let (o, _x_i1) = o#list @@ -2140,14 +2140,14 @@ class fold_map = in (o, (_x, _x_i1))) _x_i1 in let (o, _x_i2) = o#datatype' _x_i2 - in (o, (`Type ((_x, _x_i1, _x_i2)))) - | `Infix -> (o, `Infix) - | `Exp _x -> let (o, _x) = o#phrase _x in (o, (`Exp _x)) - | `Module (n, bs) -> + in (o, (Type ((_x, _x_i1, _x_i2)))) + | Infix -> (o, Infix) + | Exp _x -> let (o, _x) = o#phrase _x in (o, (Exp _x)) + | Module (n, bs) -> let (o, n) = o#string n in let (o, bs) = o#list (fun o -> o#binding) bs in - (o, (`Module (n, bs))) - | `AlienBlock (lang, lib, dts) -> + (o, (Module (n, bs))) + | AlienBlock (lang, lib, dts) -> let (o, lang) = o#name lang in let (o, lib) = o#name lib in let (o, dts) = o#list (fun o (b, dt) -> @@ -2155,7 +2155,7 @@ class fold_map = let (o, dt) = o#datatype' dt in (o, (b, dt)) ) dts in - (o, (`AlienBlock (lang, lib, dts))) + (o, (AlienBlock (lang, lib, dts))) method binding : binding -> ('self_type * binding) = fun {node; pos} -> diff --git a/core/sugartoir.ml b/core/sugartoir.ml index d52ad1cfd..296258277 100644 --- a/core/sugartoir.ml +++ b/core/sugartoir.ml @@ -1065,27 +1065,28 @@ struct | [] -> ec e | { Sugartypes.node = b; _ }::bs -> begin + let open Sugartypes in match b with - | `Val ({Sugartypes.node=Sugartypes.Pattern.Variable bndr; _}, (_, body), _, _) - when Sugartypes.binder_has_type bndr -> - let x = Sugartypes.name_of_binder bndr in - let xt = Sugartypes.type_of_binder_exn bndr in + | Val ({node=Pattern.Variable bndr; _}, (_, body), _, _) + when binder_has_type bndr -> + let x = name_of_binder bndr in + let xt = type_of_binder_exn bndr in let x_info = (xt, x, scope) in I.letvar (x_info, ec body, fun v -> eval_bindings scope (extend [x] [(v, xt)] env) bs e) - | `Val (p, (_, body), _, _) -> + | Val (p, (_, body), _, _) -> let p, penv = CompilePatterns.desugar_pattern scope p in let env' = env ++ penv in let s = ev body in let ss = eval_bindings scope env' bs e in I.comp env (p, s, ss) - | `Fun (bndr, _, (tyvars, ([ps], body)), location, _) - when Sugartypes.binder_has_type bndr -> - let f = Sugartypes.name_of_binder bndr in - let ft = Sugartypes.type_of_binder_exn bndr in + | Fun (bndr, _, (tyvars, ([ps], body)), location, _) + when binder_has_type bndr -> + let f = name_of_binder bndr in + let ft = type_of_binder_exn bndr in let ps, body_env = List.fold_right (fun p (ps, body_env) -> @@ -1098,14 +1099,14 @@ struct env ((ft, f, scope), (tyvars, (ps, body)), location) (fun v -> eval_bindings scope (extend [f] [(v, ft)] env) bs e) - | `Exp e' -> + | Exp e' -> I.comp env (`Any, ev e', eval_bindings scope env bs e) - | `Funs defs -> + | Funs defs -> let fs, inner_fts, outer_fts = List.fold_right (fun (bndr, _, ((_tyvars, inner_opt), _), _, _, _) (fs, inner_fts, outer_fts) -> - let f = Sugartypes.name_of_binder bndr in - let outer_opt = Sugartypes.type_of_binder bndr in + let f = name_of_binder bndr in + let outer_opt = type_of_binder bndr in let outer = OptionUtils.val_of outer_opt in let (inner, _) = OptionUtils.val_of inner_opt in (f::fs, inner::inner_fts, outer::outer_fts)) @@ -1115,8 +1116,8 @@ struct List.map (fun (bndr, _, ((tyvars, _), (pss, body)), location, _, _) -> assert (List.length pss = 1); - let f = Sugartypes.name_of_binder bndr in - let ft_opt = Sugartypes.type_of_binder bndr in + let f = name_of_binder bndr in + let ft_opt = type_of_binder bndr in let ft = OptionUtils.val_of ft_opt in let ps = List.hd pss in let ps, body_env = @@ -1131,17 +1132,18 @@ struct defs in I.letrec env defs (fun vs -> eval_bindings scope (extend fs (List.combine vs outer_fts) env) bs e) - | `Foreign (bndr, raw_name, language, _file, _) - when Sugartypes.binder_has_type bndr -> - let x = Sugartypes.name_of_binder bndr in - let xt = Sugartypes.type_of_binder_exn bndr in + | Foreign (bndr, raw_name, language, _file, _) + when binder_has_type bndr -> + let x = name_of_binder bndr in + let xt = type_of_binder_exn bndr in I.alien ((xt, x, scope), raw_name, language, fun v -> eval_bindings scope (extend [x] [(v, xt)] env) bs e) - | `Type _ - | `Infix -> + | Type _ + | Infix -> (* Ignore type alias and infix declarations - they shouldn't be needed in the IR *) eval_bindings scope env bs e - | `Handler _ | `QualifiedImport _ | `Fun _ | `Foreign _ | `AlienBlock _ | `Module _ -> assert false + | Handler _ | QualifiedImport _ | Fun _ | Foreign _ + | AlienBlock _ | Module _ -> assert false end and evalv env e = diff --git a/core/sugartypes.ml b/core/sugartypes.ml index e6d5eeefc..0072dd853 100644 --- a/core/sugartypes.ml +++ b/core/sugartypes.ml @@ -327,19 +327,20 @@ and phrasenode = [ | `Raise ] and phrase = phrasenode with_pos -and bindingnode = [ -| `Val of Pattern.with_pos * (tyvar list * phrase) * location * datatype' option -| `Fun of binder * declared_linearity * (tyvar list * funlit) * location * datatype' option -| `Funs of (binder * declared_linearity * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * location * datatype' option * position) list -| `Handler of binder * handlerlit * datatype' option -| `Foreign of binder * name * name * name * datatype' (* Binder, raw function name, language, external file, type *) -| `QualifiedImport of name list -| `Type of name * (quantifier * tyvar option) list * datatype' -| `Infix -| `Exp of phrase -| `Module of name * binding list -| `AlienBlock of (name * name * ((binder * datatype') list)) -] +and bindingnode = +| Val of (Pattern.with_pos * (tyvar list * phrase) * location * datatype' option) +| Fun of (binder * declared_linearity * (tyvar list * funlit) * location * datatype' option) +| Funs of (binder * declared_linearity * + ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * + location * datatype' option * position) list +| Handler of (binder * handlerlit * datatype' option) +| Foreign of (binder * name * name * name * datatype') (* Binder, raw function name, language, external file, type *) +| QualifiedImport of name list +| Type of (name * (quantifier * tyvar option) list * datatype') +| Infix +| Exp of phrase +| Module of (name * binding list) +| AlienBlock of (name * name * ((binder * datatype') list)) and binding = bindingnode with_pos and block_body = binding list * phrase and cp_phrasenode = @@ -530,14 +531,14 @@ struct and binding ({node = binding; _}: binding) : StringSet.t (* vars bound in the pattern *) * StringSet.t (* free vars in the rhs *) = match binding with - | `Val (pat, (_, rhs), _, _) -> pattern pat, phrase rhs - | `Handler (bndr, hnlit, _) -> + | Val (pat, (_, rhs), _, _) -> pattern pat, phrase rhs + | Handler (bndr, hnlit, _) -> let name = singleton (name_of_binder bndr) in name, (diff (handlerlit hnlit) name) - | `Fun (bndr, _, (_, fn), _, _) -> + | Fun (bndr, _, (_, fn), _, _) -> let name = singleton (name_of_binder bndr) in name, (diff (funlit fn) name) - | `Funs funs -> + | Funs funs -> let names, rhss = List.fold_right (fun (bndr, _, (_, rhs), _, _, _) (names, rhss) -> @@ -545,19 +546,19 @@ struct funs (empty, []) in names, union_map (fun rhs -> diff (funlit rhs) names) rhss - | `Foreign (bndr, _, _, _, _) -> singleton (name_of_binder bndr), empty - | `QualifiedImport _ - | `Type _ - | `Infix -> empty, empty - | `Exp p -> empty, phrase p - | `AlienBlock (_, _, decls) -> + | Foreign (bndr, _, _, _, _) -> singleton (name_of_binder bndr), empty + | QualifiedImport _ + | Type _ + | Infix -> empty, empty + | Exp p -> empty, phrase p + | AlienBlock (_, _, decls) -> let bound_foreigns = List.fold_left (fun acc (bndr, _) -> StringSet.add (name_of_binder bndr) acc) (StringSet.empty) decls in bound_foreigns, empty (* TODO: this needs to be implemented *) - | `Module _ -> failwith "Freevars for modules not implemented yet" + | Module _ -> failwith "Freevars for modules not implemented yet" and funlit (args, body : funlit) : StringSet.t = diff (phrase body) (union_map (union_map pattern) args) and handlerlit (_, m, cases, params : handlerlit) : StringSet.t = diff --git a/core/transformSugar.ml b/core/transformSugar.ml index 450d976fb..4e66ce118 100644 --- a/core/transformSugar.ml +++ b/core/transformSugar.ml @@ -763,15 +763,15 @@ class transform (env : Types.typing_environment) = method bindingnode : bindingnode -> ('self_type * bindingnode) = function - | `Val (p, (tyvars, e), location, t) -> + | Val (p, (tyvars, e), location, t) -> let outer_tyvars = o#backup_quantifiers in let (o, tyvars) = o#quantifiers tyvars in let (o, e, _) = o#phrase e in let o = o#restore_quantifiers outer_tyvars in let (o, p) = o#pattern p in let (o, t) = optionu o (fun o -> o#datatype') t in - (o, `Val (p, (tyvars, e), location, t)) - | `Fun (bndr, lin, (tyvars, lam), location, t) when binder_has_type bndr -> + (o, Val (p, (tyvars, e), location, t)) + | Fun (bndr, lin, (tyvars, lam), location, t) when binder_has_type bndr -> let outer_tyvars = o#backup_quantifiers in let (o, tyvars) = o#quantifiers tyvars in let inner_effects = fun_effects (type_of_binder_exn bndr) (fst lam) in @@ -779,9 +779,9 @@ class transform (env : Types.typing_environment) = let o = o#restore_quantifiers outer_tyvars in let (o, bndr) = o#binder bndr in let (o, t) = optionu o (fun o -> o#datatype') t in - (o, `Fun (bndr, lin, (tyvars, lam), location, t)) - | `Fun _ -> failwith "Unannotated non-recursive function binding" - | `Funs defs -> + (o, Fun (bndr, lin, (tyvars, lam), location, t)) + | Fun _ -> failwith "Unannotated non-recursive function binding" + | Funs defs -> (* put the inner bindings in the environment *) let o = o#rec_activate_inner_bindings defs in @@ -790,20 +790,20 @@ class transform (env : Types.typing_environment) = (* put the outer bindings in the environment *) let o, defs = o#rec_activate_outer_bindings defs in - (o, (`Funs defs)) - | `Handler _ -> assert false - | `Foreign (f, raw_name, language, file, t) -> + (o, (Funs defs)) + | Handler _ -> assert false + | Foreign (f, raw_name, language, file, t) -> let (o, f) = o#binder f in - (o, `Foreign (f, raw_name, language, file, t)) - | `Type (name, vars, (_, Some dt)) as e -> + (o, Foreign (f, raw_name, language, file, t)) + | Type (name, vars, (_, Some dt)) as e -> let tycon_env = TyEnv.bind tycon_env (name, `Alias (List.map (snd ->- val_of) vars, dt)) in {< tycon_env=tycon_env >}, e - | `Type _ -> failwith "Unannotated type alias" - | `Infix -> (o, `Infix) - | `Exp e -> let (o, e, _) = o#phrase e in (o, `Exp e) - | `AlienBlock _ -> assert false - | `Module _ -> assert false - | `QualifiedImport _ -> assert false + | Type _ -> failwith "Unannotated type alias" + | Infix -> (o, Infix) + | Exp e -> let (o, e, _) = o#phrase e in (o, Exp e) + | AlienBlock _ -> assert false + | Module _ -> assert false + | QualifiedImport _ -> assert false method binding : binding -> ('self_type * binding) = fun {node; pos} -> diff --git a/core/typeSugar.ml b/core/typeSugar.ml index b2fb34d5a..165105dc3 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -106,17 +106,17 @@ struct | `DBUpdate _ -> false and is_pure_binding ({node ; _ }: binding) = match node with (* need to check that pattern matching cannot fail *) - | `QualifiedImport _ - | `AlienBlock _ - | `Module _ - | `Fun _ - | `Funs _ - | `Infix - | `Type _ - | `Handler _ - | `Foreign _ -> true - | `Exp p -> is_pure p - | `Val (pat, (_, rhs), _, _) -> + | QualifiedImport _ + | AlienBlock _ + | Module _ + | Fun _ + | Funs _ + | Infix + | Type _ + | Handler _ + | Foreign _ -> true + | Exp p -> is_pure p + | Val (pat, (_, rhs), _, _) -> is_safe_pattern pat && is_pure rhs and is_safe_pattern {node = pat; _} = let open Pattern in match pat with @@ -3594,7 +3594,7 @@ and type_binding : context -> binding -> binding * context * usagemap = let empty_context = empty_context (context.Types.effect_row) in let typed, ctxt, usage = match def with - | `Val (pat, (_, body), location, datatype) -> + | Val (pat, (_, body), location, datatype) -> let body = tc body in let pat = tpc pat in let penv = pattern_env pat in @@ -3623,11 +3623,11 @@ and type_binding : context -> binding -> binding * context * usagemap = else [], erase_pat pat, penv in - `Val (pat, (tyvars, body), location, datatype), + Val (pat, (tyvars, body), location, datatype), {empty_context with var_env = penv}, usage - | `Fun (bndr, lin, (_, (pats, body)), location, t) -> + | Fun (bndr, lin, (_, (pats, body)), location, t) -> let name = name_of_binder bndr in let vs = name :: check_for_duplicate_names pos (List.flatten pats) in let pats = List.map (List.map tpc) pats in @@ -3696,14 +3696,14 @@ and type_binding : context -> binding -> binding * context * usagemap = (* generalise*) let (tyvars, _tyargs), ft = Utils.generalise context.var_env ft in let ft = Instantiate.freshen_quantifiers ft in - (`Fun (set_binder_type bndr ft, + (Fun (set_binder_type bndr ft, lin, (tyvars, (List.map (List.map erase_pat) pats, erase body)), location, t), {empty_context with var_env = Env.bind Env.empty (name, ft)}, StringMap.filter (fun v _ -> not (List.mem v vs)) (usages body)) - | `Funs defs -> + | Funs defs -> (* Compute initial types for the functions using - the patterns @@ -3853,29 +3853,29 @@ and type_binding : context -> binding -> binding * context * usagemap = let defined = List.map (fun (bndr, _, _, _, _, _) -> name_of_binder bndr) defs in - `Funs defs, {empty_context with var_env = outer_env}, (StringMap.filter (fun v _ -> not (List.mem v defined)) (merge_usages used)) + Funs defs, {empty_context with var_env = outer_env}, (StringMap.filter (fun v _ -> not (List.mem v defined)) (merge_usages used)) - | `Foreign (bndr, raw_name, language, file, (dt1, Some datatype)) -> + | Foreign (bndr, raw_name, language, file, (dt1, Some datatype)) -> (* Ensure that we quantify FTVs *) let (_tyvars, _args), datatype = Utils.generalise context.var_env datatype in let datatype = Instantiate.freshen_quantifiers datatype in - (`Foreign (set_binder_type bndr datatype, raw_name, language, file, (dt1, Some datatype)), + (Foreign (set_binder_type bndr datatype, raw_name, language, file, (dt1, Some datatype)), (bind_var empty_context (name_of_binder bndr, datatype)), StringMap.empty) - | `Foreign _ -> assert false - | `Type (name, vars, (_, Some dt)) as t -> + | Foreign _ -> assert false + | Type (name, vars, (_, Some dt)) as t -> t, bind_tycon empty_context (name, `Alias (List.map (snd ->- val_of) vars, dt)), StringMap.empty - | `Type _ -> assert false - | `Infix -> `Infix, empty_context, StringMap.empty - | `Exp e -> + | Type _ -> assert false + | Infix -> Infix, empty_context, StringMap.empty + | Exp e -> let e = tc e in let () = unify pos ~handle:Gripers.bind_exp (pos_and_typ e, no_pos Types.unit_type) in - `Exp (erase e), empty_context, usages e - | `Handler _ - | `QualifiedImport _ - | `AlienBlock _ - | `Module _ -> assert false + Exp (erase e), empty_context, usages e + | Handler _ + | QualifiedImport _ + | AlienBlock _ + | Module _ -> assert false in {node = typed; pos}, ctxt, usage and type_regex typing_env : regex -> regex = From eda5440c6cc295227d1e02f1a46e2cef2ed959a7 Mon Sep 17 00:00:00 2001 From: Jan Stolarek Date: Wed, 20 Feb 2019 12:15:30 +0000 Subject: [PATCH 06/28] Prefix cp_phrasenodes constructors with CP This will allow to avoid name clashes after converting phrasenode datatype to an ordinary variant datatype (instead of current polymorphic variant implementation) --- core/desugarCP.ml | 20 ++++++------ core/parser.mly | 22 +++++++------- core/sugarConstructors.ml | 2 +- core/sugarTraversals.ml | 64 +++++++++++++++++++-------------------- core/sugartypes.ml | 34 ++++++++++----------- core/transformSugar.ml | 40 ++++++++++++------------ core/typeSugar.ml | 40 ++++++++++++------------ 7 files changed, 111 insertions(+), 111 deletions(-) diff --git a/core/desugarCP.ml b/core/desugarCP.ml index 2e864b5b1..62edba9e9 100644 --- a/core/desugarCP.ml +++ b/core/desugarCP.ml @@ -22,18 +22,18 @@ object (o : 'self_type) | `CP p -> let rec desugar_cp = fun o {node = p; _} -> match p with - | Unquote (bs, e) -> + | CPUnquote (bs, e) -> let envs = o#backup_envs in let (o, bs) = TransformSugar.listu o (fun o -> o#binding) bs in let (o, e, t) = o#phrase e in let o = o#restore_envs envs in o, block_node (bs, e), t - | Grab ((c, _), None, p) -> + | CPGrab ((c, _), None, p) -> let (o, e, t) = desugar_cp o p in o, block_node ([val_binding (any_pat dp) (fn_appl_var wait_str c)], with_dummy_pos e), t - | Grab ((c, Some (`Input (_a, s), grab_tyargs)), Some {node=x, Some u; _}, p) -> (* FYI: a = u *) + | CPGrab ((c, Some (`Input (_a, s), grab_tyargs)), Some {node=x, Some u; _}, p) -> (* FYI: a = u *) let envs = o#backup_envs in let venv = TyEnv.bind (TyEnv.bind (o#get_var_env ()) (x, u)) (c, s) in @@ -46,12 +46,12 @@ object (o : 'self_type) ("2", variable_pat ~ty:s c)], None))) (fn_appl receive_str grab_tyargs [var c])], with_dummy_pos e), t - | Give ((c, _), None, p) -> + | CPGive ((c, _), None, p) -> let (o, e, t) = desugar_cp o p in o, block_node ([val_binding (any_pat dp) (fn_appl_var close_str c)], with_dummy_pos e), t - | Give ((c, Some (`Output (_t, s), give_tyargs)), Some e, p) -> + | CPGive ((c, Some (`Output (_t, s), give_tyargs)), Some e, p) -> let envs = o#backup_envs in let o = {< var_env = TyEnv.bind (o#get_var_env ()) (c, s) >} in let (o, e, _typ) = o#phrase e in @@ -61,9 +61,9 @@ object (o : 'self_type) ([val_binding (variable_pat ~ty:s c) (fn_appl send_str give_tyargs [e; var c])], with_dummy_pos p), t - | GiveNothing ({node=c, Some t; _}) -> + | CPGiveNothing ({node=c, Some t; _}) -> o, `Var c, t - | Select ({node=c, Some s; _}, label, p) -> + | CPSelect ({node=c, Some s; _}, label, p) -> let envs = o#backup_envs in let o = {< var_env = TyEnv.bind (o#get_var_env ()) (c, TypeUtils.select_type label s) >} in let (o, p, t) = desugar_cp o p in @@ -72,7 +72,7 @@ object (o : 'self_type) ([val_binding (variable_pat ~ty:(TypeUtils.select_type label s) c) (with_dummy_pos (`Select (label, var c)))], with_dummy_pos p), t - | Offer ({node=c, Some s; _}, cases) -> + | CPOffer ({node=c, Some s; _}, cases) -> let desugar_branch (label, p) (o, cases) = let envs = o#backup_envs in let o = {< var_env = TyEnv.bind (o#get_var_env ()) (c, TypeUtils.choice_at label s) >} in @@ -85,11 +85,11 @@ object (o : 'self_type) | (_, []) -> assert false (* Case list cannot be empty *) | (cases, t :: _ts) -> o, `Offer (var c, cases, Some t), t) - | Link ({node=c, Some ct; _}, {node=d, Some _; _}) -> + | CPLink ({node=c, Some ct; _}, {node=d, Some _; _}) -> o, fn_appl_node link_sync_str [`Type ct; `Row o#lookup_effects] [var c; var d], Types.make_endbang_type - | Comp ({node=c, Some s; _}, left, right) -> + | CPComp ({node=c, Some s; _}, left, right) -> let envs = o#backup_envs in let (o, left, _typ) = desugar_cp {< var_env = TyEnv.bind (o#get_var_env ()) (c, s) >} left in let (o, right, t) = desugar_cp {< var_env = TyEnv.bind (o#get_var_env ()) (c, Types.dual_type s) >} right in diff --git a/core/parser.mly b/core/parser.mly index f1fa2ac1f..1e4faf33f 100644 --- a/core/parser.mly +++ b/core/parser.mly @@ -443,17 +443,17 @@ perhaps_name: | cp_name? { $1 } cp_expression: -| LBRACE block_contents RBRACE { with_pos $loc (Unquote $2) } -| cp_name LPAREN perhaps_name RPAREN DOT cp_expression { with_pos $loc (Grab ((name_of_binder $1, None), $3, $6)) } -| cp_name LPAREN perhaps_name RPAREN { with_pos $loc (Grab ((name_of_binder $1, None), $3, cp_unit $loc)) } -| cp_name LBRACKET exp RBRACKET DOT cp_expression { with_pos $loc (Give ((name_of_binder $1, None), Some $3, $6)) } -| cp_name LBRACKET exp RBRACKET { with_pos $loc (Give ((name_of_binder $1, None), Some $3, cp_unit $loc)) } -| cp_name LBRACKET RBRACKET { with_pos $loc (GiveNothing $1) } -| OFFER cp_name LBRACE perhaps_cp_cases RBRACE { with_pos $loc (Offer ($2, $4)) } -| cp_label cp_name DOT cp_expression { with_pos $loc (Select ($2, $1, $4)) } -| cp_label cp_name { with_pos $loc (Select ($2, $1, cp_unit $loc)) } -| cp_name LRARROW cp_name { with_pos $loc (Link ($1, $3)) } -| NU cp_name DOT LPAREN cp_expression VBAR cp_expression RPAREN{ with_pos $loc (Comp ($2, $5, $7)) } +| LBRACE block_contents RBRACE { with_pos $loc (CPUnquote $2) } +| cp_name LPAREN perhaps_name RPAREN DOT cp_expression { with_pos $loc (CPGrab ((name_of_binder $1, None), $3, $6)) } +| cp_name LPAREN perhaps_name RPAREN { with_pos $loc (CPGrab ((name_of_binder $1, None), $3, cp_unit $loc)) } +| cp_name LBRACKET exp RBRACKET DOT cp_expression { with_pos $loc (CPGive ((name_of_binder $1, None), Some $3, $6)) } +| cp_name LBRACKET exp RBRACKET { with_pos $loc (CPGive ((name_of_binder $1, None), Some $3, cp_unit $loc)) } +| cp_name LBRACKET RBRACKET { with_pos $loc (CPGiveNothing $1) } +| OFFER cp_name LBRACE perhaps_cp_cases RBRACE { with_pos $loc (CPOffer ($2, $4)) } +| cp_label cp_name DOT cp_expression { with_pos $loc (CPSelect ($2, $1, $4)) } +| cp_label cp_name { with_pos $loc (CPSelect ($2, $1, cp_unit $loc)) } +| cp_name LRARROW cp_name { with_pos $loc (CPLink ($1, $3)) } +| NU cp_name DOT LPAREN cp_expression VBAR cp_expression RPAREN{ with_pos $loc (CPComp ($2, $5, $7)) } primary_expression: | atomic_expression { $1 } diff --git a/core/sugarConstructors.ml b/core/sugarConstructors.ml index 671b01715..052bfad7f 100644 --- a/core/sugarConstructors.ml +++ b/core/sugarConstructors.ml @@ -92,7 +92,7 @@ module SugarConstructors (Position : Pos) | [e] -> record ~ppos [("1", e)] | es -> with_pos ppos (`TupleLit es) - let cp_unit ppos = with_pos ppos (Unquote ([], tuple ~ppos [])) + let cp_unit ppos = with_pos ppos (CPUnquote ([], tuple ~ppos [])) let list ?(ppos=dp) ?ty elems = with_pos ppos (`ListLit (elems, ty)) diff --git a/core/sugarTraversals.ml b/core/sugarTraversals.ml index 92c760648..ad50c91a5 100644 --- a/core/sugarTraversals.ml +++ b/core/sugarTraversals.ml @@ -437,14 +437,14 @@ class map = method cp_phrasenode : cp_phrasenode -> cp_phrasenode = function - | Unquote (bs, e) -> Unquote (o#list (fun o -> o#binding) bs, o#phrase e) - | Grab (c, x, p) -> Grab (c, x, o#cp_phrase p) - | Give (c, e, p) -> Give (c, o#option (fun o -> o#phrase) e, o#cp_phrase p) - | GiveNothing c -> GiveNothing (o#binder c) - | Select (c, l, p) -> Select (c, l, o#cp_phrase p) - | Offer (c, bs) -> Offer (c, o#list (fun o (l, p) -> (l, o#cp_phrase p)) bs) - | Link (c, d) -> Link (c, d) - | Comp (c, p, q) -> Comp (c, o#cp_phrase p, o#cp_phrase q) + | CPUnquote (bs, e) -> CPUnquote (o#list (fun o -> o#binding) bs, o#phrase e) + | CPGrab (c, x, p) -> CPGrab (c, x, o#cp_phrase p) + | CPGive (c, e, p) -> CPGive (c, o#option (fun o -> o#phrase) e, o#cp_phrase p) + | CPGiveNothing c -> CPGiveNothing (o#binder c) + | CPSelect (c, l, p) -> CPSelect (c, l, o#cp_phrase p) + | CPOffer (c, bs) -> CPOffer (c, o#list (fun o (l, p) -> (l, o#cp_phrase p)) bs) + | CPLink (c, d) -> CPLink (c, d) + | CPComp (c, p, q) -> CPComp (c, o#cp_phrase p, o#cp_phrase q) method cp_phrase : cp_phrase -> cp_phrase = fun {node; pos} -> with_pos (o#position pos) (o#cp_phrasenode node) @@ -1113,14 +1113,14 @@ class fold = method cp_phrasenode : cp_phrasenode -> 'self_type = function - | Unquote (bs, e) -> (o#list (fun o -> o#binding) bs)#phrase e - | Grab (_c, _x, p) -> o#cp_phrase p - | Give (_c, e, p) -> (o#option (fun o -> o#phrase) e)#cp_phrase p - | GiveNothing c -> o#binder c - | Select (_c, _l, p) -> o#cp_phrase p - | Offer (_c, bs) -> o#list (fun o (_l, b) -> o#cp_phrase b) bs - | Link (_c, _d) -> o - | Comp (_c, p, q) -> (o#cp_phrase p)#cp_phrase q + | CPUnquote (bs, e) -> (o#list (fun o -> o#binding) bs)#phrase e + | CPGrab (_c, _x, p) -> o#cp_phrase p + | CPGive (_c, e, p) -> (o#option (fun o -> o#phrase) e)#cp_phrase p + | CPGiveNothing c -> o#binder c + | CPSelect (_c, _l, p) -> o#cp_phrase p + | CPOffer (_c, bs) -> o#list (fun o (_l, b) -> o#cp_phrase b) bs + | CPLink (_c, _d) -> o + | CPComp (_c, p, q) -> (o#cp_phrase p)#cp_phrase q method cp_phrase : cp_phrase -> 'self_node = fun {node; pos} -> (o#cp_phrasenode node)#position pos @@ -1840,34 +1840,34 @@ class fold_map = method cp_phrasenode : cp_phrasenode -> ('self_type * cp_phrasenode) = function - | Unquote (bs, e) -> + | CPUnquote (bs, e) -> let o, bs = o#list (fun o -> o#binding) bs in let o, e = o#phrase e in - o, Unquote (bs, e) - | Grab (c, x, p) -> + o, CPUnquote (bs, e) + | CPGrab (c, x, p) -> let o, p = o#cp_phrase p in - o, Grab (c, x, p) - | Give (c, e, p) -> + o, CPGrab (c, x, p) + | CPGive (c, e, p) -> let o, e = o#option (fun o -> o#phrase) e in let o, p = o#cp_phrase p in - o, Give (c, e, p) - | GiveNothing c -> + o, CPGive (c, e, p) + | CPGiveNothing c -> let o, c = o#binder c in - o, GiveNothing c - | Select (c, l, p) -> + o, CPGiveNothing c + | CPSelect (c, l, p) -> let o, p = o#cp_phrase p in - o, Select (c, l, p) - | Offer (c, bs) -> + o, CPSelect (c, l, p) + | CPOffer (c, bs) -> let o, bs = o#list (fun o (l, p) -> let o, p = o#cp_phrase p in o, (l, p)) bs in - o, Offer (c, bs) - | Link (c, d) -> - o, Link (c, d) - | Comp (c, p, q) -> + o, CPOffer (c, bs) + | CPLink (c, d) -> + o, CPLink (c, d) + | CPComp (c, p, q) -> let o, p = o#cp_phrase p in let o, q = o#cp_phrase q in - o, Comp (c, p, q) + o, CPComp (c, p, q) method cp_phrase : cp_phrase -> ('self_type * cp_phrase) = fun {node; pos} -> diff --git a/core/sugartypes.ml b/core/sugartypes.ml index 0072dd853..d20e34a69 100644 --- a/core/sugartypes.ml +++ b/core/sugartypes.ml @@ -344,14 +344,14 @@ and bindingnode = and binding = bindingnode with_pos and block_body = binding list * phrase and cp_phrasenode = -| Unquote of (binding list * phrase) -| Grab of (string * (Types.datatype * tyarg list) option) * binder option * cp_phrase -| Give of (string * (Types.datatype * tyarg list) option) * phrase option * cp_phrase -| GiveNothing of binder -| Select of (binder * string * cp_phrase) -| Offer of (binder * (string * cp_phrase) list) -| Link of (binder * binder) -| Comp of (binder * cp_phrase * cp_phrase) +| CPUnquote of (binding list * phrase) +| CPGrab of (string * (Types.datatype * tyarg list) option) * binder option * cp_phrase +| CPGive of (string * (Types.datatype * tyarg list) option) * phrase option * cp_phrase +| CPGiveNothing of binder +| CPSelect of (binder * string * cp_phrase) +| CPOffer of (binder * (string * cp_phrase) list) +| CPLink of (binder * binder) +| CPComp of (binder * cp_phrase * cp_phrase) and cp_phrase = cp_phrasenode with_pos [@@deriving show] @@ -584,18 +584,18 @@ struct | Replace (r, `Literal _) -> regex r | Replace (r, `Splice p) -> union (regex r) (phrase p) and cp_phrase {node = p; _ } = match p with - | Unquote e -> block e - | Grab ((c, _t), Some bndr, p) -> + | CPUnquote e -> block e + | CPGrab ((c, _t), Some bndr, p) -> union (singleton c) (diff (cp_phrase p) (singleton (name_of_binder bndr))) - | Grab ((c, _t), None, p) -> union (singleton c) (cp_phrase p) - | Give ((c, _t), e, p) -> union (singleton c) (union (option_map phrase e) (cp_phrase p)) - | GiveNothing bndr -> singleton (name_of_binder bndr) - | Select (bndr, _label, p) -> + | CPGrab ((c, _t), None, p) -> union (singleton c) (cp_phrase p) + | CPGive ((c, _t), e, p) -> union (singleton c) (union (option_map phrase e) (cp_phrase p)) + | CPGiveNothing bndr -> singleton (name_of_binder bndr) + | CPSelect (bndr, _label, p) -> union (singleton (name_of_binder bndr)) (cp_phrase p) - | Offer (bndr, cases) -> + | CPOffer (bndr, cases) -> union (singleton (name_of_binder bndr)) (union_map (fun (_label, p) -> cp_phrase p) cases) - | Link (bndr1, bndr2) -> + | CPLink (bndr1, bndr2) -> union (singleton (name_of_binder bndr1)) (singleton (name_of_binder bndr2)) - | Comp (bndr, left, right) -> + | CPComp (bndr, left, right) -> diff (union (cp_phrase left) (cp_phrase right)) (singleton (name_of_binder bndr)) end diff --git a/core/transformSugar.ml b/core/transformSugar.ml index 4e66ce118..ce3cc7e7d 100644 --- a/core/transformSugar.ml +++ b/core/transformSugar.ml @@ -822,44 +822,44 @@ class transform (env : Types.typing_environment) = (* TODO: should really invoke o#datatype on type annotations! *) method cp_phrasenode : cp_phrasenode -> ('self_type * cp_phrasenode * Types.datatype) = function - | Unquote (bs, e) -> + | CPUnquote (bs, e) -> let envs = o#backup_envs in let (o, bs) = listu o (fun o -> o#binding) bs in let (o, e, t) = o#phrase e in let o = o#restore_envs envs in - o, Unquote (bs, e), t - | Grab (cbind, None, p) -> + o, CPUnquote (bs, e), t + | CPGrab (cbind, None, p) -> let (o, p, t) = o#cp_phrase p in - o, Grab (cbind, None, p), t - | Grab ((c, Some (`Input (_a, s), _grab_tyargs) as cbind), Some b, p) -> (* FYI: a = u *) + o, CPGrab (cbind, None, p), t + | CPGrab ((c, Some (`Input (_a, s), _grab_tyargs) as cbind), Some b, p) -> (* FYI: a = u *) let envs = o#backup_envs in let (o, b) = o#binder b in let venv = TyEnv.bind (o#get_var_env ()) (c, s) in let o = {< var_env = venv >} in let (o, p, t) = o#cp_phrase p in let o = o#restore_envs envs in - o, Grab (cbind, Some b, p), t - | Give ((c, Some (`Output (_t, s), _tyargs) as cbind), e, p) -> + o, CPGrab (cbind, Some b, p), t + | CPGive ((c, Some (`Output (_t, s), _tyargs) as cbind), e, p) -> let envs = o#backup_envs in let o = {< var_env = TyEnv.bind (o#get_var_env ()) (c, s) >} in let (o, e, _typ) = option o (fun o -> o#phrase) e in let (o, p, t) = o#cp_phrase p in let o = o#restore_envs envs in - o, Give (cbind, e, p), t - | GiveNothing c -> + o, CPGive (cbind, e, p), t + | CPGiveNothing c -> let envs = o#backup_envs in let o, c = o#binder c in let o = o#restore_envs envs in - o, GiveNothing c, Types.make_endbang_type - | Grab _ -> failwith "Malformed grab in TransformSugar" - | Give _ -> failwith "Malformed give in TransformSugar" - | Select (b, label, p) -> + o, CPGiveNothing c, Types.make_endbang_type + | CPGrab _ -> failwith "Malformed grab in TransformSugar" + | CPGive _ -> failwith "Malformed give in TransformSugar" + | CPSelect (b, label, p) -> let envs = o#backup_envs in let o, b = o#binder b in let (o, p, t) = o#cp_phrase p in let o = o#restore_envs envs in - o, Select (b, label, p), t - | Offer (b, cases) -> + o, CPSelect (b, label, p), t + | CPOffer (b, cases) -> let (o, cases) = List.fold_right (fun (label, p) (o, cases) -> let envs = o#backup_envs in let o, _ = o#binder b in @@ -868,16 +868,16 @@ class transform (env : Types.typing_environment) = begin match List.split cases with | cases, t :: _ts -> - o, Offer (b, cases), t + o, CPOffer (b, cases), t | _ -> assert false end - | Link (c, d) -> o, Link (c, d), Types.unit_type - | Comp ({node = c, Some s; _} as bndr, left, right) -> + | CPLink (c, d) -> o, CPLink (c, d), Types.unit_type + | CPComp ({node = c, Some s; _} as bndr, left, right) -> let envs = o#backup_envs in let (o, left, _typ) = {< var_env = TyEnv.bind (o#get_var_env ()) (c, s) >}#cp_phrase left in let whiny_dual_type s = try Types.dual_type s with Invalid_argument _ -> raise (Invalid_argument ("Attempted to dualize non-session type " ^ Types.string_of_datatype s)) in let (o, right, t) = {< var_env = TyEnv.bind (o#get_var_env ()) (c, whiny_dual_type s) >}#cp_phrase right in let o = o#restore_envs envs in - o, Comp (bndr, left, right), t - | Comp _ -> assert false + o, CPComp (bndr, left, right), t + | CPComp _ -> assert false end diff --git a/core/typeSugar.ml b/core/typeSugar.ml index 165105dc3..a23dedc0a 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -3937,19 +3937,19 @@ and type_cp (context : context) = fun {node = p; pos} -> let unify ~pos ~handle (t, u) = unify_or_raise ~pos:pos ~handle:handle (("", t), ("", u)) in let (p, t, u) = match p with - | Unquote (bindings, e) -> + | CPUnquote (bindings, e) -> let context', bindings, usage_builder = type_bindings context bindings in let (e, t, u) = type_check (Types.extend_typing_environment context context') e in if Settings.get_value endbang_antiquotes then unify ~pos:pos ~handle:Gripers.cp_unquote (t, Types.make_endbang_type); - Unquote (bindings, e), t, usage_builder u - | Grab ((c, _), None, p) -> + CPUnquote (bindings, e), t, usage_builder u + | CPGrab ((c, _), None, p) -> let (_, t, _) = type_check context (with_pos pos (`Var c)) in let ctype = `Alias (("EndQuery", []), `Input (Types.unit_type, `End)) in unify ~pos:pos ~handle:(Gripers.cp_grab c) (t, ctype); let (p, pt, u) = type_cp (unbind_var context c) p in - Grab ((c, Some (ctype, [])), None, p), pt, use c u - | Grab ((c, _), Some bndr, p) -> + CPGrab ((c, Some (ctype, [])), None, p), pt, use c u + | CPGrab ((c, _), Some bndr, p) -> let x = name_of_binder bndr in let (_, t, _) = type_check context (with_pos pos (`Var c)) in let a = Types.fresh_type_variable (`Any, `Any) in @@ -3978,14 +3978,14 @@ and type_cp (context : context) = fun {node = p; pos} -> | _ -> assert false end | _ -> assert false in - Grab ((c, Some (ctype, tyargs)), Some (set_binder_type bndr a), p), pt, use c (StringMap.remove x u) - | Give ((c, _), None, p) -> + CPGrab ((c, Some (ctype, tyargs)), Some (set_binder_type bndr a), p), pt, use c (StringMap.remove x u) + | CPGive ((c, _), None, p) -> let (_, t, _) = type_check context (with_pos pos (`Var c)) in let ctype = `Output (Types.unit_type, `End) in unify ~pos:pos ~handle:(Gripers.cp_give c) (t, ctype); let (p, t, u) = type_cp (unbind_var context c) p in - Give ((c, Some (ctype, [])), None, p), t, use c u - | Give ((c, _), Some e, p) -> + CPGive ((c, Some (ctype, [])), None, p), t, use c u + | CPGive ((c, _), Some e, p) -> let (_, t, _) = type_check context (with_pos pos (`Var c)) in let (e, t', u) = type_check context e in let s = Types.fresh_session_variable `Any in @@ -4008,14 +4008,14 @@ and type_cp (context : context) = fun {node = p; pos} -> | _ -> assert false end | _ -> assert false in - Give ((c, Some (ctype, tyargs)), Some e, p), t, use c (merge_usages [u; u']) - | GiveNothing bndr -> + CPGive ((c, Some (ctype, tyargs)), Some e, p), t, use c (merge_usages [u; u']) + | CPGiveNothing bndr -> let c = name_of_binder bndr in let binder_pos = bndr.pos in let _, t, _ = type_check context (with_pos binder_pos (`Var c)) in unify ~pos:pos ~handle:Gripers.(cp_give c) (t, Types.make_endbang_type); - GiveNothing (set_binder_type bndr t), t, StringMap.singleton c 1 - | Select (bndr, label, p) -> + CPGiveNothing (set_binder_type bndr t), t, StringMap.singleton c 1 + | CPSelect (bndr, label, p) -> let c = name_of_binder bndr in let (_, t, _) = type_check context (with_pos pos (`Var c)) in let s = Types.fresh_session_variable `Any in @@ -4024,8 +4024,8 @@ and type_cp (context : context) = fun {node = p; pos} -> unify ~pos:pos ~handle:(Gripers.cp_select c) (t, ctype); let (p, t, u) = with_channel c s (type_cp (bind_var context (c, s)) p) in - Select (set_binder_type bndr ctype, label, p), t, use c u - | Offer (bndr, branches) -> + CPSelect (set_binder_type bndr ctype, label, p), t, use c u + | CPOffer (bndr, branches) -> let c = name_of_binder bndr in let (_, t, _) = type_check context (with_pos pos (`Var c)) in (* @@ -4044,8 +4044,8 @@ and type_cp (context : context) = fun {node = p; pos} -> let t' = Types.fresh_type_variable (`Any, `Any) in List.iter (fun (_, t, _) -> unify ~pos:pos ~handle:Gripers.cp_offer_branches (t, t')) branches; let u = usage_compat (List.map (fun (_, _, u) -> u) branches) in - Offer (set_binder_type bndr t, List.map (fun (x, _, _) -> x) branches), t', use c u - | Link (bndr1, bndr2) -> + CPOffer (set_binder_type bndr t, List.map (fun (x, _, _) -> x) branches), t', use c u + | CPLink (bndr1, bndr2) -> let c = name_of_binder bndr1 in let d = name_of_binder bndr2 in let (_, tc, uc) = type_check context (with_pos pos (`Var c)) in @@ -4055,14 +4055,14 @@ and type_cp (context : context) = fun {node = p; pos} -> unify ~pos:pos ~handle:Gripers.cp_link_session (td, Types.fresh_type_variable (`Any, `Session)); unify ~pos:pos ~handle:Gripers.cp_link_dual (Types.dual_type tc, td); - Link (set_binder_type bndr1 tc, set_binder_type bndr1 td), Types.make_endbang_type, merge_usages [uc; ud] - | Comp (bndr, left, right) -> + CPLink (set_binder_type bndr1 tc, set_binder_type bndr1 td), Types.make_endbang_type, merge_usages [uc; ud] + | CPComp (bndr, left, right) -> let c = name_of_binder bndr in let s = Types.fresh_session_variable `Any in let left, t, u = with_channel c s (type_cp (bind_var context (c, s)) left) in let right, t', u' = with_channel c (`Dual s) (type_cp (bind_var context (c, `Dual s)) right) in unify ~pos:pos ~handle:Gripers.cp_comp_left (Types.make_endbang_type, t); - Comp (set_binder_type bndr s, left, right), t', merge_usages [u; u'] in + CPComp (set_binder_type bndr s, left, right), t', merge_usages [u; u'] in {node = p; pos}, t, u let show_pre_sugar_typing = Basicsettings.TypeSugar.show_pre_sugar_typing From 3e5b598761de092b7885a6a78f8af7bed3f6a7ec Mon Sep 17 00:00:00 2001 From: Jan Stolarek Date: Wed, 20 Feb 2019 13:07:45 +0000 Subject: [PATCH 07/28] Redefine phrasenode as a variant --- core/checkXmlQuasiquotes.ml | 18 +- core/desugarAlienBlocks.ml | 4 +- core/desugarCP.ml | 8 +- core/desugarDatatypes.ml | 18 +- core/desugarDbs.ml | 5 +- core/desugarFormlets.ml | 36 +-- core/desugarFors.ml | 6 +- core/desugarFuns.ml | 8 +- core/desugarHandlers.ml | 14 +- core/desugarInners.ml | 18 +- core/desugarLAttributes.ml | 31 +- core/desugarModules.ml | 28 +- core/desugarPages.ml | 28 +- core/desugarProcesses.ml | 16 +- core/desugarRegexes.ml | 6 +- core/desugarSessionExceptions.ml | 32 +- core/dumpTypes.ml | 2 +- core/experimentalExtensions.ml | 20 +- core/lens/lensTypes.ml | 6 +- core/lens/lens_phrase.ml | 19 +- core/moduleUtils.ml | 2 +- core/parser.mly | 116 +++---- core/refineBindings.ml | 4 +- core/sugarConstructors.ml | 38 +-- core/sugarTraversals.ml | 538 +++++++++++++++---------------- core/sugartoir.ml | 225 ++++++------- core/sugartypes.ml | 256 ++++++++------- core/transformSugar.ml | 212 ++++++------ core/typeSugar.ml | 433 ++++++++++++------------- 29 files changed, 1073 insertions(+), 1074 deletions(-) diff --git a/core/checkXmlQuasiquotes.ml b/core/checkXmlQuasiquotes.ml index 95541b656..2cfc92042 100644 --- a/core/checkXmlQuasiquotes.ml +++ b/core/checkXmlQuasiquotes.ml @@ -16,19 +16,19 @@ let check mode pos e = method! phrase = fun ({node=e; pos} as phrase) -> match e with - | `Xml (_, _, _, children) -> + | Xml (_, _, _, children) -> o#list (fun o -> o#phrase) children - | `FormBinding _ -> + | FormBinding _ -> if mode <> `Formlet then {< error = Some (`FormletBinding, pos) >} else super#phrase phrase - | `FormletPlacement _ -> + | FormletPlacement _ -> if mode <> `Page then {< error = Some (`FormletPlacement, pos) >} else super#phrase phrase - | `PagePlacement _ -> + | PagePlacement _ -> if mode <> `Page then {< error = Some (`PagePlacement, pos) >} else @@ -72,18 +72,18 @@ object (o) method! phrase = fun ({node=e; pos} as phrase) -> match e with - | `Xml _ when mode = `Quasi -> + | Xml _ when mode = `Quasi -> super#phrase phrase - | `Xml _ when mode = `Exp -> + | Xml _ when mode = `Exp -> check `Xml pos e; o#phrase_with `Quasi phrase - | `Formlet (body, yields) when mode = `Exp -> + | Formlet (body, yields) when mode = `Exp -> check `Formlet pos body.node; (o#phrase_with `Quasi body)#phrase yields - | `Page body when mode = `Exp -> + | Page body when mode = `Exp -> check `Page pos body.node; o#phrase_with `Quasi body - | (`Formlet _ | `Page _) when mode = `Quasi -> + | (Formlet _ | Page _) when mode = `Quasi -> (* The parser should prevent this from ever happening *) raise (Errors.SugarError (pos, "Malformed quasiquote (internal error)")) | _ when mode = `Quasi -> diff --git a/core/desugarAlienBlocks.ml b/core/desugarAlienBlocks.ml index be32d8ad3..9a820265a 100644 --- a/core/desugarAlienBlocks.ml +++ b/core/desugarAlienBlocks.ml @@ -19,13 +19,13 @@ object(self) inherit SugarTraversals.map as super method! phrasenode : phrasenode -> phrasenode = function - | `Block (bs, phr) -> + | Block (bs, phr) -> let flattened_bindings = List.concat ( List.map (fun b -> ((flatten_bindings ())#binding b)#get_bindings) bs ) in let flattened_phrase = self#phrase phr in - `Block (flattened_bindings, flattened_phrase) + Block (flattened_bindings, flattened_phrase) | x -> super#phrasenode x end and flatten_bindings = fun () -> diff --git a/core/desugarCP.ml b/core/desugarCP.ml index 62edba9e9..cfc04b36b 100644 --- a/core/desugarCP.ml +++ b/core/desugarCP.ml @@ -19,7 +19,7 @@ object (o : 'self_type) inherit (TransformSugar.transform env) as super method! phrasenode = function - | `CP p -> + | CP p -> let rec desugar_cp = fun o {node = p; _} -> match p with | CPUnquote (bs, e) -> @@ -62,7 +62,7 @@ object (o : 'self_type) (fn_appl send_str give_tyargs [e; var c])], with_dummy_pos p), t | CPGiveNothing ({node=c, Some t; _}) -> - o, `Var c, t + o, Var c, t | CPSelect ({node=c, Some s; _}, label, p) -> let envs = o#backup_envs in let o = {< var_env = TyEnv.bind (o#get_var_env ()) (c, TypeUtils.select_type label s) >} in @@ -70,7 +70,7 @@ object (o : 'self_type) let o = o#restore_envs envs in o, block_node ([val_binding (variable_pat ~ty:(TypeUtils.select_type label s) c) - (with_dummy_pos (`Select (label, var c)))], + (with_dummy_pos (Select (label, var c)))], with_dummy_pos p), t | CPOffer ({node=c, Some s; _}, cases) -> let desugar_branch (label, p) (o, cases) = @@ -84,7 +84,7 @@ object (o : 'self_type) (match List.split cases with | (_, []) -> assert false (* Case list cannot be empty *) | (cases, t :: _ts) -> - o, `Offer (var c, cases, Some t), t) + o, Offer (var c, cases, Some t), t) | CPLink ({node=c, Some ct; _}, {node=d, Some _; _}) -> o, fn_appl_node link_sync_str [`Type ct; `Row o#lookup_effects] [var c; var d], diff --git a/core/desugarDatatypes.ml b/core/desugarDatatypes.ml index 99b59909a..5bf2f687b 100644 --- a/core/desugarDatatypes.ml +++ b/core/desugarDatatypes.ml @@ -19,7 +19,7 @@ object (self) | _ -> self method! phrasenode = function - | `TableLit (_, (_, None), _, _, _) -> {< all_desugared = false >} + | TableLit (_, (_, None), _, _, _) -> {< all_desugared = false >} | p -> super#phrasenode p end @@ -452,7 +452,7 @@ object (self) method! phrasenode = function - | `Block (bs, p) -> + | Block (bs, p) -> (* aliases bound in `bs' should not escape the scope of the block *) let o = {<>} in @@ -461,19 +461,19 @@ object (self) (* NB: we return `self' rather than `_o' in order to return to the outer scope; any aliases bound in _o are unreachable from outside the block *) - self, `Block (bs, p) - | `TypeAnnotation (p, dt) -> + self, Block (bs, p) + | TypeAnnotation (p, dt) -> let o, p = self#phrase p in - o, `TypeAnnotation (p, Desugar.datatype' map self#aliases dt) - | `Upcast (p, dt1, dt2) -> + o, TypeAnnotation (p, Desugar.datatype' map self#aliases dt) + | Upcast (p, dt1, dt2) -> let o, p = self#phrase p in - o, `Upcast (p, Desugar.datatype' map alias_env dt1, Desugar.datatype' map alias_env dt2) - | `TableLit (t, (dt, _), cs, keys, p) -> + o, Upcast (p, Desugar.datatype' map alias_env dt1, Desugar.datatype' map alias_env dt2) + | TableLit (t, (dt, _), cs, keys, p) -> let read, write, needed = Desugar.tableLit alias_env cs dt in let o, t = self#phrase t in let o, keys = o#phrase keys in let o, p = o#phrase p in - o, `TableLit (t, (dt, Some (read, write, needed)), cs, keys, p) + o, TableLit (t, (dt, Some (read, write, needed)), cs, keys, p) (* Switch and receive type annotations are never filled in by this point, so we ignore them. *) | p -> super#phrasenode p diff --git a/core/desugarDbs.ml b/core/desugarDbs.ml index f76f0ba88..9fae703ef 100644 --- a/core/desugarDbs.ml +++ b/core/desugarDbs.ml @@ -1,3 +1,4 @@ +open Sugartypes open SugarConstructors.Make (* @@ -46,7 +47,7 @@ object (o : 'self_type) inherit (TransformSugar.transform env) as super method! phrasenode : Sugartypes.phrasenode -> ('self_type * Sugartypes.phrasenode * Types.datatype) = function - | `DBInsert (table, _labels, rows, returning) -> + | DBInsert (table, _labels, rows, returning) -> (* TODO: work out how to type this properly *) let eff = o#lookup_effects in let o, table, table_type = o#phrase table in @@ -87,6 +88,6 @@ object method satisfied = has_no_dbs method! phrasenode = function - | `DBInsert _ -> {< has_no_dbs = false >} + | DBInsert _ -> {< has_no_dbs = false >} | e -> super#phrasenode e end diff --git a/core/desugarFormlets.ml b/core/desugarFormlets.ml index bc34a085e..29a70b0a9 100644 --- a/core/desugarFormlets.ml +++ b/core/desugarFormlets.ml @@ -4,13 +4,13 @@ open SugarConstructors.Make let rec is_raw phrase = match phrase.node with - | `TextNode _ -> true - | `Block _ -> true - | `FormBinding _ -> false - | `Xml (_, _, _, children) -> - List.for_all is_raw children - | _ -> - raise (Errors.SugarError (phrase.pos, "Invalid element in formlet literal")) + | TextNode _ -> true + | Block _ -> true + | FormBinding _ -> false + | Xml (_, _, _, children) -> + List.for_all is_raw children + | _ -> + raise (Errors.SugarError (phrase.pos, "Invalid element in formlet literal")) let tt = function @@ -38,7 +38,7 @@ object (o : 'self_type) match ph.node with | _ when is_raw ph -> [tuple_pat []], [tuple []], [Types.unit_type] - | `FormBinding (f, p) -> + | FormBinding (f, p) -> let (_o, _f, ft) = o#phrase f in let t = Types.fresh_type_variable (`Any, `Any) in let () = @@ -47,9 +47,9 @@ object (o : 'self_type) let name = Utility.gensym ~prefix:"_formlet_" () in let (xb, x) = (binder name ~ty:t, var name) in [with_dummy_pos (Pattern.As (xb, p))], [x], [t] - | `Xml (_, _, _, [node]) -> + | Xml (_, _, _, [node]) -> o#formlet_patterns node - | `Xml (_, _, _, contents) -> + | Xml (_, _, _, contents) -> let ps, vs, ts = List.fold_left (fun (ps, vs, ts) e -> @@ -67,22 +67,22 @@ object (o : 'self_type) method private formlet_body_node : Sugartypes.phrasenode -> ('self_type * Sugartypes.phrasenode * Types.datatype) = fun e -> match e with - | `TextNode s -> + | TextNode s -> let e = fn_appl_node xml_str [`Row (o#lookup_effects)] [fn_appl string_to_xml_str [`Row (o#lookup_effects)] [constant_str s]] in (o, e, Types.xml_type) - | `Block (bs, e) -> + | Block (bs, e) -> let (o, e, _) = o#phrasenode (block_node (bs, (fn_appl xml_str [`Row (o#lookup_effects)] [e]))) in (o, e, Types.xml_type) - | `FormBinding (f, _) -> + | FormBinding (f, _) -> let (o, {node=f; _}, ft) = o#phrase f in (o, f, ft) - | `Xml ("#", [], None, contents) -> + | Xml ("#", [], None, contents) -> (* pure (fun ps -> vs) <*> e1 <*> ... <*> ek *) let pss, vs, ts = let pss, vs, ts = @@ -110,7 +110,7 @@ object (o : 'self_type) match args with | [] -> let (o, e, _) = - super#phrasenode (`Xml ("#", [], None, contents)) + super#phrasenode (Xml ("#", [], None, contents)) in (o, fn_appl_node xml_str [`Row (o#lookup_effects)] [with_dummy_pos e], Types.xml_type) @@ -134,7 +134,7 @@ object (o : 'self_type) in (o, p.node, et) end - | `Xml(tag, attrs, attrexp, contents) -> + | Xml(tag, attrs, attrexp, contents) -> (* plug (fun x -> ({x})) (<#>contents)^o*) let (o, attrexp, _) = TransformSugar.option o (fun o -> o#phrase) attrexp in let eff = o#lookup_effects in @@ -154,7 +154,7 @@ object (o : 'self_type) let (o, node, t) = o#formlet_body_node node in (o, {node; pos}, t) method! phrasenode : phrasenode -> ('self_type * phrasenode * Types.datatype) = function - | `Formlet (body, yields) -> + | Formlet (body, yields) -> (* pure (fun q^ -> [[e]]* ) <*> q^o *) (* let e_in = `Formlet (body, yields) in *) let empty_eff = Types.make_empty_closed_row () in @@ -192,6 +192,6 @@ object method satisfied = has_no_formlets method! phrasenode = function - | `Formlet _ -> {< has_no_formlets = false >} + | Formlet _ -> {< has_no_formlets = false >} | e -> super#phrasenode e end diff --git a/core/desugarFors.ml b/core/desugarFors.ml index 7b5816678..895119bc9 100644 --- a/core/desugarFors.ml +++ b/core/desugarFors.ml @@ -141,7 +141,7 @@ object (o : 'self_type) method! phrasenode : Sugartypes.phrasenode -> ('self_type * Sugartypes.phrasenode * Types.datatype) = function - | `Iteration (generators, body, filter, sort) -> + | Iteration (generators, body, filter, sort) -> let eff = o#lookup_effects in let o, (es, ps, xs, ts) = o#qualifiers generators in let o, body, body_type = o#phrase body in @@ -153,7 +153,7 @@ object (o : 'self_type) match filter with | None -> body | Some condition -> - with_dummy_pos (`Conditional (condition, body, list ~ty:elem_type [])) in + with_dummy_pos (Conditional (condition, body, list ~ty:elem_type [])) in let arg = match ps with @@ -202,6 +202,6 @@ object method satisfied = has_no_fors method! phrasenode = function - | `Iteration _ -> {< has_no_fors = false >} + | Iteration _ -> {< has_no_fors = false >} | e -> super#phrasenode e end diff --git a/core/desugarFuns.ml b/core/desugarFuns.ml index acba1e8c9..a6ab9e19e 100644 --- a/core/desugarFuns.ml +++ b/core/desugarFuns.ml @@ -65,7 +65,7 @@ object (o : 'self_type) inherit (TransformSugar.transform env) as super method! phrasenode : Sugartypes.phrasenode -> ('self_type * Sugartypes.phrasenode * Types.datatype) = function - | `FunLit (Some argss, lin, lam, location) -> + | FunLit (Some argss, lin, lam, location) -> let inner_mb = snd (try last argss with Invalid_argument s -> raise (Invalid_argument ("!"^s))) in let (o, lam, rt) = o#funlit inner_mb lam in let ft = @@ -82,7 +82,7 @@ object (o : 'self_type) var f) in (o, e, ft) - | `Section (`Project name) -> + | Section (`Project name) -> let ab, a = Types.fresh_type_quantifier (`Any, `Any) in let rhob, (fields, rho, _) = Types.fresh_row_quantifier (`Any, `Any) in let effb, eff = Types.fresh_row_quantifier (`Any, `Any) in @@ -95,7 +95,7 @@ object (o : 'self_type) `Function (Types.make_tuple_type [r], eff, 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, name)) in let e : phrasenode = block_node ([fun_binding' ~tyvars:[ab; rhob; effb] (binder ~ty:ft f) (pss, body)], @@ -131,7 +131,7 @@ object method satisfied = has_no_funs method! phrasenode = function - | `FunLit _ -> {< has_no_funs = false >} + | FunLit _ -> {< has_no_funs = false >} | e -> super#phrasenode e method! bindingnode = function diff --git a/core/desugarHandlers.ml b/core/desugarHandlers.ml index 37b94efb7..aeb7623ee 100644 --- a/core/desugarHandlers.ml +++ b/core/desugarHandlers.ml @@ -141,13 +141,13 @@ let rec phrase_of_pattern : Pattern.with_pos -> phrase | Constant c -> constant c | Variable b -> var (name_of_binder b) | As (b,_) -> var (name_of_binder b) - | HasType (p,t) -> with_dummy_pos (`TypeAnnotation (phrase_of_pattern p, t)) + | HasType (p,t) -> with_dummy_pos (TypeAnnotation (phrase_of_pattern p, t)) end (* This function applies the list of parameters to the generated handle. *) let apply_params : phrase -> phrase list list -> phrase = fun h pss -> - List.fold_right (fun ps acc -> with_dummy_pos (`FnAppl (acc, ps)) ) (List.rev pss) h + List.fold_right (fun ps acc -> with_dummy_pos (FnAppl (acc, ps)) ) (List.rev pss) h let split_handler_cases : (Pattern.with_pos * phrase) list -> (Pattern.with_pos * phrase) list * (Pattern.with_pos * phrase) list = fun cases -> @@ -174,10 +174,10 @@ let split_handler_cases : (Pattern.with_pos * phrase) list -> (Pattern.with_pos let funlit_of_handlerlit : Sugartypes.handlerlit -> Sugartypes.funlit = fun (depth, m, cases, params) -> let m = deanonymize m in - let comp = with_dummy_pos (`FnAppl (phrase_of_pattern m, [])) in + let comp = with_dummy_pos (FnAppl (phrase_of_pattern m, [])) in let cases = parameterize cases params in let hndlr = SugarConstructors.Make.untyped_handler comp cases depth in - let handle = block ([], (with_dummy_pos (`Handle hndlr))) in + let handle = block ([], (with_dummy_pos (Handle hndlr))) in let params = opt_map (List.map (List.map deanonymize)) params in let body = match params with @@ -198,7 +198,7 @@ let desugar_handlers_early = object inherit SugarTraversals.map as super method! phrasenode = function - | `HandlerLit hnlit -> + | HandlerLit hnlit -> let (fnparams, body) = funlit_of_handlerlit hnlit in let funlit : Sugartypes.phrasenode = (fun_lit `Unl fnparams body).node in super#phrasenode funlit @@ -206,9 +206,9 @@ object method! phrase {node; pos} = match node with - | `Handle h -> + | Handle h -> let (val_cases, eff_cases) = split_handler_cases h.sh_effect_cases in - with_dummy_pos (`Handle { h with sh_effect_cases = eff_cases; + with_dummy_pos (Handle { h with sh_effect_cases = eff_cases; sh_value_cases = val_cases }) | _ -> super#phrase {node; pos} diff --git a/core/desugarInners.ml b/core/desugarInners.ml index 2073d1885..3b66e3e6e 100644 --- a/core/desugarInners.ml +++ b/core/desugarInners.ml @@ -34,26 +34,26 @@ object (o : 'self_type) {< extra_env = StringMap.remove f extra_env >} method! phrasenode = function - | `TAppl ({node=`Var name;_} as phn, tyargs) when StringMap.mem name extra_env -> + | TAppl ({node=Var name;_} as phn, tyargs) when StringMap.mem name extra_env -> let extras = StringMap.find name extra_env in let tyargs = add_extras (extras, tyargs) in - super#phrasenode (`TAppl (phn, tyargs)) - | `InfixAppl ((tyargs, `Name name), e1, e2) when StringMap.mem name extra_env -> + super#phrasenode (TAppl (phn, tyargs)) + | InfixAppl ((tyargs, `Name name), e1, e2) when StringMap.mem name extra_env -> let extras = StringMap.find name extra_env in let tyargs = add_extras (extras, tyargs) in - super#phrasenode (`InfixAppl ((tyargs, `Name name), e1, e2)) - | `UnaryAppl ((tyargs, `Name name), e) when StringMap.mem name extra_env -> + super#phrasenode (InfixAppl ((tyargs, `Name name), e1, e2)) + | UnaryAppl ((tyargs, `Name name), e) when StringMap.mem name extra_env -> let extras = StringMap.find name extra_env in let tyargs = add_extras (extras, tyargs) in - super#phrasenode (`UnaryAppl ((tyargs, `Name name), e)) + super#phrasenode (UnaryAppl ((tyargs, `Name name), e)) (* HACK: manage the lexical scope of extras *) - | `Spawn _ as e -> + | Spawn _ as e -> let (o, e, t) = super#phrasenode e in (o#with_extra_env extra_env, e, t) - | `Escape _ as e -> + | Escape _ as e -> let (o, e, t) = super#phrasenode e in (o#with_extra_env extra_env, e, t) - | `Block _ as e -> + | Block _ as e -> let (o, e, t) = super#phrasenode e in (o#with_extra_env extra_env, e, t) | e -> super#phrasenode e diff --git a/core/desugarLAttributes.ml b/core/desugarLAttributes.ml index 3e5f517bd..956f83281 100644 --- a/core/desugarLAttributes.ml +++ b/core/desugarLAttributes.ml @@ -11,7 +11,7 @@ open SugarConstructors.Make *) let has_lattrs : phrasenode -> bool = function - | `Xml (_, attrs, _, _) -> exists (fst ->- start_of ~is:"l:") attrs + | Xml (_, attrs, _, _) -> exists (fst ->- start_of ~is:"l:") attrs | _ -> false let apply name args : phrase = fn_appl name [] args @@ -28,7 +28,7 @@ let fresh_names () = id, name let desugar_lhref : phrasenode -> phrasenode = function - | `Xml (("a"|"A") as a, attrs, attrexp, children) + | Xml (("a"|"A") as a, attrs, attrexp, children) when mem_assoc "l:href" attrs -> let attrs = match partition (fst ->- (=)"l:href") attrs with @@ -40,12 +40,11 @@ let desugar_lhref : phrasenode -> phrasenode = function | _ -> assert false (* multiple l:hrefs, or an invalid rhs; NOTE: this is a user error and should be reported as such --ez.*) - in - `Xml (a, attrs, attrexp, children) + in Xml (a, attrs, attrexp, children) | e -> e let desugar_laction : phrasenode -> phrasenode = function - | `Xml (("form"|"FORM") as form, attrs, attrexp, children) + | Xml (("form"|"FORM") as form, attrs, attrexp, children) when mem_assoc "l:action" attrs -> begin match partition (fst ->- (=)"l:action") attrs with | [_,[action_expr]], rest -> @@ -57,7 +56,7 @@ let desugar_laction : phrasenode -> phrasenode = function [fun_lit ~location:`Server `Unl [[]] action_expr]]] None [] and action = ("action", [constant_str "#"]) - in `Xml (form, action::rest, attrexp, hidden::children) + in Xml (form, action::rest, attrexp, hidden::children) | _ -> assert false (* multiple l:actions, or an invalid rhs; NOTE: this is a user error and should be reported as such --ez. *) @@ -72,21 +71,21 @@ let desugar_lonevent : phrasenode -> phrasenode = fun_lit ~location:`Client `Unl [[variable_pat "event"]] rhs] | _ -> assert false in function - | `Xml (tag, attrs, attrexp, children) + | Xml (tag, attrs, attrexp, children) when exists (fst ->- start_of ~is:"l:on") attrs -> let lons, others = partition (fst ->- start_of ~is:"l:on") attrs in let idattr = ("key", [apply "registerEventHandlers" [list (List.map (event_handler_pair) lons)]]) in - `Xml (tag, idattr::others, attrexp, children) + Xml (tag, idattr::others, attrexp, children) | e -> e let desugar_lnames (p : phrasenode) : phrasenode * (string * string) StringMap.t = let lnames = ref StringMap.empty in let add lname (id,name) = lnames := StringMap.add lname (id,name) !lnames in let attr : string * phrase list -> (string * phrase list) list = function - | "l:name", [{node=`Constant (`String v); _}] -> + | "l:name", [{node=Constant (`String v); _}] -> let id, name = fresh_names () in add v (id,name); [("name", [constant_str name]); @@ -94,11 +93,11 @@ let desugar_lnames (p : phrasenode) : phrasenode * (string * string) StringMap.t | "l:name", _ -> failwith ("Invalid l:name binding") | a -> [a] in let rec aux : phrasenode -> phrasenode = function - | `Xml (tag, attrs, attrexp, children) -> + | Xml (tag, attrs, attrexp, children) -> let attrs = concat_map attr attrs and children = List.map (fun {node;_} -> with_dummy_pos (aux node)) children in - `Xml (tag, attrs, attrexp, children) + Xml (tag, attrs, attrexp, children) | p -> p in let p' = aux p in @@ -121,7 +120,7 @@ let bind_lname_vars lnames = function | attr -> attr let desugar_form : phrasenode -> phrasenode = function - | `Xml (("form"|"FORM") as form, attrs, attrexp, children) -> + | Xml (("form"|"FORM") as form, attrs, attrexp, children) -> let children = List.map (fun {node;_} -> node) children in let children, lnames = List.split (List.map desugar_lnames children) in let lnames = @@ -129,14 +128,14 @@ let desugar_form : phrasenode -> phrasenode = function with StringMap.Not_disjoint (item, _) -> raise (Errors.SugarError (dummy_position, "Duplicate l:name binding: " ^ item)) in let attrs = List.map (bind_lname_vars lnames) attrs in - `Xml (form, attrs, attrexp, List.map with_dummy_pos children) + Xml (form, attrs, attrexp, List.map with_dummy_pos children) | e -> e let replace_lattrs : phrasenode -> phrasenode = desugar_form ->- desugar_laction ->- desugar_lhref ->- desugar_lonevent ->- (fun (xml) -> if (has_lattrs xml) then match xml with - | `Xml (_tag, _attributes, _, _) -> + | Xml (_tag, _attributes, _, _) -> raise (Errors.SugarError (dummy_position, "Illegal l: attribute in XML node")) | _ -> assert false else @@ -146,7 +145,7 @@ let desugar_lattributes = object inherit SugarTraversals.map as super method! phrasenode = function - | `Xml _ as x when has_lattrs x -> + | Xml _ as x when has_lattrs x -> super#phrasenode (replace_lattrs x) | e -> super#phrasenode e end @@ -159,6 +158,6 @@ object (_self) method satisfied = no_lattributes method! phrasenode = function - | `Xml _ as x when has_lattrs x -> {< no_lattributes = false >} + | Xml _ as x when has_lattrs x -> {< no_lattributes = false >} | e -> super#phrasenode e end diff --git a/core/desugarModules.ml b/core/desugarModules.ml index 083983799..fb9210ad6 100644 --- a/core/desugarModules.ml +++ b/core/desugarModules.ml @@ -38,13 +38,13 @@ object(self) inherit SugarTraversals.map as super method! phrasenode : phrasenode -> phrasenode = function - | `Block (bs, phr) -> + | Block (bs, phr) -> let flattened_bindings = List.concat ( List.map (fun b -> ((flatten_bindings ())#binding b)#get_bindings) bs ) in let flattened_phrase = self#phrase phr in - `Block (flattened_bindings, flattened_phrase) + Block (flattened_bindings, flattened_phrase) | x -> super#phrasenode x end @@ -241,7 +241,7 @@ and perform_renaming module_table path term_ht type_ht = | uo -> super#unary_op uo method! phrasenode = function - | `Block (bs, phr) -> + | Block (bs, phr) -> (* Process bindings, then process the phrase using * updated shadow table. *) let (term_ht, type_ht, bs') = @@ -250,29 +250,29 @@ and perform_renaming module_table path term_ht type_ht = let (_, phr') = (perform_renaming module_table path term_ht type_ht)#phrase phr in - (self, `Block (bs', phr')) - | `Var n -> (self, `Var (resolve n term_shadow_table)) - | `RecordLit (xs, p_opt) -> + (self, Block (bs', phr')) + | Var n -> (self, Var (resolve n term_shadow_table)) + | RecordLit (xs, p_opt) -> let (_, xs') = self#list (fun o (n, p) -> let (o, p') = o#phrase p in (o, (n, p'))) xs in let (_, p_opt') = self#option (fun o -> o#phrase) p_opt in - (self, `RecordLit (xs', p_opt')) - | `Projection (p, n) -> + (self, RecordLit (xs', p_opt')) + | Projection (p, n) -> let (_, p') = self#phrase p in - (self, `Projection (p', n)) - | `ConstructorLit (n, p_opt, dt_opt) -> + (self, Projection (p', n)) + | ConstructorLit (n, p_opt, dt_opt) -> (* Resolve constructor name using term table *) let fqn = resolve n term_shadow_table in let (_, p_opt') = self#option (fun o -> o#phrase) p_opt in - (self, `ConstructorLit (fqn, p_opt', dt_opt)) - | `QualifiedVar [] -> assert false - | `QualifiedVar (hd :: tl) -> + (self, ConstructorLit (fqn, p_opt', dt_opt)) + | QualifiedVar [] -> assert false + | QualifiedVar (hd :: tl) -> (* Similar to qualified imports. *) let prefix = resolve hd term_shadow_table in let fqn = String.concat module_sep (prefix :: tl) in - (self, `Var fqn) + (self, Var fqn) | phr -> super#phrasenode phr method! datatypenode = function diff --git a/core/desugarPages.ml b/core/desugarPages.ml index 1d6347fd4..c15eb7c59 100644 --- a/core/desugarPages.ml +++ b/core/desugarPages.ml @@ -3,14 +3,14 @@ open SugarConstructors.Make let rec is_raw phrase = match phrase.node with - | `TextNode _ -> true - | `Block _ -> true - | `FormletPlacement _ - | `PagePlacement _ -> false - | `Xml (_, _, _, children) -> - List.for_all is_raw children - | _e -> - raise (Errors.SugarError (phrase.pos, "Invalid element in page literal")) + | TextNode _ -> true + | Block _ -> true + | FormletPlacement _ + | PagePlacement _ -> false + | Xml (_, _, _, children) -> + List.for_all is_raw children + | _e -> + raise (Errors.SugarError (phrase.pos, "Invalid element in page literal")) (* DODGEYNESS: @@ -33,7 +33,7 @@ let rec desugar_page (o, page_type) = | _ when is_raw phrase -> (* TODO: check that e doesn't contain any formletplacements or page placements *) fn_appl "bodyP" [`Row (o#lookup_effects)] [phrase] - | `FormletPlacement (formlet, handler, attributes) -> + | FormletPlacement (formlet, handler, attributes) -> let (_, formlet, formlet_type) = o#phrase formlet in let formlet_type = Types.concrete_type formlet_type in let a = Types.fresh_type_variable (`Any, `Any) in @@ -41,10 +41,10 @@ let rec desugar_page (o, page_type) = Unify.datatypes (`Alias (("Formlet", [`Type a]), b), formlet_type); fn_appl "formP" [`Type a; `Row (o#lookup_effects)] [formlet; handler; attributes] - | `PagePlacement (page) -> page - | `Xml ("#", [], _, children) -> + | PagePlacement (page) -> page + | Xml ("#", [], _, children) -> desugar_nodes children - | `Xml (name, attrs, dynattrs, children) -> + | Xml (name, attrs, dynattrs, children) -> let x = Utility.gensym ~prefix:"xml" () in fn_appl "plugP" [`Row (o#lookup_effects)] [fun_lit ~args:[Types.make_tuple_type [Types.xml_type], o#lookup_effects] @@ -59,7 +59,7 @@ object inherit (TransformSugar.transform env) as super method! phrasenode = function - | `Page e -> + | Page e -> let (o, e, _t) = super#phrase e in let page_type = Instantiate.alias "Page" [] env.Types.tycon_env in let e = desugar_page (o, page_type) e in @@ -75,6 +75,6 @@ object method satisfied = pageless method! phrasenode = function - | `Page _ -> {< pageless = false >} + | Page _ -> {< pageless = false >} | e -> super#phrasenode e end diff --git a/core/desugarProcesses.ml b/core/desugarProcesses.ml index 1b990b7f4..8b2406f13 100644 --- a/core/desugarProcesses.ml +++ b/core/desugarProcesses.ml @@ -18,7 +18,7 @@ object (o : 'self_type) inherit (TransformSugar.transform env) as super method! phrasenode : Sugartypes.phrasenode -> ('self_type * Sugartypes.phrasenode * Types.datatype) = function - | `Spawn (Wait, spawn_loc, body, Some inner_eff) -> + | Spawn (Wait, spawn_loc, body, Some inner_eff) -> assert (spawn_loc = NoSpawnLocation); (* bring the inner effects into scope, then restore the outer effects afterwards *) @@ -33,7 +33,7 @@ object (o : 'self_type) [fun_lit ~args:[(Types.make_tuple_type [], inner_eff)] `Unl [[]] body] in (o, e, body_type) - | `Spawn (k, spawn_loc, body, Some inner_eff) -> + | Spawn (k, spawn_loc, body, Some inner_eff) -> (* bring the inner effects into scope, then restore the outer effects afterwards *) let process_type = `Application (Types.process, [`Row inner_eff]) in @@ -66,16 +66,16 @@ object (o : 'self_type) spawn_loc_phr] in (o, e, process_type) - | `Receive (cases, Some t) -> + | Receive (cases, Some t) -> let fields, row_var, _ = o#lookup_effects in let other_effects = StringMap.remove "hear" (StringMap.remove "wild" fields), row_var, false in begin match StringMap.find "hear" fields with | (`Present mbt) -> o#phrasenode - (`Switch (fn_appl "recv" [`Type mbt; `Row other_effects] [], - cases, - Some t)) + (Switch (fn_appl "recv" [`Type mbt; `Row other_effects] [], + cases, + Some t)) | _ -> assert false end | e -> super#phrasenode e @@ -91,7 +91,7 @@ object method satisfied = has_no_processes method! phrasenode = function - | `Spawn _ - | `Receive _ -> {< has_no_processes = false >} + | Spawn _ + | Receive _ -> {< has_no_processes = false >} | e -> super#phrasenode e end diff --git a/core/desugarRegexes.ml b/core/desugarRegexes.ml index ff0091121..edb33ca9f 100644 --- a/core/desugarRegexes.ml +++ b/core/desugarRegexes.ml @@ -70,14 +70,14 @@ object(self) val regex_type = Instantiate.alias "Regex" [] env.Types.tycon_env method! phrase ({node=p; pos} as ph) = match p with - | `InfixAppl ((tyargs, `RegexMatch flags), e1, {node=`Regex((Replace(_,_) as r)); _}) -> + | InfixAppl ((tyargs, `RegexMatch flags), e1, {node=Regex((Replace(_,_) as r)); _}) -> let libfn = if List.exists ((=)RegexNative) flags then "sntilde" else "stilde" in self#phrase (fn_appl libfn tyargs [e1; desugar_regex self#phrase regex_type r]) - | `InfixAppl ((tyargs, `RegexMatch flags), e1, {node=`Regex r; _}) -> + | InfixAppl ((tyargs, `RegexMatch flags), e1, {node=Regex r; _}) -> let nativep = List.exists ((=) RegexNative) flags and listp = List.exists ((=) RegexList) flags in let libfn = match listp, nativep with @@ -87,7 +87,7 @@ object(self) | false, true -> "ntilde" in self#phrase (fn_appl libfn tyargs [e1; desugar_regex self#phrase regex_type r]) - | `InfixAppl ((_tyargs, `RegexMatch _), _, _) -> + | InfixAppl ((_tyargs, `RegexMatch _), _, _) -> raise (Errors.SugarError (pos, "Internal error: unexpected rhs of regex operator")) | _ -> super#phrase ph end diff --git a/core/desugarSessionExceptions.ml b/core/desugarSessionExceptions.ml index e3f0df7f6..b3e87edcd 100644 --- a/core/desugarSessionExceptions.ml +++ b/core/desugarSessionExceptions.ml @@ -23,12 +23,12 @@ object (o: 'self_type) inherit (TransformSugar.transform env) as super method! phrasenode = function - | (`Spawn (Wait, _, _, _)) as sw -> + | (Spawn (Wait, _, _, _)) as sw -> super#phrasenode sw - | `Spawn (k, spawn_loc, {node=body;_}, Some inner_effects) -> + | Spawn (k, spawn_loc, {node=body;_}, Some inner_effects) -> let as_var = Utility.gensym ~prefix:"spawn_aspat" () in let as_pat = variable_pat ~ty:`Not_typed as_var in - let unit_phr = with_dummy_pos (`RecordLit ([], None)) in + let unit_phr = with_dummy_pos (RecordLit ([], None)) in let (o, spawn_loc) = o#given_spawn_location spawn_loc in let envs = o#backup_envs in @@ -37,10 +37,10 @@ object (o: 'self_type) let o = o#with_effects inner_effects in let (o, body, _) = o#phrasenode body in let body = - `TryInOtherwise (with_dummy_pos body, as_pat, - var as_var, unit_phr, Some (Types.unit_type)) in + TryInOtherwise (with_dummy_pos body, as_pat, + var as_var, unit_phr, Some (Types.unit_type)) in let o = o#restore_envs envs in - (o, (`Spawn (k, spawn_loc, with_dummy_pos body, Some inner_effects)), process_type) + (o, Spawn (k, spawn_loc, with_dummy_pos body, Some inner_effects), process_type) | e -> super#phrasenode e end @@ -50,10 +50,10 @@ object (o : 'self_type) inherit (TransformSugar.transform env) as super method! phrasenode = function - | `Raise -> - (o, `DoOperation (failure_op_name, [], Some `Not_typed), `Not_typed) - | `TryInOtherwise (_, _, _, _, None) -> assert false - | `TryInOtherwise (try_phr, pat, as_phr, otherwise_phr, (Some dt)) -> + | Raise -> + (o, DoOperation (failure_op_name, [], Some `Not_typed), `Not_typed) + | TryInOtherwise (_, _, _, _, None) -> assert false + | TryInOtherwise (try_phr, pat, as_phr, otherwise_phr, (Some dt)) -> let (o, try_phr, try_dt) = o#phrase try_phr in let envs = o#backup_envs in let (o, pat) = o#pattern pat in @@ -107,7 +107,7 @@ object (o : 'self_type) sh_effect_cases = effect_cases; sh_value_cases = value_cases; sh_descr = hndl_desc - } in (o, `Handle hndlr, dt) + } in (o, Handle hndlr, dt) | e -> super#phrasenode e end @@ -120,8 +120,8 @@ let contains_session_exceptions prog = method satisfied = has_exceptions method! phrasenode = function - | `TryInOtherwise _ - | `Raise -> {< has_exceptions = true >} + | TryInOtherwise _ + | Raise -> {< has_exceptions = true >} | p -> super#phrasenode p end in (o#program prog)#satisfied @@ -160,13 +160,13 @@ let wrap_linear_handlers prog = object inherit SugarTraversals.map as super method! phrase = function - | {node=`TryInOtherwise (l, x, m, n, dtopt); _} -> + | {node=TryInOtherwise (l, x, m, n, dtopt); _} -> let fresh_var = Utility.gensym ?prefix:(Some "try_x") () in let fresh_pat = variable_pat fresh_var in with_dummy_pos - (`Switch ( + (Switch ( with_dummy_pos - (`TryInOtherwise + (TryInOtherwise (super#phrase l, fresh_pat, constructor ~body:(var fresh_var) "Just", diff --git a/core/dumpTypes.ml b/core/dumpTypes.ml index e228b3d3a..f8af13543 100644 --- a/core/dumpTypes.ml +++ b/core/dumpTypes.ml @@ -37,7 +37,7 @@ let program = method! phrase = function - | {Sugartypes.node=`Var x; Sugartypes.pos} when o#bound x -> + | {Sugartypes.node=Sugartypes.Var x; Sugartypes.pos} when o#bound x -> o#use (x, o#lookup x, pos) | e -> super#phrase e end in diff --git a/core/experimentalExtensions.ml b/core/experimentalExtensions.ml index 94bdb79f6..928537739 100644 --- a/core/experimentalExtensions.ml +++ b/core/experimentalExtensions.ml @@ -19,18 +19,18 @@ object failwith "Code uses relational lenses, but relational lenses are not enabled. Please set the relational lenses flag." in function - | `Handle _ when not (get BS.Handlers.enabled) -> + | Handle _ when not (get BS.Handlers.enabled) -> failwith "Handlers are only allowed with setting enable_handlers set to true." - | `HandlerLit _ when not (get BS.Handlers.enabled) -> + | HandlerLit _ when not (get BS.Handlers.enabled) -> failwith "Handlers are only allowed with setting enable_handlers set to true." - | `LensLit _ when relational_lenses_disabled -> relational_fail () - | `LensKeysLit _ when relational_lenses_disabled -> relational_fail () - | `LensFunDepsLit _ when relational_lenses_disabled -> relational_fail () - | `LensDropLit _ when relational_lenses_disabled -> relational_fail () - | `LensSelectLit _ when relational_lenses_disabled -> relational_fail () - | `LensJoinLit _ when relational_lenses_disabled -> relational_fail () - | `LensGetLit _ when relational_lenses_disabled -> relational_fail () - | `LensPutLit _ when relational_lenses_disabled -> relational_fail () + | LensLit _ when relational_lenses_disabled -> relational_fail () + | LensKeysLit _ when relational_lenses_disabled -> relational_fail () + | LensFunDepsLit _ when relational_lenses_disabled -> relational_fail () + | LensDropLit _ when relational_lenses_disabled -> relational_fail () + | LensSelectLit _ when relational_lenses_disabled -> relational_fail () + | LensJoinLit _ when relational_lenses_disabled -> relational_fail () + | LensGetLit _ when relational_lenses_disabled -> relational_fail () + | LensPutLit _ when relational_lenses_disabled -> relational_fail () | e -> super#phrasenode e method! bindingnode = function diff --git a/core/lens/lensTypes.ml b/core/lens/lensTypes.ml index 1cd042ee0..a786ff5da 100644 --- a/core/lens/lensTypes.ml +++ b/core/lens/lensTypes.ml @@ -39,13 +39,13 @@ let sort_cols_of_table (tableName : string) (t : Types.typ) = let var_name (var : phrase) = match var.node with - | `Var name -> name + | Var name -> name | _ -> failwith "Expected a `Var type" let cols_of_phrase (key : phrase) : string list = match key.node with - | `TupleLit keys -> List.map var_name keys - | `Var name -> [name] + | TupleLit keys -> List.map var_name keys + | Var name -> [name] | _ -> failwith "Expected a tuple or a variable." let select_lens_sort (sort : Lens_sort.t) (pred : lens_phrase) : Lens_sort.t = diff --git a/core/lens/lens_phrase.ml b/core/lens/lens_phrase.ml index 424219289..3b4257bd8 100644 --- a/core/lens/lens_phrase.ml +++ b/core/lens/lens_phrase.ml @@ -1,6 +1,5 @@ open Utility open Types -open Sugartypes open Lens_operators open Lens_utility @@ -25,19 +24,19 @@ let tuple v = TupleLit v let tuple_singleton v = tuple [v] let name_of_var expr = - match expr.node with - | `Var n -> n + match expr.Sugartypes.node with + | Sugartypes.Var n -> n | _ -> failwith "Expected var." let of_phrase p = let rec f p = - match p.node with - | `Constant c -> Constant c - | `Var v -> Var v - | `UnaryAppl ((_, op), phrase) -> UnaryAppl (Unary.from_links op, f phrase) - | `InfixAppl ((_, op), phrase1, phrase2) -> InfixAppl (Binary.of_supertype_operator op, f phrase1, f phrase2) - | `TupleLit l -> TupleLit (List.map f l) - | `FnAppl (fn, arg) -> + match p.Sugartypes.node with + | Sugartypes.Constant c -> Constant c + | Sugartypes.Var v -> Var v + | Sugartypes.UnaryAppl ((_, op), phrase) -> UnaryAppl (Unary.from_links op, f phrase) + | Sugartypes.InfixAppl ((_, op), phrase1, phrase2) -> InfixAppl (Binary.of_supertype_operator op, f phrase1, f phrase2) + | Sugartypes.TupleLit l -> TupleLit (List.map f l) + | Sugartypes.FnAppl (fn, arg) -> begin match name_of_var fn with | "not" -> UnaryAppl ((Unary.Name "!"), f (List.hd arg)) diff --git a/core/moduleUtils.ml b/core/moduleUtils.ml index 7ad2d80f8..fb76b0b82 100644 --- a/core/moduleUtils.ml +++ b/core/moduleUtils.ml @@ -64,7 +64,7 @@ object | dt -> super#datatypenode dt method! phrasenode = function - | `QualifiedVar _ -> {< has_no_modules = false >} + | QualifiedVar _ -> {< has_no_modules = false >} | pn -> super#phrasenode pn end diff --git a/core/parser.mly b/core/parser.mly index 1e4faf33f..022407a0c 100644 --- a/core/parser.mly +++ b/core/parser.mly @@ -416,13 +416,13 @@ qualified_type_name: | CONSTRUCTOR DOT separated_nonempty_list(DOT, CONSTRUCTOR) { $1 :: $3 } atomic_expression: -| qualified_name { with_pos $loc (`QualifiedVar $1) } -| VARIABLE { with_pos $loc (`Var $1) } -| constant { with_pos $loc (`Constant $1) } +| qualified_name { with_pos $loc (QualifiedVar $1) } +| VARIABLE { with_pos $loc (Var $1) } +| constant { with_pos $loc (Constant $1) } | parenthesized_thing { $1 } /* HACK: allows us to support both mailbox receive syntax and receive for session types. */ -| RECEIVE { with_pos $loc (`Var "receive") } +| RECEIVE { with_pos $loc (Var "receive") } cp_name: | VARIABLE { binder ~ppos:$loc($1) $1 } @@ -458,10 +458,10 @@ cp_expression: primary_expression: | atomic_expression { $1 } | LBRACKET perhaps_exps RBRACKET { list ~ppos:$loc $2 } -| LBRACKET exp DOTDOT exp RBRACKET { with_pos $loc (`RangeLit($2, $4)) } +| LBRACKET exp DOTDOT exp RBRACKET { with_pos $loc (RangeLit($2, $4)) } | xml { $1 } | linearity arg_lists block { fun_lit ~ppos:$loc $1 $2 $3 } -| LEFTTRIANGLE cp_expression RIGHTTRIANGLE { with_pos $loc (`CP $2) } +| LEFTTRIANGLE cp_expression RIGHTTRIANGLE { with_pos $loc (CP $2) } | handler_depth optional_computation_parameter handler_parameterization { handler_lit ~ppos:$loc (hnlit_arg $1 $2 $3) } @@ -479,12 +479,12 @@ constructor_expression: | CONSTRUCTOR parenthesized_thing? { constructor ~ppos:$loc ?body:$2 $1 } parenthesized_thing: -| LPAREN binop RPAREN { with_pos $loc (`Section $2) } -| LPAREN DOT record_label RPAREN { with_pos $loc (`Section (`Project $3)) } -| LPAREN RPAREN { record ~ppos:$loc [] } -| LPAREN labeled_exps preceded(VBAR, exp)? RPAREN { record ~ppos:$loc $2 ?exp:$3 } -| LPAREN exps RPAREN { with_pos $loc (`TupleLit ($2)) } -| LPAREN exp WITH labeled_exps RPAREN { with_pos $loc (`With ($2, $4)) } +| LPAREN binop RPAREN { with_pos $loc (Section $2) } +| LPAREN DOT record_label RPAREN { with_pos $loc (Section (`Project $3)) } +| LPAREN RPAREN { record ~ppos:$loc [] } +| LPAREN labeled_exps preceded(VBAR, exp)? RPAREN { record ~ppos:$loc $2 ?exp:$3 } +| LPAREN exps RPAREN { with_pos $loc (TupleLit ($2)) } +| LPAREN exp WITH labeled_exps RPAREN { with_pos $loc (With ($2, $4)) } binop: | MINUS { `Minus } @@ -516,10 +516,10 @@ postfix_expression: | primary_expression POSTFIXOP { unary_appl ~ppos:$loc (`Name $2) $1 } | block { $1 } | QUERY block { query ~ppos:$loc None $2 } -| QUERY LBRACKET exp RBRACKET block { query ~ppos:$loc (Some ($3, with_pos $loc (`Constant (`Int 0)))) $5 } +| QUERY LBRACKET exp RBRACKET block { query ~ppos:$loc (Some ($3, with_pos $loc (Constant (`Int 0)))) $5 } | QUERY LBRACKET exp COMMA exp RBRACKET block { query ~ppos:$loc (Some ($3, $5)) $7 } -| postfix_expression arg_spec { with_pos $loc (`FnAppl ($1, $2)) } -| postfix_expression DOT record_label { with_pos $loc (`Projection ($1, $3)) } +| postfix_expression arg_spec { with_pos $loc (FnAppl ($1, $2)) } +| postfix_expression DOT record_label { with_pos $loc (Projection ($1, $3)) } arg_spec: @@ -536,7 +536,7 @@ unary_expression: | MINUSDOT unary_expression { unary_appl ~ppos:$loc `FloatMinus $2 } | PREFIXOP unary_expression { unary_appl ~ppos:$loc (`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)) } infixr_9: @@ -643,14 +643,14 @@ logical_expression: typed_expression: | logical_expression { $1 } -| typed_expression COLON datatype { with_pos $loc (`TypeAnnotation ($1, datatype $3)) } -| typed_expression COLON datatype LARROW datatype { with_pos $loc (`Upcast ($1, datatype $3, datatype $5)) } +| typed_expression COLON datatype { with_pos $loc (TypeAnnotation ($1, datatype $3)) } +| typed_expression COLON datatype LARROW datatype { with_pos $loc (Upcast ($1, datatype $3, datatype $5)) } db_expression: -| DELETE LPAREN table_generator RPAREN perhaps_where { let pat, phrase = $3 in with_pos $loc (`DBDelete (pat, phrase, $5)) } +| DELETE LPAREN table_generator RPAREN perhaps_where { let pat, phrase = $3 in with_pos $loc (DBDelete (pat, phrase, $5)) } | UPDATE LPAREN table_generator RPAREN perhaps_where - SET LPAREN labeled_exps RPAREN { let pat, phrase = $3 in with_pos $loc (`DBUpdate(pat, phrase, $5, $8)) } + SET LPAREN labeled_exps RPAREN { let pat, phrase = $3 in with_pos $loc (DBUpdate(pat, phrase, $5, $8)) } /* XML */ xmlid: @@ -678,28 +678,28 @@ xml_contents: | block { $1 } | formlet_binding | formlet_placement | page_placement | xml { $1 } -| CDATA { with_pos $loc (`TextNode (Utility.xml_unescape $1)) } +| CDATA { with_pos $loc (TextNode (Utility.xml_unescape $1)) } formlet_binding: -| LBRACE logical_expression RARROW pattern RBRACE { with_pos $loc (`FormBinding($2, $4)) } +| LBRACE logical_expression RARROW pattern RBRACE { with_pos $loc (FormBinding($2, $4)) } formlet_placement: | LBRACE logical_expression - FATRARROW logical_expression RBRACE { with_pos $loc (`FormletPlacement ($2, $4, + FATRARROW logical_expression RBRACE { with_pos $loc (FormletPlacement ($2, $4, list ~ppos:$loc [])) } | LBRACE logical_expression FATRARROW logical_expression - WITH logical_expression RBRACE { with_pos $loc (`FormletPlacement ($2, $4, $6)) } + WITH logical_expression RBRACE { with_pos $loc (FormletPlacement ($2, $4, $6)) } page_placement: -| LBRACEBAR exp BARRBRACE { with_pos $loc($2) (`PagePlacement $2) } +| LBRACEBAR exp BARRBRACE { with_pos $loc($2) (PagePlacement $2) } session_expression: -| SELECT field_label exp { with_pos $loc (`Select ($2, $3)) } -| OFFER LPAREN exp RPAREN LBRACE perhaps_cases RBRACE { with_pos $loc (`Offer ($3, $6, None)) } +| SELECT field_label exp { with_pos $loc (Select ($2, $3)) } +| OFFER LPAREN exp RPAREN LBRACE perhaps_cases RBRACE { with_pos $loc (Offer ($3, $6, None)) } conditional_expression: -| IF LPAREN exp RPAREN exp ELSE exp { with_pos $loc (`Conditional ($3, $5, $7)) } +| IF LPAREN exp RPAREN exp ELSE exp { with_pos $loc (Conditional ($3, $5, $7)) } case: | CASE pattern RARROW block_contents { $2, block ~ppos:$loc($4) $4 } @@ -711,15 +711,15 @@ perhaps_cases: | case* { $1 } case_expression: -| SWITCH LPAREN exp RPAREN LBRACE perhaps_cases RBRACE { with_pos $loc (`Switch ($3, $6, None)) } -| RECEIVE LBRACE perhaps_cases RBRACE { with_pos $loc (`Receive ($3, None)) } -| SHALLOWHANDLE LPAREN exp RPAREN LBRACE cases RBRACE { with_pos $loc (`Handle (untyped_handler $3 $6 Shallow)) } -| HANDLE LPAREN exp RPAREN LBRACE perhaps_cases RBRACE { with_pos $loc (`Handle (untyped_handler $3 $6 Deep )) } +| SWITCH LPAREN exp RPAREN LBRACE perhaps_cases RBRACE { with_pos $loc (Switch ($3, $6, None)) } +| RECEIVE LBRACE perhaps_cases RBRACE { with_pos $loc (Receive ($3, None)) } +| SHALLOWHANDLE LPAREN exp RPAREN LBRACE cases RBRACE { with_pos $loc (Handle (untyped_handler $3 $6 Shallow)) } +| HANDLE LPAREN exp RPAREN LBRACE perhaps_cases RBRACE { with_pos $loc (Handle (untyped_handler $3 $6 Deep )) } | HANDLE LPAREN exp RPAREN LPAREN handle_params RPAREN LBRACE perhaps_cases RBRACE - { with_pos $loc (`Handle (untyped_handler ~parameters:(List.rev $6) + { with_pos $loc (Handle (untyped_handler ~parameters:(List.rev $6) $3 $9 Deep)) } -| RAISE { with_pos $loc (`Raise) } -| TRY exp AS pattern IN exp OTHERWISE exp { with_pos $loc (`TryInOtherwise ($2, $4, $6, $8, None)) } +| RAISE { with_pos $loc (Raise) } +| TRY exp AS pattern IN exp OTHERWISE exp { with_pos $loc (TryInOtherwise ($2, $4, $6, $8, None)) } handle_params: | rev(separated_nonempty_list(COMMA, @@ -729,7 +729,7 @@ iteration_expression: | FOR LPAREN perhaps_generators RPAREN perhaps_where perhaps_orderby - exp { with_pos $loc (`Iteration ($3, $7, $5, $6)) } + exp { with_pos $loc (Iteration ($3, $7, $5, $6)) } perhaps_generators: | separated_list(COMMA, generator) { $1 } @@ -753,18 +753,18 @@ perhaps_orderby: | ORDERBY LPAREN exps RPAREN { Some (tuple ~ppos:$loc($3) $3) } escape_expression: -| ESCAPE VARIABLE IN postfix_expression { with_pos $loc (`Escape (binder ~ppos:$loc($2) $2, $4)) } +| ESCAPE VARIABLE IN postfix_expression { with_pos $loc (Escape (binder ~ppos:$loc($2) $2, $4)) } formlet_expression: -| FORMLET xml YIELDS exp { with_pos $loc (`Formlet ($2, $4)) } -| PAGE xml { with_pos $loc (`Page $2) } +| FORMLET xml YIELDS exp { with_pos $loc (Formlet ($2, $4)) } +| PAGE xml { with_pos $loc (Page $2) } table_expression: -| TABLE exp WITH datatype perhaps_table_constraints FROM exp { with_pos $loc (`TableLit ($2, datatype $4, $5, - list ~ppos:$loc [], $7)) } +| TABLE exp WITH datatype perhaps_table_constraints FROM exp { with_pos $loc (TableLit ($2, datatype $4, $5, + list ~ppos:$loc [], $7)) } /* SAND */ | TABLE exp WITH datatype perhaps_table_constraints - TABLEKEYS exp FROM exp { with_pos $loc (`TableLit ($2, datatype $4, $5, $7, $9))} + TABLEKEYS exp FROM exp { with_pos $loc (TableLit ($2, datatype $4, $5, $7, $9))} perhaps_table_constraints: | loption(preceded(WHERE, table_constraints)) { $1 } @@ -806,7 +806,7 @@ database_expression: RPAREN RBRACKET preceded(RETURNING, VARIABLE)? { db_insert ~ppos:$loc $2 (labels $6) (db_exps ~ppos:$loc($6) $6) $9 } | INSERT exp VALUES LPAREN record_labels RPAREN db_expression RETURNING VARIABLE { db_insert ~ppos:$loc $2 $5 $7 (Some $9) } -| DATABASE atomic_expression perhaps_db_driver { with_pos $loc (`DatabaseLit ($2, $3)) } +| DATABASE atomic_expression perhaps_db_driver { with_pos $loc (DatabaseLit ($2, $3)) } fn_dep_cols: | VARIABLE+ { $1 } @@ -818,18 +818,18 @@ fn_deps: | separated_nonempty_list(COMMA, fn_dep) { $1 } lens_expression: -| LENS exp DEFAULT { with_pos $loc (`LensLit ($2, None))} -| LENS exp TABLEKEYS exp { with_pos $loc (`LensKeysLit ($2, $4, None))} -| LENS exp WITH LBRACE fn_deps RBRACE { with_pos $loc (`LensFunDepsLit ($2, $5, None))} +| LENS exp DEFAULT { with_pos $loc (LensLit ($2, None))} +| LENS exp TABLEKEYS exp { with_pos $loc (LensKeysLit ($2, $4, None))} +| LENS exp WITH LBRACE fn_deps RBRACE { with_pos $loc (LensFunDepsLit ($2, $5, None))} | LENSDROP VARIABLE DETERMINED BY - VARIABLE DEFAULT exp FROM exp { with_pos $loc (`LensDropLit ($9, $2, $5, $7, None)) } -| LENSSELECT FROM exp BY exp { with_pos $loc (`LensSelectLit ($3, $5, None)) } -| LENSJOIN exp WITH exp ON exp DELETE LBRACE exp COMMA exp RBRACE { with_pos $loc (`LensJoinLit ($2, $4, $6, $9, $11, None)) } -| LENSJOIN exp WITH exp ON exp DELETE_LEFT { with_pos $loc (`LensJoinLit ($2, $4, $6, - with_pos $loc (`Constant (`Bool true )), - with_pos $loc (`Constant (`Bool false)), None)) } -| LENSGET exp { with_pos $loc (`LensGetLit ($2, None)) } -| LENSPUT exp WITH exp { with_pos $loc (`LensPutLit ($2, $4, None)) } + VARIABLE DEFAULT exp FROM exp { with_pos $loc (LensDropLit ($9, $2, $5, $7, None)) } +| LENSSELECT FROM exp BY exp { with_pos $loc (LensSelectLit ($3, $5, None)) } +| LENSJOIN exp WITH exp ON exp DELETE LBRACE exp COMMA exp RBRACE { with_pos $loc (LensJoinLit ($2, $4, $6, $9, $11, None)) } +| LENSJOIN exp WITH exp ON exp DELETE_LEFT { with_pos $loc (LensJoinLit ($2, $4, $6, + with_pos $loc (Constant (`Bool true )), + with_pos $loc (Constant (`Bool false)), None)) } +| LENSGET exp { with_pos $loc (LensGetLit ($2, None)) } +| LENSPUT exp WITH exp { with_pos $loc (LensPutLit ($2, $4, None)) } record_labels: @@ -863,7 +863,7 @@ block_contents: | exp SEMICOLON { ([with_pos $loc($1) (Exp $1)], record ~ppos:$loc []) } | exp { ([], $1) } -| SEMICOLON | /* empty */ { ([], with_pos $loc (`TupleLit [])) } +| SEMICOLON | /* empty */ { ([], with_pos $loc (TupleLit [])) } labeled_exps: | separated_nonempty_list(COMMA, @@ -1099,10 +1099,10 @@ kinded_row_var: * Regular expression grammar */ regex: -| SLASH regex_pattern_alternate regex_flags_opt { with_pos $loc($2) (`Regex $2), $3 } -| SLASH regex_flags_opt { with_pos $loc (`Regex (Simply "")), $2 } +| SLASH regex_pattern_alternate regex_flags_opt { with_pos $loc($2) (Regex $2), $3 } +| SLASH regex_flags_opt { with_pos $loc (Regex (Simply "")), $2 } | SSLASH regex_pattern_alternate SLASH regex_replace - regex_flags_opt { with_pos $loc (`Regex (Replace ($2, $4))), + regex_flags_opt { with_pos $loc (Regex (Replace ($2, $4))), RegexReplace :: $5 } regex_flags_opt: diff --git a/core/refineBindings.ml b/core/refineBindings.ml index f4f2b4219..9505256f0 100644 --- a/core/refineBindings.ml +++ b/core/refineBindings.ml @@ -429,13 +429,13 @@ let refine_bindings = object (self) inherit SugarTraversals.map as super method! phrasenode : phrasenode -> phrasenode = function - |`Block (bindings, body) -> + | Block (bindings, body) -> let bindings = self#list (fun o -> o#binding) bindings in let body = self#phrase body in let refined_bindings = (RefineTypeBindings.refineTypeBindings ->- refine_bindings) bindings in - `Block (refined_bindings, body) + Block (refined_bindings, body) | p -> super#phrasenode p method! program : program -> program = diff --git a/core/sugarConstructors.ml b/core/sugarConstructors.ml index 052bfad7f..a2ffe6e29 100644 --- a/core/sugarConstructors.ml +++ b/core/sugarConstructors.ml @@ -75,37 +75,37 @@ module SugarConstructors (Position : Pos) (** Common stuff *) - let var ?(ppos=dp) name = with_pos ppos (`Var name) + let var ?(ppos=dp) name = with_pos ppos (Var name) (* Create a Block from block_body. *) - let block_node block_contents = `Block block_contents + let block_node block_contents = Block block_contents let block ?(ppos=dp) block_contents = with_pos ppos (block_node block_contents) let datatype d = (d, None) (* Create a record with a given list of labels. *) - let record ?(ppos=dp) ?exp lbls = with_pos ppos (`RecordLit (lbls, exp)) + let record ?(ppos=dp) ?exp lbls = with_pos ppos (RecordLit (lbls, exp)) (* Create a tuple. Preserves 1-tuples. *) let tuple ?(ppos=dp) = function | [e] -> record ~ppos [("1", e)] - | es -> with_pos ppos (`TupleLit es) + | es -> with_pos ppos (TupleLit es) let cp_unit ppos = with_pos ppos (CPUnquote ([], tuple ~ppos [])) let list ?(ppos=dp) ?ty elems = - with_pos ppos (`ListLit (elems, ty)) + with_pos ppos (ListLit (elems, ty)) let constructor ?(ppos=dp) ?body ?ty name = - with_pos ppos (`ConstructorLit (name, body, ty)) + with_pos ppos (ConstructorLit (name, body, ty)) (** Constants **) - let constant ?(ppos=dp) c = with_pos ppos (`Constant c) - let constant_str ?(ppos=dp) s = with_pos ppos (`Constant (`String s)) - let constant_char ?(ppos=dp) c = with_pos ppos (`Constant (`Char c)) + let constant ?(ppos=dp) c = with_pos ppos (Constant c) + let constant_str ?(ppos=dp) s = with_pos ppos (Constant (`String s)) + let constant_char ?(ppos=dp) c = with_pos ppos (Constant (`Char c)) (** Binders **) @@ -145,7 +145,7 @@ module SugarConstructors (Position : Pos) (* Create a FunLit. *) let fun_lit ?(ppos=dp) ?args ?(location=`Unknown) linearity pats blk = - with_pos ppos (`FunLit (args, linearity, (pats, blk), location)) + with_pos ppos (FunLit (args, linearity, (pats, blk), location)) (* Create an argument used by Handler and HandlerLit. *) let hnlit_arg depth computation_param handler_param = @@ -153,14 +153,14 @@ module SugarConstructors (Position : Pos) (* Create a HandlerLit. *) let handler_lit ?(ppos=dp) handlerlit = - with_pos ppos (`HandlerLit handlerlit) + with_pos ppos (HandlerLit handlerlit) (* Create a Spawn. *) let spawn ?(ppos=dp) ?row spawn_kind location blk = - with_pos ppos (`Spawn (spawn_kind, location, blk, row)) + with_pos ppos (Spawn (spawn_kind, location, blk, row)) let fn_appl_node ?(ppos=dp) name tyvars vars = - `FnAppl (with_pos ppos (tappl (`Var name, tyvars)), vars) + FnAppl (with_pos ppos (tappl (Var name, tyvars)), vars) let fn_appl ?(ppos=dp) name tyvars vars = with_pos ppos (fn_appl_node ~ppos name tyvars vars) @@ -213,7 +213,7 @@ module SugarConstructors (Position : Pos) (* Is the list of labeled database expressions empty? *) let is_empty_db_exps : phrase -> bool = function - | {node=`ListLit ([{node=`RecordLit ([], _);_}], _);_} -> true + | {node=ListLit ([{node=RecordLit ([], _);_}], _);_} -> true | _ -> false (* Create a database insertion query. Raises an exception when the list of @@ -224,18 +224,18 @@ module SugarConstructors (Position : Pos) raise (ConcreteSyntaxError ("Invalid insert statement. Either provide" ^ " a nonempty list of labeled expression or a return variable.", pos ppos)); - with_pos ppos (`DBInsert (ins_exp, lbls, exps, + with_pos ppos (DBInsert (ins_exp, lbls, exps, opt_map (fun name -> constant_str ~ppos name) var_opt)) (* Create a query. *) let query ?(ppos=dp) phrases_opt blk = - with_pos ppos (`Query (phrases_opt, blk, None)) + with_pos ppos (Query (phrases_opt, blk, None)) (** Operator applications *) (* Apply a binary infix operator. *) let infix_appl' ?(ppos=dp) arg1 op arg2 = - with_pos ppos (`InfixAppl (([], op), arg1, arg2)) + with_pos ppos (InfixAppl (([], op), arg1, arg2)) (* Apply a binary infix operator with a specified name. *) let infix_appl ?(ppos=dp) arg1 op arg2 = @@ -243,7 +243,7 @@ module SugarConstructors (Position : Pos) (* Apply an unary operator. *) let unary_appl ?(ppos=dp) op arg = - with_pos ppos (`UnaryAppl (([], op), arg)) + with_pos ppos (UnaryAppl (([], op), arg)) (** XML *) (* Create an XML tree. Raise an exception if opening and closing tags don't @@ -256,7 +256,7 @@ module SugarConstructors (Position : Pos) ("Closing tag '" ^ closing ^ "' does not match start tag '" ^ opening ^ "'.", pos ppos)) | _ -> () in - with_pos ppos (`Xml (name, attr_list, blk_opt, contents)) + with_pos ppos (Xml (name, attr_list, blk_opt, contents)) (** Handlers *) let untyped_handler ?(val_cases = []) ?parameters expr eff_cases depth = diff --git a/core/sugarTraversals.ml b/core/sugarTraversals.ml index ad50c91a5..b6504a4e5 100644 --- a/core/sugarTraversals.ml +++ b/core/sugarTraversals.ml @@ -153,68 +153,68 @@ class map = method phrasenode : phrasenode -> phrasenode = function - | `Constant _x -> let _x = o#constant _x in `Constant _x - | `Var _x -> let _x = o#name _x in `Var _x - | `QualifiedVar _xs -> - let _xs = o#list (fun o -> o#name) _xs in `QualifiedVar _xs - | `FunLit (_x, _x1, _x_i1, _x_i2) -> let _x_i1 = o#funlit _x_i1 in - let _x_i2 = o#location _x_i2 in `FunLit (_x, _x1, _x_i1, _x_i2) - | `HandlerLit hnlit -> + | Constant _x -> let _x = o#constant _x in Constant _x + | Var _x -> let _x = o#name _x in Var _x + | QualifiedVar _xs -> + let _xs = o#list (fun o -> o#name) _xs in QualifiedVar _xs + | FunLit (_x, _x1, _x_i1, _x_i2) -> let _x_i1 = o#funlit _x_i1 in + let _x_i2 = o#location _x_i2 in FunLit (_x, _x1, _x_i1, _x_i2) + | HandlerLit hnlit -> let hnlit = o#handlerlit hnlit in - `HandlerLit hnlit - | `Spawn (_spawn_kind, _given_spawn_location, _block_phr, _dt) -> + HandlerLit hnlit + | Spawn (_spawn_kind, _given_spawn_location, _block_phr, _dt) -> let _given_spawn_location = o#given_spawn_location _given_spawn_location in let _block_phr = o#phrase _block_phr in - `Spawn (_spawn_kind, _given_spawn_location, _block_phr, _dt) - | `Query (_x, _x_i1, _x_i2) -> + Spawn (_spawn_kind, _given_spawn_location, _block_phr, _dt) + | Query (_x, _x_i1, _x_i2) -> let _x = o#option (fun o (_x, _x_i1) -> let _x = o#phrase _x in let _x_i1 = o#phrase _x_i1 in (_x, _x_i1)) _x in - let _x_i1 = o#phrase _x_i1 in `Query (_x, _x_i1, _x_i2) - | `ListLit (_x, _x_i1) -> - let _x = o#list (fun o -> o#phrase) _x in `ListLit (_x, _x_i1) - | `Iteration ((_x, _x_i1, _x_i2, _x_i3)) -> + let _x_i1 = o#phrase _x_i1 in Query (_x, _x_i1, _x_i2) + | ListLit (_x, _x_i1) -> + let _x = o#list (fun o -> o#phrase) _x in ListLit (_x, _x_i1) + | Iteration ((_x, _x_i1, _x_i2, _x_i3)) -> let _x = o#list (fun o -> o#iterpatt) _x in let _x_i1 = o#phrase _x_i1 in let _x_i2 = o#option (fun o -> o#phrase) _x_i2 in let _x_i3 = o#option (fun o -> o#phrase) _x_i3 - in `Iteration ((_x, _x_i1, _x_i2, _x_i3)) - | `Escape ((_x, _x_i1)) -> + in Iteration ((_x, _x_i1, _x_i2, _x_i3)) + | Escape ((_x, _x_i1)) -> let _x = o#binder _x in - let _x_i1 = o#phrase _x_i1 in `Escape ((_x, _x_i1)) - | `Section _x -> let _x = o#sec _x in `Section _x - | `Conditional ((_x, _x_i1, _x_i2)) -> + let _x_i1 = o#phrase _x_i1 in Escape ((_x, _x_i1)) + | Section _x -> let _x = o#sec _x in Section _x + | Conditional ((_x, _x_i1, _x_i2)) -> let _x = o#phrase _x in let _x_i1 = o#phrase _x_i1 in - let _x_i2 = o#phrase _x_i2 in `Conditional ((_x, _x_i1, _x_i2)) - | `Block ((_x, _x_i1)) -> + let _x_i2 = o#phrase _x_i2 in Conditional ((_x, _x_i1, _x_i2)) + | Block ((_x, _x_i1)) -> let _x = o#list (fun o -> o#binding) _x in - let _x_i1 = o#phrase _x_i1 in `Block ((_x, _x_i1)) - | `InfixAppl ((_x, _x_i1, _x_i2)) -> + let _x_i1 = o#phrase _x_i1 in Block ((_x, _x_i1)) + | InfixAppl ((_x, _x_i1, _x_i2)) -> let _x = o#tybinop _x in let _x_i1 = o#phrase _x_i1 in - let _x_i2 = o#phrase _x_i2 in `InfixAppl ((_x, _x_i1, _x_i2)) - | `RangeLit ((_x_i1, _x_i2)) -> + let _x_i2 = o#phrase _x_i2 in InfixAppl ((_x, _x_i1, _x_i2)) + | RangeLit ((_x_i1, _x_i2)) -> let _x_i1 = o#phrase _x_i1 in - let _x_i2 = o#phrase _x_i2 in `RangeLit ((_x_i1, _x_i2)) - | `Regex _x -> let _x = o#regex _x in `Regex _x - | `UnaryAppl ((_x, _x_i1)) -> + let _x_i2 = o#phrase _x_i2 in RangeLit ((_x_i1, _x_i2)) + | Regex _x -> let _x = o#regex _x in Regex _x + | UnaryAppl ((_x, _x_i1)) -> let _x = o#tyunary_op _x in - let _x_i1 = o#phrase _x_i1 in `UnaryAppl ((_x, _x_i1)) - | `FnAppl ((_x, _x_i1)) -> + let _x_i1 = o#phrase _x_i1 in UnaryAppl ((_x, _x_i1)) + | FnAppl ((_x, _x_i1)) -> let _x = o#phrase _x in let _x_i1 = o#list (fun o -> o#phrase) _x_i1 - in `FnAppl ((_x, _x_i1)) - | `TAbstr ((_x, _x_i1)) -> - let _x_i1 = o#phrase _x_i1 in `TAbstr ((_x, _x_i1)) - | `TAppl ((_x, _x_i1)) -> - let _x = o#phrase _x in `TAppl ((_x, _x_i1)) - | `TupleLit _x -> - let _x = o#list (fun o -> o#phrase) _x in `TupleLit _x - | `RecordLit ((_x, _x_i1)) -> + in FnAppl ((_x, _x_i1)) + | TAbstr ((_x, _x_i1)) -> + let _x_i1 = o#phrase _x_i1 in TAbstr ((_x, _x_i1)) + | TAppl ((_x, _x_i1)) -> + let _x = o#phrase _x in TAppl ((_x, _x_i1)) + | TupleLit _x -> + let _x = o#list (fun o -> o#phrase) _x in TupleLit _x + | RecordLit ((_x, _x_i1)) -> let _x = o#list (fun o (_x, _x_i1) -> @@ -222,11 +222,11 @@ class map = 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)) -> + 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)) - | `With ((_x, _x_i1)) -> + let _x_i1 = o#name _x_i1 in Projection ((_x, _x_i1)) + | With ((_x, _x_i1)) -> let _x = o#phrase _x in let _x_i1 = o#list @@ -234,23 +234,23 @@ class map = let _x = o#name _x in let _x_i1 = o#phrase _x_i1 in (_x, _x_i1)) _x_i1 - in `With ((_x, _x_i1)) - | `TypeAnnotation ((_x, _x_i1)) -> + in With ((_x, _x_i1)) + | TypeAnnotation ((_x, _x_i1)) -> let _x = o#phrase _x in - let _x_i1 = o#datatype' _x_i1 in `TypeAnnotation ((_x, _x_i1)) - | `Upcast ((_x, _x_i1, _x_i2)) -> + let _x_i1 = o#datatype' _x_i1 in TypeAnnotation ((_x, _x_i1)) + | Upcast ((_x, _x_i1, _x_i2)) -> let _x = o#phrase _x in let _x_i1 = o#datatype' _x_i1 in - let _x_i2 = o#datatype' _x_i2 in `Upcast ((_x, _x_i1, _x_i2)) - | `ConstructorLit ((_x, _x_i1, _x_i2)) -> + let _x_i2 = o#datatype' _x_i2 in Upcast ((_x, _x_i1, _x_i2)) + | ConstructorLit ((_x, _x_i1, _x_i2)) -> let _x = o#name _x in let _x_i1 = o#option (fun o -> o#phrase) _x_i1 - in `ConstructorLit ((_x, _x_i1, _x_i2)) - | `DoOperation (name, ps, t) -> + in ConstructorLit ((_x, _x_i1, _x_i2)) + | DoOperation (name, ps, t) -> let ps = o#list (fun o -> o#phrase) ps in let t = o#option (fun o -> o#unknown) t in - `DoOperation (name, ps, t) - | `Handle { sh_expr; sh_effect_cases; sh_value_cases; sh_descr } -> + DoOperation (name, ps, t) + | Handle { sh_expr; sh_effect_cases; sh_value_cases; sh_descr } -> let m = o#phrase sh_expr in let params = o#option (fun o -> o#handle_params) sh_descr.shd_params @@ -271,8 +271,8 @@ class map = ) sh_value_cases in - `Handle { sh_expr = m; sh_effect_cases = eff_cases; sh_value_cases = val_cases; sh_descr = { sh_descr with shd_params = params } } - | `Switch ((_x, _x_i1, _x_i2)) -> + Handle { sh_expr = m; sh_effect_cases = eff_cases; sh_value_cases = val_cases; sh_descr = { sh_descr with shd_params = params } } + | Switch ((_x, _x_i1, _x_i2)) -> let _x = o#phrase _x in let _x_i1 = o#list @@ -281,8 +281,8 @@ class map = let _x_i1 = o#phrase _x_i1 in (_x, _x_i1)) _x_i1 in let _x_i2 = o#option (fun o -> o#unknown) _x_i2 - in `Switch ((_x, _x_i1, _x_i2)) - | `Receive ((_x, _x_i1)) -> + in Switch ((_x, _x_i1, _x_i2)) + | Receive ((_x, _x_i1)) -> let _x = o#list (fun o (_x, _x_i1) -> @@ -290,15 +290,15 @@ class map = let _x_i1 = o#phrase _x_i1 in (_x, _x_i1)) _x in let _x_i1 = o#option (fun o -> o#unknown) _x_i1 - in `Receive (_x, _x_i1) - (* | `Link ((_x, _x_i1)) -> *) + in Receive (_x, _x_i1) + (* | Link ((_x, _x_i1)) -> *) (* let _x = o#phrase _x in *) - (* let _x_i1 = o#phrase _x_i1 in `Link ((_x, _x_i1)) *) - | `Select ((_x, _x_i1)) -> + (* let _x_i1 = o#phrase _x_i1 in Link ((_x, _x_i1)) *) + | Select ((_x, _x_i1)) -> let _x = o#name _x in let _x_i1 = o#phrase _x_i1 - in `Select (_x, _x_i1) - | `Offer ((_x, _x_i1, _x_i2)) -> + in Select (_x, _x_i1) + | Offer ((_x, _x_i1, _x_i2)) -> let _x = o#phrase _x in let _x_i1 = o#list @@ -307,17 +307,17 @@ class map = let _x_i1 = o#phrase _x_i1 in (_x, _x_i1)) _x_i1 in let _x_i2 = o#option (fun o -> o#unknown) _x_i2 - in `Offer (_x, _x_i1, _x_i2) - | `CP p -> `CP (o#cp_phrase p) - | `DatabaseLit ((_x, _x_i1)) -> + in Offer (_x, _x_i1, _x_i2) + | CP p -> CP (o#cp_phrase p) + | DatabaseLit ((_x, _x_i1)) -> let _x = o#phrase _x in let _x_i1 = (fun (_x, _x_i1) -> let _x = o#option (fun o -> o#phrase) _x in let _x_i1 = o#option (fun o -> o#phrase) _x_i1 in (_x, _x_i1)) _x_i1 - in `DatabaseLit ((_x, _x_i1)) - | `TableLit ((_x, (y, z), _x_i2, _x_i3, _x_i4)) -> + in DatabaseLit ((_x, _x_i1)) + | TableLit ((_x, (y, z), _x_i2, _x_i3, _x_i4)) -> let _x = o#phrase _x in let y = o#datatype y in let z = o#option @@ -332,59 +332,59 @@ class map = in (_x, _x_i1)) _x_i2 in let _x_i3 = o#phrase _x_i3 in - let _x_i4 = o#phrase _x_i4 in `TableLit ((_x, (y, z), _x_i2, _x_i3, _x_i4)) - | `LensLit ((_x, _x_i1)) -> + let _x_i4 = o#phrase _x_i4 in TableLit ((_x, (y, z), _x_i2, _x_i3, _x_i4)) + | LensLit ((_x, _x_i1)) -> let _x = o#phrase _x in let _x_i1 = o#option (fun o -> o#unknown) _x_i1 in - `LensLit (_x, _x_i1) - | `LensKeysLit ((_x, _x_i1, _x_i2)) -> + LensLit (_x, _x_i1) + | LensKeysLit ((_x, _x_i1, _x_i2)) -> let _x = o#phrase _x in let _x_i1 = o#phrase _x_i1 in let _x_i2 = o#option (fun o -> o#unknown) _x_i2 in - `LensKeysLit (_x, _x_i1, _x_i2) - | `LensFunDepsLit ((_x, _x_i1, _x_i2)) -> + LensKeysLit (_x, _x_i1, _x_i2) + | LensFunDepsLit ((_x, _x_i1, _x_i2)) -> let _x = o#phrase _x in let _x_i2 = o#option (fun o -> o#unknown) _x_i2 in - `LensFunDepsLit (_x, _x_i1, _x_i2) - | `LensDropLit ((_x, _x_i1, _x_i2, _x_i3, _x_i4)) -> + 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_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)) - | `LensSelectLit ((_x, _x_i1, _x_i2)) -> + LensDropLit((_x, _x_i1, _x_i2, _x_i3, _x_i4)) + | LensSelectLit ((_x, _x_i1, _x_i2)) -> let _x = o#phrase _x in (* let _x_i1 = o#phrase _x_i1 in *) let _x_i2 = o#option (fun o -> o#unknown) _x_i2 in - `LensSelectLit ((_x, _x_i1, _x_i2)) - | `LensJoinLit ((_x, _x_i1, _x_i2, _x_i3, _x_i4, _x_i5)) -> + LensSelectLit ((_x, _x_i1, _x_i2)) + | LensJoinLit ((_x, _x_i1, _x_i2, _x_i3, _x_i4, _x_i5)) -> let _x = o#phrase _x in let _x_i1 = o#phrase _x_i1 in let _x_i2 = o#phrase _x_i2 in (* _x_i3 and _x_i4 are both phrases which are left unchanged *) let _x_i5 = o#option (fun o -> o#unknown) _x_i5 in - `LensJoinLit ((_x, _x_i1, _x_i2, _x_i3, _x_i4, _x_i5)) - | `LensGetLit ((_x, _x_i1)) -> + LensJoinLit ((_x, _x_i1, _x_i2, _x_i3, _x_i4, _x_i5)) + | LensGetLit ((_x, _x_i1)) -> let _x = o#phrase _x in let _x_i1 = o#option (fun o -> o#unknown) _x_i1 in - `LensGetLit ((_x, _x_i1)) - | `LensPutLit ((_x, _x_i1, _x_i2)) -> + LensGetLit ((_x, _x_i1)) + | LensPutLit ((_x, _x_i1, _x_i2)) -> let _x = o#phrase _x in let _x_i1 = o#phrase _x_i1 in let _x_i2 = o#option (fun o -> o#unknown) _x_i2 in - `LensPutLit ((_x, _x_i1, _x_i2)) - | `DBDelete ((_x, _x_i1, _x_i2)) -> + LensPutLit ((_x, _x_i1, _x_i2)) + | DBDelete ((_x, _x_i1, _x_i2)) -> let _x = o#pattern _x in let _x_i1 = o#phrase _x_i1 in let _x_i2 = o#option (fun o -> o#phrase) _x_i2 - in `DBDelete ((_x, _x_i1, _x_i2)) - | `DBInsert ((_x, _x_i1, _x_i2, _x_i3)) -> + in DBDelete ((_x, _x_i1, _x_i2)) + | DBInsert ((_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_i2 = o#phrase _x_i2 in - let _x_i3 = o#option (fun o -> o#phrase) _x_i3 in `DBInsert ((_x, _x_i1, _x_i2, _x_i3)) - | `DBUpdate ((_x, _x_i1, _x_i2, _x_i3)) -> + let _x_i3 = o#option (fun o -> o#phrase) _x_i3 in DBInsert ((_x, _x_i1, _x_i2, _x_i3)) + | DBUpdate ((_x, _x_i1, _x_i2, _x_i3)) -> let _x = o#pattern _x in let _x_i1 = o#phrase _x_i1 in let _x_i2 = o#option (fun o -> o#phrase) _x_i2 in @@ -394,8 +394,8 @@ class map = let _x = o#name _x in let _x_i1 = o#phrase _x_i1 in (_x, _x_i1)) _x_i3 - in `DBUpdate ((_x, _x_i1, _x_i2, _x_i3)) - | `Xml ((_x, _x_i1, _x_i2, _x_i3)) -> + in DBUpdate ((_x, _x_i1, _x_i2, _x_i3)) + | Xml ((_x, _x_i1, _x_i2, _x_i3)) -> let _x = o#name _x in let _x_i1 = o#list @@ -405,28 +405,28 @@ class map = _x_i1 in let _x_i2 = o#option (fun o -> o#phrase) _x_i2 in let _x_i3 = o#list (fun o -> o#phrase) _x_i3 - in `Xml ((_x, _x_i1, _x_i2, _x_i3)) - | `TextNode _x -> let _x = o#string _x in `TextNode _x - | `Formlet ((_x, _x_i1)) -> + in Xml ((_x, _x_i1, _x_i2, _x_i3)) + | TextNode _x -> let _x = o#string _x in TextNode _x + | Formlet ((_x, _x_i1)) -> let _x = o#phrase _x in - let _x_i1 = o#phrase _x_i1 in `Formlet ((_x, _x_i1)) - | `Page _x -> let _x = o#phrase _x in `Page _x - | `FormletPlacement ((_x, _x_i1, _x_i2)) -> + let _x_i1 = o#phrase _x_i1 in Formlet ((_x, _x_i1)) + | Page _x -> let _x = o#phrase _x in Page _x + | FormletPlacement ((_x, _x_i1, _x_i2)) -> let _x = o#phrase _x in let _x_i1 = o#phrase _x_i1 in let _x_i2 = o#phrase _x_i2 - in `FormletPlacement ((_x, _x_i1, _x_i2)) - | `PagePlacement _x -> let _x = o#phrase _x in `PagePlacement _x - | `FormBinding ((_x, _x_i1)) -> + in FormletPlacement ((_x, _x_i1, _x_i2)) + | PagePlacement _x -> let _x = o#phrase _x in PagePlacement _x + | FormBinding ((_x, _x_i1)) -> let _x = o#phrase _x in - let _x_i1 = o#pattern _x_i1 in `FormBinding ((_x, _x_i1)) - | `TryInOtherwise (_p1, _pat, _p2, _p3, _ty) -> + let _x_i1 = o#pattern _x_i1 in FormBinding ((_x, _x_i1)) + | TryInOtherwise (_p1, _pat, _p2, _p3, _ty) -> let _p1 = o#phrase _p1 in let _pat = o#pattern _pat in let _p2 = o#phrase _p2 in let _p3 = o#phrase _p3 in - `TryInOtherwise (_p1, _pat, _p2, _p3, _ty) - | `Raise -> `Raise + TryInOtherwise (_p1, _pat, _p2, _p3, _ty) + | Raise -> Raise method phrase : phrase -> phrase = @@ -861,18 +861,18 @@ class fold = method phrasenode : phrasenode -> 'self_type = function - | `Constant _x -> let o = o#constant _x in o - | `Var _x -> let o = o#name _x in o - | `QualifiedVar _xs -> + | Constant _x -> let o = o#constant _x in o + | Var _x -> let o = o#name _x in o + | QualifiedVar _xs -> let o = o#list (fun o -> o#name) _xs in o - | `FunLit (_x, _x1, _x_i1, _x_i2) -> let o = o#funlit _x_i1 in let _x_i2 = o#location _x_i2 in o - | `HandlerLit hnlit -> + | FunLit (_x, _x1, _x_i1, _x_i2) -> let o = o#funlit _x_i1 in let _x_i2 = o#location _x_i2 in o + | HandlerLit hnlit -> let o = o#handlerlit hnlit in o - | `Spawn (_spawn_kind, _given_spawn_location, _block_phr, _dt) -> + | Spawn (_spawn_kind, _given_spawn_location, _block_phr, _dt) -> let o = o#given_spawn_location _given_spawn_location in let o = o#phrase _block_phr in o - | `Query (_x, _x_i1, _x_i2) -> + | Query (_x, _x_i1, _x_i2) -> let o = o#option (fun o (_x, _x_i1) -> @@ -880,48 +880,48 @@ class fold = let o = o#phrase _x_i1 in o) _x in let o = o#phrase _x_i1 in o - | `ListLit (_x, _x_i1) -> let o = o#list (fun o -> o#phrase) _x in o - | `Iteration ((_x, _x_i1, _x_i2, _x_i3)) -> + | ListLit (_x, _x_i1) -> let o = o#list (fun o -> o#phrase) _x in o + | Iteration ((_x, _x_i1, _x_i2, _x_i3)) -> let o = o#list (fun o -> o#iterpatt) _x in let o = o#phrase _x_i1 in let o = o#option (fun o -> o#phrase) _x_i2 in let o = o#option (fun o -> o#phrase) _x_i3 in o - | `Escape ((_x, _x_i1)) -> + | Escape ((_x, _x_i1)) -> let o = o#binder _x in let o = o#phrase _x_i1 in o - | `Section _x -> let o = o#sec _x in o - | `Conditional ((_x, _x_i1, _x_i2)) -> + | Section _x -> let o = o#sec _x in o + | Conditional ((_x, _x_i1, _x_i2)) -> let o = o#phrase _x in let o = o#phrase _x_i1 in let o = o#phrase _x_i2 in o - | `Block ((_x, _x_i1)) -> + | Block ((_x, _x_i1)) -> let o = o#list (fun o -> o#binding) _x in let o = o#phrase _x_i1 in o - | `InfixAppl ((_x, _x_i1, _x_i2)) -> + | InfixAppl ((_x, _x_i1, _x_i2)) -> let o = o#tybinop _x in let o = o#phrase _x_i1 in let o = o#phrase _x_i2 in o - | `RangeLit ((_x_i1, _x_i2)) -> + | RangeLit ((_x_i1, _x_i2)) -> let o = o#phrase _x_i1 in let o = o#phrase _x_i2 in o - | `Regex _x -> let o = o#regex _x in o - | `UnaryAppl ((_x, _x_i1)) -> + | Regex _x -> let o = o#regex _x in o + | UnaryAppl ((_x, _x_i1)) -> let o = o#tyunary_op _x in let o = o#phrase _x_i1 in o - | `FnAppl ((_x, _x_i1)) -> + | FnAppl ((_x, _x_i1)) -> let o = o#phrase _x in let o = o#list (fun o -> o#phrase) _x_i1 in o - | `TAbstr ((_x, _x_i1)) -> + | TAbstr ((_x, _x_i1)) -> let o = o#list (fun o -> o#tyvar) (Types.unbox_quantifiers _x) in let o = o#phrase _x_i1 in o - | `TAppl ((_x, _x_i1)) -> + | TAppl ((_x, _x_i1)) -> let o = o#phrase _x in o - | `TupleLit _x -> let o = o#list (fun o -> o#phrase) _x in o - | `RecordLit ((_x, _x_i1)) -> + | TupleLit _x -> let o = o#list (fun o -> o#phrase) _x in o + | RecordLit ((_x, _x_i1)) -> let o = o#list (fun o (_x, _x_i1) -> let o = o#name _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)) -> + | Projection ((_x, _x_i1)) -> let o = o#phrase _x in let o = o#name _x_i1 in o - | `With ((_x, _x_i1)) -> + | With ((_x, _x_i1)) -> let o = o#phrase _x in let o = o#list @@ -929,19 +929,19 @@ class fold = let o = o#name _x in let o = o#phrase _x_i1 in o) _x_i1 in o - | `TypeAnnotation ((_x, _x_i1)) -> + | TypeAnnotation ((_x, _x_i1)) -> let o = o#phrase _x in let o = o#datatype' _x_i1 in o - | `Upcast ((_x, _x_i1, _x_i2)) -> + | Upcast ((_x, _x_i1, _x_i2)) -> let o = o#phrase _x in let o = o#datatype' _x_i1 in let o = o#datatype' _x_i2 in o - | `ConstructorLit ((_x, _x_i1, _x_i2)) -> + | ConstructorLit ((_x, _x_i1, _x_i2)) -> let o = o#name _x in let o = o#option (fun o -> o#phrase) _x_i1 in o - | `DoOperation (name,ps,t) -> + | DoOperation (name,ps,t) -> let o = o#name 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 } -> + | Handle { sh_expr; sh_effect_cases; sh_value_cases; sh_descr } -> let o = o#phrase sh_expr in let o = o#option (fun o -> o#handle_params) sh_descr.shd_params @@ -962,7 +962,7 @@ class fold = ) sh_value_cases in o - | `Switch ((_x, _x_i1, _x_i2)) -> + | Switch ((_x, _x_i1, _x_i2)) -> let o = o#phrase _x in let o = o#list @@ -971,7 +971,7 @@ class fold = _x_i1 in let o = o#option (fun o -> o#unknown) _x_i2 in o - | `Receive ((_x, _x_i1)) -> + | Receive ((_x, _x_i1)) -> let o = o#list (fun o (_x, _x_i1) -> @@ -979,15 +979,15 @@ class fold = _x in let o = o#option (fun o -> o#unknown) _x_i1 in o - (* | `Link ((_x, _x_i1)) -> *) + (* | Link ((_x, _x_i1)) -> *) (* let o = o#phrase _x in *) (* let o = o#phrase _x_i1 *) (* in o *) - | `Select ((_x, _x_i1)) -> + | Select ((_x, _x_i1)) -> let o = o#name _x in let o = o#phrase _x_i1 in o - | `Offer ((_x, _x_i1, _x_i2)) -> + | Offer ((_x, _x_i1, _x_i2)) -> let o = o#phrase _x in let o = o#list @@ -996,8 +996,8 @@ class fold = _x_i1 in let o = o#option (fun o -> o#unknown) _x_i2 in o - | `CP p -> o#cp_phrase p - | `DatabaseLit ((_x, _x_i1)) -> + | CP p -> o#cp_phrase p + | DatabaseLit ((_x, _x_i1)) -> let o = o#phrase _x in let o = (fun (_x, _x_i1) -> @@ -1005,7 +1005,7 @@ class fold = let o = o#option (fun o -> o#phrase) _x_i1 in o) _x_i1 in o - | `TableLit ((_x, (y,z), _x_i2, _x_i3, _x_i4)) -> + | TableLit ((_x, (y,z), _x_i2, _x_i3, _x_i4)) -> let o = o#phrase _x in let o = o#datatype y in let o = o#option @@ -1021,55 +1021,55 @@ class fold = let o = o#phrase _x_i3 in let o = o#phrase _x_i4 in o - | `LensLit ((_x, _x_i1)) -> + | LensLit ((_x, _x_i1)) -> let o = o#phrase _x in let o = o#option (fun o -> o#unknown) _x_i1 in o - | `LensKeysLit ((_x, _x_i1, _x_i2)) -> + | LensKeysLit ((_x, _x_i1, _x_i2)) -> let o = o#phrase _x in let o = o#phrase _x_i1 in let o = o#option (fun o -> o#unknown) _x_i2 in o - | `LensFunDepsLit ((_x, _x_i1, _x_i2)) -> + | LensFunDepsLit ((_x, _x_i1, _x_i2)) -> let o = o#phrase _x in let o = o#option (fun o -> o#unknown) _x_i2 in o - | `LensDropLit ((_x, _x_i1, _x_i2, _x_i3, _x_i4)) -> + | 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#phrase _x_i3 in let o = o#option (fun o -> o#unknown) _x_i4 in o - | `LensSelectLit ((_x, _x_i1, _x_i2)) -> + | LensSelectLit ((_x, _x_i1, _x_i2)) -> let o = o#phrase _x in (* let o = o#phrase _x_i1 in *) let o = o#option (fun o -> o#unknown) _x_i2 in o - | `LensJoinLit ((_x, _x_i1, _x_i2, _x_i3, _x_i4, _x_i5)) -> + | LensJoinLit ((_x, _x_i1, _x_i2, _x_i3, _x_i4, _x_i5)) -> let o = o#phrase _x in let o = o#phrase _x_i1 in let o = o#phrase _x_i2 in let o = o#option (fun o -> o#unknown) _x_i5 in o - | `LensGetLit ((_x, _x_i1)) -> + | LensGetLit ((_x, _x_i1)) -> let o = o#phrase _x in let o = o#option (fun o -> o#unknown) _x_i1 in o - | `LensPutLit ((_x, _x_i1, _x_i2)) -> + | LensPutLit ((_x, _x_i1, _x_i2)) -> let o = o#phrase _x in let o = o#phrase _x_i1 in let o = o#option (fun o -> o#unknown) _x_i2 in o - | `DBDelete ((_x, _x_i1, _x_i2)) -> + | DBDelete ((_x, _x_i1, _x_i2)) -> let o = o#pattern _x in let o = o#phrase _x_i1 in let o = o#option (fun o -> o#phrase) _x_i2 in o - | `DBInsert ((_x, _x_i1, _x_i2, _x_i3)) -> + | DBInsert ((_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#phrase _x_i2 in let o = o#option (fun o -> o#phrase) _x_i3 in o - | `DBUpdate ((_x, _x_i1, _x_i2, _x_i3)) -> + | DBUpdate ((_x, _x_i1, _x_i2, _x_i3)) -> let o = o#pattern _x in let o = o#phrase _x_i1 in let o = o#option (fun o -> o#phrase) _x_i2 in @@ -1079,7 +1079,7 @@ class fold = let o = o#name _x in let o = o#phrase _x_i1 in o) _x_i3 in o - | `Xml ((_x, _x_i1, _x_i2, _x_i3)) -> + | Xml ((_x, _x_i1, _x_i2, _x_i3)) -> let o = o#name _x in let o = o#list @@ -1089,23 +1089,23 @@ class fold = _x_i1 in let o = o#option (fun o -> o#phrase) _x_i2 in let o = o#list (fun o -> o#phrase) _x_i3 in o - | `TextNode _x -> let o = o#string _x in o - | `Formlet ((_x, _x_i1)) -> + | TextNode _x -> let o = o#string _x in o + | Formlet ((_x, _x_i1)) -> let o = o#phrase _x in let o = o#phrase _x_i1 in o - | `Page _x -> let o = o#phrase _x in o - | `FormletPlacement ((_x, _x_i1, _x_i2)) -> + | Page _x -> let o = o#phrase _x in o + | FormletPlacement ((_x, _x_i1, _x_i2)) -> let o = o#phrase _x in let o = o#phrase _x_i1 in let o = o#phrase _x_i2 in o - | `PagePlacement _x -> let o = o#phrase _x in o - | `FormBinding ((_x, _x_i1)) -> + | PagePlacement _x -> let o = o#phrase _x in o + | FormBinding ((_x, _x_i1)) -> let o = o#phrase _x in let o = o#pattern _x_i1 in o - | `TryInOtherwise (_p1, _pat, _p2, _p3, _ty) -> + | TryInOtherwise (_p1, _pat, _p2, _p3, _ty) -> let o = o#phrase _p1 in let o = o#pattern _pat in let o = o#phrase _p2 in let o = o#phrase _p3 in o - | `Raise -> o + | Raise -> o method phrase : phrase -> 'self_type = fun {node; pos} -> @@ -1537,73 +1537,73 @@ class fold_map = method phrasenode : phrasenode -> ('self_type * phrasenode) = function - | `Constant _x -> let (o, _x) = o#constant _x in (o, (`Constant _x)) - | `Var _x -> let (o, _x) = o#name _x in (o, (`Var _x)) - | `QualifiedVar _xs -> + | Constant _x -> let (o, _x) = o#constant _x in (o, (Constant _x)) + | Var _x -> let (o, _x) = o#name _x in (o, (Var _x)) + | QualifiedVar _xs -> let (o, _xs) = o#list (fun o n -> o#name n) _xs in - (o, (`QualifiedVar _xs)) - | `FunLit (_x, _x1, _x_i1, _x_i2) -> + (o, (QualifiedVar _xs)) + | FunLit (_x, _x1, _x_i1, _x_i2) -> let (o, _x_i1) = o#funlit _x_i1 in - let (o, _x_i2) = o#location _x_i2 in (o, (`FunLit (_x, _x1, _x_i1, _x_i2))) - | `HandlerLit hnlit -> + let (o, _x_i2) = o#location _x_i2 in (o, (FunLit (_x, _x1, _x_i1, _x_i2))) + | HandlerLit hnlit -> let (o, hnlit) = o#handlerlit hnlit in - (o, `HandlerLit hnlit) - | `Spawn (_spawn_kind, _given_spawn_location, _block_phr, _dt) -> + (o, HandlerLit hnlit) + | Spawn (_spawn_kind, _given_spawn_location, _block_phr, _dt) -> let (o, _given_spawn_location) = o#given_spawn_location _given_spawn_location in let (o, _block_phr) = o#phrase _block_phr in - (o, (`Spawn (_spawn_kind, _given_spawn_location, _block_phr, _dt))) - | `Query (_x, _x_i1, _x_i2) -> + (o, (Spawn (_spawn_kind, _given_spawn_location, _block_phr, _dt))) + | Query (_x, _x_i1, _x_i2) -> let (o, _x) = o#option (fun o (_x, _x_i1) -> let (o, _x) = o#phrase _x in let (o, _x_i1) = o#phrase _x_i1 in (o, (_x, _x_i1))) _x in - let (o, _x_i1) = o#phrase _x_i1 in (o, (`Query (_x, _x_i1, _x_i2))) - | `ListLit (_x, _x_i1) -> - let (o, _x) = o#list (fun o -> o#phrase) _x in (o, (`ListLit (_x, _x_i1))) - | `RangeLit ((_x_i1, _x_i2)) -> + let (o, _x_i1) = o#phrase _x_i1 in (o, (Query (_x, _x_i1, _x_i2))) + | ListLit (_x, _x_i1) -> + let (o, _x) = o#list (fun o -> o#phrase) _x in (o, (ListLit (_x, _x_i1))) + | RangeLit ((_x_i1, _x_i2)) -> let (o, _x_i1) = o#phrase _x_i1 in let (o, _x_i2) = o#phrase _x_i2 - in (o, (`RangeLit ((_x_i1, _x_i2)))) - | `Iteration ((_x, _x_i1, _x_i2, _x_i3)) -> + in (o, (RangeLit ((_x_i1, _x_i2)))) + | Iteration ((_x, _x_i1, _x_i2, _x_i3)) -> let (o, _x) = o#list (fun o -> o#iterpatt) _x in let (o, _x_i1) = o#phrase _x_i1 in let (o, _x_i2) = o#option (fun o -> o#phrase) _x_i2 in let (o, _x_i3) = o#option (fun o -> o#phrase) _x_i3 - in (o, (`Iteration ((_x, _x_i1, _x_i2, _x_i3)))) - | `Escape ((_x, _x_i1)) -> + in (o, (Iteration ((_x, _x_i1, _x_i2, _x_i3)))) + | Escape ((_x, _x_i1)) -> let (o, _x) = o#binder _x in - let (o, _x_i1) = o#phrase _x_i1 in (o, (`Escape ((_x, _x_i1)))) - | `Section _x -> let (o, _x) = o#sec _x in (o, (`Section _x)) - | `Conditional ((_x, _x_i1, _x_i2)) -> + let (o, _x_i1) = o#phrase _x_i1 in (o, (Escape ((_x, _x_i1)))) + | Section _x -> let (o, _x) = o#sec _x in (o, (Section _x)) + | Conditional ((_x, _x_i1, _x_i2)) -> let (o, _x) = o#phrase _x in let (o, _x_i1) = o#phrase _x_i1 in let (o, _x_i2) = o#phrase _x_i2 - in (o, (`Conditional ((_x, _x_i1, _x_i2)))) - | `Block ((_x, _x_i1)) -> + in (o, (Conditional ((_x, _x_i1, _x_i2)))) + | Block ((_x, _x_i1)) -> let (o, _x) = o#list (fun o -> o#binding) _x in - let (o, _x_i1) = o#phrase _x_i1 in (o, (`Block ((_x, _x_i1)))) - | `InfixAppl ((_x, _x_i1, _x_i2)) -> + let (o, _x_i1) = o#phrase _x_i1 in (o, (Block ((_x, _x_i1)))) + | InfixAppl ((_x, _x_i1, _x_i2)) -> let (o, _x) = o#tybinop _x in let (o, _x_i1) = o#phrase _x_i1 in let (o, _x_i2) = o#phrase _x_i2 - in (o, (`InfixAppl ((_x, _x_i1, _x_i2)))) - | `Regex _x -> let (o, _x) = o#regex _x in (o, (`Regex _x)) - | `UnaryAppl ((_x, _x_i1)) -> + in (o, (InfixAppl ((_x, _x_i1, _x_i2)))) + | Regex _x -> let (o, _x) = o#regex _x in (o, (Regex _x)) + | UnaryAppl ((_x, _x_i1)) -> let (o, _x) = o#tyunary_op _x in - let (o, _x_i1) = o#phrase _x_i1 in (o, (`UnaryAppl ((_x, _x_i1)))) - | `FnAppl ((_x, _x_i1)) -> + let (o, _x_i1) = o#phrase _x_i1 in (o, (UnaryAppl ((_x, _x_i1)))) + | FnAppl ((_x, _x_i1)) -> let (o, _x) = o#phrase _x in let (o, _x_i1) = o#list (fun o -> o#phrase) _x_i1 - in (o, (`FnAppl ((_x, _x_i1)))) - | `TAbstr ((_x, _x_i1)) -> - let (o, _x_i1) = o#phrase _x_i1 in (o, (`TAbstr ((_x, _x_i1)))) - | `TAppl ((_x, _x_i1)) -> - let (o, _x) = o#phrase _x in (o, (`TAppl ((_x, _x_i1)))) - | `TupleLit _x -> - let (o, _x) = o#list (fun o -> o#phrase) _x in (o, (`TupleLit _x)) - | `RecordLit ((_x, _x_i1)) -> + in (o, (FnAppl ((_x, _x_i1)))) + | TAbstr ((_x, _x_i1)) -> + let (o, _x_i1) = o#phrase _x_i1 in (o, (TAbstr ((_x, _x_i1)))) + | TAppl ((_x, _x_i1)) -> + let (o, _x) = o#phrase _x in (o, (TAppl ((_x, _x_i1)))) + | TupleLit _x -> + let (o, _x) = o#list (fun o -> o#phrase) _x in (o, (TupleLit _x)) + | RecordLit ((_x, _x_i1)) -> let (o, _x) = o#list (fun o (_x, _x_i1) -> @@ -1611,11 +1611,11 @@ class fold_map = 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)) -> + 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)))) - | `With ((_x, _x_i1)) -> + let (o, _x_i1) = o#name _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 @@ -1623,25 +1623,25 @@ class fold_map = let (o, _x) = o#name _x in let (o, _x_i1) = o#phrase _x_i1 in (o, (_x, _x_i1))) _x_i1 - in (o, (`With ((_x, _x_i1)))) - | `TypeAnnotation ((_x, _x_i1)) -> + in (o, (With ((_x, _x_i1)))) + | TypeAnnotation ((_x, _x_i1)) -> let (o, _x) = o#phrase _x in let (o, _x_i1) = o#datatype' _x_i1 - in (o, (`TypeAnnotation ((_x, _x_i1)))) - | `Upcast ((_x, _x_i1, _x_i2)) -> + in (o, (TypeAnnotation ((_x, _x_i1)))) + | Upcast ((_x, _x_i1, _x_i2)) -> let (o, _x) = o#phrase _x in let (o, _x_i1) = o#datatype' _x_i1 in let (o, _x_i2) = o#datatype' _x_i2 - in (o, (`Upcast ((_x, _x_i1, _x_i2)))) - | `ConstructorLit ((_x, _x_i1, _x_i2)) -> + in (o, (Upcast ((_x, _x_i1, _x_i2)))) + | ConstructorLit ((_x, _x_i1, _x_i2)) -> let (o, _x) = o#name _x in let (o, _x_i1) = o#option (fun o -> o#phrase) _x_i1 - in (o, (`ConstructorLit ((_x, _x_i1, _x_i2)))) - | `DoOperation (name, ps, t) -> + in (o, (ConstructorLit ((_x, _x_i1, _x_i2)))) + | DoOperation (name, ps, t) -> let (o, t) = o#option (fun o -> o#unknown) t in let (o, ps) = o#list (fun o -> o#phrase) ps in - (o, `DoOperation (name, ps, t)) - | `Handle { sh_expr; sh_effect_cases; sh_value_cases; sh_descr } -> + (o, DoOperation (name, ps, t)) + | Handle { sh_expr; sh_effect_cases; sh_value_cases; sh_descr } -> let (o, m) = o#phrase sh_expr in let (o, params) = o#option (fun o -> o#handle_params) sh_descr.shd_params @@ -1662,8 +1662,8 @@ class fold_map = ) sh_value_cases in - (o, (`Handle { sh_expr = m; sh_effect_cases = eff_cases; sh_value_cases = val_cases; sh_descr = { sh_descr with shd_params = params } })) - | `Switch ((_x, _x_i1, _x_i2)) -> + (o, (Handle { sh_expr = m; sh_effect_cases = eff_cases; sh_value_cases = val_cases; sh_descr = { sh_descr with shd_params = params } })) + | Switch ((_x, _x_i1, _x_i2)) -> let (o, _x) = o#phrase _x in let (o, _x_i1) = o#list @@ -1672,8 +1672,8 @@ class fold_map = let (o, _x_i1) = o#phrase _x_i1 in (o, (_x, _x_i1))) _x_i1 in let (o, _x_i2) = o#option (fun o -> o#unknown) _x_i2 - in (o, (`Switch ((_x, _x_i1, _x_i2)))) - | `Receive ((_x, _x_i1)) -> + in (o, (Switch ((_x, _x_i1, _x_i2)))) + | Receive ((_x, _x_i1)) -> let (o, _x) = o#list (fun o (_x, _x_i1) -> @@ -1681,15 +1681,15 @@ class fold_map = let (o, _x_i1) = o#phrase _x_i1 in (o, (_x, _x_i1))) _x in let (o, _x_i1) = o#option (fun o -> o#unknown) _x_i1 - in (o, (`Receive ((_x, _x_i1)))) - (* | `Link ((_x, _x_i1)) -> *) + in (o, (Receive ((_x, _x_i1)))) + (* | Link ((_x, _x_i1)) -> *) (* 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_i1) = o#phrase _x in (o, (Link(_x, _x_i1))) *) + | Select ((_x, _x_i1)) -> let (o, _x) = o#name _x in let (o, _x_i1) = o#phrase _x_i1 - in (o, (`Select (_x, _x_i1))) - | `Offer ((_x, _x_i1, _x_i2)) -> + in (o, (Select (_x, _x_i1))) + | Offer ((_x, _x_i1, _x_i2)) -> let (o, _x) = o#phrase _x in let (o, _x_i1) = o#list @@ -1698,11 +1698,11 @@ class fold_map = let (o, _x_i1) = o#phrase _x_i1 in (o, (_x, _x_i1))) _x_i1 in let (o, _x_i2) = o#option (fun o -> o#unknown) _x_i2 - in (o, (`Offer ((_x, _x_i1, _x_i2)))) - | `CP p -> + in (o, (Offer ((_x, _x_i1, _x_i2)))) + | CP p -> let (o, p) = o#cp_phrase p in - o, `CP p - | `DatabaseLit ((_x, _x_i1)) -> + o, CP p + | DatabaseLit ((_x, _x_i1)) -> let (o, _x) = o#phrase _x in let (o, _x_i1) = (fun (_x, _x_i1) -> @@ -1710,8 +1710,8 @@ class fold_map = let (o, _x_i1) = o#option (fun o -> o#phrase) _x_i1 in (o, (_x, _x_i1))) _x_i1 - in (o, (`DatabaseLit ((_x, _x_i1)))) - | `TableLit ((_x, _x_i1, _x_i2, _x_i3, _x_i4)) -> + in (o, (DatabaseLit ((_x, _x_i1)))) + | TableLit ((_x, _x_i1, _x_i2, _x_i3, _x_i4)) -> let (o, _x) = o#phrase _x in let (o, _x_i1) = (fun (_x, _x_i1) -> @@ -1732,60 +1732,60 @@ class fold_map = _x_i2 in let (o, _x_i3) = o#phrase _x_i3 in let (o, _x_i4) = o#phrase _x_i4 - in (o, (`TableLit ((_x, _x_i1, _x_i2, _x_i3, _x_i4)))) - | `LensLit ((_x, _x_i1)) -> + in (o, (TableLit ((_x, _x_i1, _x_i2, _x_i3, _x_i4)))) + | LensLit ((_x, _x_i1)) -> let (o, _x) = o#phrase _x in let (o, _x_i1) = o#option (fun o -> o#unknown) _x_i1 in - (o, (`LensLit (_x, _x_i1))) - | `LensKeysLit ((_x, _x_i1, _x_i2)) -> + (o, (LensLit (_x, _x_i1))) + | LensKeysLit ((_x, _x_i1, _x_i2)) -> let (o, _x) = o#phrase _x in let (o, _x_i1) = o#phrase _x_i1 in let (o, _x_i2) = o#option (fun o -> o#unknown) _x_i2 in - (o, (`LensKeysLit (_x, _x_i1, _x_i2))) - | `LensFunDepsLit ((_x, _x_i1, _x_i2)) -> + (o, (LensKeysLit (_x, _x_i1, _x_i2))) + | LensFunDepsLit ((_x, _x_i1, _x_i2)) -> let (o, _x) = o#phrase _x in let (o, _x_i2) = o#option (fun o -> o#unknown) _x_i2 in - (o, (`LensFunDepsLit (_x, _x_i1, _x_i2))) - | `LensDropLit ((_x, _x_i1, _x_i2, _x_i3, _x_i4)) -> + (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_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)))) - | `LensSelectLit ((_x, _x_i1, _x_i2)) -> + (o, (LensDropLit ((_x, _x_i1, _x_i2, _x_i3, _x_i4)))) + | LensSelectLit ((_x, _x_i1, _x_i2)) -> let (o, _x) = o#phrase _x in (* let (o, _x_i1) = o#phrase _x_i1 in *) let (o, _x_i2) = o#option (fun o -> o#unknown) _x_i2 in - (o, (`LensSelectLit ((_x, _x_i1, _x_i2)))) + (o, (LensSelectLit ((_x, _x_i1, _x_i2)))) - | `LensJoinLit ((_x, _x_i1, _x_i2, _x_i3, _x_i4, _x_i5)) -> + | LensJoinLit ((_x, _x_i1, _x_i2, _x_i3, _x_i4, _x_i5)) -> let (o, _x) = o#phrase _x in let (o, _x_i1) = o#phrase _x_i1 in let (o, _x_i2) = o#phrase _x_i2 in let (o, _x_i5) = o#option (fun o -> o#unknown) _x_i5 in - (o, (`LensJoinLit ((_x, _x_i1, _x_i2, _x_i3, _x_i4, _x_i5)))) - | `LensGetLit ((_x, _x_i1)) -> + (o, (LensJoinLit ((_x, _x_i1, _x_i2, _x_i3, _x_i4, _x_i5)))) + | LensGetLit ((_x, _x_i1)) -> let (o, _x) = o#phrase _x in let (o, _x_i1) = o#option (fun o -> o#unknown) _x_i1 in - (o, (`LensGetLit ((_x, _x_i1)))) - | `LensPutLit ((_x, _x_i1, _x_i2)) -> + (o, (LensGetLit ((_x, _x_i1)))) + | LensPutLit ((_x, _x_i1, _x_i2)) -> let (o, _x) = o#phrase _x in let (o, _x_i1) = o#phrase _x_i1 in let (o, _x_i2) = o#option (fun o -> o#unknown) _x_i2 in - (o, (`LensPutLit ((_x, _x_i1, _x_i2)))) - | `DBDelete ((_x, _x_i1, _x_i2)) -> + (o, (LensPutLit ((_x, _x_i1, _x_i2)))) + | DBDelete ((_x, _x_i1, _x_i2)) -> let (o, _x) = o#pattern _x in let (o, _x_i1) = o#phrase _x_i1 in let (o, _x_i2) = o#option (fun o -> o#phrase) _x_i2 - in (o, (`DBDelete ((_x, _x_i1, _x_i2)))) - | `DBInsert ((_x, _x_i1, _x_i2, _x_i3)) -> + in (o, (DBDelete ((_x, _x_i1, _x_i2)))) + | DBInsert ((_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_i2) = o#phrase _x_i2 in let (o, _x_i3) = o#option (fun o -> o#phrase) _x_i3 - in (o, (`DBInsert ((_x, _x_i1, _x_i2, _x_i3)))) - | `DBUpdate ((_x, _x_i1, _x_i2, _x_i3)) -> + in (o, (DBInsert ((_x, _x_i1, _x_i2, _x_i3)))) + | DBUpdate ((_x, _x_i1, _x_i2, _x_i3)) -> let (o, _x) = o#pattern _x in let (o, _x_i1) = o#phrase _x_i1 in let (o, _x_i2) = o#option (fun o -> o#phrase) _x_i2 in @@ -1795,8 +1795,8 @@ class fold_map = let (o, _x) = o#name _x in let (o, _x_i1) = o#phrase _x_i1 in (o, (_x, _x_i1))) _x_i3 - in (o, (`DBUpdate ((_x, _x_i1, _x_i2, _x_i3)))) - | `Xml ((_x, _x_i1, _x_i2, _x_i3)) -> + in (o, (DBUpdate ((_x, _x_i1, _x_i2, _x_i3)))) + | Xml ((_x, _x_i1, _x_i2, _x_i3)) -> let (o, _x) = o#name _x in let (o, _x_i1) = o#list @@ -1807,30 +1807,30 @@ class fold_map = _x_i1 in let (o, _x_i2) = o#option (fun o -> o#phrase) _x_i2 in let (o, _x_i3) = o#list (fun o -> o#phrase) _x_i3 - in (o, (`Xml ((_x, _x_i1, _x_i2, _x_i3)))) - | `TextNode _x -> let (o, _x) = o#string _x in (o, (`TextNode _x)) - | `Formlet ((_x, _x_i1)) -> + in (o, (Xml ((_x, _x_i1, _x_i2, _x_i3)))) + | TextNode _x -> let (o, _x) = o#string _x in (o, (TextNode _x)) + | Formlet ((_x, _x_i1)) -> let (o, _x) = o#phrase _x in - let (o, _x_i1) = o#phrase _x_i1 in (o, (`Formlet ((_x, _x_i1)))) - | `Page _x -> let (o, _x) = o#phrase _x in (o, (`Page _x)) - | `FormletPlacement ((_x, _x_i1, _x_i2)) -> + let (o, _x_i1) = o#phrase _x_i1 in (o, (Formlet ((_x, _x_i1)))) + | Page _x -> let (o, _x) = o#phrase _x in (o, (Page _x)) + | FormletPlacement ((_x, _x_i1, _x_i2)) -> let (o, _x) = o#phrase _x in let (o, _x_i1) = o#phrase _x_i1 in let (o, _x_i2) = o#phrase _x_i2 - in (o, (`FormletPlacement ((_x, _x_i1, _x_i2)))) - | `PagePlacement _x -> - let (o, _x) = o#phrase _x in (o, (`PagePlacement _x)) - | `FormBinding ((_x, _x_i1)) -> + in (o, (FormletPlacement ((_x, _x_i1, _x_i2)))) + | PagePlacement _x -> + let (o, _x) = o#phrase _x in (o, (PagePlacement _x)) + | FormBinding ((_x, _x_i1)) -> let (o, _x) = o#phrase _x in let (o, _x_i1) = o#pattern _x_i1 - in (o, (`FormBinding ((_x, _x_i1)))) - | `TryInOtherwise (_p1, _pat, _p2, _p3, _ty) -> + in (o, (FormBinding ((_x, _x_i1)))) + | TryInOtherwise (_p1, _pat, _p2, _p3, _ty) -> let (o, _p1) = o#phrase _p1 in let (o, _pat) = o#pattern _pat in let (o, _p2) = o#phrase _p2 in let (o, _p3) = o#phrase _p3 in - (o, (`TryInOtherwise (_p1, _pat, _p2, _p3, _ty))) - | `Raise -> (o, `Raise) + (o, (TryInOtherwise (_p1, _pat, _p2, _p3, _ty))) + | Raise -> (o, Raise) method phrase : phrase -> ('self_type * phrase) = fun {node; pos} -> diff --git a/core/sugartoir.ml b/core/sugartoir.ml index 296258277..4892a1f27 100644 --- a/core/sugartoir.ml +++ b/core/sugartoir.ml @@ -724,7 +724,6 @@ struct let rec eval : env -> Sugartypes.phrase -> tail_computation I.sem = fun env {Sugartypes.node=e; Sugartypes.pos} -> - let with_pos = Sugartypes.with_pos in let lookup_var name = let x, xt = lookup_name_and_type name env in I.var (x, xt) in @@ -744,10 +743,11 @@ struct failwith "fatal internal error" in let rec is_pure_primitive e = - match e.Sugartypes.node with - | `TAbstr (_, e) - | `TAppl (e, _) -> is_pure_primitive e - | `Var f when Lib.is_pure_primitive f -> true + let open Sugartypes in + match e.node with + | TAbstr (_, e) + | TAppl (e, _) -> is_pure_primitive e + | Var f when Lib.is_pure_primitive f -> true | _ -> false in let eff = lookup_effects env in @@ -756,69 +756,70 @@ struct let ec = eval env in let ev = evalv env in let evs = List.map ev in + let open Sugartypes in match e with - | `Constant c -> cofv (I.constant c) - | `Var x -> cofv (I.var (lookup_name_and_type x env)) - | `RangeLit (low, high) -> + | Constant c -> cofv (I.constant c) + | Var x -> cofv (I.var (lookup_name_and_type x env)) + | RangeLit (low, high) -> I.apply (instantiate_mb "intRange", [ev low; ev high]) - | `ListLit ([], Some t) -> + | ListLit ([], Some t) -> cofv (instantiate "Nil" [`Type t]) - | `ListLit (e::es, Some t) -> + | ListLit (e::es, Some t) -> cofv (I.apply_pure(instantiate "Cons" [`Type t; `Row eff], - [ev e; ev (with_pos pos (`ListLit (es, Some t)))])) - | `Escape (bndr, body) when Sugartypes.binder_has_type bndr -> - let k = Sugartypes.name_of_binder bndr in - let kt = Sugartypes.type_of_binder_exn bndr in + [ev e; ev (with_pos pos (ListLit (es, Some t)))])) + | Escape (bndr, body) when binder_has_type bndr -> + let k = name_of_binder bndr in + let kt = type_of_binder_exn bndr in I.escape ((kt, k, `Local), eff, fun v -> eval (extend [k] [(v, kt)] env) body) - | `Section (`Minus) -> cofv (lookup_var "-") - | `Section (`FloatMinus) -> cofv (lookup_var "-.") - | `Section (`Name name) -> cofv (lookup_var name) - | `Conditional (p, e1, e2) -> + | Section (`Minus) -> cofv (lookup_var "-") + | Section (`FloatMinus) -> cofv (lookup_var "-.") + | Section (`Name name) -> cofv (lookup_var name) + | Conditional (p, e1, e2) -> I.condition (ev p, ec e1, ec e2) - | `InfixAppl ((tyargs, `Name ((">" | ">=" | "==" | "<" | "<=" | "<>") as op)), e1, e2) -> + | InfixAppl ((tyargs, `Name ((">" | ">=" | "==" | "<" | "<=" | "<>") as op)), e1, e2) -> cofv (I.apply_pure (instantiate op tyargs, [ev e1; ev e2])) - | `InfixAppl ((tyargs, `Name "++"), e1, e2) -> + | InfixAppl ((tyargs, `Name "++"), e1, e2) -> cofv (I.apply_pure (instantiate "Concat" tyargs, [ev e1; ev e2])) - | `InfixAppl ((tyargs, `Name "!"), e1, e2) -> + | InfixAppl ((tyargs, `Name "!"), e1, e2) -> I.apply (instantiate "Send" tyargs, [ev e1; ev e2]) - | `InfixAppl ((tyargs, `Name n), e1, e2) when Lib.is_pure_primitive n -> + | InfixAppl ((tyargs, `Name n), e1, e2) when Lib.is_pure_primitive n -> cofv (I.apply_pure (instantiate n tyargs, [ev e1; ev e2])) - | `InfixAppl ((tyargs, `Name n), e1, e2) -> + | InfixAppl ((tyargs, `Name n), e1, e2) -> I.apply (instantiate n tyargs, [ev e1; ev e2]) - | `InfixAppl ((tyargs, `Cons), e1, e2) -> + | InfixAppl ((tyargs, `Cons), e1, e2) -> cofv (I.apply_pure (instantiate "Cons" tyargs, [ev e1; ev e2])) - | `InfixAppl ((tyargs, `FloatMinus), e1, e2) -> + | InfixAppl ((tyargs, `FloatMinus), e1, e2) -> cofv (I.apply_pure (instantiate "-." tyargs, [ev e1; ev e2])) - | `InfixAppl ((tyargs, `Minus), e1, e2) -> + | InfixAppl ((tyargs, `Minus), e1, e2) -> cofv (I.apply_pure (instantiate "-" tyargs, [ev e1; ev e2])) - | `InfixAppl ((_tyargs, `And), e1, e2) -> + | InfixAppl ((_tyargs, `And), e1, e2) -> (* IMPORTANT: we compile boolean expressions to conditionals in order to faithfully capture short-circuit evaluation *) I.condition (ev e1, ec e2, cofv (I.constant (`Bool false))) - | `InfixAppl ((_tyargs, `Or), e1, e2) -> + | InfixAppl ((_tyargs, `Or), e1, e2) -> I.condition (ev e1, cofv (I.constant (`Bool true)), ec e2) - | `UnaryAppl ((_tyargs, `Minus), e) -> + | UnaryAppl ((_tyargs, `Minus), e) -> cofv (I.apply_pure(instantiate_mb "negate", [ev e])) - | `UnaryAppl ((_tyargs, `FloatMinus), e) -> + | UnaryAppl ((_tyargs, `FloatMinus), e) -> cofv (I.apply_pure(instantiate_mb "negatef", [ev e])) - | `UnaryAppl ((tyargs, `Name n), e) when Lib.is_pure_primitive n -> + | UnaryAppl ((tyargs, `Name n), e) when Lib.is_pure_primitive n -> cofv (I.apply_pure(instantiate n tyargs, [ev e])) - | `UnaryAppl ((tyargs, `Name n), e) -> + | UnaryAppl ((tyargs, `Name n), e) -> I.apply (instantiate n tyargs, [ev e]) - | `FnAppl ({Sugartypes.node=`Var f; _}, es) when Lib.is_pure_primitive f -> + | FnAppl ({node=Var f; _}, es) when Lib.is_pure_primitive f -> cofv (I.apply_pure (I.var (lookup_name_and_type f env), evs es)) - | `FnAppl ({Sugartypes.node=`TAppl ({Sugartypes.node=`Var f; _}, tyargs); _}, es) + | FnAppl ({node=TAppl ({node=Var f; _}, tyargs); _}, es) when Lib.is_pure_primitive f -> cofv (I.apply_pure (instantiate f tyargs, evs es)) - | `FnAppl (e, es) when is_pure_primitive e -> + | FnAppl (e, es) when is_pure_primitive e -> cofv (I.apply_pure (ev e, evs es)) - | `FnAppl (e, es) -> + | FnAppl (e, es) -> I.apply (ev e, evs es) - | `TAbstr (tyvars, e) -> + | TAbstr (tyvars, e) -> let v = ev e in cofv (I.tabstr (Types.unbox_quantifiers tyvars, v)) - | `TAppl (e, tyargs) -> + | TAppl (e, tyargs) -> let v = ev e in let vt = I.sem_type v in begin @@ -827,50 +828,50 @@ struct with Instantiate.ArityMismatch -> prerr_endline ("Arity mismatch in type application (Sugartoir)"); - prerr_endline ("expression: " ^ Sugartypes.show_phrasenode (`TAppl (e, tyargs))); + prerr_endline ("expression: " ^ show_phrasenode (TAppl (e, tyargs))); prerr_endline ("type: "^Types.string_of_datatype vt); prerr_endline ("tyargs: "^String.concat "," (List.map (fun t -> Types.string_of_type_arg t) tyargs)); failwith "fatal internal error" end - | `TupleLit [e] -> + | TupleLit [e] -> (* It isn't entirely clear whether there should be any 1-tuples at this stage, but if there are we should get rid of them. The parser certainly doesn't disallow them. *) ec e - | `TupleLit es -> + | TupleLit es -> let fields = mapIndex (fun e i -> (string_of_int (i+1), ev e)) es in cofv (I.record (fields, None)) - | `RecordLit (fields, rest) -> + | RecordLit (fields, rest) -> cofv (I.record (List.map (fun (name, e) -> (name, ev e)) fields, opt_map ev rest)) - | `Projection (e, name) -> + | Projection (e, name) -> cofv (I.project (ev e, name)) - | `With (e, fields) -> + | With (e, fields) -> cofv (I.update (ev e, List.map (fun (name, e) -> (name, ev e)) fields)) - | `TypeAnnotation (e, _) -> + | TypeAnnotation (e, _) -> (* we might consider getting rid of type annotations before here *) ec e - | `Upcast (e, (_, Some t), _) -> + | Upcast (e, (_, Some t), _) -> cofv (I.coerce (ev e, t)) - | `ConstructorLit (name, None, Some t) -> + | ConstructorLit (name, None, Some t) -> cofv (I.inject (name, I.record ([], None), t)) - | `ConstructorLit (name, Some e, Some t) -> + | ConstructorLit (name, Some e, Some t) -> cofv (I.inject (name, ev e, t)) - | `DoOperation (name, ps, Some t) -> + | DoOperation (name, ps, Some t) -> let vs = evs ps in I.do_operation (name, vs, t) - | `Handle { Sugartypes.sh_expr; Sugartypes.sh_effect_cases; Sugartypes.sh_value_cases; Sugartypes.sh_descr } -> + | Handle { sh_expr; sh_effect_cases; sh_value_cases; sh_descr } -> let henv, params = let empty_env = (NEnv.empty, TEnv.empty, Types.make_empty_open_row (`Any, `Any)) in - match Sugartypes.(sh_descr.shd_params) with + match (sh_descr.shd_params) with | None -> empty_env, [] - | Some { Sugartypes.shp_bindings = bindings; Sugartypes.shp_types = types } -> + | Some { shp_bindings = bindings; shp_types = types } -> let env, bindings = List.fold_left2 (fun (env, bindings) (body, p) t -> @@ -896,7 +897,7 @@ struct sh_value_cases in I.handle env (ec sh_expr, val_cases, eff_cases, params, sh_descr) - | `Switch (e, cases, Some t) -> + | Switch (e, cases, Some t) -> let cases = List.map (fun (p, body) -> @@ -905,45 +906,45 @@ struct cases in I.switch env (ev e, cases, t) - | `DatabaseLit (name, (None, _)) -> - I.database (ev (with_pos pos (`RecordLit ([("name", name)], - Some (with_pos pos (`FnAppl (with_pos pos (`Var "getDatabaseConfig"), []))))))) - | `DatabaseLit (name, (Some driver, args)) -> + | DatabaseLit (name, (None, _)) -> + I.database (ev (with_pos pos (RecordLit ([("name", name)], + Some (with_pos pos (FnAppl (with_pos pos (Var "getDatabaseConfig"), []))))))) + | DatabaseLit (name, (Some driver, args)) -> let args = match args with - | None -> with_pos pos (`Constant (`String "")) + | None -> with_pos pos (Constant (`String "")) | Some args -> args in I.database - (ev (with_pos pos (`RecordLit ([("name", name); ("driver", driver); ("args", args)], None)))) - | `LensLit (table, Some t) -> + (ev (with_pos pos (RecordLit ([("name", name); ("driver", driver); ("args", args)], None)))) + | LensLit (table, Some t) -> let table = ev table in I.lens_handle (table, t) - | `LensDropLit (lens, drop, key, default, Some t) -> + | 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) - | `LensSelectLit (lens, pred, Some t) -> + | LensSelectLit (lens, pred, Some t) -> let lens = ev lens in let pred = Lens.Phrase.of_phrase pred in I.lens_select_handle (lens, pred, t) - | `LensJoinLit (lens1, lens2, on, left, right, Some t) -> + | LensJoinLit (lens1, lens2, on, left, right, Some t) -> let lens1 = ev lens1 in let lens2 = ev lens2 in let on = Lens.Types.cols_of_phrase on in let left = Lens.Phrase.of_phrase left in let right = Lens.Phrase.of_phrase right in I.lens_join_handle (lens1, lens2, on, left, right, t) - | `LensGetLit (lens, Some t) -> + | LensGetLit (lens, Some t) -> let lens = ev lens in I.lens_get (lens, t) - | `LensPutLit (lens, data, Some t) -> + | LensPutLit (lens, data, Some t) -> let lens = ev lens in let data = ev data in I.lens_put (lens, data, t) - | `TableLit (name, (_, Some (readtype, writetype, neededtype)), _constraints, keys, db) -> + | TableLit (name, (_, Some (readtype, writetype, neededtype)), _constraints, keys, db) -> I.table_handle (ev db, ev name, ev keys, (readtype, writetype, neededtype)) - | `Xml (tag, attrs, attrexp, children) -> + | Xml (tag, attrs, attrexp, children) -> (* check for duplicates *) let () = let rec dup_check names = @@ -979,15 +980,15 @@ struct | Some e -> cofv (I.apply_pure (instantiate_mb "addAttributes", [body; ev e])) end - | `TextNode name -> + | TextNode name -> cofv (I.apply_pure - (instantiate_mb "stringToXml", [ev (with_pos pos (`Constant (`String name)))])) - | `Block (bs, e) -> eval_bindings `Local env bs e - | `Query (range, e, _) -> + (instantiate_mb "stringToXml", [ev (with_pos pos (Constant (`String name)))])) + | Block (bs, e) -> eval_bindings `Local env bs e + | Query (range, e, _) -> I.query (opt_map (fun (limit, offset) -> (ev limit, ev offset)) range, ec e) - | `DBUpdate (p, source, where, fields) -> + | DBUpdate (p, source, where, fields) -> let p, penv = CompilePatterns.desugar_pattern `Local p in let env' = env ++ penv in let source = ev source in @@ -995,9 +996,9 @@ struct opt_map (fun where -> eval env' where) where in - let body = eval env' (Sugartypes.with_dummy_pos (`RecordLit (fields, None))) in + let body = eval env' (with_dummy_pos (RecordLit (fields, None))) in I.db_update env (p, source, where, body) - | `DBDelete (p, source, where) -> + | DBDelete (p, source, where) -> let p, penv = CompilePatterns.desugar_pattern `Local p in let env' = env ++ penv in let source = ev source in @@ -1008,9 +1009,9 @@ struct in I.db_delete env (p, source, where) - | `Select (l, e) -> + | Select (l, e) -> I.select (l, ev e) - | `Offer (e, cases, Some t) -> + | Offer (e, cases, Some t) -> let cases = List.map (fun (p, body) -> @@ -1021,41 +1022,41 @@ struct I.offer env (ev e, cases, t) (* These things should all have been desugared already *) - | `Spawn _ - | `Receive _ - | `Section (`Project _) - | `FunLit _ - | `Iteration _ - | `InfixAppl ((_, `RegexMatch _), _, _) - | `DBInsert _ - | `Regex _ - | `Formlet _ - | `Page _ - | `FormletPlacement _ - | `PagePlacement _ - | `FormBinding _ - | `ListLit _ - | `Escape _ - | `Upcast _ - | `ConstructorLit _ - | `Switch _ - | `TableLit _ - | `LensLit _ - | `LensDropLit _ - | `LensSelectLit _ - | `LensJoinLit _ - | `LensGetLit _ - | `LensPutLit _ - | `LensFunDepsLit _ - | `LensKeysLit _ - | `Offer _ - | `QualifiedVar _ - | `HandlerLit _ - | `DoOperation _ - | `TryInOtherwise _ - | `Raise - | `CP _ -> - Debug.print ("oops: " ^ Sugartypes.show_phrasenode e); + | Spawn _ + | Receive _ + | Section (`Project _) + | FunLit _ + | Iteration _ + | InfixAppl ((_, `RegexMatch _), _, _) + | DBInsert _ + | Regex _ + | Formlet _ + | Page _ + | FormletPlacement _ + | PagePlacement _ + | FormBinding _ + | ListLit _ + | Escape _ + | Upcast _ + | ConstructorLit _ + | Switch _ + | TableLit _ + | LensLit _ + | LensDropLit _ + | LensSelectLit _ + | LensJoinLit _ + | LensGetLit _ + | LensPutLit _ + | LensFunDepsLit _ + | LensKeysLit _ + | Offer _ + | QualifiedVar _ + | HandlerLit _ + | DoOperation _ + | TryInOtherwise _ + | Raise + | CP _ -> + Debug.print ("oops: " ^ show_phrasenode e); assert false and eval_bindings scope env bs' e = @@ -1205,7 +1206,7 @@ struct (* Debug.print (Sugartypes.show_program (bindings, body)); *) let body = match body with - | None -> Sugartypes.with_dummy_pos (`RecordLit ([], None)) + | None -> Sugartypes.with_dummy_pos (Sugartypes.RecordLit ([], None)) | Some body -> body in let s = eval_bindings `Global env bindings body in let r = (I.reify s) in diff --git a/core/sugartypes.ml b/core/sugartypes.ml index d20e34a69..fae7efd43 100644 --- a/core/sugartypes.ml +++ b/core/sugartypes.ml @@ -260,72 +260,71 @@ and handler_parameterisation = { and iterpatt = | List of (Pattern.with_pos * phrase) | Table of (Pattern.with_pos * phrase) -and phrasenode = [ -| `Constant of constant -| `Var of name -| `QualifiedVar of name list -| `FunLit of ((Types.datatype * Types.row) list) option * declared_linearity * funlit * location -| `HandlerLit of handlerlit +and phrasenode = +| Constant of constant +| Var of name +| QualifiedVar of name list +| FunLit of ((Types.datatype * Types.row) list) option * declared_linearity * funlit * location +| HandlerLit of handlerlit (* Spawn kind, expression referring to spawn location (client n, server...), spawn block, row opt *) -| `Spawn of spawn_kind * given_spawn_location * phrase * Types.row option -| `Query of (phrase * phrase) option * phrase * Types.datatype option -| `RangeLit of (phrase * phrase) -| `ListLit of phrase list * Types.datatype option -| `Iteration of iterpatt list * phrase +| Spawn of spawn_kind * given_spawn_location * phrase * Types.row option +| Query of (phrase * phrase) option * phrase * Types.datatype option +| RangeLit of (phrase * phrase) +| ListLit of phrase list * Types.datatype option +| Iteration of iterpatt list * phrase * (*where:*) phrase option * (*orderby:*) phrase option -| `Escape of binder * phrase -| `Section of sec -| `Conditional of phrase * phrase * phrase -| `Block of block_body -| `InfixAppl of (tyarg list * binop) * phrase * phrase -| `Regex of regex -| `UnaryAppl of (tyarg list * unary_op) * phrase -| `FnAppl of phrase * phrase list -| `TAbstr of tyvar list ref * phrase -| `TAppl of phrase * tyarg list -| `TupleLit of phrase list -| `RecordLit of (name * phrase) list * phrase option -| `Projection of phrase * name -| `With of phrase * (name * phrase) list -| `TypeAnnotation of phrase * datatype' -| `Upcast of phrase * datatype' * datatype' -| `ConstructorLit of name * phrase option * Types.datatype option -| `DoOperation of name * phrase list * Types.datatype option -| `Handle of handler -| `Switch of phrase * (Pattern.with_pos * phrase) list * Types.datatype option -| `Receive of (Pattern.with_pos * phrase) list * Types.datatype option -| `DatabaseLit of phrase * (phrase option * phrase option) -| `TableLit of phrase * (datatype * (Types.datatype * Types.datatype * Types.datatype) option) * (name * fieldconstraint list) list * phrase * phrase -| `DBDelete of Pattern.with_pos * phrase * phrase option -| `DBInsert of phrase * name list * phrase * phrase option -| `DBUpdate of Pattern.with_pos * phrase * phrase option * (name * phrase) list -| `LensLit of phrase * Types.lens_sort option +| Escape of binder * phrase +| Section of sec +| Conditional of phrase * phrase * phrase +| Block of block_body +| InfixAppl of (tyarg list * binop) * phrase * phrase +| Regex of regex +| UnaryAppl of (tyarg list * unary_op) * phrase +| FnAppl of phrase * phrase list +| TAbstr of tyvar list ref * phrase +| TAppl of phrase * tyarg list +| TupleLit of phrase list +| RecordLit of (name * phrase) list * phrase option +| Projection of phrase * name +| With of phrase * (name * phrase) list +| TypeAnnotation of phrase * datatype' +| Upcast of phrase * datatype' * datatype' +| ConstructorLit of name * phrase option * Types.datatype option +| DoOperation of name * phrase list * Types.datatype option +| Handle of handler +| Switch of phrase * (Pattern.with_pos * phrase) list * Types.datatype option +| Receive of (Pattern.with_pos * phrase) list * Types.datatype option +| DatabaseLit of phrase * (phrase option * phrase option) +| TableLit of phrase * (datatype * (Types.datatype * Types.datatype * Types.datatype) option) * (name * fieldconstraint list) list * phrase * phrase +| DBDelete of Pattern.with_pos * phrase * phrase option +| DBInsert of phrase * name list * phrase * phrase option +| DBUpdate of Pattern.with_pos * phrase * phrase option * (name * phrase) list +| LensLit of phrase * Types.lens_sort 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 * Types.lens_sort option -| `LensFunDepsLit of phrase * (string list * string list) list * Types.lens_sort option -| `LensDropLit of phrase * string * string * phrase * Types.lens_sort option -| `LensSelectLit of phrase * phrase * Types.lens_sort option -| `LensJoinLit of phrase * phrase * phrase * phrase * phrase * Types.lens_sort option -| `LensGetLit of phrase * Types.datatype option -| `LensPutLit of phrase * phrase * Types.datatype option -| `Xml of name * (name * (phrase list)) list * phrase option * phrase list -| `TextNode of string -| `Formlet of phrase * phrase -| `Page of phrase -| `FormletPlacement of phrase * phrase * phrase -| `PagePlacement of phrase -| `FormBinding of phrase * Pattern.with_pos +| LensKeysLit of phrase * phrase * Types.lens_sort option +| LensFunDepsLit of phrase * (string list * string list) list * Types.lens_sort option +| LensDropLit of phrase * string * string * phrase * Types.lens_sort option +| LensSelectLit of phrase * phrase * Types.lens_sort option +| LensJoinLit of phrase * phrase * phrase * phrase * phrase * Types.lens_sort option +| LensGetLit of phrase * Types.datatype option +| LensPutLit of phrase * phrase * Types.datatype option +| Xml of name * (name * (phrase list)) list * phrase option * phrase list +| TextNode of string +| Formlet of phrase * phrase +| Page of phrase +| FormletPlacement of phrase * phrase * phrase +| PagePlacement of phrase +| FormBinding of phrase * Pattern.with_pos (* choose *) -| `Select of name * phrase +| Select of name * phrase (* choice *) -| `Offer of phrase * (Pattern.with_pos * phrase) list * Types.datatype option +| Offer of phrase * (Pattern.with_pos * phrase) list * Types.datatype option (* | `Fork of binder * phrase *) -| `CP of cp_phrase -| `TryInOtherwise of (phrase * Pattern.with_pos * phrase * phrase * Types.datatype option) -| `Raise -] +| CP of cp_phrase +| TryInOtherwise of (phrase * Pattern.with_pos * phrase * phrase * Types.datatype option) +| Raise and phrase = phrasenode with_pos and bindingnode = | Val of (Pattern.with_pos * (tyvar list * phrase) * location * datatype' option) @@ -379,13 +378,12 @@ exception RedundantPatternMatch of SourceCode.pos let tabstr : tyvar list * phrasenode -> phrasenode = fun (tyvars, e) -> match tyvars with | [] -> e - | _ -> - `TAbstr (Types.box_quantifiers tyvars, with_dummy_pos e) + | _ -> TAbstr (Types.box_quantifiers tyvars, with_dummy_pos e) let tappl : phrasenode * tyarg list -> phrasenode = fun (e, tys) -> match tys with | [] -> e - | _ -> `TAppl (with_dummy_pos e, tys) + | _ -> TAppl (with_dummy_pos e, tys) module Freevars = struct @@ -416,81 +414,81 @@ struct let rec formlet_bound ({node; _} : phrase) : StringSet.t = match node with - | `Xml (_, _, _, children) -> union_map formlet_bound children - | `FormBinding (_, pat) -> pattern pat + | Xml (_, _, _, children) -> union_map formlet_bound children + | FormBinding (_, pat) -> pattern pat | _ -> empty let rec phrase (p : phrase) : StringSet.t = let p = p.node in match p with - | `Var v -> singleton v - | `Section (`Name n) -> singleton n - - | `Constant _ - | `TextNode _ - | `Section (`Minus|`FloatMinus|`Project _) -> empty - - | `Spawn (_, _, p, _) - | `TAbstr (_, p) - | `TAppl (p, _) - | `FormBinding (p, _) - | `Projection (p, _) - | `Page p - | `PagePlacement p - | `Upcast (p, _, _) - | `Select (_, p) - | `TypeAnnotation (p, _) -> phrase p - - | `ListLit (ps, _) - | `TupleLit ps -> union_map phrase ps - - | `LensLit (l, _) -> phrase l + | Var v -> singleton v + | Section (`Name n) -> singleton n + + | Constant _ + | TextNode _ + | Section (`Minus|`FloatMinus|`Project _) -> empty + + | Spawn (_, _, p, _) + | TAbstr (_, p) + | TAppl (p, _) + | FormBinding (p, _) + | Projection (p, _) + | Page p + | PagePlacement p + | Upcast (p, _, _) + | Select (_, p) + | TypeAnnotation (p, _) -> phrase p + + | ListLit (ps, _) + | TupleLit ps -> union_map phrase ps + + | LensLit (l, _) -> phrase l (* this should be converted to `LensLit during typeSugar *) - | `LensFunDepsLit _ -> assert false - | `LensKeysLit (l, _, _) -> phrase l - | `LensSelectLit (l, _, _) -> phrase l - | `LensDropLit (l, _, _, _, _) -> phrase l - | `LensJoinLit (l1, l2, _, _, _, _) -> union_all [phrase l1; phrase l2] - - | `LensGetLit (l, _) -> phrase l - | `LensPutLit (l, data, _) -> union_all [phrase l; phrase data] - - | `Query (None, p, _) -> phrase p - | `Query (Some (limit, offset), p, _) -> union_all [phrase limit; phrase offset; phrase p] - - | `Escape (v, p) -> diff (phrase p) (singleton (name_of_binder v)) - | `FormletPlacement (p1, p2, p3) - | `Conditional (p1, p2, p3) -> union_map phrase [p1;p2;p3] - | `Block b -> block b - | `InfixAppl ((_, `Name n), p1, p2) -> union (singleton n) (union_map phrase [p1;p2]) - | `InfixAppl (_, p1, p2) -> union_map phrase [p1;p2] - | `RangeLit (p1, p2) -> union_map phrase [p1;p2] - | `Regex r -> regex r - | `UnaryAppl (_, p) -> phrase p - | `FnAppl (p, ps) -> union_map phrase (p::ps) - | `RecordLit (fields, p) -> + | LensFunDepsLit _ -> assert false + | LensKeysLit (l, _, _) -> phrase l + | LensSelectLit (l, _, _) -> phrase l + | LensDropLit (l, _, _, _, _) -> phrase l + | LensJoinLit (l1, l2, _, _, _, _) -> union_all [phrase l1; phrase l2] + + | LensGetLit (l, _) -> phrase l + | LensPutLit (l, data, _) -> union_all [phrase l; phrase data] + + | Query (None, p, _) -> phrase p + | Query (Some (limit, offset), p, _) -> union_all [phrase limit; phrase offset; phrase p] + + | Escape (v, p) -> diff (phrase p) (singleton (name_of_binder v)) + | FormletPlacement (p1, p2, p3) + | Conditional (p1, p2, p3) -> union_map phrase [p1;p2;p3] + | Block b -> block b + | InfixAppl ((_, `Name n), p1, p2) -> union (singleton n) (union_map phrase [p1;p2]) + | InfixAppl (_, p1, p2) -> union_map phrase [p1;p2] + | RangeLit (p1, p2) -> union_map phrase [p1;p2] + | Regex r -> regex r + | UnaryAppl (_, p) -> phrase p + | FnAppl (p, ps) -> union_map phrase (p::ps) + | RecordLit (fields, p) -> union (union_map (snd ->- phrase) fields) (option_map phrase p) - | `With (p, fields) -> + | With (p, fields) -> union (union_map (snd ->- phrase) fields) (phrase p) - | `ConstructorLit (_, popt, _) -> option_map phrase popt - | `DatabaseLit (p, (popt1, popt2)) -> + | ConstructorLit (_, popt, _) -> option_map phrase popt + | DatabaseLit (p, (popt1, popt2)) -> union_all [phrase p; option_map phrase popt1; option_map phrase popt2] - | `DBInsert (p1, _labels, p2, popt) -> + | DBInsert (p1, _labels, p2, popt) -> union_all [phrase p1; phrase p2; option_map phrase popt] - | `TableLit (p1, _, _, _, p2) -> union (phrase p1) (phrase p2) - | `Xml (_, attrs, attrexp, children) -> + | TableLit (p1, _, _, _, p2) -> union (phrase p1) (phrase p2) + | Xml (_, attrs, attrexp, children) -> union_all [union_map (snd ->- union_map phrase) attrs; option_map phrase attrexp; union_map phrase children] - | `Formlet (xml, yields) -> + | Formlet (xml, yields) -> let binds = formlet_bound xml in union (phrase xml) (diff (phrase yields) binds) - | `HandlerLit hnlit -> handlerlit hnlit - | `FunLit (_, _, fnlit, _) -> funlit fnlit - | `Iteration (generators, body, where, orderby) -> + | HandlerLit hnlit -> handlerlit hnlit + | FunLit (_, _, fnlit, _) -> funlit fnlit + | Iteration (generators, body, where, orderby) -> let xs = union_map (function | List (_, source) | Table (_, source) -> phrase source) generators in @@ -501,7 +499,7 @@ struct diff (phrase body) pat_bound; diff (option_map phrase where) pat_bound; diff (option_map phrase orderby) pat_bound] - | `Handle { sh_expr = e; sh_effect_cases = eff_cases; sh_value_cases = val_cases; sh_descr = descr } -> + | Handle { sh_expr = e; sh_effect_cases = eff_cases; sh_value_cases = val_cases; sh_descr = descr } -> let params_bound = option_map (fun params -> union_map (snd ->- pattern) params.shp_bindings) @@ -511,23 +509,23 @@ struct union_map case eff_cases; union_map case val_cases; diff (option_map (fun params -> union_map (fst ->- phrase) params.shp_bindings) descr.shd_params) params_bound] - | `Switch (p, cases, _) - | `Offer (p, cases, _) -> union (phrase p) (union_map case cases) - | `CP cp -> cp_phrase cp - | `Receive (cases, _) -> union_map case cases - | `DBDelete (pat, p, where) -> + | Switch (p, cases, _) + | Offer (p, cases, _) -> union (phrase p) (union_map case cases) + | CP cp -> cp_phrase cp + | Receive (cases, _) -> union_map case cases + | DBDelete (pat, p, where) -> union (phrase p) (diff (option_map phrase where) (pattern pat)) - | `DBUpdate (pat, from, where, fields) -> + | DBUpdate (pat, from, where, fields) -> let pat_bound = pattern pat in union_all [phrase from; diff (option_map phrase where) pat_bound; diff (union_map (snd ->- phrase) fields) pat_bound] - | `DoOperation (_, ps, _) -> union_map phrase ps - | `QualifiedVar _ -> empty - | `TryInOtherwise (p1, pat, p2, p3, _ty) -> union (union_map phrase [p1; p2; p3]) (pattern pat) - | `Raise -> empty + | DoOperation (_, ps, _) -> union_map phrase ps + | QualifiedVar _ -> empty + | TryInOtherwise (p1, pat, p2, p3, _ty) -> union (union_map phrase [p1; p2; p3]) (pattern pat) + | Raise -> empty and binding ({node = binding; _}: binding) : StringSet.t (* vars bound in the pattern *) * StringSet.t (* free vars in the rhs *) = match binding with diff --git a/core/transformSugar.ml b/core/transformSugar.ml index ce3cc7e7d..c359a0353 100644 --- a/core/transformSugar.ml +++ b/core/transformSugar.ml @@ -228,9 +228,9 @@ class transform (env : Types.typing_environment) = method phrasenode : phrasenode -> ('self_type * phrasenode * Types.datatype) = function - | `Constant c -> let (o, c, t) = o#constant c in (o, (`Constant c), t) - | `Var var -> (o, `Var var, o#lookup_type var) - | `FunLit (Some argss, lin, lam, location) -> + | Constant c -> let (o, c, t) = o#constant c in (o, Constant c, t) + | Var var -> (o, Var var, o#lookup_type var) + | FunLit (Some argss, lin, lam, location) -> let inner_e = snd (try last argss with Invalid_argument s -> raise (Invalid_argument ("@" ^ s))) in let (o, lam, rt) = o#funlit inner_e lam in let (o, t) = @@ -242,9 +242,9 @@ class transform (env : Types.typing_environment) = argss (o, rt) in - (o, `FunLit (Some argss, lin, lam, location), t) - | `HandlerLit _ -> assert false - | `Spawn (Wait, loc, body, Some inner_effects) -> + (o, FunLit (Some argss, lin, lam, location), t) + | HandlerLit _ -> assert false + | Spawn (Wait, loc, body, Some inner_effects) -> assert (loc = NoSpawnLocation); (* bring the inner effects into scope, then restore the environments afterwards *) @@ -253,8 +253,8 @@ class transform (env : Types.typing_environment) = let o = o#with_effects inner_effects in let (o, body, body_type) = o#phrase body in let o = o#restore_envs envs in - (o, `Spawn (Wait, loc, body, Some inner_effects), body_type) - | `Spawn (k, spawn_loc, body, Some inner_effects) -> + (o, Spawn (Wait, loc, body, Some inner_effects), body_type) + | Spawn (k, spawn_loc, body, Some inner_effects) -> (* bring the inner effects into scope, then restore the environments afterwards *) let (o, spawn_loc) = o#given_spawn_location spawn_loc in @@ -264,11 +264,11 @@ class transform (env : Types.typing_environment) = let o = o#with_effects inner_effects in let (o, body, _) = o#phrase body in let o = o#restore_envs envs in - (o, (`Spawn (k, spawn_loc, body, Some inner_effects)), process_type) - | `Select (l, e) -> + (o, Spawn (k, spawn_loc, body, Some inner_effects), process_type) + | Select (l, e) -> let (o, e, t) = o#phrase e in - (o, (`Select (l, e)), TypeUtils.select_type l t) - | `Offer (e, bs, Some t) -> + (o, Select (l, e), TypeUtils.select_type l t) + | Offer (e, bs, Some t) -> let (o, e, _) = o#phrase e in let (o, bs) = listu o @@ -277,11 +277,11 @@ class transform (env : Types.typing_environment) = let (o, e, _) = o#phrase e in (o, (p, e))) bs in let (o, t) = o#datatype t in - (o, `Offer (e, bs, Some t), t) - | `CP p -> + (o, Offer (e, bs, Some t), t) + | CP p -> let (o, p, t) = o#cp_phrase p in - (o, `CP p, t) - | `Query (range, body, Some t) -> + (o, CP p, t) + | Query (range, body, Some t) -> let (o, range) = optionu o (fun o (limit, offset) -> @@ -291,88 +291,88 @@ class transform (env : Types.typing_environment) = range in let (o, body, _) = o#phrase body in let (o, t) = o#datatype t in - (o, (`Query (range, body, Some t)), t) - | `ListLit (es, Some t) -> + (o, Query (range, body, Some t), t) + | ListLit (es, Some t) -> let (o, es, _) = list o (fun o -> o#phrase) es in let (o, t) = o#datatype t in - (o, `ListLit (es, Some t), Types.make_list_type t) - | `RangeLit (e1, e2) -> + (o, ListLit (es, Some t), Types.make_list_type t) + | RangeLit (e1, e2) -> let (o, e1, _) = o#phrase e1 in let (o, e2, _) = o#phrase e2 in - (o, `RangeLit (e1, e2), Types.make_list_type Types.int_type) - | `Iteration (gens, body, cond, orderby) -> + (o, RangeLit (e1, e2), Types.make_list_type Types.int_type) + | Iteration (gens, body, cond, orderby) -> let (o, gens) = listu o (fun o -> o#iterpatt) gens in let (o, body, t) = o#phrase body in let (o, cond, _) = option o (fun o -> o#phrase) cond in let (o, orderby, _) = option o (fun o -> o#phrase) orderby in - (o, `Iteration (gens, body, cond, orderby), t) - | `Escape (b, e) -> + (o, Iteration (gens, body, cond, orderby), t) + | Escape (b, e) -> let envs = o#backup_envs in let (o, b) = o#binder b in let (o, e, t) = o#phrase e in let o = o#restore_envs envs in - (o, `Escape (b, e), t) - | `Section sec -> (o, `Section sec, type_section var_env sec) - | `Conditional (p, e1, e2) -> + (o, Escape (b, e), t) + | Section sec -> (o, Section sec, type_section var_env sec) + | Conditional (p, e1, e2) -> let (o, p, _) = o#phrase p in let (o, e1, t) = o#phrase e1 in let (o, e2, _) = o#phrase e2 - in (o, `Conditional (p, e1, e2), t) - | `Block (bs, e) -> + in (o, Conditional (p, e1, e2), t) + | Block (bs, e) -> let envs = o#backup_envs in let (o, bs) = listu o (fun o -> o#binding) bs in let (o, e, t) = o#phrase e in let o = o#restore_envs envs in - o, `Block (bs, e), t - | `InfixAppl ((tyargs, op), e1, e2) -> + o, Block (bs, e), t + | InfixAppl ((tyargs, op), e1, e2) -> let (o, op, t) = o#binop op in check_type_application - (`InfixAppl ((tyargs, op), e1, e2), t) + (InfixAppl ((tyargs, op), e1, e2), t) (fun () -> let t = TypeUtils.return_type (Instantiate.apply_type t tyargs) in let (o, e1, _) = o#phrase e1 in let (o, e2, _) = o#phrase e2 in - (o, `InfixAppl ((tyargs, op), e1, e2), t)) - | `Regex r -> + (o, InfixAppl ((tyargs, op), e1, e2), t)) + | Regex r -> let (o, r) = o#regex r in - (o, `Regex r, Instantiate.alias "Regex" [] tycon_env) - | `UnaryAppl ((tyargs, op), e) -> + (o, Regex r, Instantiate.alias "Regex" [] tycon_env) + | UnaryAppl ((tyargs, op), e) -> let (o, op, t) = o#unary_op op in check_type_application - (`UnaryAppl ((tyargs, op), e), t) + (UnaryAppl ((tyargs, op), e), t) (fun () -> let t = TypeUtils.return_type (Instantiate.apply_type t tyargs) in let (o, e, _) = o#phrase e in - (o, `UnaryAppl ((tyargs, op), e), t)) - | `FnAppl (f, args) -> + (o, UnaryAppl ((tyargs, op), e), t)) + | FnAppl (f, args) -> let (o, f, ft) = o#phrase f in let (o, args, _) = list o (fun o -> o#phrase) args in - (o, `FnAppl (f, args), TypeUtils.return_type ft) - | `TAbstr (tyvars, e) -> + (o, FnAppl (f, args), TypeUtils.return_type ft) + | TAbstr (tyvars, e) -> let outer_tyvars = o#backup_quantifiers in let (o, qs) = o#quantifiers (Types.unbox_quantifiers tyvars) in let (o, e, t) = o#phrase e in let o = o#restore_quantifiers outer_tyvars in let t = Types.for_all (qs, t) in (o, tabstr (qs, e.node), t) - | `TAppl (e, tyargs) -> + | TAppl (e, tyargs) -> let (o, e, t) = o#phrase e in check_type_application - (`TAppl (e, tyargs), t) + (TAppl (e, tyargs), t) (fun () -> let t = Instantiate.apply_type t tyargs in - (o, `TAppl (e, tyargs), t)) - | `TupleLit [e] -> + (o, TAppl (e, tyargs), t)) + | TupleLit [e] -> (* QUESTION: Why do we type 1-tuples as if they aren't tuples? *) let (o, e, t) = o#phrase e in - (o, `TupleLit [e], t) - | `TupleLit es -> + (o, TupleLit [e], t) + | TupleLit es -> let (o, es, ts) = list o (fun o -> o#phrase) es in - (o, `TupleLit es, Types.make_tuple_type ts) - | `RecordLit (fields, base) -> + (o, TupleLit es, Types.make_tuple_type ts) + | RecordLit (fields, base) -> let (o, fields, field_types) = let rec list o = function @@ -399,11 +399,11 @@ class transform (env : Types.typing_environment) = assert false end in - (o, `RecordLit (fields, base), t) - | `Projection (e, name) -> + (o, RecordLit (fields, base), t) + | Projection (e, name) -> let (o, e, t) = o#phrase e in - (o, `Projection (e, name), TypeUtils.project_type name t) - | `With (e, fields) -> + (o, Projection (e, name), TypeUtils.project_type name t) + | With (e, fields) -> let (o, e, t) = o#phrase e in let (o, fields) = let rec list o = @@ -416,26 +416,26 @@ class transform (env : Types.typing_environment) = in list o fields in - (o, `With (e, fields), t) - | `TypeAnnotation (e, ann_type) -> + (o, With (e, fields), t) + | TypeAnnotation (e, ann_type) -> let (o, e, _) = o#phrase e in let (o, ann_type) = o#datatype' ann_type in let t = val_of (snd ann_type) in - (o, `TypeAnnotation (e, ann_type), t) - | `Upcast (e, to_type, from_type) -> + (o, TypeAnnotation (e, ann_type), t) + | Upcast (e, to_type, from_type) -> let (o, e, _) = o#phrase e in let (o, to_type) = o#datatype' to_type in let (o, from_type) = o#datatype' from_type in let t = val_of (snd to_type) in - (o, `Upcast (e, to_type, from_type), t) - | `ConstructorLit (name, e, Some t) -> + (o, Upcast (e, to_type, from_type), t) + | ConstructorLit (name, e, Some t) -> let (o, e, _) = option o (fun o -> o#phrase) e in let (o, t) = o#datatype t in - (o, `ConstructorLit (name, e, Some t), t) - | `DoOperation (name, ps, Some t) -> + (o, ConstructorLit (name, e, Some t), t) + | DoOperation (name, ps, Some t) -> let (o, ps, _) = list o (fun o -> o#phrase) ps in - (o, `DoOperation (name, ps, Some t), t) - | `Handle { sh_expr; sh_effect_cases; sh_value_cases; sh_descr } -> + (o, DoOperation (name, ps, Some t), t) + | Handle { sh_expr; sh_effect_cases; sh_value_cases; sh_descr } -> let (input_row, input_t, output_row, output_t) = sh_descr.shd_types in let (o, expr, _) = o#phrase sh_expr in let envs = o#backup_envs in @@ -479,16 +479,16 @@ class transform (env : Types.typing_environment) = shd_raw_row = raw_row; shd_params = params} in - (o, `Handle { sh_expr = expr; sh_effect_cases = eff_cases; sh_value_cases = val_cases; sh_descr = descr }, output_t) - | `TryInOtherwise (try_phr, as_pat, as_phr, otherwise_phr, (Some dt)) -> + (o, Handle { sh_expr = expr; sh_effect_cases = eff_cases; sh_value_cases = val_cases; sh_descr = descr }, output_t) + | TryInOtherwise (try_phr, as_pat, as_phr, otherwise_phr, (Some dt)) -> let (o, try_phr, _) = o#phrase try_phr in let (o, as_pat) = o#pattern as_pat in let (o, as_phr, _) = o#phrase as_phr in let (o, otherwise_phr, _) = o#phrase otherwise_phr in let (o, dt) = o#datatype dt in - (o, `TryInOtherwise (try_phr, as_pat, as_phr, otherwise_phr, (Some dt)), dt) - | `Raise -> (o, `Raise, `Not_typed) (* TEMP *) - | `Switch (v, cases, Some t) -> + (o, TryInOtherwise (try_phr, as_pat, as_phr, otherwise_phr, (Some dt)), dt) + | Raise -> (o, Raise, `Not_typed) (* TEMP *) + | Switch (v, cases, Some t) -> let (o, v, _) = o#phrase v in let (o, cases) = listu o @@ -497,8 +497,8 @@ class transform (env : Types.typing_environment) = let (o, e, _) = o#phrase e in (o, (p, e))) cases in let (o, t) = o#datatype t in - (o, `Switch (v, cases, Some t), t) - | `Receive (cases, Some t) -> + (o, Switch (v, cases, Some t), t) + | Receive (cases, Some t) -> let (o, cases) = listu o (fun o (p, e) -> @@ -506,49 +506,49 @@ class transform (env : Types.typing_environment) = let (o, e, _) = o#phrase e in (o, (p, e))) cases in let (o, t) = o#datatype t in - (o, `Receive (cases, Some t), t) - | `DatabaseLit (name, (driver, args)) -> + (o, Receive (cases, Some t), t) + | DatabaseLit (name, (driver, args)) -> let (o, name, _) = o#phrase name in let (o, driver, _) = option o (fun o -> o#phrase) driver in let (o, args, _) = option o (fun o -> o#phrase) args in - (o, `DatabaseLit (name, (driver, args)), `Primitive `DB) - | `LensLit (table, Some t) -> + (o, DatabaseLit (name, (driver, args)), `Primitive `DB) + | LensLit (table, Some t) -> let (o, table, _) = o#phrase table in let (o, t) = o#lens_sort t in - (o, `LensLit (table, Some t), `Lens (t)) - | `LensDropLit (lens, drop, key, default, Some t) -> + (o, LensLit (table, Some t), `Lens (t)) + | LensDropLit (lens, drop, key, default, Some t) -> let (o, lens, _) = o#phrase lens in let (o, t) = o#lens_sort t in let (o, default, _) = o#phrase default in - (o, `LensDropLit (lens, drop, key, default, Some t), `Lens (t)) - | `LensSelectLit (lens, predicate, Some t) -> + (o, LensDropLit (lens, drop, key, default, Some t), `Lens (t)) + | LensSelectLit (lens, predicate, Some t) -> let (o, lens, _) = o#phrase lens in (* let (o, predicate, _) = o#phrase predicate in *) let (o, t) = o#lens_sort t in - (o, `LensSelectLit (lens, predicate, Some t), `Lens t) - | `LensJoinLit (lens1, lens2, on, left, right, Some t) -> + (o, LensSelectLit (lens, predicate, Some t), `Lens t) + | LensJoinLit (lens1, lens2, on, left, right, Some t) -> let (o, lens1, _) = o#phrase lens1 in let (o, lens2, _) = o#phrase lens2 in let (o, t) = o#lens_sort t in - (o, `LensJoinLit (lens1, lens2, on, left, right, Some t), `Lens t) - | `LensGetLit (lens, Some t) -> + (o, LensJoinLit (lens1, lens2, on, left, right, Some t), `Lens t) + | LensGetLit (lens, Some t) -> let (o, lens, _) = o#phrase lens in let (o, t) = o#datatype t in - (o, `LensGetLit (lens, Some t), Types.make_list_type t) - | `LensPutLit (lens, data, Some t) -> + (o, LensGetLit (lens, Some t), Types.make_list_type t) + | LensPutLit (lens, data, Some t) -> let (o, lens, _) = o#phrase lens in let (o, data, _) = o#phrase data in let (o, t) = o#datatype t in - (o, `LensPutLit (lens, data, Some t), Types.make_list_type t) - | `TableLit (name, (dtype, Some (read_row, write_row, needed_row)), constraints, keys, db) -> + (o, LensPutLit (lens, data, Some t), Types.make_list_type t) + | TableLit (name, (dtype, Some (read_row, write_row, needed_row)), constraints, keys, db) -> let (o, name, _) = o#phrase name in let (o, db, _) = o#phrase db in let (o, dtype) = o#sugar_datatype dtype in let (o, read_row) = o#datatype read_row in let (o, write_row) = o#datatype write_row in let (o, needed_row) = o#datatype needed_row in - (o, `TableLit (name, (dtype, Some (read_row, write_row, needed_row)), constraints, keys, db), `Table (read_row, write_row, needed_row)) - | `DBDelete (p, from, where) -> + (o, TableLit (name, (dtype, Some (read_row, write_row, needed_row)), constraints, keys, db), `Table (read_row, write_row, needed_row)) + | DBDelete (p, from, where) -> let (o, from, _) = o#phrase from in let (o, p) = o#pattern p in (* BUG: @@ -556,16 +556,16 @@ class transform (env : Types.typing_environment) = We should really reset the environment: variables bound by p shouldn't be visible in subsequent expression. - The same applies to `DBUpdate and `Iteration. + The same applies to DBUpdate and Iteration. *) let (o, where, _) = option o (fun o -> o#phrase) where in - (o, `DBDelete (p, from, where), Types.unit_type) - | `DBInsert (into, labels, values, id) -> + (o, DBDelete (p, from, where), Types.unit_type) + | DBInsert (into, labels, values, id) -> let (o, into, _) = o#phrase into in let (o, values, _) = o#phrase values in let (o, id, _) = option o (fun o -> o#phrase) id in - (o, `DBInsert (into, labels, values, id), Types.unit_type) - | `DBUpdate (p, from, where, set) -> + (o, DBInsert (into, labels, values, id), Types.unit_type) + | DBUpdate (p, from, where, set) -> let (o, from, _) = o#phrase from in let (o, p) = o#pattern p in let (o, where, _) = option o (fun o -> o#phrase) where in @@ -575,8 +575,8 @@ class transform (env : Types.typing_environment) = let (o, value, _) = o#phrase value in (o, (name, value))) set in - (o, `DBUpdate (p, from, where, set), Types.unit_type) - | `Xml (tag, attrs, attrexp, children) -> + (o, DBUpdate (p, from, where, set), Types.unit_type) + | Xml (tag, attrs, attrexp, children) -> let (o, attrs) = listu o (fun o (name, value) -> @@ -585,9 +585,9 @@ class transform (env : Types.typing_environment) = attrs in let (o, attrexp, _) = option o (fun o -> o#phrase) attrexp in let (o, children, _) = list o (fun o -> o#phrase) children in - (o, `Xml (tag, attrs, attrexp, children), Types.xml_type) - | `TextNode s -> (o, `TextNode s, Types.xml_type) - | `Formlet (body, yields) -> + (o, Xml (tag, attrs, attrexp, children), Types.xml_type) + | TextNode s -> (o, TextNode s, Types.xml_type) + | Formlet (body, yields) -> let envs = o#backup_envs in let (o, body, _) = o#phrase body in (* ensure that the formlet bindings are only in scope in the @@ -595,16 +595,16 @@ class transform (env : Types.typing_environment) = let o = o#with_var_env (TyEnv.extend (o#get_var_env ()) (o#get_formlet_env ())) in let (o, yields, t) = o#phrase yields in let o = o#restore_envs envs in - (o, `Formlet (body, yields), Instantiate.alias "Formlet" [`Type t] tycon_env) - | `Page e -> let (o, e, _) = o#phrase e in (o, `Page e, Instantiate.alias "Page" [] tycon_env) - | `FormletPlacement (f, h, attributes) -> + (o, Formlet (body, yields), Instantiate.alias "Formlet" [`Type t] tycon_env) + | Page e -> let (o, e, _) = o#phrase e in (o, Page e, Instantiate.alias "Page" [] tycon_env) + | FormletPlacement (f, h, attributes) -> let (o, f, _) = o#phrase f in let (o, h, _) = o#phrase h in let (o, attributes, _) = o#phrase attributes in - (o, `FormletPlacement (f, h, attributes), Types.xml_type) - | `PagePlacement e -> - let (o, e, _) = o#phrase e in (o, `PagePlacement e, Types.xml_type) - | `FormBinding (f, p) -> + (o, FormletPlacement (f, h, attributes), Types.xml_type) + | PagePlacement e -> + let (o, e, _) = o#phrase e in (o, PagePlacement e, Types.xml_type) + | FormBinding (f, p) -> let envs = o#backup_envs in let (o, f, _) = o#phrase f in (* HACK: add the formlet bindings to the formlet environment *) @@ -614,7 +614,7 @@ class transform (env : Types.typing_environment) = let o = o#restore_envs envs in let o = o#with_formlet_env formlet_env in (* let o = {< formlet_env=TyEnv.extend formlet_env (o#get_var_env()) >} in *) - (o, `FormBinding (f, p), Types.xml_type) + (o, FormBinding (f, p), Types.xml_type) | e -> failwith ("oops: "^show_phrasenode e) method phrase : phrase -> ('self_type * phrase * Types.datatype) = diff --git a/core/typeSugar.ml b/core/typeSugar.ml index a23dedc0a..3513c1fea 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -36,74 +36,73 @@ struct let rec opt_generalisable o = opt_app is_pure true o and is_pure p = match p.node with - | `Constant _ - | `Var _ - | `QualifiedVar _ - | `FunLit _ - | `DatabaseLit _ - | `TableLit _ - | `TextNode _ - | `HandlerLit _ - | `Section _ -> true - - | `ListLit (ps, _) - | `TupleLit ps -> List.for_all is_pure ps - | `RangeLit (e1, e2) -> is_pure e1 && is_pure e2 - | `TAbstr (_, p) - | `TAppl (p, _) - | `Projection (p, _) - | `TypeAnnotation (p, _) - | `Upcast (p, _, _) - | `Escape (_, p) -> is_pure p - | `ConstructorLit (_, p, _) -> opt_generalisable p - | `RecordLit (fields, p) -> - List.for_all (snd ->- is_pure) fields && opt_generalisable p - | `With (p, fields) -> - List.for_all (snd ->- is_pure) fields && is_pure p - | `Block (bindings, e) -> - List.for_all is_pure_binding bindings && is_pure e - | `Conditional (p1, p2, p3) -> + | QualifiedVar _ + | Constant _ + | Var _ + | FunLit _ + | DatabaseLit _ + | TableLit _ + | TextNode _ + | HandlerLit _ + | Section _ -> true + + | ListLit (ps, _) + | TupleLit ps -> List.for_all is_pure ps + | RangeLit (e1, e2) -> is_pure e1 && is_pure e2 + | TAbstr (_, p) + | TAppl (p, _) + | Projection (p, _) + | TypeAnnotation (p, _) + | Upcast (p, _, _) + | Escape (_, p) -> is_pure p + | ConstructorLit (_, p, _) -> opt_generalisable p + | RecordLit (fields, p) -> + List.for_all (snd ->- is_pure) fields && opt_generalisable p + | With (p, fields) -> + List.for_all (snd ->- is_pure) fields && is_pure p + | Block (bindings, e) -> + List.for_all is_pure_binding bindings && is_pure e + | Conditional (p1, p2, p3) -> is_pure p1 && is_pure p2 && is_pure p3 - | `Xml (_, attrs, attrexp, children) -> + | Xml (_, attrs, attrexp, children) -> List.for_all (snd ->- List.for_all is_pure) attrs && opt_generalisable attrexp && List.for_all (is_pure) children - | `Formlet (p1, p2) -> + | Formlet (p1, p2) -> is_pure p1 && is_pure p2 - | `Regex r -> is_pure_regex r - | `Iteration _ (* could do a little better in some of these cases *) - | `Page _ - | `FormletPlacement _ - | `PagePlacement _ - | `UnaryAppl _ - | `FormBinding _ - | `InfixAppl _ - | `Spawn _ - | `Query _ - | `FnAppl _ - | `Handle _ - | `Switch _ - | `Receive _ - | `Select _ - | `Offer _ - | `CP _ - (* | `Fork _ *) - | `LensLit _ - | `LensKeysLit _ - | `LensFunDepsLit _ - | `LensDropLit _ - | `LensSelectLit _ - | `LensJoinLit _ - | `LensGetLit _ - | `LensPutLit _ - | `DoOperation _ - | `DBDelete _ - | `DBInsert _ - | `TryInOtherwise _ - | `Raise - | `DBUpdate _ -> false + | Regex r -> is_pure_regex r + | Iteration _ (* could do a little better in some of these cases *) + | Page _ + | FormletPlacement _ + | PagePlacement _ + | UnaryAppl _ + | FormBinding _ + | InfixAppl _ + | Spawn _ + | Query _ + | FnAppl _ + | Handle _ + | Switch _ + | Receive _ + | Select _ + | Offer _ + | CP _ + | LensLit _ + | LensKeysLit _ + | LensFunDepsLit _ + | LensDropLit _ + | LensSelectLit _ + | LensJoinLit _ + | LensGetLit _ + | LensPutLit _ + | DoOperation _ + | DBDelete _ + | DBInsert _ + | TryInOtherwise _ + | Raise + | DBUpdate _ -> false and is_pure_binding ({node ; _ }: binding) = match node with (* need to check that pattern matching cannot fail *) | QualifiedImport _ @@ -1379,25 +1378,27 @@ let unbind_var context v = {context with var_env = Env.unbind context.var_env v} let bind_tycon context (v, t) = {context with tycon_env = Env.bind context.tycon_env (v,t)} let bind_effects context r = {context with effect_row = r} -let type_section context (`Section s as s') = - let env = context.var_env in - let ((tyargs, t), usages) = - match s with - | `Minus -> Utils.instantiate env "-", StringMap.empty - | `FloatMinus -> Utils.instantiate env "-.", StringMap.empty - | `Project label -> +let type_section context = function + | Section s as s' -> + let env = context.var_env in + let ((tyargs, t), usages) = + match s with + | `Minus -> Utils.instantiate env "-", StringMap.empty + | `FloatMinus -> Utils.instantiate env "-.", StringMap.empty + | `Project label -> let a = Types.fresh_type_variable (`Any, `Any) in let rho = Types.fresh_row_variable (`Any, `Any) in let effects = Types.make_empty_open_row (`Any, `Any) in (* projection is pure! *) let r = `Record (StringMap.add label (`Present a) StringMap.empty, rho, false) in ([`Type a; `Row (StringMap.empty, rho, false); `Row effects], `Function (Types.make_tuple_type [r], effects, a)), StringMap.empty - | `Name var -> Utils.instantiate env var, StringMap.singleton var 1 - in - if Settings.get_value Instantiate.quantified_instantiation then - let tyvars = Types.quantifiers_of_type_args tyargs in - tabstr(tyvars, tappl (s', tyargs)), t, usages - else - tappl (s', tyargs), t, usages + | `Name var -> Utils.instantiate env var, StringMap.singleton var 1 + in + if Settings.get_value Instantiate.quantified_instantiation then + let tyvars = Types.quantifiers_of_type_args tyargs in + tabstr(tyvars, tappl (s', tyargs)), t, usages + else + tappl (s', tyargs), t, usages + | _ -> assert false let datatype aliases = Instantiate.typ -<- DesugarDatatypes.read ~aliases let add_usages (p, t) m = (p, t, m) @@ -1998,8 +1999,8 @@ let update_pattern_vars env = let rec extract_formlet_bindings : phrase -> Types.datatype Env.t = fun p -> match p.node with - | `FormBinding (_, pattern) -> pattern_env pattern - | `Xml (_, _, _, children) -> + | FormBinding (_, pattern) -> pattern_env pattern + | Xml (_, _, _, children) -> List.fold_right (fun child env -> Env.extend env (extract_formlet_bindings child)) @@ -2160,29 +2161,29 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let e, t, usages = match (expr : phrasenode) with - | `Var v -> + | Var v -> ( try let (tyargs, t) = Utils.instantiate context.var_env v in if Settings.get_value Instantiate.quantified_instantiation then let tyvars = Types.quantifiers_of_type_args tyargs in - tabstr(tyvars, tappl (`Var v, tyargs)), t, StringMap.singleton v 1 + tabstr(tyvars, tappl (Var v, tyargs)), t, StringMap.singleton v 1 else - tappl (`Var v, tyargs), t, StringMap.singleton v 1 + tappl (Var v, tyargs), t, StringMap.singleton v 1 with Errors.UndefinedVariable _msg -> Gripers.die pos ("Unknown variable " ^ v ^ ".") ) - | `Section _ as s -> type_section context s + | Section _ as s -> type_section context s (* literals *) - | `Constant c as c' -> c', Constant.constant_type c, StringMap.empty - | `TupleLit [p] -> + | Constant c as c' -> c', Constant.constant_type c, StringMap.empty + | TupleLit [p] -> let p = tc p in - `TupleLit [erase p], typ p, usages p (* When is a tuple not a tuple? *) - | `TupleLit ps -> + TupleLit [erase p], typ p, usages p (* When is a tuple not a tuple? *) + | TupleLit ps -> let ps = List.map tc ps in - `TupleLit (List.map erase ps), Types.make_tuple_type (List.map typ ps), merge_usages (List.map usages ps) - | `RecordLit (fields, rest) -> + TupleLit (List.map erase ps), Types.make_tuple_type (List.map typ ps), merge_usages (List.map usages ps) + | RecordLit (fields, rest) -> let _ = (* check that each label only occurs once *) List.fold_left @@ -2204,7 +2205,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = fields ([], StringMap.empty, StringMap.empty, StringMap.empty) in begin match rest with | None -> - `RecordLit (alistmap erase fields, None), `Record (field_env, Unionfind.fresh `Closed, false), field_usages + RecordLit (alistmap erase fields, None), `Record (field_env, Unionfind.fresh `Closed, false), field_usages | Some r -> let r : phrase * Types.datatype * usagemap = tc r in @@ -2252,19 +2253,19 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = StringMap.add label (`Present t) field_env' | `Var _ -> assert false) rfield_env field_env in let usages = merge_usages [field_usages; usages r] in - `RecordLit (alistmap erase fields, Some (erase r)), `Record (field_env', rrow_var, false), usages + RecordLit (alistmap erase fields, Some (erase r)), `Record (field_env', rrow_var, false), usages end - | `ListLit (es, _) -> + | ListLit (es, _) -> begin match List.map tc es with | [] -> let t = Types.fresh_type_variable (`Any, `Any) in - `ListLit ([], Some t), `Application (Types.list, [`Type t]), StringMap.empty + ListLit ([], Some t), `Application (Types.list, [`Type t]), StringMap.empty | e :: es -> List.iter (fun e' -> unify ~handle:Gripers.list_lit (pos_and_typ e, pos_and_typ e')) es; - `ListLit (List.map erase (e::es), Some (typ e)), `Application (Types.list, [`Type (typ e)]), merge_usages (List.map usages (e::es)) + ListLit (List.map erase (e::es), Some (typ e)), `Application (Types.list, [`Type (typ e)]), merge_usages (List.map usages (e::es)) end - | `HandlerLit _ -> assert false (* already desugared at this point *) - | `FunLit (_, lin, (pats, body), location) -> + | HandlerLit _ -> assert false (* already desugared at this point *) + | FunLit (_, lin, (pats, body), location) -> let vs = check_for_duplicate_names pos (List.flatten pats) in let pats = List.map (List.map tpc) pats in let pat_env = List.fold_left (List.fold_left (fun env pat' -> Env.extend env (pattern_env pat'))) Env.empty pats in @@ -2324,7 +2325,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = Needs more thought... *) - let e = `FunLit (Some argss, lin, (List.map (List.map erase_pat) pats, erase body), location) in + let e = FunLit (Some argss, lin, (List.map (List.map erase_pat) pats, erase body), location) in if Settings.get_value Instantiate.quantified_instantiation then let (qs, _tyargs), ftype = Utils.generalise context.var_env ftype in let _, ftype = Instantiate.typ ftype in @@ -2332,59 +2333,59 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = else e, ftype, StringMap.filter (fun v _ -> not (List.mem v vs)) (usages body) - | `ConstructorLit (c, None, _) -> + | ConstructorLit (c, None, _) -> let type' = `Variant (Types.make_singleton_open_row (c, `Present Types.unit_type) (`Any, `Any)) in - `ConstructorLit (c, None, Some type'), type', StringMap.empty + ConstructorLit (c, None, Some type'), type', StringMap.empty - | `ConstructorLit (c, Some v, _) -> + | ConstructorLit (c, Some v, _) -> let v = tc v in let type' = `Variant (Types.make_singleton_open_row (c, `Present (typ v)) (`Any, `Any)) in - `ConstructorLit (c, Some (erase v), Some type'), type', usages v + ConstructorLit (c, Some (erase v), Some type'), type', usages v (* database *) - | `DatabaseLit (name, (driver, args)) -> + | DatabaseLit (name, (driver, args)) -> let driver = opt_map tc driver and args = opt_map tc args and name = tc name in - `DatabaseLit (erase name, (opt_map erase driver, opt_map erase args)), `Primitive `DB, + DatabaseLit (erase name, (opt_map erase driver, opt_map erase args)), `Primitive `DB, merge_usages [from_option StringMap.empty (opt_map usages driver); from_option StringMap.empty (opt_map usages args); usages name] - | `TableLit (tname, (dtype, Some (read_row, write_row, needed_row)), constraints, keys, db) -> + | TableLit (tname, (dtype, Some (read_row, write_row, needed_row)), constraints, keys, db) -> let tname = tc tname and db = tc db and keys = tc keys in let () = unify ~handle:Gripers.table_name (pos_and_typ tname, no_pos Types.string_type) and () = unify ~handle:Gripers.table_db (pos_and_typ db, no_pos Types.database_type) and () = unify ~handle:Gripers.table_keys (pos_and_typ keys, no_pos Types.keys_type) in - `TableLit (erase tname, (dtype, Some (read_row, write_row, needed_row)), constraints, erase keys, erase db), + TableLit (erase tname, (dtype, Some (read_row, write_row, needed_row)), constraints, erase keys, erase db), `Table (read_row, write_row, needed_row), merge_usages [usages tname; usages db] - | `TableLit _ -> assert false - | `LensLit (table, _) -> + | TableLit _ -> assert false + | LensLit (table, _) -> let open Lens in let table = tc table in let cols = Types.sort_cols_of_table "" (typ table) in let lens_sort = Sort.make cols in - `LensLit (erase table, Some (lens_sort)), `Lens (lens_sort), merge_usages [usages table] - | `LensKeysLit (table, keys, _) -> + LensLit (erase table, Some (lens_sort)), `Lens (lens_sort), merge_usages [usages table] + | LensKeysLit (table, keys, _) -> let open Lens in let table = tc table in let cols = Types.sort_cols_of_table "" (typ table) in let keys = Types.cols_of_phrase keys in let fds = Fun_dep.Set.key_fds ~keys ~cols:(Column.List.present_aliases cols) in let lens_sort = Sort.make ~fds cols in - `LensLit (erase table, Some (lens_sort)), `Lens (lens_sort), merge_usages [usages table] - | `LensFunDepsLit (table, fds, _) -> + LensLit (erase table, Some (lens_sort)), `Lens (lens_sort), merge_usages [usages table] + | LensFunDepsLit (table, fds, _) -> let open Lens in let table = tc table in let cols = Types.sort_cols_of_table "" (typ table) in let fds = Helpers.Incremental.get_fds fds cols in let lens_sort = Sort.make ~fds cols in - `LensLit (erase table, Some (lens_sort)), `Lens (lens_sort), merge_usages [usages table] - | `LensDropLit (lens, drop, key, default, _) -> + LensLit (erase table, Some (lens_sort)), `Lens (lens_sort), merge_usages [usages table] + | LensDropLit (lens, drop, key, default, _) -> let open Lens in let lens = tc lens and default = tc default in @@ -2394,12 +2395,12 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (Alias.Set.singleton drop) (Alias.Set.singleton key) in - `LensDropLit (erase lens, drop, key, erase default, Some (sort)), `Lens (sort), merge_usages [usages lens; usages default] - | `LensSelectLit (lens, predicate, _) -> + LensDropLit (erase lens, drop, key, erase default, Some (sort)), `Lens (sort), merge_usages [usages lens; usages default] + | LensSelectLit (lens, predicate, _) -> let lens = tc lens in let lens_sort = Lens.Type.sort (typ lens) in - `LensSelectLit(erase lens, predicate, Some (lens_sort)), `Lens(lens_sort), merge_usages [usages lens] - | `LensJoinLit (lens1, lens2, on, left, right, _) -> + LensSelectLit(erase lens, predicate, Some (lens_sort)), `Lens(lens_sort), merge_usages [usages lens] + | LensJoinLit (lens1, lens2, on, left, right, _) -> let lens1 = tc lens1 and lens2 = tc lens2 in let sort1 = Lens.Type.sort (typ lens1) in @@ -2410,20 +2411,20 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = sort2 ~on:(Lens.Types.cols_of_phrase on) in - `LensJoinLit (erase lens1, erase lens2, on, left, right, Some sort), `Lens(sort), merge_usages [usages lens1; usages lens2] - | `LensGetLit (lens, _) -> + LensJoinLit (erase lens1, erase lens2, on, left, right, Some sort), `Lens(sort), merge_usages [usages lens1; usages lens2] + | LensGetLit (lens, _) -> let lens = tc lens in let sort = Lens.Type.sort (typ lens) in let trowtype = Lens.Sort.record_type sort in - `LensGetLit (erase lens, Some trowtype), Types.make_list_type trowtype, merge_usages [usages lens] - | `LensPutLit (lens, data, _) -> + LensGetLit (erase lens, Some trowtype), Types.make_list_type trowtype, merge_usages [usages lens] + | LensPutLit (lens, data, _) -> let make_tuple_type = Types.make_tuple_type in let lens = tc lens in let sort = Lens.Type.sort (typ lens) in let trowtype = Lens.Sort.record_type sort in let data = tc data in - `LensPutLit (erase lens, erase data, Some trowtype), make_tuple_type [], merge_usages [usages lens; usages data] - | `DBDelete (pat, from, where) -> + LensPutLit (erase lens, erase data, Some trowtype), make_tuple_type [], merge_usages [usages lens; usages data] + | DBDelete (pat, from, where) -> let pat = tpc pat in let from = tc from in let read = `Record (Types.make_empty_open_row (`Any, `Base)) in @@ -2453,9 +2454,9 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = unify ~handle:Gripers.delete_outer (no_pos (`Record context.effect_row), no_pos (`Record outer_effects)) in - `DBDelete (erase_pat pat, erase from, opt_map erase where), Types.unit_type, + DBDelete (erase_pat pat, erase from, opt_map erase where), Types.unit_type, merge_usages [usages from; hide (from_option StringMap.empty (opt_map usages where))] - | `DBInsert (into, labels, values, id) -> + | DBInsert (into, labels, values, id) -> let into = tc into in let values = tc values in let id = opt_map tc id in @@ -2504,7 +2505,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = | Some ({node=(id : phrasenode); _}, _, _) -> begin match id with - | `Constant (`String id) -> + | Constant (`String id) -> (* HACK: The returned column is encoded as a string. We check here that it appears as a column in the read type of @@ -2526,9 +2527,9 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = unify ~handle:Gripers.insert_outer (no_pos (`Record context.effect_row), no_pos (`Record outer_effects)) in - `DBInsert (erase into, labels, erase values, opt_map erase id), return_type, + DBInsert (erase into, labels, erase values, opt_map erase id), return_type, merge_usages [usages into; usages values; from_option StringMap.empty (opt_map usages id)] - | `DBUpdate (pat, from, where, set) -> + | DBUpdate (pat, from, where, set) -> let pat = tpc pat in let from = tc from in let read = `Record (Types.make_empty_open_row (`Any, `Base)) in @@ -2589,10 +2590,10 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = unify ~handle:Gripers.update_outer (no_pos (`Record context.effect_row), no_pos (`Record outer_effects)) in - `DBUpdate (erase_pat pat, erase from, opt_map erase where, List.map (fun (n,(p,_,_)) -> n, p) set), + DBUpdate (erase_pat pat, erase from, opt_map erase where, List.map (fun (n,(p,_,_)) -> n, p) set), Types.unit_type, merge_usages (usages from :: hide (from_option StringMap.empty (opt_map usages where)) :: List.map hide (List.map (usages -<- snd) set)) - | `Query (range, p, _) -> + | Query (range, p, _) -> let range, outer_effects, range_usages = match range with | None -> None, Types.make_empty_open_row (`Any, `Any), StringMap.empty @@ -2612,9 +2613,9 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let () = if Settings.get_value Basicsettings.Shredding.relax_query_type_constraint then () else let shape = Types.make_list_type (`Record (StringMap.empty, Types.fresh_row_variable (`Any, `Base), false)) in unify ~handle:Gripers.query_base_row (pos_and_typ p, no_pos shape) in - `Query (range, erase p, Some (typ p)), typ p, merge_usages [range_usages; usages p] + Query (range, erase p, Some (typ p)), typ p, merge_usages [range_usages; usages p] (* mailbox-based concurrency *) - | `Spawn (Wait, l, p, _) -> + | Spawn (Wait, l, p, _) -> assert (l = NoSpawnLocation); (* (() -{b}-> d) -> d *) let inner_effects = Types.make_empty_open_row (`Any, `Any) in @@ -2628,8 +2629,8 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (no_pos (`Record context.effect_row), no_pos (`Record outer_effects)) in let p = type_check (bind_effects context inner_effects) p in let return_type = typ p in - `Spawn (Wait, l, erase p, Some inner_effects), return_type, usages p - | `Spawn (k, given_loc, p, _) -> + Spawn (Wait, l, erase p, Some inner_effects), return_type, usages p + | Spawn (k, given_loc, p, _) -> (* Location -> (() -e-> _) -> Process (e) *) (match given_loc with | ExplicitSpawnLocation loc_phr -> @@ -2650,8 +2651,8 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let p = type_check (bind_effects context inner_effects) p in if not (Types.type_can_be_unl (typ p)) then Gripers.die pos ("Spawned processes cannot produce values of linear type (here " ^ Types.string_of_datatype (typ p) ^ ")"); - `Spawn (k, given_loc, erase p, Some inner_effects), pid_type, usages p - | `Receive (binders, _) -> + Spawn (k, given_loc, erase p, Some inner_effects), pid_type, usages p + | Receive (binders, _) -> let mb_type = Types.fresh_type_variable (`Any, `Any) in let effects = Types.row_with ("wild", `Present Types.unit_type) @@ -2664,7 +2665,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let () = unify ~handle:Gripers.receive_patterns (no_pos mb_type, no_pos pattern_type) in - `Receive (erase_cases binders, Some body_type), body_type, usages_cases binders + Receive (erase_cases binders, Some body_type), body_type, usages_cases binders (* session-based concurrency *) (* | `Link (l, r) -> *) @@ -2677,37 +2678,37 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (* unify ~handle:Gripers.cp_link_dual *) (* ((exp_pos l, Types.dual_type (typ l)), pos_and_typ r); *) (* `Link (erase l, erase r), Types.unit_type, merge_usages [usages l; usages r] *) - | `Select (l, e) -> + | Select (l, e) -> let e = tc e in let selected_session = Types.fresh_type_variable (`Any, `Session) in unify ~handle:Gripers.selection (pos_and_typ e, no_pos (`Select (Types.make_singleton_open_row (l, `Present selected_session) (`Any, `Session)))); - `Select (l, erase e), selected_session, usages e - | `Offer (e, branches, _) -> + Select (l, erase e), selected_session, usages e + | Offer (e, branches, _) -> let e = tc e in let branches, pattern_type, body_type = type_cases branches in let r = Types.make_empty_open_row (`Any, `Session) in unify ~handle:Gripers.offer_variant (no_pos pattern_type, no_pos (`Variant r)); unify ~handle:Gripers.offer_patterns (pos_and_typ e, no_pos (`Choice r)); - `Offer (erase e, erase_cases branches, Some body_type), body_type, merge_usages [usages e; usages_cases branches] + Offer (erase e, erase_cases branches, Some body_type), body_type, merge_usages [usages e; usages_cases branches] (* No comment *) - | `CP p -> + | CP p -> let (p, t, u) = type_cp context p in - `CP p, t, u + CP p, t, u (* applications of various sorts *) - | `UnaryAppl ((_, op), p) -> + | UnaryAppl ((_, op), p) -> let tyargs, opt, op_usage = type_unary_op context op and p = tc p and rettyp = Types.fresh_type_variable (`Any, `Any) in unify ~handle:Gripers.unary_apply ((string_of_unary_op op, opt), no_pos (`Function (Types.make_tuple_type [typ p], context.effect_row, rettyp))); - `UnaryAppl ((tyargs, op), erase p), rettyp, merge_usages [usages p; op_usage] - | `InfixAppl ((_, op), l, r) -> + UnaryAppl ((tyargs, op), erase p), rettyp, merge_usages [usages p; op_usage] + | InfixAppl ((_, op), l, r) -> let tyargs, opt, op_usages = type_binary_op context op in let l = tc l and r = tc r @@ -2716,17 +2717,17 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = ((string_of_binop op, opt), no_pos (`Function (Types.make_tuple_type [typ l; typ r], context.effect_row, rettyp))); - `InfixAppl ((tyargs, op), erase l, erase r), rettyp, merge_usages [usages l; usages r; op_usages] - | `RangeLit (l, r) -> + InfixAppl ((tyargs, op), erase l, erase r), rettyp, merge_usages [usages l; usages r; op_usages] + | RangeLit (l, r) -> let l, r = tc l, tc r in let () = unify ~handle:Gripers.range_bound (pos_and_typ l, no_pos Types.int_type) and () = unify ~handle:Gripers.range_bound (pos_and_typ r, no_pos Types.int_type) - in `RangeLit (erase l, erase r), + in RangeLit (erase l, erase r), Types.make_list_type Types.int_type, merge_usages [usages l; usages r] - | `FnAppl (f, ps) -> + | FnAppl (f, ps) -> let f = tc f in let ps = List.map (tc) ps in @@ -2801,7 +2802,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let ft = `Function (fps, fe, rettyp) in let f' = erase f in let fn, fpos = f'.node, f'.pos in - let e = tabstr (rqs, `FnAppl (with_pos fpos (tappl (fn, tyargs)), List.map erase ps)) in + let e = tabstr (rqs, FnAppl (with_pos fpos (tappl (fn, tyargs)), List.map erase ps)) in unify ~handle:Gripers.fun_apply ((exp_pos f, ft), no_pos (`Function (Types.make_tuple_type (List.map typ ps), context.effect_row, @@ -2812,7 +2813,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let ft = `Function (fps, fe, rettyp) in let f' = erase f in let fn, fpos = f'.node, f'.pos in - let e = tabstr (rqs, `FnAppl (with_pos fpos (tappl (fn, tyargs)), List.map erase ps)) in + let e = tabstr (rqs, FnAppl (with_pos fpos (tappl (fn, tyargs)), List.map erase ps)) in unify ~handle:Gripers.fun_apply ((exp_pos f, ft), no_pos (`Lolli (Types.make_tuple_type (List.map typ ps), context.effect_row, @@ -2831,18 +2832,18 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = ((exp_pos f, ft), no_pos (`Lolli (Types.make_tuple_type (List.map typ ps), context.effect_row, rettyp))) end; - `FnAppl (erase f, List.map erase ps), rettyp, merge_usages (usages f :: List.map usages ps) + FnAppl (erase f, List.map erase ps), rettyp, merge_usages (usages f :: List.map usages ps) end - | `TAbstr (qs, e) -> + | TAbstr (qs, e) -> let e, t, u = tc e in let qs = Types.unbox_quantifiers qs in let t = Types.for_all(qs, t) in tabstr (qs, e.node), t, u - | `TAppl (e, _qs) -> + | TAppl (e, _qs) -> let e, t, u = tc e in e.node, t, u (* xml *) - | `Xml (tag, attrs, attrexp, children) -> + | Xml (tag, attrs, attrexp, children) -> let attrs = alistmap (List.map (tc)) attrs and attrexp = opt_map tc attrexp and children = List.map (tc) children in @@ -2859,30 +2860,30 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = and () = List.iter (fun child -> unify ~handle:Gripers.xml_child (pos_and_typ child, no_pos Types.xml_type)) children in - `Xml (tag, - List.map (fun (x,p) -> (x, List.map erase p)) attrs, - opt_map erase attrexp, - List.map erase children), + Xml (tag, + List.map (fun (x,p) -> (x, List.map erase p)) attrs, + opt_map erase attrexp, + List.map erase children), Types.xml_type, merge_usages (List.concat [ List.concat (List.map snd (alistmap (List.map usages) attrs)); [from_option StringMap.empty (opt_map usages attrexp)]; List.map usages children ]) - | `TextNode _ as t -> t, Types.xml_type, StringMap.empty - | `Formlet (body, yields) -> + | TextNode _ as t -> t, Types.xml_type, StringMap.empty + | Formlet (body, yields) -> let body = tc body in let env = extract_formlet_bindings (erase body) in let vs = Env.domain env in let context' = context ++ env in 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), + (Formlet (erase body, erase yields), Instantiate.alias "Formlet" [`Type (typ yields)] context.tycon_env, merge_usages [usages body; StringMap.filter (fun v _ -> not (StringSet.mem v vs)) (usages yields)]) - | `Page e -> + | 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 - | `FormletPlacement (f, h, attributes) -> + Page (erase e), Instantiate.alias "Page" [] context.tycon_env, usages e + | FormletPlacement (f, h, attributes) -> let t = Types.fresh_type_variable (`Any, `Any) in let f = tc f @@ -2896,23 +2897,23 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let () = unify ~handle:Gripers.render_attributes (pos_and_typ attributes, no_pos (Instantiate.alias "Attributes" [] context.tycon_env)) in - `FormletPlacement (erase f, erase h, erase attributes), Types.xml_type, merge_usages [usages f; usages h; usages attributes] - | `PagePlacement e -> + FormletPlacement (erase f, erase h, erase attributes), Types.xml_type, merge_usages [usages f; usages h; usages attributes] + | PagePlacement e -> let e = tc e 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) -> + 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 (`Any, `Any) in let ft = Instantiate.alias "Formlet" [`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 + FormBinding (erase e, erase_pat pattern), Types.xml_type, usages e (* various expressions *) - | `Iteration (generators, body, where, orderby) -> + | Iteration (generators, body, where, orderby) -> let is_query = List.exists (function | List _ -> false @@ -2970,16 +2971,16 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = if is_query && not (Settings.get_value Basicsettings.Shredding.relax_query_type_constraint) then unify ~handle:Gripers.iteration_base_body (pos_and_typ body, no_pos (Types.make_list_type (`Record (Types.make_empty_open_row (`Any, `Base))))) in - let e = `Iteration (generators, erase body, opt_map erase where, opt_map erase orderby) in + let e = Iteration (generators, erase body, opt_map erase where, opt_map erase orderby) in let vs = List.fold_left StringSet.union StringSet.empty (List.map Env.domain environments) in let us = merge_usages (List.append generator_usages (List.map (StringMap.filter (fun v _ -> not (StringSet.mem v vs))) [usages body; from_option StringMap.empty (opt_map usages where); from_option StringMap.empty (opt_map usages orderby)])) in if is_query then - `Query (None, with_pos pos e, Some (typ body)), typ body, us + Query (None, with_pos pos e, Some (typ body)), typ body, us else e, typ body, us - | `Escape (bndr, e) -> + | Escape (bndr, e) -> (* There's a question here whether to generalise the return type of continuations. With `escape' continuations are let-bound, so generalising the return @@ -3021,8 +3022,8 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (no_pos (`Record context.effect_row), no_pos (`Record outer_effects)) in let () = unify ~handle:Gripers.escape (pos_and_typ e, no_pos f) in - `Escape (set_binder_type bndr cont_type, erase e), typ e, StringMap.filter (fun v _ -> v <> name) (usages e) - | `Conditional (i,t,e) -> + Escape (set_binder_type bndr cont_type, erase e), typ e, StringMap.filter (fun v _ -> v <> name) (usages e) + | Conditional (i,t,e) -> let i = tc i and t = tc t and e = tc e in @@ -3030,16 +3031,16 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (pos_and_typ i, no_pos (`Primitive `Bool)); unify ~handle:Gripers.if_branches (pos_and_typ t, pos_and_typ e); - `Conditional (erase i, erase t, erase e), (typ t), merge_usages [usages i; usage_compat [usages t; usages e]] - | `Block (bindings, e) -> + Conditional (erase i, erase t, erase e), (typ t), merge_usages [usages i; usage_compat [usages t; usages e]] + | Block (bindings, e) -> let context', bindings, usage_builder = type_bindings context bindings in let e = type_check (Types.extend_typing_environment context context') e in - `Block (bindings, erase e), typ e, usage_builder (usages e) - | `Regex r -> - `Regex (type_regex context r), + Block (bindings, erase e), typ e, usage_builder (usages e) + | Regex r -> + Regex (type_regex context r), Instantiate.alias "Regex" [] context.tycon_env, StringMap.empty - | `Projection (r,l) -> + | Projection (r,l) -> (* Take advantage of the type isomorphism: @@ -3106,7 +3107,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (l, `Present (Types.fresh_type_variable (`Any, `Any)))))); let r' = erase r in let rn, rpos = r'.node, r'.pos in - let e = tabstr (pqs, `Projection (with_pos rpos (tappl (rn, tyargs)), l)) in + let e = tabstr (pqs, Projection (with_pos rpos (tappl (rn, tyargs)), l)) in e, fieldtype, usages r | Some (`Absent | `Var _) | None -> @@ -3118,7 +3119,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (`Unl, `Any)))); let r' = erase r in let rn, rpos = r'.node, r'.pos in - let e = `Projection (with_pos rpos (tappl (rn, tyargs)), l) in + let e = Projection (with_pos rpos (tappl (rn, tyargs)), l) in e, fieldtype, usages r end | _ -> @@ -3127,9 +3128,9 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (pos_and_typ r, no_pos (`Record (Types.make_singleton_open_row (l, `Present fieldtype) (`Unl, `Any)))); - `Projection (erase r, l), fieldtype, usages r + Projection (erase r, l), fieldtype, usages r end - | `With (r, fields) -> + | With (r, fields) -> let r = tc r in let fields = alistmap tc fields in @@ -3150,23 +3151,23 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = else t) rfields in - `With (erase r, alistmap erase fields), `Record (rfields, row_var, false), merge_usages (usages r :: List.map usages (range fields)) - | `TypeAnnotation (e, (_, Some t as dt)) -> + With (erase r, alistmap erase fields), `Record (rfields, row_var, false), merge_usages (usages r :: List.map usages (range fields)) + | TypeAnnotation (e, (_, Some t as dt)) -> let e = tc e in unify ~handle:Gripers.type_annotation (pos_and_typ e, no_pos t); - `TypeAnnotation (erase e, dt), t, usages e - | `TypeAnnotation _ -> assert false - | `Upcast (e, (_, Some t1 as t1'), (_, Some t2 as t2')) -> + TypeAnnotation (erase e, dt), t, usages e + | TypeAnnotation _ -> assert false + | Upcast (e, (_, Some t1 as t1'), (_, Some t2 as t2')) -> let e = tc e in if Types.is_sub_type (t2, t1) then begin unify ~handle:Gripers.upcast_source (pos_and_typ e, no_pos t2); - `Upcast (erase e, t1', t2'), t1, usages e + Upcast (erase e, t1', t2'), t1, usages e end else Gripers.upcast_subtype pos t2 t1 - | `Upcast _ -> assert false - | `Handle { sh_expr = m; sh_value_cases = val_cases; sh_effect_cases = eff_cases; sh_descr = descr; } -> + | Upcast _ -> assert false + | Handle { sh_expr = m; sh_value_cases = val_cases; sh_effect_cases = eff_cases; sh_descr = descr; } -> let rec pop_last = function | [] -> assert false | [x] -> x, [] @@ -3456,11 +3457,11 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = shd_types = (Types.flatten_row inner_eff, typ m, Types.flatten_row outer_eff, body_type); shd_raw_row = Types.make_empty_closed_row (); } in - `Handle { sh_expr = erase m; - sh_effect_cases = erase_cases eff_cases; - sh_value_cases = erase_cases val_cases; - sh_descr = descr }, body_type, merge_usages [usage_compat (List.map (fun ((_, _, m),_) -> m) params); usages m; usages_cases eff_cases; usages_cases val_cases] - | `DoOperation (opname, args, _) -> + Handle { sh_expr = erase m; + sh_effect_cases = erase_cases eff_cases; + sh_value_cases = erase_cases val_cases; + sh_descr = descr }, body_type, merge_usages [usage_compat (List.map (fun ((_, _, m),_) -> m) params); usages m; usages_cases eff_cases; usages_cases val_cases] + | DoOperation (opname, args, _) -> (* Strategy: 1. List.map tc args 2. Construct operation type @@ -3482,13 +3483,13 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let () = unify ~handle:Gripers.do_operation (no_pos (`Effect context.effect_row), (p, `Effect row)) in - (`DoOperation (opname, List.map erase args, Some return_type), return_type, StringMap.empty) - | `Switch (e, binders, _) -> + (DoOperation (opname, List.map erase args, Some return_type), return_type, StringMap.empty) + | Switch (e, binders, _) -> let e = tc e in let binders, pattern_type, body_type = type_cases binders in let () = unify ~handle:Gripers.switch_pattern (pos_and_typ e, no_pos pattern_type) in - `Switch (erase e, erase_cases binders, Some body_type), body_type, merge_usages [usages e; usages_cases binders] - | `TryInOtherwise (try_phrase, pat, in_phrase, unless_phrase, _) -> + Switch (erase e, erase_cases binders, Some body_type), body_type, merge_usages [usages e; usages_cases binders] + | TryInOtherwise (try_phrase, pat, in_phrase, unless_phrase, _) -> let try_phrase = tc try_phrase in (* Pattern.with_posype variable *) @@ -3554,11 +3555,11 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let return_type = typ in_phrase in - `TryInOtherwise + TryInOtherwise (erase try_phrase, erase_pat pat, erase in_phrase, erase unless_phrase, Some return_type), return_type, usages_res - | `QualifiedVar _ -> assert false - | `Raise -> (`Raise, Types.fresh_type_variable (`Any, `Any), StringMap.empty) + | QualifiedVar _ -> assert false + | Raise -> (Raise, Types.fresh_type_variable (`Any, `Any), StringMap.empty) in with_pos pos e, t, usages (** [type_binding] takes XXX YYY (FIXME) @@ -3944,14 +3945,14 @@ and type_cp (context : context) = fun {node = p; pos} -> unify ~pos:pos ~handle:Gripers.cp_unquote (t, Types.make_endbang_type); CPUnquote (bindings, e), t, usage_builder u | CPGrab ((c, _), None, p) -> - let (_, t, _) = type_check context (with_pos pos (`Var c)) in + let (_, t, _) = type_check context (with_pos pos (Sugartypes.Var c)) in let ctype = `Alias (("EndQuery", []), `Input (Types.unit_type, `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 | CPGrab ((c, _), Some bndr, p) -> let x = name_of_binder bndr in - let (_, t, _) = type_check context (with_pos pos (`Var c)) in + let (_, t, _) = type_check context (with_pos pos (Sugartypes.Var c)) in let a = Types.fresh_type_variable (`Any, `Any) in let s = Types.fresh_session_variable `Any in let ctype = `Input (a, s) in @@ -3964,7 +3965,7 @@ and type_cp (context : context) = fun {node = p; pos} -> Types.make_type_unl a else Gripers.non_linearity pos uses x a; - let (_, grab_ty, _) = type_check context (with_pos pos (`Var "receive")) in + let (_, grab_ty, _) = type_check context (with_pos pos (Sugartypes.Var "receive")) in let tyargs = match Types.concrete_type grab_ty with | `ForAll (qs, _t) -> @@ -3980,13 +3981,13 @@ and type_cp (context : context) = fun {node = p; pos} -> | _ -> assert false in CPGrab ((c, Some (ctype, tyargs)), Some (set_binder_type bndr a), p), pt, use c (StringMap.remove x u) | CPGive ((c, _), None, p) -> - let (_, t, _) = type_check context (with_pos pos (`Var c)) in + let (_, t, _) = type_check context (with_pos pos (Sugartypes.Var c)) in let ctype = `Output (Types.unit_type, `End) in unify ~pos:pos ~handle:(Gripers.cp_give c) (t, ctype); let (p, t, u) = type_cp (unbind_var context c) p in CPGive ((c, Some (ctype, [])), None, p), t, use c u | CPGive ((c, _), Some e, p) -> - let (_, t, _) = type_check context (with_pos pos (`Var c)) in + let (_, t, _) = type_check context (with_pos pos (Sugartypes.Var c)) in let (e, t', u) = type_check context e in let s = Types.fresh_session_variable `Any in let ctype = `Output (t', s) in @@ -3994,7 +3995,7 @@ and type_cp (context : context) = fun {node = p; pos} -> (t, ctype); let (p, t, u') = with_channel c s (type_cp (bind_var context (c, s)) p) in - let (_, give_ty, _) = type_check context (with_pos pos (`Var "send")) in + let (_, give_ty, _) = type_check context (with_pos pos (Sugartypes.Var "send")) in let tyargs = match Types.concrete_type give_ty with | `ForAll (qs, _t) -> @@ -4012,12 +4013,12 @@ and type_cp (context : context) = fun {node = p; pos} -> | CPGiveNothing bndr -> let c = name_of_binder bndr in let binder_pos = bndr.pos in - let _, t, _ = type_check context (with_pos binder_pos (`Var c)) in + let _, t, _ = type_check context (with_pos binder_pos (Sugartypes.Var c)) in unify ~pos:pos ~handle:Gripers.(cp_give c) (t, Types.make_endbang_type); CPGiveNothing (set_binder_type bndr t), t, StringMap.singleton c 1 | CPSelect (bndr, label, p) -> let c = name_of_binder bndr in - let (_, t, _) = type_check context (with_pos pos (`Var c)) in + let (_, t, _) = type_check context (with_pos pos (Sugartypes.Var c)) in let s = Types.fresh_session_variable `Any in let r = Types.make_singleton_open_row (label, `Present s) (`Any, `Session) in let ctype = `Select r in @@ -4027,7 +4028,7 @@ and type_cp (context : context) = fun {node = p; pos} -> CPSelect (set_binder_type bndr ctype, label, p), t, use c u | CPOffer (bndr, branches) -> let c = name_of_binder bndr in - let (_, t, _) = type_check context (with_pos pos (`Var c)) in + let (_, t, _) = type_check context (with_pos pos (Sugartypes.Var c)) in (* let crow = Types.make_empty_open_row (`Any, `Session) in let ctype = `Choice crow in @@ -4048,8 +4049,8 @@ and type_cp (context : context) = fun {node = p; pos} -> | CPLink (bndr1, bndr2) -> let c = name_of_binder bndr1 in let d = name_of_binder bndr2 in - let (_, tc, uc) = type_check context (with_pos pos (`Var c)) in - let (_, td, ud) = type_check context (with_pos pos (`Var d)) in + let (_, tc, uc) = type_check context (with_pos pos (Sugartypes.Var c)) in + let (_, td, ud) = type_check context (with_pos pos (Sugartypes.Var d)) in unify ~pos:pos ~handle:Gripers.cp_link_session (tc, Types.fresh_type_variable (`Any, `Session)); unify ~pos:pos ~handle:Gripers.cp_link_session From f9d483cc7cfd2784453e0d5dcaf98c3e2febd657 Mon Sep 17 00:00:00 2001 From: Jan Stolarek Date: Wed, 20 Feb 2019 13:32:03 +0000 Subject: [PATCH 08/28] Redefine replace_rhs as a variant --- core/desugarRegexes.ml | 4 ++-- core/parser.mly | 6 +++--- core/sugarTraversals.ml | 12 ++++++------ core/sugartypes.ml | 11 +++++------ core/transformSugar.ml | 8 ++++---- core/typeSugar.ml | 8 ++++---- 6 files changed, 24 insertions(+), 25 deletions(-) diff --git a/core/desugarRegexes.ml b/core/desugarRegexes.ml index edb33ca9f..aa2e63641 100644 --- a/core/desugarRegexes.ml +++ b/core/desugarRegexes.ml @@ -55,9 +55,9 @@ let desugar_regex phrase regex_type regex : phrase = constructor' repeat_str ~body:(tuple [desugar_repeat rep; aux r]) | Splice e -> constructor' quote_str ~body:(constructor' ~body:(expr e) simply_str) - | Replace (re, (`Literal tmpl)) -> + | Replace (re, (Literal tmpl)) -> constructor' replace_str ~body:(tuple [aux re; constant_str tmpl]) - | Replace (re, (`Splice e)) -> + | Replace (re, (SpliceExpr e)) -> constructor' replace_str ~body:(tuple [aux re; expr e]) in block (List.map (fun (v, e1, t) -> val_binding (variable_pat ~ty:t v) e1) !exprs, diff --git a/core/parser.mly b/core/parser.mly index 022407a0c..428792cee 100644 --- a/core/parser.mly +++ b/core/parser.mly @@ -1110,9 +1110,9 @@ regex_flags_opt: | SLASHFLAGS { parseRegexFlags $1 } regex_replace: -| /* empty */ { `Literal "" } -| REGEXREPL { `Literal $1 } -| block { `Splice $1 } +| /* empty */ { Literal "" } +| REGEXREPL { Literal $1 } +| block { SpliceExpr $1 } regex_pattern: | RANGE { Range $1 } diff --git a/core/sugarTraversals.ml b/core/sugarTraversals.ml index b6504a4e5..cc25fdeac 100644 --- a/core/sugarTraversals.ml +++ b/core/sugarTraversals.ml @@ -105,8 +105,8 @@ class map = method replace_rhs : replace_rhs -> replace_rhs = function - | `Literal _x -> let _x = o#string _x in `Literal _x - | `Splice _x -> let _x = o#phrase _x in `Splice _x + | Literal _x -> let _x = o#string _x in Literal _x + | SpliceExpr _x -> let _x = o#phrase _x in SpliceExpr _x method regexflag : regexflag -> regexflag = fun flag -> flag @@ -818,8 +818,8 @@ class fold = method replace_rhs : replace_rhs -> 'self_type = function - | `Literal _x -> let o = o#string _x in o - | `Splice _x -> let o = o#phrase _x in o + | Literal _x -> let o = o#string _x in o + | SpliceExpr _x -> let o = o#phrase _x in o method regexflag : regexflag -> 'self_type = fun _ -> o @@ -1487,8 +1487,8 @@ class fold_map = method replace_rhs : replace_rhs -> ('self_type * replace_rhs) = function - | `Literal _x -> let (o, _x) = o#string _x in (o, (`Literal _x)) - | `Splice _x -> let (o, _x) = o#phrase _x in (o, (`Splice _x)) + | Literal _x -> let (o, _x) = o#string _x in (o, (Literal _x)) + | SpliceExpr _x -> let (o, _x) = o#phrase _x in (o, (SpliceExpr _x)) method regexflag : regexflag -> ('self_type * regexflag) = fun flag -> (o, flag) diff --git a/core/sugartypes.ml b/core/sugartypes.ml index fae7efd43..a7e16470d 100644 --- a/core/sugartypes.ml +++ b/core/sugartypes.ml @@ -217,10 +217,9 @@ type fn_dep = string * string type handler_depth = Deep | Shallow [@@deriving show] -type replace_rhs = [ -| `Literal of string -| `Splice of phrase -] +type replace_rhs = +| Literal of string +| SpliceExpr of phrase and given_spawn_location = | ExplicitSpawnLocation of phrase (* spawnAt function *) | SpawnClient (* spawnClient function *) @@ -579,8 +578,8 @@ struct | Group r | Repeat (_, r) -> regex r | Splice p -> phrase p - | Replace (r, `Literal _) -> regex r - | Replace (r, `Splice p) -> union (regex r) (phrase p) + | Replace (r, Literal _) -> regex r + | Replace (r, SpliceExpr p) -> union (regex r) (phrase p) and cp_phrase {node = p; _ } = match p with | CPUnquote e -> block e | CPGrab ((c, _t), Some bndr, p) -> diff --git a/core/transformSugar.ml b/core/transformSugar.ml index c359a0353..d70a3e68c 100644 --- a/core/transformSugar.ml +++ b/core/transformSugar.ml @@ -204,13 +204,13 @@ class transform (env : Types.typing_environment) = | Repeat (repeat, r) -> let (o, r) = o#regex r in (o, Repeat (repeat, r)) | Splice e -> let (o, e, _) = o#phrase e in (o, Splice e) - | Replace (r, `Literal s) -> + | Replace (r, Literal s) -> let (o, r) = o#regex r in - (o, Replace (r, `Literal s)) - | Replace (r, `Splice e) -> + (o, Replace (r, Literal s)) + | Replace (r, SpliceExpr e) -> let (o, r) = o#regex r in let (o, e, _) = o#phrase e in - (o, Replace (r, `Splice e)) + (o, Replace (r, SpliceExpr e)) method program : program -> ('self_type * program * Types.datatype option) = fun (bs, e) -> diff --git a/core/typeSugar.ml b/core/typeSugar.ml index 3513c1fea..416d9df0c 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -151,8 +151,8 @@ struct | Seq rs -> List.for_all is_pure_regex rs | Alternate (r1, r2) -> is_pure_regex r1 && is_pure_regex r2 | Splice p -> is_pure p - | Replace (r, `Literal _) -> is_pure_regex r - | Replace (r, `Splice p) -> is_pure_regex r && is_pure p + | Replace (r, Literal _) -> is_pure_regex r + | Replace (r, SpliceExpr p) -> is_pure_regex r && is_pure p let is_generalisable = is_pure end @@ -3898,8 +3898,8 @@ and type_regex typing_env : regex -> regex = let () = unify_or_raise ~pos:pos ~handle:Gripers.splice_exp (no_pos (typ e), no_pos Types.string_type) in Splice (erase e) - | Replace (r, `Literal s) -> Replace (tr r, `Literal s) - | Replace (r, `Splice e) -> Replace (tr r, `Splice (erase (type_check typing_env e))) + | Replace (r, Literal s) -> Replace (tr r, Literal s) + | Replace (r, SpliceExpr e) -> Replace (tr r, SpliceExpr (erase (type_check typing_env e))) and type_bindings (globals : context) bindings = let tyenv, (bindings, uinf) = List.fold_left From c5517d6d791571a24e17868a11e3f7de060214a4 Mon Sep 17 00:00:00 2001 From: Jan Stolarek Date: Wed, 20 Feb 2019 14:16:41 +0000 Subject: [PATCH 09/28] Redefine datatype as an ordinary variant Also, put all the datatype-related datatype definitions into a module --- core/desugarDatatypes.ml | 93 ++++++------- core/desugarModules.ml | 21 +-- core/moduleUtils.ml | 4 +- core/parse.ml | 2 +- core/parse.mli | 2 +- core/parser.mly | 81 ++++++------ core/refineBindings.ml | 36 +++--- core/sugarConstructors.ml | 18 +-- core/sugarConstructorsIntf.ml | 22 ++-- core/sugarTraversals.ml | 237 +++++++++++++++++----------------- core/sugarTraversals.mli | 36 +++--- core/sugartypes.ml | 67 +++++----- core/transformSugar.ml | 2 +- core/transformSugar.mli | 2 +- 14 files changed, 308 insertions(+), 315 deletions(-) diff --git a/core/desugarDatatypes.ml b/core/desugarDatatypes.ml index 5bf2f687b..0afbfdec3 100644 --- a/core/desugarDatatypes.ml +++ b/core/desugarDatatypes.ml @@ -76,19 +76,14 @@ object (self) | Type _ -> self | b -> super#bindingnode b - method! datatypenode = function - | `TypeVar (x, k, freedom) -> self#add (x, (`Type, k), freedom) - | `Mu (v, t) -> let o = self#bind (v, (`Type, None), `Rigid) in o#datatype t - | `Forall (qs, t) -> - let o = - List.fold_left - (fun o q -> - o#bind (rigidify q)) - self - qs - in - o#datatype t - | dt -> super#datatypenode dt + method! datatypenode = let open Datatype in + function + | TypeVar (x, k, freedom) -> self#add (x, (`Type, k), freedom) + | Mu (v, t) -> let o = self#bind (v, (`Type, None), `Rigid) in o#datatype t + | Forall (qs, t) -> + let o = List.fold_left (fun o q -> o#bind (rigidify q)) self qs in + o#datatype t + | dt -> super#datatypenode dt method! row_var = function | `Closed -> self @@ -117,26 +112,27 @@ struct match t' with | {node = t; pos} -> let lookup_type t = StringMap.find t var_env.tenv in + let open Datatype in match t with - | `TypeVar (s, _, _) -> (try `MetaTypeVar (lookup_type s) + | TypeVar (s, _, _) -> (try `MetaTypeVar (lookup_type s) with NotFound _ -> raise (UnexpectedFreeVar s)) - | `QualifiedTypeApplication _ -> assert false (* will have been erased *) - | `Function (f, e, t) -> + | QualifiedTypeApplication _ -> assert false (* will have been erased *) + | Function (f, e, t) -> `Function (Types.make_tuple_type (List.map (datatype var_env) f), - effect_row var_env alias_env e, - datatype var_env t) - | `Lolli (f, e, t) -> + effect_row var_env alias_env e, + datatype var_env t) + | Lolli (f, e, t) -> `Lolli (Types.make_tuple_type (List.map (datatype var_env) f), effect_row var_env alias_env e, datatype var_env t) - | `Mu (name, t) -> + | Mu (name, t) -> let var = Types.fresh_raw_variable () in (* FIXME: shouldn't we support other subkinds for recursive types? *) let point = Unionfind.fresh (`Var (var, default_subkind, `Flexible)) in let tenv = StringMap.add name point var_env.tenv in let _ = Unionfind.change point (`Recursive (var, datatype {var_env with tenv=tenv} t)) in `MetaTypeVar point - | `Forall (qs, t) -> + | Forall (qs, t) -> let desugar_quantifier (var_env, qs) = fun (name, kind, _freedom) -> match kind with @@ -167,25 +163,25 @@ struct let qs = List.rev qs in let t = datatype var_env t in `ForAll (Types.box_quantifiers qs, t) - | `Unit -> Types.unit_type - | `Tuple ks -> + | Unit -> Types.unit_type + | Tuple ks -> let labels = map string_of_int (Utility.fromTo 1 (1 + length ks)) in let unit = Types.make_empty_closed_row () in let present (s, x) = (s, `Present x) in `Record (fold_right2 (curry (Types.row_with -<- present)) labels (map (datatype var_env) ks) unit) - | `Record r -> `Record (row var_env alias_env r) - | `Variant r -> `Variant (row var_env alias_env r) - | `Effect r -> `Effect (row var_env alias_env r) - | `Table (r, w, n) -> `Table (datatype var_env r, datatype var_env w, datatype var_env n) - | `List k -> `Application (Types.list, [`Type (datatype var_env k)]) - | `TypeApplication (tycon, ts) -> + | Record r -> `Record (row var_env alias_env r) + | Variant r -> `Variant (row var_env alias_env r) + | Effect r -> `Effect (row var_env alias_env r) + | Table (r, w, n) -> `Table (datatype var_env r, datatype var_env w, datatype var_env n) + | List k -> `Application (Types.list, [`Type (datatype var_env k)]) + | TypeApplication (tycon, ts) -> begin match SEnv.find alias_env tycon with | None -> raise (UnboundTyCon (pos,tycon)) | Some (`Alias (qs, _dt)) -> let exception Kind_mismatch (* TODO add more information *) in let match_kinds (q, t) = - let primary_kind_of_type_arg : Sugartypes.type_arg -> primary_kind = function + let primary_kind_of_type_arg : Datatype.type_arg -> primary_kind = function | `Type _ -> `Type | `Row _ -> `Row | `Presence _ -> `Presence @@ -219,31 +215,20 @@ struct (* TODO: check that the kinds match up *) `Application (abstype, List.map (type_arg var_env alias_env) ts) end - | `Primitive k -> `Primitive k - | `DB -> `Primitive `DB - | (`Input _ | `Output _ | `Select _ | `Choice _ | `Dual _ | `End) as s -> session_type var_env alias_env s + | Primitive k -> `Primitive k + | DB -> `Primitive `DB + | (Input _ | Output _ | Select _ | Choice _ | Dual _ | End) as s -> session_type var_env alias_env s and session_type var_env alias_env = (* let lookup_type t = StringMap.find t var_env.tenv in -- used only in commented code *) (* HACKY *) + let open Datatype in function - | `Input (t, s) -> `Input (datatype var_env alias_env t, datatype var_env alias_env s) - | `Output (t, s) -> `Output (datatype var_env alias_env t, datatype var_env alias_env s) - | `Select r -> `Select (row var_env alias_env r) - | `Choice r -> `Choice (row var_env alias_env r) - (* | `TypeVar (name, _, _) -> *) - (* begin *) - (* try `MetaSessionVar (lookup_type name) *) - (* with NotFound _ -> raise (UnexpectedFreeVar name) *) - (* end *) - (* | `Mu (name, s) -> *) - (* let var = Types.fresh_raw_variable () in *) - (* let point = Unionfind.fresh (`Var (var, (`Any, `Session), `Flexible)) in *) - (* let tenv = StringMap.add name point var_env.tenv in *) - (* let _ = Unionfind.change point (`Recursive (var, *) - (* `Session (session_type {var_env with tenv=tenv} alias_env s))) in *) - (* `MetaSessionVar point *) - | `Dual s -> `Dual (datatype var_env alias_env s) - | `End -> `End + | Input (t, s) -> `Input (datatype var_env alias_env t, datatype var_env alias_env s) + | Output (t, s) -> `Output (datatype var_env alias_env t, datatype var_env alias_env s) + | Select r -> `Select (row var_env alias_env r) + | Choice r -> `Choice (row var_env alias_env r) + | Dual s -> `Dual (datatype var_env alias_env s) + | End -> `End | _ -> assert false and fieldspec var_env alias_env = let lookup_flag = flip StringMap.find var_env.penv in @@ -284,15 +269,15 @@ struct operations. Note any row which can be closed will have an unbound effect variable. *) try List.map - (function - | (name, `Present { node = `Function (domain, (fields, rv), codomain); pos}) as op + (let open Datatype in function + | (name, `Present { node = Function (domain, (fields, rv), codomain); pos}) as op when not (TypeUtils.is_builtin_effect name) -> (* Elaborates `Op : a -> b' to `Op : a {}-> b' *) begin match rv, fields with | `Closed, [] -> op | `Open _, [] | (`Recursive _), [] -> (* might need an extra check on recursive rows *) - (name, `Present { node = `Function (domain, ([], `Closed), codomain); pos}) + (name, `Present { node = Function (domain, ([], `Closed), codomain); pos}) | _,_ -> raise (UnexpectedOperationEffects name) end | x -> x) diff --git a/core/desugarModules.ml b/core/desugarModules.ml index fb9210ad6..a3364f097 100644 --- a/core/desugarModules.ml +++ b/core/desugarModules.ml @@ -275,22 +275,23 @@ and perform_renaming module_table path term_ht type_ht = (self, Var fqn) | phr -> super#phrasenode phr - method! datatypenode = function - | `Function (dts, row, dt) -> + method! datatypenode = let open Datatype in + function + | Function (dts, row, dt) -> let (_, dts') = self#list (fun o -> o#datatype) dts in let (_, dt') = self#datatype dt in - (self, `Function (dts', row, dt')) - | `TypeApplication (n, args) -> + (self, Function (dts', row, dt')) + | TypeApplication (n, args) -> let fqn = resolve n type_shadow_table in let (_, args') = self#list (fun o -> o#type_arg) args in - (self, `TypeApplication (fqn, args')) - | `QualifiedTypeApplication ([], _args) -> assert false - | `QualifiedTypeApplication (hd :: tl, args) -> + (self, TypeApplication (fqn, args')) + | QualifiedTypeApplication ([], _args) -> assert false + | QualifiedTypeApplication (hd :: tl, args) -> let prefix = resolve hd type_shadow_table in let fqn = String.concat module_sep (prefix :: tl) in let (_, args') = self#list (fun o -> o#type_arg) args in - (self, `TypeApplication (fqn, args')) - | `Variant (xs, rv) -> + (self, TypeApplication (fqn, args')) + | Variant (xs, rv) -> (* Variants need to have constructors renamed *) let (o, xs') = self#list (fun o (name, fspec) -> @@ -299,7 +300,7 @@ and perform_renaming module_table path term_ht type_ht = let (o, fspec') = o#fieldspec fspec in (o, (fqn, fspec'))) xs in let (o, rv') = o#row_var rv in - (o, `Variant (xs', rv')) + (o, Variant (xs', rv')) | dt -> super#datatypenode dt end diff --git a/core/moduleUtils.ml b/core/moduleUtils.ml index fb76b0b82..b338de80f 100644 --- a/core/moduleUtils.ml +++ b/core/moduleUtils.ml @@ -60,7 +60,7 @@ object | b -> super#bindingnode b method! datatypenode = function - | `QualifiedTypeApplication _ -> {< has_no_modules = false >} + | Datatype.QualifiedTypeApplication _ -> {< has_no_modules = false >} | dt -> super#datatypenode dt method! phrasenode = function @@ -142,7 +142,7 @@ let get_data_constructors init_constrs = method get_constrs = StringSet.elements constrs method! datatypenode = function - | `Variant (xs, _) -> + | Datatype.Variant (xs, _) -> self#list (fun o (lbl, _) -> o#add_constr lbl) xs | dt -> super#datatypenode dt end diff --git a/core/parse.ml b/core/parse.ml index ef25f401f..0ab5b6ab1 100644 --- a/core/parse.ml +++ b/core/parse.ml @@ -115,7 +115,7 @@ let reader_of_readline ps1 = let interactive : Sugartypes.sentence grammar = Parser.interactive let program : (Sugartypes.binding list * Sugartypes.phrase option) grammar = Parser.file -let datatype : Sugartypes.datatype grammar = Parser.just_datatype +let datatype : Sugartypes.Datatype.with_pos grammar = Parser.just_datatype let normalize_pp = function | "" -> None diff --git a/core/parse.mli b/core/parse.mli index 4e4331317..75bbfd806 100644 --- a/core/parse.mli +++ b/core/parse.mli @@ -3,7 +3,7 @@ type 'result grammar (* Grammar for types *) -val datatype : Sugartypes.datatype grammar +val datatype : Sugartypes.Datatype.with_pos grammar (* Grammar for interactive shell *) val interactive : Sugartypes.sentence grammar (* Grammar for programs stored in files etc. *) diff --git a/core/parser.mly b/core/parser.mly index 428792cee..ee3cc0190 100644 --- a/core/parser.mly +++ b/core/parser.mly @@ -140,7 +140,7 @@ let attach_subkind_helper update sk = update sk let attach_subkind (t, subkind) = let update sk = match t with - | `TypeVar (x, _, freedom) -> `TypeVar (x, sk, freedom) + | Datatype.TypeVar (x, _, freedom) -> Datatype.TypeVar (x, sk, freedom) | _ -> assert false in attach_subkind_helper update subkind @@ -234,8 +234,8 @@ let parseRegexFlags f = %start file %type file -%type datatype -%type just_datatype +%type datatype +%type just_datatype %type interactive %type regex_pattern_alternate %type regex_pattern @@ -898,26 +898,26 @@ hear_arrow_prefix: straight_arrow: | parenthesized_datatypes - straight_arrow_prefix RARROW datatype { `Function ($1, $2, $4) } + straight_arrow_prefix RARROW datatype { Datatype.Function ($1, $2, $4) } | parenthesized_datatypes - straight_arrow_prefix LOLLI datatype { `Lolli ($1, $2, $4) } -| parenthesized_datatypes RARROW datatype { `Function ($1, fresh_row (), $3) } -| parenthesized_datatypes LOLLI datatype { `Lolli ($1, fresh_row (), $3) } + straight_arrow_prefix LOLLI datatype { Datatype.Lolli ($1, $2, $4) } +| parenthesized_datatypes RARROW datatype { Datatype.Function ($1, fresh_row (), $3) } +| parenthesized_datatypes LOLLI datatype { Datatype.Lolli ($1, fresh_row (), $3) } squiggly_arrow: | parenthesized_datatypes - squig_arrow_prefix SQUIGRARROW datatype { `Function ($1, row_with_wp $2, $4) } + squig_arrow_prefix SQUIGRARROW datatype { Datatype.Function ($1, row_with_wp $2, $4) } | parenthesized_datatypes - squig_arrow_prefix SQUIGLOLLI datatype { `Lolli ($1, row_with_wp $2, $4) } -| parenthesized_datatypes SQUIGRARROW datatype { `Function ($1, row_with_wp (fresh_row ()), $3) } -| parenthesized_datatypes SQUIGLOLLI datatype { `Lolli ($1, row_with_wp (fresh_row ()), $3) } + squig_arrow_prefix SQUIGLOLLI datatype { Datatype.Lolli ($1, row_with_wp $2, $4) } +| parenthesized_datatypes SQUIGRARROW datatype { Datatype.Function ($1, row_with_wp (fresh_row ()), $3) } +| parenthesized_datatypes SQUIGLOLLI datatype { Datatype.Lolli ($1, row_with_wp (fresh_row ()), $3) } mu_datatype: -| MU VARIABLE DOT mu_datatype { `Mu ($2, with_pos $loc($4) $4) } +| MU VARIABLE DOT mu_datatype { Datatype.Mu ($2, with_pos $loc($4) $4) } | forall_datatype { $1 } forall_datatype: -| FORALL varlist DOT datatype { `Forall (labels $2, $4) } +| FORALL varlist DOT datatype { Datatype.Forall (labels $2, $4) } | session_datatype { $1 } /* Parenthesised dts disambiguate between sending qualified types and recursion variables. @@ -937,14 +937,14 @@ forall_datatype: among several nonterminals. */ session_datatype: -| BANG primary_datatype_pos DOT datatype { `Output ($2, $4) } -| QUESTION primary_datatype_pos DOT datatype { `Input ($2, $4) } -| LBRACKETPLUSBAR row BARPLUSRBRACKET { `Select $2 } -| LBRACKETAMPBAR row BARAMPRBRACKET { `Choice $2 } -| END { `End } -| primary_datatype { $1 } -| qualified_type_name { `QualifiedTypeApplication ($1, []) } -| qualified_type_name LPAREN type_arg_list RPAREN { `QualifiedTypeApplication ($1, $3) } +| BANG primary_datatype_pos DOT datatype { Datatype.Output ($2, $4) } +| QUESTION primary_datatype_pos DOT datatype { Datatype.Input ($2, $4) } +| LBRACKETPLUSBAR row BARPLUSRBRACKET { Datatype.Select $2 } +| LBRACKETAMPBAR row BARAMPRBRACKET { Datatype.Choice $2 } +| END { Datatype.End } +| primary_datatype { $1 } +| qualified_type_name { Datatype.QualifiedTypeApplication ($1, []) } +| qualified_type_name LPAREN type_arg_list RPAREN { Datatype.QualifiedTypeApplication ($1, $3) } parenthesized_datatypes: | LPAREN RPAREN { [] } @@ -954,33 +954,34 @@ primary_datatype_pos: | primary_datatype { with_pos $loc $1 } primary_datatype: -| TILDE primary_datatype_pos { `Dual $2 } +| TILDE primary_datatype_pos { Datatype.Dual $2 } | parenthesized_datatypes { match $1 with - | [] -> `Unit + | [] -> Datatype.Unit | [{node;_}] -> node - | ts -> `Tuple ts } -| LPAREN rfields RPAREN { `Record $2 } + | ts -> Datatype.Tuple ts } +| LPAREN rfields RPAREN { Datatype.Record $2 } | TABLEHANDLE - LPAREN datatype COMMA datatype COMMA datatype RPAREN { `Table ($3, $5, $7) } -| LBRACKETBAR vrow BARRBRACKET { `Variant $2 } -| LBRACKET datatype RBRACKET { `List $2 } + LPAREN datatype COMMA datatype COMMA datatype RPAREN { Datatype.Table ($3, $5, $7) } +| LBRACKETBAR vrow BARRBRACKET { Datatype.Variant $2 } +| LBRACKET datatype RBRACKET { Datatype.List $2 } | type_var { $1 } | kinded_type_var { $1 } -| CONSTRUCTOR { match $1 with - | "Bool" -> `Primitive `Bool - | "Int" -> `Primitive `Int - | "Char" -> `Primitive `Char - | "Float" -> `Primitive `Float - | "XmlItem" -> `Primitive `XmlItem - | "String" -> `Primitive `String - | "Database"-> `DB - | t -> `TypeApplication (t, []) +| CONSTRUCTOR { let open Datatype in + match $1 with + | "Bool" -> Primitive `Bool + | "Int" -> Primitive `Int + | "Char" -> Primitive `Char + | "Float" -> Primitive `Float + | "XmlItem" -> Primitive `XmlItem + | "String" -> Primitive `String + | "Database"-> DB + | t -> TypeApplication (t, []) } -| CONSTRUCTOR LPAREN type_arg_list RPAREN { `TypeApplication ($1, $3) } +| CONSTRUCTOR LPAREN type_arg_list RPAREN { Datatype.TypeApplication ($1, $3) } type_var: -| VARIABLE { `TypeVar ($1, None, `Rigid) } -| PERCENTVAR { `TypeVar ($1, None, `Flexible) } +| VARIABLE { Datatype.TypeVar ($1, None, `Rigid) } +| PERCENTVAR { Datatype.TypeVar ($1, None, `Flexible) } | UNDERSCORE { fresh_rigid_type_variable () } | PERCENT { fresh_type_variable () } diff --git a/core/refineBindings.ml b/core/refineBindings.ml index 9505256f0..0027fdd60 100644 --- a/core/refineBindings.ml +++ b/core/refineBindings.ml @@ -119,7 +119,7 @@ object (self) StringSet.elements (StringSet.from_list (List.rev references)) method! datatypenode = function - | `TypeApplication (tyAppName, argList) -> + | Datatype.TypeApplication (tyAppName, argList) -> let o = List.fold_left (fun acc ta -> acc#type_arg ta) self argList in @@ -143,9 +143,10 @@ let subst_ty_app refFrom refTo = object(_self) inherit SugarTraversals.map as super - method! datatypenode : datatypenode -> datatypenode = function - | `TypeApplication (tyAppName, _) as tyApp -> - if tyAppName = refFrom then `TypeVar (refTo, Some default_subkind, `Rigid) + method! datatypenode : Datatype.t -> Datatype.t = let open Datatype in + function + | TypeApplication (tyAppName, _) as tyApp -> + if tyAppName = refFrom then TypeVar (refTo, Some default_subkind, `Rigid) else super#datatypenode tyApp | dt -> super#datatypenode dt end @@ -155,7 +156,7 @@ let substTyApp ty refFrom refTo = (* Type variable substitution *) -let subst_ty_var varFrom (taTo : type_arg) = +let subst_ty_var varFrom (taTo : Datatype.type_arg) = object(self) inherit SugarTraversals.map as super @@ -165,25 +166,26 @@ object(self) * - This is the one found in the application *) - method! datatypenode : datatypenode -> datatypenode = + method! datatypenode : Datatype.t -> Datatype.t = fun dt -> + let open Datatype in match dt with - | `TypeVar (n, _, _) when n = varFrom -> + | TypeVar (n, _, _) when n = varFrom -> (match taTo with | `Type {node = dtTo; _} -> dtTo | _ -> super#datatypenode dt) - | `Forall (qs, {node = quantDt; pos}) -> + | Forall (qs, {node = quantDt; pos}) -> (match taTo with - | `Type {node = `TypeVar (n, _, _); _} -> + | `Type {node = TypeVar (n, _, _); _} -> let qs' = List.map (fun (tv, k, f as q) -> if tv = varFrom then (n, k, f) - else q) qs in `Forall (qs', with_pos pos (self#datatypenode quantDt)) + else q) qs in Forall (qs', with_pos pos (self#datatypenode quantDt)) | _ -> super#datatypenode dt) | _ -> super#datatypenode dt - method! fieldspec : fieldspec -> fieldspec = + method! fieldspec : Datatype.fieldspec -> Datatype.fieldspec = fun fs -> match fs with | `Var (n, _, _) when n = varFrom -> @@ -192,7 +194,7 @@ object(self) | _ -> super#fieldspec fs) | _ -> super#fieldspec fs - method! row_var : row_var -> row_var = function + method! row_var : Datatype.row_var -> Datatype.row_var = function | `Open (n, _, _) as rv when n = varFrom -> (match taTo with | `Row (_, (`Open _ as rv2)) -> rv2 @@ -209,10 +211,10 @@ let inline_ty toFind inlineArgs toInline = object(_self) inherit SugarTraversals.map as super - method! datatypenode : datatypenode -> datatypenode = + method! datatypenode : Datatype.t -> Datatype.t = fun dt -> match dt with - | `TypeApplication (tyAppName, argList) as tyApp -> + | Datatype.TypeApplication (tyAppName, argList) as tyApp -> if tyAppName = toFind then (* && List.length argList = 0 then *) (* Ok, so what we need to do: * We have a list of the type arguments of the type to inline, @@ -302,11 +304,11 @@ module RefineTypeBindings = struct fun (name, _, _) -> name (* Gets the sugared datatype from a type binding. *) - let getDT : type_ty -> datatype = + let getDT : type_ty -> Datatype.with_pos = fun (_, _, (dt, _)) -> dt (* Updates the datatype in a type binding. *) - let updateDT : type_ty -> datatypenode -> type_ty = + let updateDT : type_ty -> Datatype.t -> type_ty = fun (name, tyArgs, ({pos; _}, unsugaredDT)) newDT -> (name, tyArgs, ((with_pos pos newDT), unsugaredDT)) @@ -352,7 +354,7 @@ module RefineTypeBindings = struct if List.mem_assoc tyName env then assert false else if rts || List.length sccs > 1 then let muName = gensym ~prefix:"refined_mu" () in - ((tyName, muName) :: env, `Mu (muName, sugaredDT)) + ((tyName, muName) :: env, Datatype.Mu (muName, sugaredDT)) else (env, sugaredDT.node) in (* Now, we go through the list of type references. * If the reference is in the substitution environment, we replace it diff --git a/core/sugarConstructors.ml b/core/sugarConstructors.ml index a2ffe6e29..40717a308 100644 --- a/core/sugarConstructors.ml +++ b/core/sugarConstructors.ml @@ -21,27 +21,27 @@ module SugarConstructors (Position : Pos) let type_variable_counter = ref 0 - let fresh_type_variable () : datatypenode = + let fresh_type_variable () : Datatype.t = incr type_variable_counter; - `TypeVar ("_" ^ string_of_int (!type_variable_counter), None, `Flexible) + Datatype.TypeVar ("_" ^ string_of_int (!type_variable_counter), None, `Flexible) - let fresh_rigid_type_variable () : datatypenode = + let fresh_rigid_type_variable () : Datatype.t = incr type_variable_counter; - `TypeVar ("_" ^ string_of_int (!type_variable_counter), None, `Rigid) + Datatype.TypeVar ("_" ^ string_of_int (!type_variable_counter), None, `Rigid) - let fresh_row_variable () : row_var = + let fresh_row_variable () : Datatype.row_var = incr type_variable_counter; `Open ("_" ^ string_of_int (!type_variable_counter), None, `Flexible) - let fresh_rigid_row_variable () : row_var = + let fresh_rigid_row_variable () : Datatype.row_var = incr type_variable_counter; `Open ("_" ^ string_of_int (!type_variable_counter), None, `Rigid) - let fresh_presence_variable () : fieldspec = + let fresh_presence_variable () : Datatype.fieldspec = incr type_variable_counter; `Var ("_" ^ string_of_int (!type_variable_counter), None, `Flexible) - let fresh_rigid_presence_variable () : fieldspec = + let fresh_rigid_presence_variable () : Datatype.fieldspec = incr type_variable_counter; `Var ("_" ^ string_of_int (!type_variable_counter), None, `Rigid) @@ -127,7 +127,7 @@ module SugarConstructors (Position : Pos) (** Fieldspec *) - let present = `Present (Sugartypes.with_dummy_pos `Unit) + let present = `Present (Sugartypes.with_dummy_pos Datatype.Unit) let wild_present = ("wild", present) let hear_present p = ("hear", `Present p) diff --git a/core/sugarConstructorsIntf.ml b/core/sugarConstructorsIntf.ml index 25d8382c5..c7bcc6682 100644 --- a/core/sugarConstructorsIntf.ml +++ b/core/sugarConstructorsIntf.ml @@ -37,12 +37,12 @@ module type SugarConstructorsSig = sig val with_dummy_pos : 'a -> 'a with_pos (* Fresh type variables. *) - val fresh_type_variable : unit -> datatypenode - val fresh_rigid_type_variable : unit -> datatypenode - val fresh_row_variable : unit -> row_var - val fresh_rigid_row_variable : unit -> row_var - val fresh_presence_variable : unit -> fieldspec - val fresh_rigid_presence_variable : unit -> fieldspec + val fresh_type_variable : unit -> Datatype.t + val fresh_rigid_type_variable : unit -> Datatype.t + val fresh_row_variable : unit -> Datatype.row_var + val fresh_rigid_row_variable : unit -> Datatype.row_var + val fresh_presence_variable : unit -> Datatype.fieldspec + val fresh_rigid_presence_variable : unit -> Datatype.fieldspec (* Helper data types and functions for passing arguments to smart constructors. *) @@ -58,7 +58,7 @@ module type SugarConstructorsSig = sig val var : ?ppos:t -> name -> phrase val block : ?ppos:t -> block_body -> phrase val block_node : block_body -> phrasenode - val datatype : datatype -> datatype * 'a option + val datatype : Datatype.with_pos -> Datatype.with_pos * 'a option val cp_unit : t -> cp_phrase val record : ?ppos:t -> ?exp:phrase -> (name * phrase) list -> phrase val tuple : ?ppos:t -> phrase list -> phrase @@ -81,12 +81,12 @@ module type SugarConstructorsSig = sig val any_pat : t -> Pattern.with_pos (* Fieldspec *) - val present : fieldspec + val present : Datatype.fieldspec (* Rows *) - val fresh_row : unit -> row - val row_with_wp : row -> row - val hear_arrow_prefix : datatype -> row -> row + val fresh_row : unit -> Datatype.row + val row_with_wp : Datatype.row -> Datatype.row + val hear_arrow_prefix : Datatype.with_pos -> Datatype.row -> Datatype.row (* Various phrases *) val fun_lit diff --git a/core/sugarTraversals.ml b/core/sugarTraversals.ml index cc25fdeac..7c8f59500 100644 --- a/core/sugarTraversals.ml +++ b/core/sugarTraversals.ml @@ -84,7 +84,7 @@ class map = let _x_i1 = o#option (fun o -> o#subkind) _x_i1 in let _x_i2 = o#freedom _x_i2 in (_x, _x_i1, _x_i2) - method row_var : row_var -> row_var = + method row_var : Datatype.row_var -> Datatype.row_var = function | `Closed -> `Closed | `Open _x -> @@ -93,7 +93,7 @@ class map = let _x = o#name _x in let _x_i1 = o#row _x_i1 in `Recursive ((_x, _x_i1)) - method row : row -> row = + method row : Datatype.row -> Datatype.row = fun (_x, _x_i1) -> let _x = o#list @@ -546,7 +546,7 @@ class map = in { params with shp_bindings = bindings } - method fieldspec : fieldspec -> fieldspec = + method fieldspec : Datatype.fieldspec -> Datatype.fieldspec = function | `Present _x -> let _x = o#datatype _x in `Present _x | `Absent -> `Absent @@ -560,69 +560,70 @@ class map = let _x = o#string _x in let _x_i1 = o#list (fun o -> o#string) _x_i1 in (_x, _x_i1) - method datatypenode : datatypenode -> datatypenode = + method datatypenode : Datatype.t -> Datatype.t = + let open Datatype in function - | `TypeVar _x -> - let _x = o#known_type_variable _x in `TypeVar _x - | `QualifiedTypeApplication (ns, args) -> + | TypeVar _x -> + let _x = o#known_type_variable _x in TypeVar _x + | QualifiedTypeApplication (ns, args) -> let ns = o#list (fun o -> o#name) ns in let args = o#list (fun o -> o#type_arg) args in - `QualifiedTypeApplication (ns, args) - | `Function (_x, _x_i1, _x_i2) -> + QualifiedTypeApplication (ns, args) + | Function (_x, _x_i1, _x_i2) -> let _x = o#list (fun o -> o#datatype) _x in let _x_i1 = o#row _x_i1 in - let _x_i2 = o#datatype _x_i2 in `Function (_x, _x_i1, _x_i2) - | `Lolli (_x, _x_i1, _x_i2) -> + let _x_i2 = o#datatype _x_i2 in Function (_x, _x_i1, _x_i2) + | Lolli (_x, _x_i1, _x_i2) -> let _x = o#list (fun o -> o#datatype) _x in let _x_i1 = o#row _x_i1 in - let _x_i2 = o#datatype _x_i2 in `Lolli (_x, _x_i1, _x_i2) - | `Mu (_x, _x_i1) -> + let _x_i2 = o#datatype _x_i2 in Lolli (_x, _x_i1, _x_i2) + | Mu (_x, _x_i1) -> let _x = o#name _x in - let _x_i1 = o#datatype _x_i1 in `Mu (_x, _x_i1) - | `Forall (_x, _x_i1) -> - let _x = _x in (*o#list (fun o -> o#quantifier) _x in*) - let _x_i1 = o#datatype _x_i1 in `Forall (_x, _x_i1) - | `Unit -> `Unit - | `Tuple _x -> - let _x = o#list (fun o -> o#datatype) _x in `Tuple _x - | `Record _x -> let _x = o#row _x in `Record _x - | `Variant _x -> let _x = o#row _x in `Variant _x - | `Effect r -> let r = o#row r in `Effect r - | `Table (_x, _x_i1, _x_i2) -> + let _x_i1 = o#datatype _x_i1 in Mu (_x, _x_i1) + | Forall (_x, _x_i1) -> + let _x = _x in + let _x_i1 = o#datatype _x_i1 in Forall (_x, _x_i1) + | Unit -> Unit + | Tuple _x -> + let _x = o#list (fun o -> o#datatype) _x in Tuple _x + | Record _x -> let _x = o#row _x in Record _x + | Variant _x -> let _x = o#row _x in Variant _x + | Effect r -> let r = o#row r in Effect r + | Table (_x, _x_i1, _x_i2) -> let _x = o#datatype _x in let _x_i1 = o#datatype _x_i1 in - let _x_i2 = o#datatype _x_i2 in `Table (_x, _x_i1, _x_i2) - | `List _x -> let _x = o#datatype _x in `List _x - | `TypeApplication _x -> + let _x_i2 = o#datatype _x_i2 in Table (_x, _x_i1, _x_i2) + | List _x -> let _x = o#datatype _x in List _x + | TypeApplication _x -> let _x = (fun (_x, _x_i1) -> let _x = o#name _x in let _x_i1 = o#list (fun o -> o#type_arg) _x_i1 in (_x, _x_i1)) _x - in `TypeApplication _x - | `Primitive _x -> let _x = o#unknown _x in `Primitive _x - | `DB -> `DB - | `Input (_x, _x_i1) -> + in TypeApplication _x + | Primitive _x -> let _x = o#unknown _x in Primitive _x + | DB -> DB + | Input (_x, _x_i1) -> let _x = o#datatype _x in - let _x_i1 = o#datatype _x_i1 in `Input (_x, _x_i1) - | `Output (_x, _x_i1) -> + let _x_i1 = o#datatype _x_i1 in Input (_x, _x_i1) + | Output (_x, _x_i1) -> let _x = o#datatype _x in - let _x_i1 = o#datatype _x_i1 in `Output (_x, _x_i1) - | `Select _x -> - let _x = o#row _x in `Select _x - | `Choice _x -> - let _x = o#row _x in `Choice _x - | `Dual _x -> - let _x = o#datatype _x in `Dual _x - | `End -> `End - - method datatype : datatype -> datatype = + let _x_i1 = o#datatype _x_i1 in Output (_x, _x_i1) + | Select _x -> + let _x = o#row _x in Select _x + | Choice _x -> + let _x = o#row _x in Choice _x + | Dual _x -> + let _x = o#datatype _x in Dual _x + | End -> End + + method datatype : Datatype.with_pos -> Datatype.with_pos = fun {node; pos} -> let node = o#datatypenode node in let pos = o#position pos in {node; pos} - method type_arg : type_arg -> type_arg = + method type_arg : Datatype.type_arg -> Datatype.type_arg = function | `Type _x -> let _x = o#datatype _x in `Type _x | `Row _x -> let _x = o#row _x in `Row _x @@ -799,7 +800,7 @@ class fold = let o = o#option (fun o -> o#subkind) _x_i1 in let o = o#freedom _x_i2 in o - method row_var : row_var -> 'self_type = + method row_var : Datatype.row_var -> 'self_type = function | `Closed -> o | `Open _x -> @@ -807,7 +808,7 @@ class fold = | `Recursive ((_x, _x_i1)) -> let o = o#name _x in let o = o#row _x_i1 in o - method row : row -> 'self_type = + method row : Datatype.row -> 'self_type = fun (_x, _x_i1) -> let o = o#list @@ -1210,7 +1211,7 @@ class fold = o#pattern pat) params.shp_bindings - method fieldspec : fieldspec -> 'self_type = + method fieldspec : Datatype.fieldspec -> 'self_type = function | `Present _x -> let o = o#datatype _x in o | `Absent -> o @@ -1225,62 +1226,63 @@ class fold = method tyvar : tyvar -> 'self_type = fun _ -> o - method datatypenode : datatypenode -> 'self_type = + method datatypenode : Datatype.t -> 'self_type = + let open Datatype in function - | `TypeVar _x -> + | TypeVar _x -> let o = o#known_type_variable _x in o - | `QualifiedTypeApplication (ns, args) -> + | QualifiedTypeApplication (ns, args) -> let o = o#list (fun o -> o#name) ns in let o = o#list (fun o -> o#type_arg) args in o - | `Function (_x, _x_i1, _x_i2) -> + | Function (_x, _x_i1, _x_i2) -> let o = o#list (fun o -> o#datatype) _x in let o = o#row _x_i1 in let o = o#datatype _x_i2 in o - | `Lolli (_x, _x_i1, _x_i2) -> + | Lolli (_x, _x_i1, _x_i2) -> let o = o#list (fun o -> o#datatype) _x in let o = o#row _x_i1 in let o = o#datatype _x_i2 in o - | `Mu (_x, _x_i1) -> + | Mu (_x, _x_i1) -> let o = o#name _x in let o = o#datatype _x_i1 in o - | `Forall (_x, _x_i1) -> - let o = o (*o#list (fun o -> o#quantifier) _x*) in let o = o#datatype _x_i1 in o - | `Unit -> o - | `Tuple _x -> let o = o#list (fun o -> o#datatype) _x in o - | `Record _x -> let o = o#row _x in o - | `Variant _x -> let o = o#row _x in o - | `Effect r -> let o = o#row r in o - | `Table (_x, _x_i1, _x_i2) -> + | Forall (_x, _x_i1) -> + let o = o#datatype _x_i1 in o + | Unit -> o + | Tuple _x -> let o = o#list (fun o -> o#datatype) _x in o + | Record _x -> let o = o#row _x in o + | Variant _x -> let o = o#row _x in o + | Effect r -> let o = o#row r in o + | Table (_x, _x_i1, _x_i2) -> let o = o#datatype _x in let o = o#datatype _x_i1 in let o = o#datatype _x_i2 in o - | `List _x -> let o = o#datatype _x in o - | `TypeApplication _x -> + | List _x -> let o = o#datatype _x in o + | TypeApplication _x -> let o = (fun (_x, _x_i1) -> let o = o#name _x in let o = o#list (fun o -> o#type_arg) _x_i1 in o) _x in o - | `Primitive _x -> let o = o#unknown _x in o - | `DB -> o - | `Input (_x, _x_i1) -> + | Primitive _x -> let o = o#unknown _x in o + | DB -> o + | Input (_x, _x_i1) -> let o = o#datatype _x in let o = o#datatype _x_i1 in o - | `Output (_x, _x_i1) -> + | Output (_x, _x_i1) -> let o = o#datatype _x in let o = o#datatype _x_i1 in o - | `Select _x -> + | Select _x -> let o = o#row _x in o - | `Choice _x -> + | Choice _x -> let o = o#row _x in o - | `Dual _x -> + | Dual _x -> let o = o#datatype _x in o - | `End -> o + | End -> o - method datatype : datatype -> 'self_type = + method datatype : Datatype.with_pos -> 'self_type = fun {node; pos} -> let o = o#datatypenode node in let o = o#position pos in o - method type_arg : type_arg -> 'self_type = + method type_arg : Datatype.type_arg -> 'self_type = function | `Type _x -> let o = o#datatype _x in o | `Row _x -> let o = o#row _x in o @@ -1466,7 +1468,7 @@ class fold_map = let (o, _x_i1) = o#option (fun o -> o#subkind) _x_i1 in let (o, _x_i2) = o#freedom _x_i2 in (o, (_x, _x_i1, _x_i2)) - method row_var : row_var -> ('self_type * row_var) = + method row_var : Datatype.row_var -> ('self_type * Datatype.row_var) = function | `Closed -> (o, `Closed) | `Open _x -> @@ -1475,7 +1477,7 @@ class fold_map = let (o, _x) = o#name _x in let (o, _x_i1) = o#row _x_i1 in (o, (`Recursive ((_x, _x_i1)))) - method row : row -> ('self_type * row) = + method row : Datatype.row -> ('self_type * Datatype.row) = fun (_x, _x_i1) -> let (o, _x) = o#list @@ -1974,7 +1976,7 @@ class fold_map = in (o, { params with shp_bindings = bindings }) - method fieldspec : fieldspec -> ('self_type * fieldspec) = + method fieldspec : Datatype.fieldspec -> ('self_type * Datatype.fieldspec) = function | `Present _x -> let (o, _x) = o#datatype _x in (o, `Present _x) | `Absent -> (o, `Absent) @@ -1994,73 +1996,74 @@ class fold_map = let (o, _x_i1) = o#option (fun o -> o#unknown) _x_i1 in (o, (_x, _x_i1)) - method datatypenode : datatypenode -> ('self_type * datatypenode) = + method datatypenode : Datatype.t -> ('self_type * Datatype.t) = + let open Datatype in function - | `TypeVar _x -> - let (o, _x) = o#known_type_variable _x in (o, (`TypeVar _x)) - | `QualifiedTypeApplication (ns, args) -> + | TypeVar _x -> + let (o, _x) = o#known_type_variable _x in (o, (TypeVar _x)) + | QualifiedTypeApplication (ns, args) -> let (o, ns) = o#list (fun o -> o#name) ns in let (o, args) = o#list (fun o -> o#type_arg) args in - (o, `QualifiedTypeApplication (ns, args)) - | `Function (_x, _x_i1, _x_i2) -> + (o, QualifiedTypeApplication (ns, args)) + | Function (_x, _x_i1, _x_i2) -> let (o, _x) = o#list (fun o -> o#datatype) _x in let (o, _x_i1) = o#row _x_i1 in let (o, _x_i2) = o#datatype _x_i2 - in (o, (`Function (_x, _x_i1, _x_i2))) - | `Lolli (_x, _x_i1, _x_i2) -> + in (o, (Function (_x, _x_i1, _x_i2))) + | Lolli (_x, _x_i1, _x_i2) -> let (o, _x) = o#list (fun o -> o#datatype) _x in let (o, _x_i1) = o#row _x_i1 in let (o, _x_i2) = o#datatype _x_i2 - in (o, (`Lolli (_x, _x_i1, _x_i2))) - | `Mu (_x, _x_i1) -> + in (o, (Lolli (_x, _x_i1, _x_i2))) + | Mu (_x, _x_i1) -> let (o, _x) = o#name _x in - let (o, _x_i1) = o#datatype _x_i1 in (o, (`Mu (_x, _x_i1))) - | `Forall (_x, _x_i1) -> + let (o, _x_i1) = o#datatype _x_i1 in (o, (Mu (_x, _x_i1))) + | Forall (_x, _x_i1) -> (*let (o, _x) = o#list (fun o -> o#quantifier) _x in*) - let (o, _x_i1) = o#datatype _x_i1 in (o, (`Forall (_x, _x_i1))) - | `Unit -> (o, `Unit) - | `Tuple _x -> + let (o, _x_i1) = o#datatype _x_i1 in (o, (Forall (_x, _x_i1))) + | Unit -> (o, Unit) + | Tuple _x -> let (o, _x) = o#list (fun o -> o#datatype) _x - in (o, (`Tuple _x)) - | `Record _x -> let (o, _x) = o#row _x in (o, (`Record _x)) - | `Variant _x -> let (o, _x) = o#row _x in (o, (`Variant _x)) - | `Effect r -> let (o, r) = o#row r in (o, `Effect r) - | `Table (_x, _x_i1, _x_i2) -> + in (o, (Tuple _x)) + | Record _x -> let (o, _x) = o#row _x in (o, (Record _x)) + | Variant _x -> let (o, _x) = o#row _x in (o, (Variant _x)) + | Effect r -> let (o, r) = o#row r in (o, Effect r) + | Table (_x, _x_i1, _x_i2) -> let (o, _x) = o#datatype _x in let (o, _x_i1) = o#datatype _x_i1 in - let (o, _x_i2) = o#datatype _x_i2 in (o, (`Table (_x, _x_i1, _x_i2))) - | `List _x -> let (o, _x) = o#datatype _x in (o, (`List _x)) - | `TypeApplication _x -> + let (o, _x_i2) = o#datatype _x_i2 in (o, (Table (_x, _x_i1, _x_i2))) + | List _x -> let (o, _x) = o#datatype _x in (o, (List _x)) + | TypeApplication _x -> let (o, _x) = (fun (_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, (_x, _x_i1))) _x - in (o, (`TypeApplication _x)) - | `Primitive _x -> - let (o, _x) = o#unknown _x in (o, (`Primitive _x)) - | `DB -> (o, `DB) - | `Input (_x, _x_i1) -> + in (o, (TypeApplication _x)) + | Primitive _x -> + let (o, _x) = o#unknown _x in (o, (Primitive _x)) + | DB -> (o, DB) + | Input (_x, _x_i1) -> let (o, _x) = o#datatype _x in - let (o, _x_i1) = o#datatype _x_i1 in (o, `Input (_x, _x_i1)) - | `Output (_x, _x_i1) -> + let (o, _x_i1) = o#datatype _x_i1 in (o, Input (_x, _x_i1)) + | Output (_x, _x_i1) -> let (o, _x) = o#datatype _x in - let (o, _x_i1) = o#datatype _x_i1 in (o, `Output (_x, _x_i1)) - | `Select _x -> - let (o, _x) = o#row _x in (o, `Select _x) - | `Choice _x -> - let (o, _x) = o#row _x in (o, `Choice _x) - | `Dual _x -> - let (o, _x) = o#datatype _x in (o, `Dual _x) - | `End -> (o, `End) - - method datatype : datatype -> ('self_type * datatype) = + let (o, _x_i1) = o#datatype _x_i1 in (o, Output (_x, _x_i1)) + | Select _x -> + let (o, _x) = o#row _x in (o, Select _x) + | Choice _x -> + let (o, _x) = o#row _x in (o, Choice _x) + | Dual _x -> + let (o, _x) = o#datatype _x in (o, Dual _x) + | End -> (o, End) + + method datatype : Datatype.with_pos -> ('self_type * Datatype.with_pos) = fun {node; pos} -> let (o, node) = o#datatypenode node in let (o, pos) = o#position pos in (o, {node; pos}) - method type_arg : type_arg -> ('self_type * type_arg) = + method type_arg : Datatype.type_arg -> ('self_type * Datatype.type_arg) = function | `Type _x -> let (o, _x) = o#datatype _x in (o, `Type _x) | `Row _x -> let (o, _x) = o#row _x in (o, `Row _x) diff --git a/core/sugarTraversals.mli b/core/sugarTraversals.mli index edf0256c1..f85130d0b 100644 --- a/core/sugarTraversals.mli +++ b/core/sugarTraversals.mli @@ -32,8 +32,8 @@ class map : method freedom : freedom -> freedom method type_variable : type_variable -> type_variable method known_type_variable : known_type_variable -> known_type_variable - method row_var : row_var -> row_var - method row : row -> row + method row_var : Datatype.row_var -> Datatype.row_var + method row : Datatype.row -> Datatype.row method replace_rhs : replace_rhs -> replace_rhs method regexflag : regexflag -> regexflag method regex : regex -> regex @@ -52,13 +52,13 @@ class map : method funlit : funlit -> funlit method handlerlit : handlerlit -> handlerlit method handle_params : handler_parameterisation -> handler_parameterisation - method fieldspec : fieldspec -> fieldspec + method fieldspec : Datatype.fieldspec -> Datatype.fieldspec method fieldconstraint : fieldconstraint -> fieldconstraint method directive : directive -> directive - method datatype : datatype -> datatype - method datatypenode : datatypenode -> datatypenode + method datatype : Datatype.with_pos -> Datatype.with_pos + method datatypenode : Datatype.t -> Datatype.t method datatype' : datatype' -> datatype' - method type_arg : type_arg -> type_arg + method type_arg : Datatype.type_arg -> Datatype.type_arg method constant : constant -> constant method binop : binop -> binop method tybinop : tyarg list * binop -> tyarg list * binop @@ -102,8 +102,8 @@ class fold : method freedom : freedom -> 'self method type_variable : type_variable -> 'self method known_type_variable : known_type_variable -> 'self - method row_var : row_var -> 'self - method row : row -> 'self + method row_var : Datatype.row_var -> 'self + method row : Datatype.row -> 'self method replace_rhs : replace_rhs -> 'self method regexflag : regexflag -> 'self method regex : regex -> 'self @@ -123,14 +123,14 @@ class fold : method handlerlit : handlerlit -> 'self method handle_params : handler_parameterisation -> 'self (* method quantifier : quantifier -> 'self *) - method fieldspec : fieldspec -> 'self + method fieldspec : Datatype.fieldspec -> 'self method fieldconstraint : fieldconstraint -> 'self method directive : directive -> 'self method tyvar : tyvar -> 'self - method datatype : datatype -> 'self - method datatypenode : datatypenode -> 'self + method datatype : Datatype.with_pos -> 'self + method datatypenode : Datatype.t -> 'self method datatype' : datatype' -> 'self - method type_arg : type_arg -> 'self + method type_arg : Datatype.type_arg -> 'self method constant : constant -> 'self method binop : binop -> 'self method tybinop : tyarg list * binop -> 'self @@ -161,12 +161,12 @@ object ('self) method bool : bool -> 'self * bool method char : char -> 'self * char method constant : constant -> 'self * constant - method datatype : datatype -> 'self * datatype - method datatypenode : datatypenode -> 'self * datatypenode + method datatype : Datatype.with_pos -> 'self * Datatype.with_pos + method datatypenode : Datatype.t -> 'self * Datatype.t method datatype' : datatype' -> 'self * datatype' method directive : directive -> 'self * directive method fieldconstraint : fieldconstraint -> 'self * fieldconstraint - method fieldspec : fieldspec -> 'self * fieldspec + method fieldspec : Datatype.fieldspec -> 'self * Datatype.fieldspec method int : int -> 'self * int method float : float -> 'self * float method funlit : funlit -> 'self * funlit @@ -191,8 +191,8 @@ object ('self) method regex : regex -> 'self * regex method regexflag : regexflag -> 'self * regexflag method replace_rhs : replace_rhs -> 'self * replace_rhs - method row : row -> 'self * row - method row_var : row_var -> 'self * row_var + method row : Datatype.row -> 'self * Datatype.row + method row_var : Datatype.row_var -> 'self * Datatype.row_var method sec : sec -> 'self * sec method sentence : sentence -> 'self * sentence method string : name -> 'self * name @@ -201,7 +201,7 @@ object ('self) method freedom : freedom -> 'self * freedom method type_variable : type_variable -> 'self * type_variable method known_type_variable : known_type_variable -> 'self * known_type_variable - method type_arg : type_arg -> 'self * type_arg + method type_arg : Datatype.type_arg -> 'self * Datatype.type_arg method tyunary_op : tyarg list * unary_op -> 'self * (tyarg list * unary_op) method unary_op : unary_op -> 'self * unary_op method unknown : 'a . 'a -> 'self * 'a diff --git a/core/sugartypes.ml b/core/sugartypes.ml index a7e16470d..b13eb6434 100644 --- a/core/sugartypes.ml +++ b/core/sugartypes.ml @@ -136,47 +136,49 @@ let rigidify (name, kind, _) = (name, kind, `Rigid) type fieldconstraint = Readonly | Default [@@deriving show] -type datatypenode = - [ `TypeVar of known_type_variable - | `QualifiedTypeApplication of (name list * type_arg list) - | `Function of datatype list * row * datatype - | `Lolli of datatype list * row * datatype - | `Mu of name * datatype - | `Forall of quantifier list * datatype - | `Unit - | `Tuple of datatype list - | `Record of row - | `Variant of row - | `Effect of row - | `Table of datatype * datatype * datatype - | `List of datatype - | `TypeApplication of (string * type_arg list) - | `Primitive of Types.primitive - | `DB - | `Input of datatype * datatype - | `Output of datatype * datatype - | `Select of row - | `Choice of row - | `Dual of datatype - | `End ] -and datatype = datatypenode with_pos -and row = (string * fieldspec) list * row_var -and row_var = +module Datatype = struct + type t = + | TypeVar of known_type_variable + | QualifiedTypeApplication of (name list * type_arg list) + | Function of with_pos list * row * with_pos + | Lolli of with_pos list * row * with_pos + | Mu of name * with_pos + | Forall of quantifier list * with_pos + | Unit + | Tuple of with_pos list + | Record of row + | Variant of row + | Effect of row + | Table of with_pos * with_pos * with_pos + | List of with_pos + | TypeApplication of (string * type_arg list) + | Primitive of Types.primitive + | DB + | Input of with_pos * with_pos + | Output of with_pos * with_pos + | Select of row + | Choice of row + | Dual of with_pos + | End + and with_pos = t WithPos.t + and row = (string * fieldspec) list * row_var + and row_var = [ `Closed | `Open of known_type_variable | `Recursive of name * row ] -and fieldspec = - [ `Present of datatype + and fieldspec = + [ `Present of with_pos | `Absent | `Var of known_type_variable ] -and type_arg = - [ `Type of datatype + and type_arg = + [ `Type of with_pos | `Row of row | `Presence of fieldspec ] [@@deriving show] +end (* Store the denotation along with the notation once it's computed *) -type datatype' = datatype * Types.datatype option +type datatype' = Datatype.with_pos * Types.datatype option [@@deriving show] type constant = Constant.constant @@ -295,7 +297,7 @@ and phrasenode = | Switch of phrase * (Pattern.with_pos * phrase) list * Types.datatype option | Receive of (Pattern.with_pos * phrase) list * Types.datatype option | DatabaseLit of phrase * (phrase option * phrase option) -| TableLit of phrase * (datatype * (Types.datatype * Types.datatype * Types.datatype) option) * (name * fieldconstraint list) list * phrase * phrase +| TableLit of phrase * (Datatype.with_pos * (Types.datatype * Types.datatype * Types.datatype) option) * (name * fieldconstraint list) list * phrase * phrase | DBDelete of Pattern.with_pos * phrase * phrase option | DBInsert of phrase * name list * phrase * phrase option | DBUpdate of Pattern.with_pos * phrase * phrase option * (name * phrase) list @@ -320,7 +322,6 @@ and phrasenode = | Select of name * phrase (* choice *) | Offer of phrase * (Pattern.with_pos * phrase) list * Types.datatype option -(* | `Fork of binder * phrase *) | CP of cp_phrase | TryInOtherwise of (phrase * Pattern.with_pos * phrase * phrase * Types.datatype option) | Raise diff --git a/core/transformSugar.ml b/core/transformSugar.ml index d70a3e68c..91911079c 100644 --- a/core/transformSugar.ml +++ b/core/transformSugar.ml @@ -151,7 +151,7 @@ class transform (env : Types.typing_environment) = method with_effects : Types.row -> 'self_type = fun effects -> {< effect_row = fst (Types.unwrap_row effects) >} - method sugar_datatype : datatype -> ('self_type * datatype) = + method sugar_datatype : Datatype.with_pos -> ('self_type * Datatype.with_pos) = fun s -> (o, s) method datatype : Types.datatype -> ('self_type * Types.datatype) = diff --git a/core/transformSugar.mli b/core/transformSugar.mli index 2caeb6b5f..4000c225b 100644 --- a/core/transformSugar.mli +++ b/core/transformSugar.mli @@ -71,7 +71,7 @@ object ('self) (binder * declared_linearity * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * location * datatype' option * position) list -> 'self - method sugar_datatype : datatype -> 'self * datatype + method sugar_datatype : Datatype.with_pos -> 'self * Datatype.with_pos method datatype : Types.datatype -> 'self * Types.datatype method datatype' : datatype' -> 'self * datatype' method lens_sort : Types.lens_sort -> 'self * Types.lens_sort From 08258e2b99c0bf9e35cbc87e02092be3c0bba16b Mon Sep 17 00:00:00 2001 From: Jan Stolarek Date: Wed, 20 Feb 2019 14:32:35 +0000 Subject: [PATCH 10/28] Redefine row_var as a variant --- core/desugarDatatypes.ml | 23 ++++++++++++----------- core/parser.mly | 38 +++++++++++++++++++------------------- core/refineBindings.ml | 12 ++++++------ core/sugarConstructors.ml | 4 ++-- core/sugarTraversals.ml | 31 ++++++++++++++++--------------- core/sugartypes.ml | 6 +++--- 6 files changed, 58 insertions(+), 56 deletions(-) diff --git a/core/desugarDatatypes.ml b/core/desugarDatatypes.ml index 0afbfdec3..34ddb9a9c 100644 --- a/core/desugarDatatypes.ml +++ b/core/desugarDatatypes.ml @@ -85,10 +85,10 @@ object (self) o#datatype t | dt -> super#datatypenode dt - method! row_var = function - | `Closed -> self - | `Open (x, k, freedom) -> self#add (x, (`Row, k), freedom) - | `Recursive (s, r) -> let o = self#bind (s, (`Row, None), `Rigid) in o#row r + method! row_var = let open Datatype in function + | Closed -> self + | Open (x, k, freedom) -> self#add (x, (`Row, k), freedom) + | Recursive (s, r) -> let o = self#bind (s, (`Row, None), `Rigid) in o#row r method! fieldspec = function | `Absent -> self @@ -243,14 +243,15 @@ struct and row var_env alias_env (fields, rv) = let lookup_row = flip StringMap.find var_env.renv in let seed = + let open Datatype in match rv with - | `Closed -> Types.make_empty_closed_row () - | `Open (rv, _, _) -> + | Closed -> Types.make_empty_closed_row () + | Open (rv, _, _) -> begin try (StringMap.empty, lookup_row rv, false) with NotFound _ -> raise (UnexpectedFreeVar rv) end - | `Recursive (name, r) -> + | Recursive (name, r) -> let var = Types.fresh_raw_variable () in let point = Unionfind.fresh (`Var (var, default_subkind, `Flexible)) in let renv = StringMap.add name point var_env.renv in @@ -274,10 +275,10 @@ struct when not (TypeUtils.is_builtin_effect name) -> (* Elaborates `Op : a -> b' to `Op : a {}-> b' *) begin match rv, fields with - | `Closed, [] -> op - | `Open _, [] - | (`Recursive _), [] -> (* might need an extra check on recursive rows *) - (name, `Present { node = Function (domain, ([], `Closed), codomain); pos}) + | Closed, [] -> op + | Open _, [] + | Recursive _, [] -> (* might need an extra check on recursive rows *) + (name, `Present { node = Function (domain, ([], Closed), codomain); pos}) | _,_ -> raise (UnexpectedOperationEffects name) end | x -> x) diff --git a/core/parser.mly b/core/parser.mly index ee3cc0190..8e53a3398 100644 --- a/core/parser.mly +++ b/core/parser.mly @@ -147,7 +147,7 @@ let attach_subkind (t, subkind) = let attach_row_subkind (r, subkind) = let update sk = match r with - | `Open (x, _, freedom) -> `Open (x, sk, freedom) + | Datatype.Open (x, _, freedom) -> Datatype.Open (x, sk, freedom) | _ -> assert false in attach_subkind_helper update subkind @@ -879,7 +879,7 @@ datatype: | mu_datatype | straight_arrow | squiggly_arrow { with_pos $loc $1 } arrow_prefix: -| LBRACE RBRACE { ([], `Closed) } +| LBRACE RBRACE { ([], Datatype.Closed) } | LBRACE efields RBRACE { $2 } straight_arrow_prefix: @@ -891,10 +891,10 @@ squig_arrow_prefix: | TILDE nonrec_row_var | TILDE kinded_nonrec_row_var { ([], $2) } hear_arrow_prefix: -| LBRACE COLON datatype COMMA efields RBRACE { hear_arrow_prefix $3 $5 } -| LBRACE COLON datatype RBRACE { hear_arrow_prefix $3 ([], `Closed) } +| LBRACE COLON datatype COMMA efields RBRACE { hear_arrow_prefix $3 $5 } +| LBRACE COLON datatype RBRACE { hear_arrow_prefix $3 ([], Datatype.Closed) } | LBRACE COLON datatype VBAR nonrec_row_var RBRACE -| LBRACE COLON datatype VBAR kinded_nonrec_row_var RBRACE { hear_arrow_prefix $3 ([], $5) } +| LBRACE COLON datatype VBAR kinded_nonrec_row_var RBRACE { hear_arrow_prefix $3 ([], $5) } straight_arrow: | parenthesized_datatypes @@ -1005,17 +1005,17 @@ datatypes: | separated_nonempty_list(COMMA, datatype) { $1 } vrow: -| vfields { $1 } -| /* empty */ { ([], `Closed) } +| vfields { $1 } +| /* empty */ { ([], Datatype.Closed) } row: -| fields { $1 } -| /* empty */ { ([], `Closed) } +| fields { $1 } +| /* empty */ { ([], Datatype.Closed) } fields_def(field_prod, row_var_prod, kinded_row_var_prod): -| field_prod { ([$1] , `Closed) } -| soption(field_prod) VBAR row_var_prod { ( $1 , $3 ) } -| soption(field_prod) VBAR kinded_row_var_prod { ( $1 , $3 ) } +| field_prod { ([$1], Datatype.Closed) } +| soption(field_prod) VBAR row_var_prod { ( $1 , $3 ) } +| soption(field_prod) VBAR kinded_row_var_prod { ( $1 , $3 ) } | field_prod COMMA fields_def(field_prod, row_var_prod, kinded_row_var_prod) { ( $1::fst $3, snd $3 ) } @@ -1046,10 +1046,10 @@ record_label: | field_label { $1 } vfields: -| vfield { ([$1] , `Closed) } -| row_var { ([] , $1 ) } -| kinded_row_var { ([] , $1 ) } -| vfield VBAR vfields { ($1::fst $3, snd $3 ) } +| vfield { ([$1], Datatype.Closed) } +| row_var { ([] , $1 ) } +| kinded_row_var { ([] , $1 ) } +| vfield VBAR vfields { ($1::fst $3, snd $3 ) } vfield: | CONSTRUCTOR { ($1, present) } @@ -1077,8 +1077,8 @@ fieldspec: | LBRACE PERCENT RBRACE { fresh_presence_variable () } nonrec_row_var: -| VARIABLE { `Open ($1, None, `Rigid ) } -| PERCENTVAR { `Open ($1, None, `Flexible) } +| VARIABLE { Datatype.Open ($1, None, `Rigid ) } +| PERCENTVAR { Datatype.Open ($1, None, `Flexible) } | UNDERSCORE { fresh_rigid_row_variable () } | PERCENT { fresh_row_variable () } @@ -1088,7 +1088,7 @@ nonrec_row_var: */ row_var: | nonrec_row_var { $1 } -| LPAREN MU VARIABLE DOT vfields RPAREN { `Recursive ($3, $5) } +| LPAREN MU VARIABLE DOT vfields RPAREN { Datatype.Recursive ($3, $5) } kinded_nonrec_row_var: | nonrec_row_var subkind { attach_row_subkind ($1, $2) } diff --git a/core/refineBindings.ml b/core/refineBindings.ml index 0027fdd60..4e9880747 100644 --- a/core/refineBindings.ml +++ b/core/refineBindings.ml @@ -126,9 +126,9 @@ object (self) o#add tyAppName | x -> super#datatypenode x - method! row_var = function - | `Open (x, _, _) -> self#add x - | `Recursive (x, row) -> + method! row_var = let open Datatype in function + | Open (x, _, _) -> self#add x + | Recursive (x, row) -> let o = self#add x in o#row row | x -> super#row_var x @@ -194,10 +194,10 @@ object(self) | _ -> super#fieldspec fs) | _ -> super#fieldspec fs - method! row_var : Datatype.row_var -> Datatype.row_var = function - | `Open (n, _, _) as rv when n = varFrom -> + method! row_var : Datatype.row_var -> Datatype.row_var = let open Datatype in function + | Open (n, _, _) as rv when n = varFrom -> (match taTo with - | `Row (_, (`Open _ as rv2)) -> rv2 + | `Row (_, (Open _ as rv2)) -> rv2 | _ -> super#row_var rv) | rv -> super#row_var rv diff --git a/core/sugarConstructors.ml b/core/sugarConstructors.ml index 40717a308..566e997c6 100644 --- a/core/sugarConstructors.ml +++ b/core/sugarConstructors.ml @@ -31,11 +31,11 @@ module SugarConstructors (Position : Pos) let fresh_row_variable () : Datatype.row_var = incr type_variable_counter; - `Open ("_" ^ string_of_int (!type_variable_counter), None, `Flexible) + Datatype.Open ("_" ^ string_of_int (!type_variable_counter), None, `Flexible) let fresh_rigid_row_variable () : Datatype.row_var = incr type_variable_counter; - `Open ("_" ^ string_of_int (!type_variable_counter), None, `Rigid) + Datatype.Open ("_" ^ string_of_int (!type_variable_counter), None, `Rigid) let fresh_presence_variable () : Datatype.fieldspec = incr type_variable_counter; diff --git a/core/sugarTraversals.ml b/core/sugarTraversals.ml index 7c8f59500..7fa25ccad 100644 --- a/core/sugarTraversals.ml +++ b/core/sugarTraversals.ml @@ -85,13 +85,14 @@ class map = let _x_i2 = o#freedom _x_i2 in (_x, _x_i1, _x_i2) method row_var : Datatype.row_var -> Datatype.row_var = + let open Datatype in function - | `Closed -> `Closed - | `Open _x -> - let _x = o#known_type_variable _x in `Open _x - | `Recursive ((_x, _x_i1)) -> + | Closed -> Closed + | Open _x -> + let _x = o#known_type_variable _x in Open _x + | Recursive ((_x, _x_i1)) -> let _x = o#name _x in - let _x_i1 = o#row _x_i1 in `Recursive ((_x, _x_i1)) + let _x_i1 = o#row _x_i1 in Recursive ((_x, _x_i1)) method row : Datatype.row -> Datatype.row = fun (_x, _x_i1) -> @@ -801,11 +802,11 @@ class fold = let o = o#freedom _x_i2 in o method row_var : Datatype.row_var -> 'self_type = - function - | `Closed -> o - | `Open _x -> + let open Datatype in function + | Closed -> o + | Open _x -> let o = o#known_type_variable _x in o - | `Recursive ((_x, _x_i1)) -> + | Recursive ((_x, _x_i1)) -> let o = o#name _x in let o = o#row _x_i1 in o method row : Datatype.row -> 'self_type = @@ -1469,13 +1470,13 @@ class fold_map = let (o, _x_i2) = o#freedom _x_i2 in (o, (_x, _x_i1, _x_i2)) method row_var : Datatype.row_var -> ('self_type * Datatype.row_var) = - function - | `Closed -> (o, `Closed) - | `Open _x -> - let (o, _x) = o#known_type_variable _x in (o, (`Open _x)) - | `Recursive ((_x, _x_i1)) -> + let open Datatype in function + | Closed -> (o, Closed) + | Open _x -> + let (o, _x) = o#known_type_variable _x in (o, (Open _x)) + | Recursive ((_x, _x_i1)) -> let (o, _x) = o#name _x in - let (o, _x_i1) = o#row _x_i1 in (o, (`Recursive ((_x, _x_i1)))) + let (o, _x_i1) = o#row _x_i1 in (o, Recursive ((_x, _x_i1))) method row : Datatype.row -> ('self_type * Datatype.row) = fun (_x, _x_i1) -> diff --git a/core/sugartypes.ml b/core/sugartypes.ml index b13eb6434..227e6f5b4 100644 --- a/core/sugartypes.ml +++ b/core/sugartypes.ml @@ -163,9 +163,9 @@ module Datatype = struct and with_pos = t WithPos.t and row = (string * fieldspec) list * row_var and row_var = - [ `Closed - | `Open of known_type_variable - | `Recursive of name * row ] + | Closed + | Open of known_type_variable + | Recursive of name * row and fieldspec = [ `Present of with_pos | `Absent From 70ab823ca1762c774c4d285d4e9c2c6a0fdfff04 Mon Sep 17 00:00:00 2001 From: Jan Stolarek Date: Wed, 20 Feb 2019 15:06:47 +0000 Subject: [PATCH 11/28] Remove unused logical_binope datatype --- core/sugarTraversals.ml | 18 ++++++------------ core/sugarTraversals.mli | 3 --- core/sugartypes.ml | 5 +---- 3 files changed, 7 insertions(+), 19 deletions(-) diff --git a/core/sugarTraversals.ml b/core/sugarTraversals.ml index 7fa25ccad..3f0fe8245 100644 --- a/core/sugarTraversals.ml +++ b/core/sugarTraversals.ml @@ -497,9 +497,6 @@ class map = method name : name -> name = o#string - method logical_binop : logical_binop -> logical_binop = - function | `And -> `And | `Or -> `Or - method location : location -> location = o#unknown method iterpatt : iterpatt -> iterpatt = @@ -644,7 +641,8 @@ class map = | `FloatMinus -> `FloatMinus | `RegexMatch _x -> let _x = o#list (fun o -> o#regexflag) _x in `RegexMatch _x - | (#logical_binop as x) -> (o#logical_binop x :> binop) + | `And -> `And + | `Or -> `Or | `Cons -> `Cons | `Name _x -> let _x = o#name _x in `Name _x @@ -1168,9 +1166,6 @@ class fold = method name : name -> 'self_type = o#string - method logical_binop : logical_binop -> 'self_type = - function | `And -> o | `Or -> o - method location : location -> 'self_type = o#unknown method iterpatt : iterpatt -> 'self_type = @@ -1302,7 +1297,8 @@ class fold = | `Minus -> o | `FloatMinus -> o | `RegexMatch _x -> let o = o#list (fun o -> o#regexflag) _x in o - | (#logical_binop as x) -> o#logical_binop x + | `And -> o + | `Or -> o | `Cons -> o | `Name _x -> let o = o#name _x in o @@ -1927,9 +1923,6 @@ class fold_map = method name : name -> ('self_type * name) = o#string - method logical_binop : logical_binop -> ('self_type * logical_binop) = - function | `And -> (o, `And) | `Or -> (o, `Or) - method location : location -> ('self_type * location) = o#unknown method iterpatt : iterpatt -> ('self_type * iterpatt) = @@ -2085,7 +2078,8 @@ class fold_map = | `RegexMatch _x -> let (o, _x) = o#list (fun o -> o#regexflag) _x in (o, (`RegexMatch _x)) - | (#logical_binop as x) -> (o#logical_binop x :> 'self_type * binop) + | `And -> (o, `And) + | `Or -> (o, `Or) | `Cons -> (o, `Cons) | `Name _x -> let (o, _x) = o#name _x in (o, (`Name _x)) diff --git a/core/sugarTraversals.mli b/core/sugarTraversals.mli index f85130d0b..f70f74e81 100644 --- a/core/sugarTraversals.mli +++ b/core/sugarTraversals.mli @@ -46,7 +46,6 @@ class map : method patternnode : Pattern.t -> Pattern.t method pattern : Pattern.with_pos -> Pattern.with_pos method name : name -> name - method logical_binop : logical_binop -> logical_binop method location : location -> location method iterpatt : iterpatt -> iterpatt method funlit : funlit -> funlit @@ -116,7 +115,6 @@ class fold : method patternnode : Pattern.t -> 'self method pattern : Pattern.with_pos -> 'self method name : name -> 'self - method logical_binop : logical_binop -> 'self method location : location -> 'self method iterpatt : iterpatt -> 'self method funlit : funlit -> 'self @@ -175,7 +173,6 @@ object ('self) method iterpatt : iterpatt -> 'self * iterpatt method list : 'a . ('self -> 'a -> 'self * 'a) -> 'a list -> 'self * 'a list method location : location -> 'self * location - method logical_binop : logical_binop -> 'self * logical_binop method name : name -> 'self * name method option : 'a . ('self -> 'a -> 'self * 'a) -> 'a option -> 'self * 'a option method patternnode : Pattern.t -> 'self * Pattern.t diff --git a/core/sugartypes.ml b/core/sugartypes.ml index 227e6f5b4..a928147c1 100644 --- a/core/sugartypes.ml +++ b/core/sugartypes.ml @@ -20,9 +20,7 @@ type unary_op = [ ] and regexflag = RegexList | RegexNative | RegexGlobal | RegexReplace [@@deriving show] -type logical_binop = [`And | `Or ] - [@@deriving show] -type binop = [ `Minus | `FloatMinus | `RegexMatch of regexflag list | logical_binop | `Cons | `Name of name ] +type binop = [ `Minus | `FloatMinus | `RegexMatch of regexflag list | `And | `Or | `Cons | `Name of name ] [@@deriving show] let string_of_unary_op = @@ -199,7 +197,6 @@ module Pattern = struct | Variable of binder | As of binder * with_pos | HasType of with_pos * datatype' - [@@deriving show] and with_pos = t WithPos.t [@@deriving show] end From 013c10c47887bd87bb0277ade4006734a5422eef Mon Sep 17 00:00:00 2001 From: Jan Stolarek Date: Wed, 20 Feb 2019 15:14:16 +0000 Subject: [PATCH 12/28] Redefine fieldspec as a variant --- core/desugarDatatypes.ml | 31 ++++++++++--------------------- core/parser.mly | 12 ++++++------ core/refineBindings.ml | 5 +++-- core/sugarConstructors.ml | 8 ++++---- core/sugarTraversals.ml | 24 ++++++++++++------------ core/sugartypes.ml | 6 +++--- 6 files changed, 38 insertions(+), 48 deletions(-) diff --git a/core/desugarDatatypes.ml b/core/desugarDatatypes.ml index 34ddb9a9c..2191cfb0f 100644 --- a/core/desugarDatatypes.ml +++ b/core/desugarDatatypes.ml @@ -90,10 +90,10 @@ object (self) | Open (x, k, freedom) -> self#add (x, (`Row, k), freedom) | Recursive (s, r) -> let o = self#bind (s, (`Row, None), `Rigid) in o#row r - method! fieldspec = function - | `Absent -> self - | `Present t -> self#datatype t - | `Var (x, k, freedom) -> self#add (x, (`Presence, k), freedom) + method! fieldspec = let open Datatype in function + | Absent -> self + | Present t -> self#datatype t + | Var (x, k, freedom) -> self#add (x, (`Presence, k), freedom) end type var_env = { tenv : Types.meta_type_var StringMap.t; @@ -232,10 +232,10 @@ struct | _ -> assert false and fieldspec var_env alias_env = let lookup_flag = flip StringMap.find var_env.penv in - function - | `Absent -> `Absent - | `Present t -> `Present (datatype var_env alias_env t) - | `Var (name, _, _) -> + let open Datatype in function + | Absent -> `Absent + | Present t -> `Present (datatype var_env alias_env t) + | Var (name, _, _) -> begin try `Var (lookup_flag name) with NotFound _ -> raise (UnexpectedFreeVar name) @@ -271,14 +271,14 @@ struct unbound effect variable. *) try List.map (let open Datatype in function - | (name, `Present { node = Function (domain, (fields, rv), codomain); pos}) as op + | (name, Present { node = Function (domain, (fields, rv), codomain); pos}) as op when not (TypeUtils.is_builtin_effect name) -> (* Elaborates `Op : a -> b' to `Op : a {}-> b' *) begin match rv, fields with | Closed, [] -> op | Open _, [] | Recursive _, [] -> (* might need an extra check on recursive rows *) - (name, `Present { node = Function (domain, ([], Closed), codomain); pos}) + (name, Present { node = Function (domain, ([], Closed), codomain); pos}) | _,_ -> raise (UnexpectedOperationEffects name) end | x -> x) @@ -297,17 +297,6 @@ struct (* Elaborates `Op : a' to `Op : () {}-> a' *) let eff = Types.make_empty_closed_row () in `Present (Types.make_function_type [] eff t) - (* | `Present t *) - (* when not (TypeUtils.is_builtin_effect name) && TypeUtils.is_function_type t -> *) - (* let domain = TypeUtils.arg_types t in *) - (* let eff = TypeUtils.effect_row t in *) - (* let codomain = TypeUtils.return_type t in *) - (* let t = *) - (* if Types.is_empty_row eff *) - (* then Types.make_function_type domain (Types.make_empty_closed_row ()) codomain *) - (* else t *) - (* in *) - (* `Present t *) | t -> t) fields in diff --git a/core/parser.mly b/core/parser.mly index 8e53a3398..93303e741 100644 --- a/core/parser.mly +++ b/core/parser.mly @@ -1067,12 +1067,12 @@ effect_label: | VARIABLE { $1 } fieldspec: -| COLON datatype { `Present $2 } -| LBRACE COLON datatype RBRACE { `Present $3 } -| MINUS { `Absent } -| LBRACE MINUS RBRACE { `Absent } -| LBRACE VARIABLE RBRACE { `Var ($2, None, `Rigid) } -| LBRACE PERCENTVAR RBRACE { `Var ($2, None, `Flexible) } +| COLON datatype { Datatype.Present $2 } +| LBRACE COLON datatype RBRACE { Datatype.Present $3 } +| MINUS { Datatype.Absent } +| LBRACE MINUS RBRACE { Datatype.Absent } +| LBRACE VARIABLE RBRACE { Datatype.Var ($2, None, `Rigid) } +| LBRACE PERCENTVAR RBRACE { Datatype.Var ($2, None, `Flexible) } | LBRACE UNDERSCORE RBRACE { fresh_rigid_presence_variable () } | LBRACE PERCENT RBRACE { fresh_presence_variable () } diff --git a/core/refineBindings.ml b/core/refineBindings.ml index 4e9880747..b170cfbf3 100644 --- a/core/refineBindings.ml +++ b/core/refineBindings.ml @@ -187,10 +187,11 @@ object(self) method! fieldspec : Datatype.fieldspec -> Datatype.fieldspec = fun fs -> + let open Datatype in match fs with - | `Var (n, _, _) when n = varFrom -> + | Var (n, _, _) when n = varFrom -> (match taTo with - | `Presence (`Var _ as fsTo) -> fsTo + | `Presence (Var _ as fsTo) -> fsTo | _ -> super#fieldspec fs) | _ -> super#fieldspec fs diff --git a/core/sugarConstructors.ml b/core/sugarConstructors.ml index 566e997c6..d3909edee 100644 --- a/core/sugarConstructors.ml +++ b/core/sugarConstructors.ml @@ -39,11 +39,11 @@ module SugarConstructors (Position : Pos) let fresh_presence_variable () : Datatype.fieldspec = incr type_variable_counter; - `Var ("_" ^ string_of_int (!type_variable_counter), None, `Flexible) + Datatype.Var ("_" ^ string_of_int (!type_variable_counter), None, `Flexible) let fresh_rigid_presence_variable () : Datatype.fieldspec = incr type_variable_counter; - `Var ("_" ^ string_of_int (!type_variable_counter), None, `Rigid) + Datatype.Var ("_" ^ string_of_int (!type_variable_counter), None, `Rigid) (** Helper data types and functions for passing arguments to smart @@ -127,9 +127,9 @@ module SugarConstructors (Position : Pos) (** Fieldspec *) - let present = `Present (Sugartypes.with_dummy_pos Datatype.Unit) + let present = Datatype.Present (Sugartypes.with_dummy_pos Datatype.Unit) let wild_present = ("wild", present) - let hear_present p = ("hear", `Present p) + let hear_present p = ("hear", Datatype.Present p) (** Rows *) diff --git a/core/sugarTraversals.ml b/core/sugarTraversals.ml index 3f0fe8245..87bfeeeb0 100644 --- a/core/sugarTraversals.ml +++ b/core/sugarTraversals.ml @@ -545,10 +545,10 @@ class map = { params with shp_bindings = bindings } method fieldspec : Datatype.fieldspec -> Datatype.fieldspec = - function - | `Present _x -> let _x = o#datatype _x in `Present _x - | `Absent -> `Absent - | `Var _x -> let _x = o#known_type_variable _x in `Var _x + let open Datatype in function + | Present _x -> let _x = o#datatype _x in Present _x + | Absent -> Absent + | Var _x -> let _x = o#known_type_variable _x in Var _x method fieldconstraint : fieldconstraint -> fieldconstraint = fun fc -> fc @@ -1208,10 +1208,10 @@ class fold = params.shp_bindings method fieldspec : Datatype.fieldspec -> 'self_type = - function - | `Present _x -> let o = o#datatype _x in o - | `Absent -> o - | `Var _x -> let o = o#known_type_variable _x in o + let open Datatype in function + | Present _x -> let o = o#datatype _x in o + | Absent -> o + | Var _x -> let o = o#known_type_variable _x in o method fieldconstraint : fieldconstraint -> 'self_type = fun _ -> o @@ -1971,10 +1971,10 @@ class fold_map = (o, { params with shp_bindings = bindings }) method fieldspec : Datatype.fieldspec -> ('self_type * Datatype.fieldspec) = - function - | `Present _x -> let (o, _x) = o#datatype _x in (o, `Present _x) - | `Absent -> (o, `Absent) - | `Var _x -> let (o, _x) = o#known_type_variable _x in (o, `Var _x) + let open Datatype in function + | Present _x -> let (o, _x) = o#datatype _x in (o, Present _x) + | Absent -> (o, Absent) + | Var _x -> let (o, _x) = o#known_type_variable _x in (o, Var _x) method fieldconstraint : fieldconstraint -> ('self_type * fieldconstraint) = fun fc -> (o, fc) diff --git a/core/sugartypes.ml b/core/sugartypes.ml index a928147c1..f7bb33ac9 100644 --- a/core/sugartypes.ml +++ b/core/sugartypes.ml @@ -165,9 +165,9 @@ module Datatype = struct | Open of known_type_variable | Recursive of name * row and fieldspec = - [ `Present of with_pos - | `Absent - | `Var of known_type_variable ] + | Present of with_pos + | Absent + | Var of known_type_variable and type_arg = [ `Type of with_pos | `Row of row From 2d8ce796667614bbfcbe283bbbf31d3e31c8f108 Mon Sep 17 00:00:00 2001 From: Jan Stolarek Date: Wed, 20 Feb 2019 15:33:39 +0000 Subject: [PATCH 13/28] Redefine type_arg as a variant --- core/desugarDatatypes.ml | 20 +++++++++++--------- core/parser.mly | 12 ++++++------ core/refineBindings.ml | 10 +++++----- core/sugarTraversals.ml | 24 ++++++++++++------------ core/sugartypes.ml | 6 +++--- 5 files changed, 37 insertions(+), 35 deletions(-) diff --git a/core/desugarDatatypes.ml b/core/desugarDatatypes.ml index 2191cfb0f..ca65451f2 100644 --- a/core/desugarDatatypes.ml +++ b/core/desugarDatatypes.ml @@ -179,19 +179,21 @@ struct begin match SEnv.find alias_env tycon with | None -> raise (UnboundTyCon (pos,tycon)) | Some (`Alias (qs, _dt)) -> + let open Datatype in let exception Kind_mismatch (* TODO add more information *) in let match_kinds (q, t) = - let primary_kind_of_type_arg : Datatype.type_arg -> primary_kind = function - | `Type _ -> `Type - | `Row _ -> `Row - | `Presence _ -> `Presence + let primary_kind_of_type_arg : Datatype.type_arg -> primary_kind = + function + | Type _ -> `Type + | Row _ -> `Row + | Presence _ -> `Presence in if primary_kind_of_quantifier q <> primary_kind_of_type_arg t then raise Kind_mismatch else (q, t) in let type_arg' var_env alias_env = function - | `Row r -> `Row (effect_row var_env alias_env r) + | Row r -> `Row (effect_row var_env alias_env r) | t -> type_arg var_env alias_env t in begin try @@ -302,10 +304,10 @@ struct in (fields, rho, dual) and type_arg var_env alias_env = - function - | `Type t -> `Type (datatype var_env alias_env t) - | `Row r -> `Row (row var_env alias_env r) - | `Presence f -> `Presence (fieldspec var_env alias_env f) + let open Datatype in function + | Type t -> `Type (datatype var_env alias_env t) + | Row r -> `Row (row var_env alias_env r) + | Presence f -> `Presence (fieldspec var_env alias_env f) (* pre condition: all subkinds have been filled in *) let generate_var_mapping (vars : type_variable list) : (Types.quantifier list * var_env) = diff --git a/core/parser.mly b/core/parser.mly index 93303e741..2d8ef133b 100644 --- a/core/parser.mly +++ b/core/parser.mly @@ -121,7 +121,7 @@ let kind_of p = | "Any" -> (`Type, Some (`Any, `Any)) | "Base" -> (`Type, Some (`Unl, `Base)) | "Session" -> (`Type, Some (`Any, `Session)) - | "Eff" -> (`Row, Some (`Unl, `Effect)) + | "Eff" -> (`Row , Some (`Unl, `Effect)) | k -> raise (ConcreteSyntaxError ("Invalid kind: " ^ k, pos p)) let subkind_of p = @@ -995,11 +995,11 @@ type_arg_list: (TYPE, ROW, and PRESENCE are no longer tokens...) */ type_arg: -| datatype { `Type $1 } -| TYPE LPAREN datatype RPAREN { `Type $3 } -| ROW LPAREN row RPAREN { `Row $3 } -| PRESENCE LPAREN fieldspec RPAREN { `Presence $3 } -| LBRACE row RBRACE { `Row $2 } +| datatype { Datatype.Type $1 } +| TYPE LPAREN datatype RPAREN { Datatype.Type $3 } +| ROW LPAREN row RPAREN { Datatype.Row $3 } +| PRESENCE LPAREN fieldspec RPAREN { Datatype.Presence $3 } +| LBRACE row RBRACE { Datatype.Row $2 } datatypes: | separated_nonempty_list(COMMA, datatype) { $1 } diff --git a/core/refineBindings.ml b/core/refineBindings.ml index b170cfbf3..20013082f 100644 --- a/core/refineBindings.ml +++ b/core/refineBindings.ml @@ -172,11 +172,11 @@ object(self) match dt with | TypeVar (n, _, _) when n = varFrom -> (match taTo with - | `Type {node = dtTo; _} -> dtTo + | Type {node = dtTo; _} -> dtTo | _ -> super#datatypenode dt) | Forall (qs, {node = quantDt; pos}) -> (match taTo with - | `Type {node = TypeVar (n, _, _); _} -> + | Type {node = TypeVar (n, _, _); _} -> let qs' = List.map (fun (tv, k, f as q) -> if tv = varFrom then @@ -187,18 +187,18 @@ object(self) method! fieldspec : Datatype.fieldspec -> Datatype.fieldspec = fun fs -> - let open Datatype in + let open Datatype in match fs with | Var (n, _, _) when n = varFrom -> (match taTo with - | `Presence (Var _ as fsTo) -> fsTo + | Presence (Var _ as fsTo) -> fsTo | _ -> super#fieldspec fs) | _ -> super#fieldspec fs method! row_var : Datatype.row_var -> Datatype.row_var = let open Datatype in function | Open (n, _, _) as rv when n = varFrom -> (match taTo with - | `Row (_, (Open _ as rv2)) -> rv2 + | Row (_, (Open _ as rv2)) -> rv2 | _ -> super#row_var rv) | rv -> super#row_var rv diff --git a/core/sugarTraversals.ml b/core/sugarTraversals.ml index 87bfeeeb0..870c4762a 100644 --- a/core/sugarTraversals.ml +++ b/core/sugarTraversals.ml @@ -622,10 +622,10 @@ class map = {node; pos} method type_arg : Datatype.type_arg -> Datatype.type_arg = - function - | `Type _x -> let _x = o#datatype _x in `Type _x - | `Row _x -> let _x = o#row _x in `Row _x - | `Presence _x -> let _x = o#fieldspec _x in `Presence _x + let open Datatype in function + | Type _x -> let _x = o#datatype _x in Type _x + | Row _x -> let _x = o#row _x in Row _x + | Presence _x -> let _x = o#fieldspec _x in Presence _x method constant : constant -> constant = function @@ -1279,10 +1279,10 @@ class fold = o method type_arg : Datatype.type_arg -> 'self_type = - function - | `Type _x -> let o = o#datatype _x in o - | `Row _x -> let o = o#row _x in o - | `Presence _x -> let o = o#fieldspec _x in o + let open Datatype in function + | Type _x -> let o = o#datatype _x in o + | Row _x -> let o = o#row _x in o + | Presence _x -> let o = o#fieldspec _x in o method constant : constant -> 'self_type = function @@ -2058,10 +2058,10 @@ class fold_map = let (o, pos) = o#position pos in (o, {node; pos}) method type_arg : Datatype.type_arg -> ('self_type * Datatype.type_arg) = - function - | `Type _x -> let (o, _x) = o#datatype _x in (o, `Type _x) - | `Row _x -> let (o, _x) = o#row _x in (o, `Row _x) - | `Presence _x -> let (o, _x) = o#fieldspec _x in (o, `Presence _x) + let open Datatype in function + | Type _x -> let (o, _x) = o#datatype _x in (o, Type _x) + | Row _x -> let (o, _x) = o#row _x in (o, Row _x) + | Presence _x -> let (o, _x) = o#fieldspec _x in (o, Presence _x) method constant : constant -> ('self_type * constant) = function diff --git a/core/sugartypes.ml b/core/sugartypes.ml index f7bb33ac9..e5e4b3075 100644 --- a/core/sugartypes.ml +++ b/core/sugartypes.ml @@ -169,9 +169,9 @@ module Datatype = struct | Absent | Var of known_type_variable and type_arg = - [ `Type of with_pos - | `Row of row - | `Presence of fieldspec ] + | Type of with_pos + | Row of row + | Presence of fieldspec [@@deriving show] end From cf31b0144726619b180e8b7a663f4483266ff7d4 Mon Sep 17 00:00:00 2001 From: Jan Stolarek Date: Wed, 20 Feb 2019 15:36:53 +0000 Subject: [PATCH 14/28] Rename sec datatype to section --- core/sugarTraversals.ml | 12 ++++++------ core/sugarTraversals.mli | 6 +++--- core/sugartypes.ml | 4 ++-- core/transformSugar.ml | 6 +++--- core/transformSugar.mli | 2 +- 5 files changed, 15 insertions(+), 15 deletions(-) diff --git a/core/sugarTraversals.ml b/core/sugarTraversals.ml index 870c4762a..5d79147e0 100644 --- a/core/sugarTraversals.ml +++ b/core/sugarTraversals.ml @@ -59,7 +59,7 @@ class map = | Expression _x -> let _x = o#phrase _x in Expression _x | Directive _x -> let _x = o#directive _x in Directive _x - method sec : sec -> sec = + method section : section -> section = function | `Minus -> `Minus | `FloatMinus -> `FloatMinus @@ -186,7 +186,7 @@ class map = | Escape ((_x, _x_i1)) -> let _x = o#binder _x in let _x_i1 = o#phrase _x_i1 in Escape ((_x, _x_i1)) - | Section _x -> let _x = o#sec _x in Section _x + | Section _x -> let _x = o#section _x in Section _x | Conditional ((_x, _x_i1, _x_i2)) -> let _x = o#phrase _x in let _x_i1 = o#phrase _x_i1 in @@ -774,7 +774,7 @@ class fold = | Expression _x -> let o = o#phrase _x in o | Directive _x -> let o = o#directive _x in o - method sec : sec -> 'self_type = + method section : section -> 'self_type = function | `Minus -> o | `FloatMinus -> o @@ -888,7 +888,7 @@ class fold = let o = o#option (fun o -> o#phrase) _x_i3 in o | Escape ((_x, _x_i1)) -> let o = o#binder _x in let o = o#phrase _x_i1 in o - | Section _x -> let o = o#sec _x in o + | Section _x -> let o = o#section _x in o | Conditional ((_x, _x_i1, _x_i2)) -> let o = o#phrase _x in let o = o#phrase _x_i1 in let o = o#phrase _x_i2 in o @@ -1440,7 +1440,7 @@ class fold_map = | Expression _x -> let (o, _x) = o#phrase _x in (o, Expression _x) | Directive _x -> let (o, _x) = o#directive _x in (o, Directive _x) - method sec : sec -> ('self_type * sec) = + method section : section -> ('self_type * section) = function | `Minus -> (o, `Minus) | `FloatMinus -> (o, `FloatMinus) @@ -1574,7 +1574,7 @@ class fold_map = | Escape ((_x, _x_i1)) -> let (o, _x) = o#binder _x in let (o, _x_i1) = o#phrase _x_i1 in (o, (Escape ((_x, _x_i1)))) - | Section _x -> let (o, _x) = o#sec _x in (o, (Section _x)) + | Section _x -> let (o, _x) = o#section _x in (o, (Section _x)) | Conditional ((_x, _x_i1, _x_i2)) -> let (o, _x) = o#phrase _x in let (o, _x_i1) = o#phrase _x_i1 in diff --git a/core/sugarTraversals.mli b/core/sugarTraversals.mli index f70f74e81..f3c352ae6 100644 --- a/core/sugarTraversals.mli +++ b/core/sugarTraversals.mli @@ -26,7 +26,7 @@ class map : method tyunary_op : tyarg list * unary_op -> tyarg list * unary_op method binder : binder -> binder method sentence : sentence -> sentence - method sec : sec -> sec + method section : section -> section method subkind : subkind -> subkind method kind : kind -> kind method freedom : freedom -> freedom @@ -95,7 +95,7 @@ class fold : method tyunary_op : tyarg list * unary_op -> 'self method binder : binder -> 'self method sentence : sentence -> 'self - method sec : sec -> 'self + method section : section -> 'self method subkind : subkind -> 'self method kind : kind -> 'self method freedom : freedom -> 'self @@ -190,7 +190,7 @@ object ('self) method replace_rhs : replace_rhs -> 'self * replace_rhs method row : Datatype.row -> 'self * Datatype.row method row_var : Datatype.row_var -> 'self * Datatype.row_var - method sec : sec -> 'self * sec + method section : section -> 'self * section method sentence : sentence -> 'self * sentence method string : name -> 'self * name method subkind : subkind -> 'self * subkind diff --git a/core/sugartypes.ml b/core/sugartypes.ml index e5e4b3075..92e44ab0e 100644 --- a/core/sugartypes.ml +++ b/core/sugartypes.ml @@ -204,7 +204,7 @@ end type spawn_kind = Angel | Demon | Wait [@@deriving show] -type sec = [`Minus | `FloatMinus | `Project of name | `Name of name] +type section = [`Minus | `FloatMinus | `Project of name | `Name of name] [@@deriving show] type declared_linearity = [ `Lin | `Unl ] @@ -273,7 +273,7 @@ and phrasenode = * (*where:*) phrase option * (*orderby:*) phrase option | Escape of binder * phrase -| Section of sec +| Section of section | Conditional of phrase * phrase * phrase | Block of block_body | InfixAppl of (tyarg list * binop) * phrase * phrase diff --git a/core/transformSugar.ml b/core/transformSugar.ml index 91911079c..a253d6f89 100644 --- a/core/transformSugar.ml +++ b/core/transformSugar.ml @@ -178,9 +178,9 @@ class transform (env : Types.typing_environment) = fun op -> (o, op, type_binary_op var_env tycon_env op) - method sec : sec -> ('self_type * sec * Types.datatype) = - fun sec -> - (o, sec, type_section var_env sec) + method section : section -> ('self_type * section * Types.datatype) = + fun section -> + (o, section, type_section var_env section) method sentence : sentence -> ('self_type * sentence) = function diff --git a/core/transformSugar.mli b/core/transformSugar.mli index 4000c225b..6e06ec335 100644 --- a/core/transformSugar.mli +++ b/core/transformSugar.mli @@ -86,7 +86,7 @@ object ('self) method cp_phrasenode : cp_phrasenode -> 'self * cp_phrasenode * Types.datatype method program : program -> 'self * program * Types.datatype option method regex : regex -> 'self * regex - method sec : sec -> 'self * sec * Types.datatype + method section : section -> 'self * section * Types.datatype method sentence : sentence -> 'self * sentence (* method sentence' : sentence' -> 'self * sentence' From 58daac475315bd26796576d36d628821a4c64281 Mon Sep 17 00:00:00 2001 From: Jan Stolarek Date: Wed, 20 Feb 2019 15:50:54 +0000 Subject: [PATCH 15/28] Redefine section as a variant --- core/desugarFuns.ml | 2 +- core/desugarLAttributes.ml | 2 +- core/parser.mly | 24 +++++++++++------------ core/sugarConstructors.ml | 4 ++-- core/sugarConstructorsIntf.ml | 4 ++-- core/sugarTraversals.ml | 36 +++++++++++++++++------------------ core/sugarTraversals.mli | 6 +++--- core/sugartoir.ml | 8 ++++---- core/sugartypes.ml | 10 ++++++---- core/transformSugar.ml | 26 ++++++++++++------------- core/transformSugar.mli | 2 +- core/typeSugar.ml | 10 +++++----- 12 files changed, 68 insertions(+), 66 deletions(-) diff --git a/core/desugarFuns.ml b/core/desugarFuns.ml index a6ab9e19e..1997ee8a0 100644 --- a/core/desugarFuns.ml +++ b/core/desugarFuns.ml @@ -82,7 +82,7 @@ object (o : 'self_type) var f) in (o, e, ft) - | Section (`Project name) -> + | Section (Section.Project name) -> let ab, a = Types.fresh_type_quantifier (`Any, `Any) in let rhob, (fields, rho, _) = Types.fresh_row_quantifier (`Any, `Any) in let effb, eff = Types.fresh_row_quantifier (`Any, `Any) in diff --git a/core/desugarLAttributes.ml b/core/desugarLAttributes.ml index 956f83281..ab69865b9 100644 --- a/core/desugarLAttributes.ml +++ b/core/desugarLAttributes.ml @@ -104,7 +104,7 @@ let desugar_lnames (p : phrasenode) : phrasenode * (string * string) StringMap.t p', !lnames let let_in name rhs body : phrase = - block ([val_binding' NoSig (Name name, rhs, `Unknown)], body) + block ([val_binding' NoSig (PatName name, rhs, `Unknown)], body) let bind_lname_vars lnames = function | "l:action" as attr, es -> diff --git a/core/parser.mly b/core/parser.mly index 2d8ef133b..0f876a9b2 100644 --- a/core/parser.mly +++ b/core/parser.mly @@ -355,7 +355,7 @@ tlfunbinding: | OP pattern POSTFIXOP perhaps_location block { (`Unl, $3, [[$2]], $4, $5) } tlvarbinding: -| VAR VARIABLE perhaps_location EQ exp { (Name $2, $5, $3) } +| VAR VARIABLE perhaps_location EQ exp { (PatName $2, $5, $3) } signature: | SIG var COLON datatype { with_pos $loc ($2, datatype $4) } @@ -479,17 +479,17 @@ constructor_expression: | CONSTRUCTOR parenthesized_thing? { constructor ~ppos:$loc ?body:$2 $1 } parenthesized_thing: -| LPAREN binop RPAREN { with_pos $loc (Section $2) } -| LPAREN DOT record_label RPAREN { with_pos $loc (Section (`Project $3)) } -| LPAREN RPAREN { record ~ppos:$loc [] } -| LPAREN labeled_exps preceded(VBAR, exp)? RPAREN { record ~ppos:$loc $2 ?exp:$3 } -| LPAREN exps RPAREN { with_pos $loc (TupleLit ($2)) } -| LPAREN exp WITH labeled_exps RPAREN { with_pos $loc (With ($2, $4)) } - -binop: -| MINUS { `Minus } -| MINUSDOT { `FloatMinus } -| op { `Name ($1.node) } +| LPAREN binop_section RPAREN { with_pos $loc (Section $2) } +| LPAREN DOT record_label RPAREN { with_pos $loc (Section (Section.Project $3)) } +| LPAREN RPAREN { record ~ppos:$loc [] } +| LPAREN labeled_exps preceded(VBAR, exp)? RPAREN { record ~ppos:$loc $2 ?exp:$3 } +| LPAREN exps RPAREN { with_pos $loc (TupleLit ($2)) } +| LPAREN exp WITH labeled_exps RPAREN { with_pos $loc (With ($2, $4)) } + +binop_section: +| MINUS { Section.Minus } +| MINUSDOT { Section.FloatMinus } +| op { Section.Name ($1.node) } op: | INFIX0 | INFIXL0 | INFIXR0 diff --git a/core/sugarConstructors.ml b/core/sugarConstructors.ml index d3909edee..7df47e5c5 100644 --- a/core/sugarConstructors.ml +++ b/core/sugarConstructors.ml @@ -51,7 +51,7 @@ module SugarConstructors (Position : Pos) (* Stores either a name of variable to be used in a binding pattern or the pattern itself. Used for passing an argument to val_binding. *) - type name_or_pat = Name of name | Pat of Pattern.with_pos + type name_or_pat = PatName of name | Pat of Pattern.with_pos (* Optionally stores a datatype signature. Isomporphic to Option. *) type signature = Sig of (name with_pos * datatype') with_pos | NoSig @@ -191,7 +191,7 @@ module SugarConstructors (Position : Pos) should be passed. *) let val_binding' ?(ppos=dp) sig_opt (name_or_pat, phrase, location) = let pat, datatype = match name_or_pat with - | Name name -> + | PatName name -> let pat = variable_pat ~ppos name in let datatype = datatype_opt_of_sig_opt sig_opt name in (pat, datatype) diff --git a/core/sugarConstructorsIntf.ml b/core/sugarConstructorsIntf.ml index c7bcc6682..a20984c1f 100644 --- a/core/sugarConstructorsIntf.ml +++ b/core/sugarConstructorsIntf.ml @@ -46,8 +46,8 @@ module type SugarConstructorsSig = sig (* Helper data types and functions for passing arguments to smart constructors. *) - type name_or_pat = Name of name - | Pat of Pattern.with_pos + type name_or_pat = PatName of name + | Pat of Pattern.with_pos type signature = Sig of (name with_pos * datatype') with_pos | NoSig diff --git a/core/sugarTraversals.ml b/core/sugarTraversals.ml index 5d79147e0..cf4c839e6 100644 --- a/core/sugarTraversals.ml +++ b/core/sugarTraversals.ml @@ -59,12 +59,12 @@ class map = | Expression _x -> let _x = o#phrase _x in Expression _x | Directive _x -> let _x = o#directive _x in Directive _x - method section : section -> section = - function - | `Minus -> `Minus - | `FloatMinus -> `FloatMinus - | `Project _x -> let _x = o#name _x in `Project _x - | `Name _x -> let _x = o#name _x in `Name _x + method section : Section.t -> Section.t = + let open Section in function + | Minus -> Minus + | FloatMinus -> FloatMinus + | Project _x -> let _x = o#name _x in Project _x + | Name _x -> let _x = o#name _x in Name _x method subkind : subkind -> subkind = fun x -> x @@ -774,12 +774,12 @@ class fold = | Expression _x -> let o = o#phrase _x in o | Directive _x -> let o = o#directive _x in o - method section : section -> 'self_type = - function - | `Minus -> o - | `FloatMinus -> o - | `Project _x -> let o = o#name _x in o - | `Name _x -> let o = o#name _x in o + method section : Section.t -> 'self_type = + let open Section in function + | Minus -> o + | FloatMinus -> o + | Project _x -> let o = o#name _x in o + | Name _x -> let o = o#name _x in o method subkind : subkind -> 'self_type = fun _ -> o @@ -1440,12 +1440,12 @@ class fold_map = | Expression _x -> let (o, _x) = o#phrase _x in (o, Expression _x) | Directive _x -> let (o, _x) = o#directive _x in (o, Directive _x) - method section : section -> ('self_type * section) = - function - | `Minus -> (o, `Minus) - | `FloatMinus -> (o, `FloatMinus) - | `Project _x -> let (o, _x) = o#name _x in (o, (`Project _x)) - | `Name _x -> let (o, _x) = o#name _x in (o, (`Name _x)) + method section : Section.t -> ('self_type * Section.t) = + let open Section in function + | Minus -> (o, Minus) + | FloatMinus -> (o, FloatMinus) + | Project _x -> let (o, _x) = o#name _x in (o, Project _x) + | Name _x -> let (o, _x) = o#name _x in (o, Name _x) method subkind : subkind -> ('self_type * subkind) = fun k -> (o, k) diff --git a/core/sugarTraversals.mli b/core/sugarTraversals.mli index f3c352ae6..571a35cf5 100644 --- a/core/sugarTraversals.mli +++ b/core/sugarTraversals.mli @@ -26,7 +26,7 @@ class map : method tyunary_op : tyarg list * unary_op -> tyarg list * unary_op method binder : binder -> binder method sentence : sentence -> sentence - method section : section -> section + method section : Section.t -> Section.t method subkind : subkind -> subkind method kind : kind -> kind method freedom : freedom -> freedom @@ -95,7 +95,7 @@ class fold : method tyunary_op : tyarg list * unary_op -> 'self method binder : binder -> 'self method sentence : sentence -> 'self - method section : section -> 'self + method section : Section.t -> 'self method subkind : subkind -> 'self method kind : kind -> 'self method freedom : freedom -> 'self @@ -190,7 +190,7 @@ object ('self) method replace_rhs : replace_rhs -> 'self * replace_rhs method row : Datatype.row -> 'self * Datatype.row method row_var : Datatype.row_var -> 'self * Datatype.row_var - method section : section -> 'self * section + method section : Section.t -> 'self * Section.t method sentence : sentence -> 'self * sentence method string : name -> 'self * name method subkind : subkind -> 'self * subkind diff --git a/core/sugartoir.ml b/core/sugartoir.ml index 4892a1f27..490b07b4e 100644 --- a/core/sugartoir.ml +++ b/core/sugartoir.ml @@ -771,9 +771,9 @@ struct let k = name_of_binder bndr in let kt = type_of_binder_exn bndr in I.escape ((kt, k, `Local), eff, fun v -> eval (extend [k] [(v, kt)] env) body) - | Section (`Minus) -> cofv (lookup_var "-") - | Section (`FloatMinus) -> cofv (lookup_var "-.") - | Section (`Name name) -> cofv (lookup_var name) + | Section (Section.Minus) -> cofv (lookup_var "-") + | Section (Section.FloatMinus) -> cofv (lookup_var "-.") + | Section (Section.Name name) -> cofv (lookup_var name) | Conditional (p, e1, e2) -> I.condition (ev p, ec e1, ec e2) | InfixAppl ((tyargs, `Name ((">" | ">=" | "==" | "<" | "<=" | "<>") as op)), e1, e2) -> @@ -1024,7 +1024,7 @@ struct (* These things should all have been desugared already *) | Spawn _ | Receive _ - | Section (`Project _) + | Section (Section.Project _) | FunLit _ | Iteration _ | InfixAppl ((_, `RegexMatch _), _, _) diff --git a/core/sugartypes.ml b/core/sugartypes.ml index 92e44ab0e..37970dd22 100644 --- a/core/sugartypes.ml +++ b/core/sugartypes.ml @@ -204,8 +204,10 @@ end type spawn_kind = Angel | Demon | Wait [@@deriving show] -type section = [`Minus | `FloatMinus | `Project of name | `Name of name] +module Section = struct + type t = Minus | FloatMinus | Project of name | Name of name [@@deriving show] +end type declared_linearity = [ `Lin | `Unl ] [@@deriving show] @@ -273,7 +275,7 @@ and phrasenode = * (*where:*) phrase option * (*orderby:*) phrase option | Escape of binder * phrase -| Section of section +| Section of Section.t | Conditional of phrase * phrase * phrase | Block of block_body | InfixAppl of (tyarg list * binop) * phrase * phrase @@ -419,11 +421,11 @@ struct let p = p.node in match p with | Var v -> singleton v - | Section (`Name n) -> singleton n + | Section (Section.Name n) -> singleton n | Constant _ | TextNode _ - | Section (`Minus|`FloatMinus|`Project _) -> empty + | Section (Section.Minus|Section.FloatMinus|Section.Project _) -> empty | Spawn (_, _, p, _) | TAbstr (_, p) diff --git a/core/transformSugar.ml b/core/transformSugar.ml index a253d6f89..69629e2c1 100644 --- a/core/transformSugar.ml +++ b/core/transformSugar.ml @@ -4,18 +4,18 @@ open Sugartypes module TyEnv = Env.String let type_section env = - function - | `Minus -> TyEnv.lookup env "-" - | `FloatMinus -> TyEnv.lookup env "-." - | `Project label -> - let ab, a = Types.fresh_type_quantifier (`Any, `Any) in - let rhob, (fields, rho, _) = Types.fresh_row_quantifier (`Any, `Any) in - let eb, e = Types.fresh_row_quantifier (`Any, `Any) in - - let r = `Record (StringMap.add label (`Present a) fields, rho, false) in - `ForAll (Types.box_quantifiers [ab; rhob; eb], - `Function (Types.make_tuple_type [r], e, a)) - | `Name var -> TyEnv.lookup env var + let open Section in function + | Minus -> TyEnv.lookup env "-" + | FloatMinus -> TyEnv.lookup env "-." + | Project label -> + let ab, a = Types.fresh_type_quantifier (`Any, `Any) in + let rhob, (fields, rho, _) = Types.fresh_row_quantifier (`Any, `Any) in + let eb, e = Types.fresh_row_quantifier (`Any, `Any) in + + let r = `Record (StringMap.add label (`Present a) fields, rho, false) in + `ForAll (Types.box_quantifiers [ab; rhob; eb], + `Function (Types.make_tuple_type [r], e, a)) + | Name var -> TyEnv.lookup env var let type_unary_op env tycon_env = let datatype = DesugarDatatypes.read ~aliases:tycon_env in function @@ -178,7 +178,7 @@ class transform (env : Types.typing_environment) = fun op -> (o, op, type_binary_op var_env tycon_env op) - method section : section -> ('self_type * section * Types.datatype) = + method section : Section.t -> ('self_type * Section.t * Types.datatype) = fun section -> (o, section, type_section var_env section) diff --git a/core/transformSugar.mli b/core/transformSugar.mli index 6e06ec335..8c731526a 100644 --- a/core/transformSugar.mli +++ b/core/transformSugar.mli @@ -86,7 +86,7 @@ object ('self) method cp_phrasenode : cp_phrasenode -> 'self * cp_phrasenode * Types.datatype method program : program -> 'self * program * Types.datatype option method regex : regex -> 'self * regex - method section : section -> 'self * section * Types.datatype + method section : Section.t -> 'self * Section.t * Types.datatype method sentence : sentence -> 'self * sentence (* method sentence' : sentence' -> 'self * sentence' diff --git a/core/typeSugar.ml b/core/typeSugar.ml index 416d9df0c..396dfc6c0 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -1382,16 +1382,16 @@ let type_section context = function | Section s as s' -> let env = context.var_env in let ((tyargs, t), usages) = - match s with - | `Minus -> Utils.instantiate env "-", StringMap.empty - | `FloatMinus -> Utils.instantiate env "-.", StringMap.empty - | `Project label -> + let open Section in match s with + | Minus -> Utils.instantiate env "-", StringMap.empty + | FloatMinus -> Utils.instantiate env "-.", StringMap.empty + | Project label -> let a = Types.fresh_type_variable (`Any, `Any) in let rho = Types.fresh_row_variable (`Any, `Any) in let effects = Types.make_empty_open_row (`Any, `Any) in (* projection is pure! *) let r = `Record (StringMap.add label (`Present a) StringMap.empty, rho, false) in ([`Type a; `Row (StringMap.empty, rho, false); `Row effects], `Function (Types.make_tuple_type [r], effects, a)), StringMap.empty - | `Name var -> Utils.instantiate env var, StringMap.singleton var 1 + | Name var -> Utils.instantiate env var, StringMap.singleton var 1 in if Settings.get_value Instantiate.quantified_instantiation then let tyvars = Types.quantifiers_of_type_args tyargs in From 961c3d05137cf0c90d50b6fb62d78bfdcdffd567 Mon Sep 17 00:00:00 2001 From: Jan Stolarek Date: Wed, 20 Feb 2019 17:10:09 +0000 Subject: [PATCH 16/28] Redefine linearity as an ordinary variant Also, create a CommonTypes module to store simple definitions used throughout the compiler. --- core/commonTypes.ml | 12 +++ core/compilePatterns.ml | 3 +- core/desugarDbs.ml | 3 +- core/desugarFormlets.ml | 3 +- core/desugarFuns.ml | 7 +- core/desugarPages.ml | 5 +- core/instantiate.ml | 5 +- core/lib.ml | 3 +- core/parser.mly | 21 ++-- core/sugartoir.ml | 3 +- core/sugartypes.ml | 7 +- core/transformSugar.ml | 11 +- core/typeSugar.ml | 227 ++++++++++++++++++++-------------------- core/typeUtils.ml | 3 +- core/types.ml | 68 ++++++------ core/types.mli | 6 +- core/unify.ml | 15 +-- 17 files changed, 210 insertions(+), 192 deletions(-) create mode 100644 core/commonTypes.ml diff --git a/core/commonTypes.ml b/core/commonTypes.ml new file mode 100644 index 000000000..ed42cd319 --- /dev/null +++ b/core/commonTypes.ml @@ -0,0 +1,12 @@ +module Linearity = struct + type t = Any | Unl + [@@deriving eq,show] +end + +let string_of_linearity = function + | Linearity.Any -> "Any" + | Linearity.Unl -> "Unl" + +let linUnl = Linearity.Unl +let linAny = Linearity.Any +let isUnl lin = lin == Linearity.Unl diff --git a/core/compilePatterns.ml b/core/compilePatterns.ml index c7df0d6ec..723b70d81 100644 --- a/core/compilePatterns.ml +++ b/core/compilePatterns.ml @@ -8,6 +8,7 @@ to adjust our intermediate language. *) +open CommonTypes open Utility open Ir @@ -77,7 +78,7 @@ let lookup_effects (_nenv, _tenv, eff, _penv) = eff let rec desugar_pattern : Ir.scope -> Sugartypes.Pattern.with_pos -> pattern * raw_env = fun scope {Sugartypes.node=p; Sugartypes.pos} -> let desugar_pat = desugar_pattern scope in - let empty = (NEnv.empty, TEnv.empty, Types.make_empty_open_row (`Any, `Any)) in + let empty = (NEnv.empty, TEnv.empty, Types.make_empty_open_row (linAny, `Any)) in let (++) (nenv, tenv, _) (nenv', tenv', eff') = (NEnv.extend nenv nenv', TEnv.extend tenv tenv', eff') in let fresh_binder (nenv, tenv, eff) bndr = assert (Sugartypes.binder_has_type bndr); diff --git a/core/desugarDbs.ml b/core/desugarDbs.ml index 9fae703ef..164014d89 100644 --- a/core/desugarDbs.ml +++ b/core/desugarDbs.ml @@ -1,3 +1,4 @@ +open CommonTypes open Sugartypes open SugarConstructors.Make @@ -63,7 +64,7 @@ object (o : 'self_type) from well-typed insert expressions. An alternative approach would be to maintain some kind of insert expression in the IR. *) - let value_type = `Record (Types.make_empty_open_row (`Any, `Any)) in + let value_type = `Record (Types.make_empty_open_row (linAny, `Any)) in let o, rows, _ = o#phrase rows in let tyvars = [`Type read_type; `Type write_type; `Type needed_type; `Type value_type; `Row eff] in diff --git a/core/desugarFormlets.ml b/core/desugarFormlets.ml index 29a70b0a9..f60260388 100644 --- a/core/desugarFormlets.ml +++ b/core/desugarFormlets.ml @@ -1,3 +1,4 @@ +open CommonTypes open Utility open Sugartypes open SugarConstructors.Make @@ -40,7 +41,7 @@ object (o : 'self_type) [tuple_pat []], [tuple []], [Types.unit_type] | FormBinding (f, p) -> let (_o, _f, ft) = o#phrase f in - let t = Types.fresh_type_variable (`Any, `Any) in + let t = Types.fresh_type_variable (linAny, `Any) in let () = Unify.datatypes (ft, Instantiate.alias "Formlet" [`Type t] tycon_env) in diff --git a/core/desugarFuns.ml b/core/desugarFuns.ml index 1997ee8a0..f3ad2995b 100644 --- a/core/desugarFuns.ml +++ b/core/desugarFuns.ml @@ -1,3 +1,4 @@ +open CommonTypes open Utility open Sugartypes open SugarConstructors.Make @@ -83,9 +84,9 @@ object (o : 'self_type) in (o, e, ft) | Section (Section.Project name) -> - let ab, a = Types.fresh_type_quantifier (`Any, `Any) in - let rhob, (fields, rho, _) = Types.fresh_row_quantifier (`Any, `Any) in - let effb, eff = Types.fresh_row_quantifier (`Any, `Any) in + let ab, a = Types.fresh_type_quantifier (linAny, `Any) in + let rhob, (fields, rho, _) = Types.fresh_row_quantifier (linAny, `Any) in + let effb, eff = Types.fresh_row_quantifier (linAny, `Any) in let r = `Record (StringMap.add name (`Present a) fields, rho, false) in diff --git a/core/desugarPages.ml b/core/desugarPages.ml index c15eb7c59..bfe0437dc 100644 --- a/core/desugarPages.ml +++ b/core/desugarPages.ml @@ -1,3 +1,4 @@ +open CommonTypes open Sugartypes open SugarConstructors.Make @@ -36,8 +37,8 @@ let rec desugar_page (o, page_type) = | FormletPlacement (formlet, handler, attributes) -> let (_, formlet, formlet_type) = o#phrase formlet in let formlet_type = Types.concrete_type formlet_type in - let a = Types.fresh_type_variable (`Any, `Any) in - let b = Types.fresh_type_variable (`Any, `Any) in + let a = Types.fresh_type_variable (linAny, `Any) in + let b = Types.fresh_type_variable (linAny, `Any) in Unify.datatypes (`Alias (("Formlet", [`Type a]), b), formlet_type); fn_appl "formP" [`Type a; `Row (o#lookup_effects)] [formlet; handler; attributes] diff --git a/core/instantiate.ml b/core/instantiate.ml index c3172b695..c4a238bdf 100644 --- a/core/instantiate.ml +++ b/core/instantiate.ml @@ -1,3 +1,4 @@ +open CommonTypes open Utility open Types @@ -49,7 +50,7 @@ let instantiate_datatype : instantiation_maps -> datatype -> datatype = else begin let var' = Types.fresh_raw_variable () in - let point' = Unionfind.fresh (`Var (var', (`Any, `Any), `Flexible)) in + let point' = Unionfind.fresh (`Var (var', (linAny, `Any), `Flexible)) in let t' = inst (IntMap.add var point' rec_type_env, rec_row_env) t in let _ = Unionfind.change point' (`Recursive (var', t')) in `MetaTypeVar point' @@ -149,7 +150,7 @@ let instantiate_datatype : instantiation_maps -> datatype -> datatype = else begin let var' = Types.fresh_raw_variable () in - let point' = Unionfind.fresh (`Var (var', (`Any, `Any), `Flexible)) in + let point' = Unionfind.fresh (`Var (var', (linAny, `Any), `Flexible)) in let rec_row' = inst_row (rec_type_env, IntMap.add var point' rec_row_env) rec_row in let _ = Unionfind.change point' (`Recursive (var', rec_row')) in (StringMap.empty, point', dual) diff --git a/core/lib.ml b/core/lib.ml index c2431dd97..1cd728bef 100644 --- a/core/lib.ml +++ b/core/lib.ml @@ -1,3 +1,4 @@ +open CommonTypes open List (*open Value*) @@ -71,7 +72,7 @@ let conversion_op' ~unbox ~conv ~(box :'a->Value.t): Value.t list -> Value.t = f let conversion_op ~from ~unbox ~conv ~(box :'a->Value.t) ~into pure : located_primitive * Types.datatype * pure = ((`PFun (fun _ x -> conversion_op' ~unbox:unbox ~conv:conv ~box:box x) : located_primitive), - (let q, r = Types.fresh_row_quantifier (`Any, `Any) in + (let q, r = Types.fresh_row_quantifier (linAny, `Any) in (`ForAll (Types.box_quantifiers [q], `Function (make_tuple_type [from], r, into)) : Types.datatype)), pure) diff --git a/core/parser.mly b/core/parser.mly index 0f876a9b2..3329e74d6 100644 --- a/core/parser.mly +++ b/core/parser.mly @@ -37,6 +37,7 @@ or Menhir it is no longer necessary. %{ +open CommonTypes open Utility open Sugartypes open SugarConstructors @@ -78,8 +79,8 @@ let primary_kind_of_string p = let linearity_of_string p = function - | "Any" -> `Any - | "Unl" -> `Unl + | "Any" -> Linearity.Any + | "Unl" -> Linearity.Unl | lin -> raise (ConcreteSyntaxError ("Invalid kind linearity: " ^ lin, pos p)) @@ -118,19 +119,19 @@ let kind_of p = | "Row" -> (`Row, None) | "Presence" -> (`Presence, None) (* subkind of type abbreviations *) - | "Any" -> (`Type, Some (`Any, `Any)) - | "Base" -> (`Type, Some (`Unl, `Base)) - | "Session" -> (`Type, Some (`Any, `Session)) - | "Eff" -> (`Row , Some (`Unl, `Effect)) + | "Any" -> (`Type, Some (Linearity.Any, `Any)) + | "Base" -> (`Type, Some (Linearity.Unl, `Base)) + | "Session" -> (`Type, Some (Linearity.Any, `Session)) + | "Eff" -> (`Row , Some (Linearity.Unl, `Effect)) | k -> raise (ConcreteSyntaxError ("Invalid kind: " ^ k, pos p)) let subkind_of p = function (* subkind abbreviations *) - | "Any" -> Some (`Any, `Any) - | "Base" -> Some (`Unl, `Base) - | "Session" -> Some (`Any, `Session) - | "Eff" -> Some (`Unl, `Effect) + | "Any" -> Some (Linearity.Any, `Any) + | "Base" -> Some (Linearity.Unl, `Base) + | "Session" -> Some (Linearity.Any, `Session) + | "Eff" -> Some (Linearity.Unl, `Effect) | sk -> raise (ConcreteSyntaxError ("Invalid subkind: " ^ sk, pos p)) let attach_kind (t, k) = (t, k, `Rigid) diff --git a/core/sugartoir.ml b/core/sugartoir.ml index 490b07b4e..9af911642 100644 --- a/core/sugartoir.ml +++ b/core/sugartoir.ml @@ -1,3 +1,4 @@ +open CommonTypes open Utility open Ir @@ -868,7 +869,7 @@ struct I.do_operation (name, vs, t) | Handle { sh_expr; sh_effect_cases; sh_value_cases; sh_descr } -> let henv, params = - let empty_env = (NEnv.empty, TEnv.empty, Types.make_empty_open_row (`Any, `Any)) in + let empty_env = (NEnv.empty, TEnv.empty, Types.make_empty_open_row (linAny, `Any)) in match (sh_descr.shd_params) with | None -> empty_env, [] | Some { shp_bindings = bindings; shp_types = types } -> diff --git a/core/sugartypes.ml b/core/sugartypes.ml index 37970dd22..6b423a2b6 100644 --- a/core/sugartypes.ml +++ b/core/sugartypes.ml @@ -1,3 +1,4 @@ +open CommonTypes open Utility (** The syntax tree created by the parser. *) @@ -102,13 +103,11 @@ let string_of_location = function type restriction = [ `Any | `Base | `Session | `Effect ] [@@deriving eq,show] -type linearity = [ `Any | `Unl ] - [@@deriving eq,show] -type subkind = linearity * restriction +type subkind = Linearity.t * restriction [@@deriving eq,show] -let default_subkind = (`Unl, `Any) +let default_subkind : subkind = (Linearity.Unl, `Any) type freedom = [`Flexible | `Rigid] [@@deriving show] diff --git a/core/transformSugar.ml b/core/transformSugar.ml index 69629e2c1..cf3f201a5 100644 --- a/core/transformSugar.ml +++ b/core/transformSugar.ml @@ -1,3 +1,4 @@ +open CommonTypes open Utility open Sugartypes @@ -8,9 +9,9 @@ let type_section env = | Minus -> TyEnv.lookup env "-" | FloatMinus -> TyEnv.lookup env "-." | Project label -> - let ab, a = Types.fresh_type_quantifier (`Any, `Any) in - let rhob, (fields, rho, _) = Types.fresh_row_quantifier (`Any, `Any) in - let eb, e = Types.fresh_row_quantifier (`Any, `Any) in + let ab, a = Types.fresh_type_quantifier (linAny, `Any) in + let rhob, (fields, rho, _) = Types.fresh_row_quantifier (linAny, `Any) in + let eb, e = Types.fresh_row_quantifier (linAny, `Any) in let r = `Record (StringMap.add label (`Present a) fields, rho, false) in `ForAll (Types.box_quantifiers [ab; rhob; eb], @@ -47,8 +48,8 @@ let type_binary_op env tycon_env = | `Name "<" | `Name "<=" | `Name "<>" -> - let ab, a = Types.fresh_type_quantifier (`Any, `Any) in - let eb, e = Types.fresh_row_quantifier (`Any, `Any) in + let ab, a = Types.fresh_type_quantifier (linAny, `Any) in + let eb, e = Types.fresh_row_quantifier (linAny, `Any) in `ForAll (Types.box_quantifiers [ab; eb], `Function (Types.make_tuple_type [a; a], e, `Primitive `Bool)) | `Name "!" -> TyEnv.lookup env "Send" diff --git a/core/typeSugar.ml b/core/typeSugar.ml index 396dfc6c0..b2a1d568c 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -1,3 +1,4 @@ +open CommonTypes open Utility open Types open Sugartypes @@ -969,8 +970,8 @@ end let iteration_table_pattern ~pos ~t1:l ~t2:(rexpr,rt) ~error:_ = build_tyvar_names [snd l; rt]; let rt = Types.make_table_type - (rt, Types.fresh_type_variable (`Any, `Any) - , Types.fresh_type_variable (`Any, `Any)) in + (rt, Types.fresh_type_variable (linAny, `Any) + , Types.fresh_type_variable (linAny, `Any)) in with_but2things pos ("The binding must match the table in a table generator") ("pattern", l) ("expression", (rexpr, rt)) @@ -1386,9 +1387,9 @@ let type_section context = function | Minus -> Utils.instantiate env "-", StringMap.empty | FloatMinus -> Utils.instantiate env "-.", StringMap.empty | Project label -> - let a = Types.fresh_type_variable (`Any, `Any) in - let rho = Types.fresh_row_variable (`Any, `Any) in - let effects = Types.make_empty_open_row (`Any, `Any) in (* projection is pure! *) + let a = Types.fresh_type_variable (linAny, `Any) in + let rho = Types.fresh_row_variable (linAny, `Any) in + let effects = Types.make_empty_open_row (linAny, `Any) in (* projection is pure! *) let r = `Record (StringMap.add label (`Present a) StringMap.empty, rho, false) in ([`Type a; `Row (StringMap.empty, rho, false); `Row effects], `Function (Types.make_tuple_type [r], effects, a)), StringMap.empty | Name var -> Utils.instantiate env var, StringMap.singleton var 1 @@ -1436,8 +1437,8 @@ let type_binary_op ctxt = | `Name "<" | `Name "<=" | `Name "<>" -> - let a = Types.fresh_type_variable (`Any, `Any) in - let eff = (StringMap.empty, Types.fresh_row_variable (`Any, `Any), false) in + let a = Types.fresh_type_variable (linAny, `Any) in + let eff = (StringMap.empty, Types.fresh_row_variable (linAny, `Any), false) in ([`Type a; `Row eff], `Function (Types.make_tuple_type [a; a], eff, `Primitive `Bool), StringMap.empty) @@ -1761,7 +1762,7 @@ let type_pattern closed : Pattern.with_pos -> Pattern.with_pos * Types.environme let make_singleton_row = match closed with | `Closed -> Types.make_singleton_closed_row - | `Open -> (fun var -> Types.make_singleton_open_row var (`Any, `Any)) in + | `Open -> (fun var -> Types.make_singleton_open_row var (linAny, `Any)) in (* type_pattern p types the pattern p returning a typed pattern, a type environment for the variables bound by the pattern and two @@ -1788,16 +1789,16 @@ let type_pattern closed : Pattern.with_pos -> Pattern.with_pos * Types.environme let open Pattern in match pattern with | Nil -> - let t = Types.make_list_type (Types.fresh_type_variable (`Any, `Any)) in + let t = Types.make_list_type (Types.fresh_type_variable (linAny, `Any)) in Nil, Env.empty, (t, t) | Any -> - let t = Types.fresh_type_variable (`Unl, `Any) in + let t = Types.fresh_type_variable (linUnl, `Any) in Any, Env.empty, (t, t) | Constant c as c' -> let t = Constant.constant_type c in c', Env.empty, (t, t) | Variable bndr -> - let xtype = Types.fresh_type_variable (`Any, `Any) in + let xtype = Types.fresh_type_variable (linAny, `Any) in (Variable (set_binder_type bndr xtype), Env.bind Env.empty (name_of_binder bndr, xtype), (xtype, xtype)) @@ -1818,7 +1819,7 @@ let type_pattern closed : Pattern.with_pos -> Pattern.with_pos * Types.environme Types.make_list_type (typ p) in let ts = match ps' with - | [] -> let t = Types.fresh_type_variable (`Any, `Any) in t, t + | [] -> let t = Types.fresh_type_variable (linAny, `Any) in t, t | p::ps -> list_type p ps ot, list_type p ps it in @@ -1834,9 +1835,9 @@ let type_pattern closed : Pattern.with_pos -> Pattern.with_pos * Types.environme (* Auxiliary machinery for typing effect patterns *) let rec type_resumption_pat (kpat : Pattern.with_pos) : Pattern.with_pos * Types.environment * (Types.datatype * Types.datatype) = let fresh_resumption_type () = - let domain = Types.fresh_type_variable (`Unl, `Any) in - let codomain = Types.fresh_type_variable (`Unl, `Any) in - let effrow = Types.make_empty_open_row (`Unl, `Any) in + let domain = Types.fresh_type_variable (linUnl, `Any) in + let codomain = Types.fresh_type_variable (linUnl, `Any) in + let effrow = Types.make_empty_open_row (linUnl, `Any) in Types.make_function_type [domain] effrow codomain in let pos' = kpat.pos in @@ -1889,12 +1890,12 @@ let type_pattern closed : Pattern.with_pos -> Pattern.with_pos * Types.environme in Effect (name, List.map erase ps, erase k), env, (eff ot, eff it) | Negative names -> - let row_var = Types.fresh_row_variable (`Any, `Any) in + let row_var = Types.fresh_row_variable (linAny, `Any) in let positive, negative = List.fold_right (fun name (positive, negative) -> - let a = Types.fresh_type_variable (`Any, `Any) in + let a = Types.fresh_type_variable (linAny, `Any) in (StringMap.add name (`Present a) positive, StringMap.add name `Absent negative)) names (StringMap.empty, StringMap.empty) in @@ -1916,7 +1917,7 @@ let type_pattern closed : Pattern.with_pos -> Pattern.with_pos * Types.environme List.fold_right (fun (label, _) -> Types.row_with (label, `Absent)) - ps (Types.make_empty_open_row (`Any, `Any)) in + ps (Types.make_empty_open_row (linAny, `Any)) in let () = unify ~handle:Gripers.record_pattern (("", `Record row), (pos r, typ r)) in @@ -2025,7 +2026,7 @@ let make_ft declared_linearity ps effects return_type = let rec ft = function | [p] -> ftcon (args p, effects, return_type) - | p::ps -> ftcon (args p, (StringMap.empty, Types.fresh_row_variable (`Any, `Any), false), ft ps) + | p::ps -> ftcon (args p, (StringMap.empty, Types.fresh_row_variable (linAny, `Any), false), ft ps) | [] -> assert false in ft ps @@ -2040,7 +2041,7 @@ let make_ft_poly_curry declared_linearity ps effects return_type = | [p] -> [], ftcon (args p, effects, return_type) | p::ps -> let qs, t = ft ps in - let q, eff = Types.fresh_row_quantifier (`Any, `Any) in + let q, eff = Types.fresh_row_quantifier (linAny, `Any) in q::qs, ftcon (args p, eff, t) | [] -> assert false in @@ -2122,8 +2123,8 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let (_,_,e) = SourceCode.resolve_pos p.pos in e and erase_cases = List.map (fun ((p, _, _t), (e, _, _)) -> p, e) in let type_cases binders = - let pt = Types.fresh_type_variable (`Any, `Any) in - let bt = Types.fresh_type_variable (`Any, `Any) in + let pt = Types.fresh_type_variable (linAny, `Any) in + let bt = Types.fresh_type_variable (linAny, `Any) in let binders, pats = List.fold_right (fun (pat, body) (binders, pats) -> @@ -2227,7 +2228,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (* make sure rtype is a record type that doesn't match any of the existing fields *) let () = unify ~handle:Gripers.extend_record - (pos_and_typ r, no_pos (`Record (absent_field_env, Types.fresh_row_variable (`Any, `Any), false))) in + (pos_and_typ r, no_pos (`Record (absent_field_env, Types.fresh_row_variable (linAny, `Any), false))) in let (rfield_env, rrow_var, lr), _ = Types.unwrap_row (TypeUtils.extract_row rtype) in assert (lr = false); @@ -2258,7 +2259,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = | ListLit (es, _) -> begin match List.map tc es with | [] -> - let t = Types.fresh_type_variable (`Any, `Any) in + let t = Types.fresh_type_variable (linAny, `Any) in ListLit ([], Some t), `Application (Types.list, [`Type t]), StringMap.empty | e :: es -> List.iter (fun e' -> unify ~handle:Gripers.list_lit (pos_and_typ e, pos_and_typ e')) es; @@ -2272,7 +2273,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let env' = Env.extend context.var_env pat_env in (* type of the effects in the body of the lambda *) - let effects = (StringMap.empty, Types.fresh_row_variable (`Any, `Any), false) in + let effects = (StringMap.empty, Types.fresh_row_variable (linAny, `Any), false) in let body = type_check ({context with var_env = env'; effect_row = effects}) body in @@ -2336,14 +2337,14 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = | ConstructorLit (c, None, _) -> let type' = `Variant (Types.make_singleton_open_row (c, `Present Types.unit_type) - (`Any, `Any)) in + (linAny, `Any)) in ConstructorLit (c, None, Some type'), type', StringMap.empty | ConstructorLit (c, Some v, _) -> let v = tc v in let type' = `Variant (Types.make_singleton_open_row (c, `Present (typ v)) - (`Any, `Any)) in + (linAny, `Any)) in ConstructorLit (c, Some (erase v), Some type'), type', usages v (* database *) @@ -2427,9 +2428,9 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = | DBDelete (pat, from, where) -> let pat = tpc pat in let from = tc from in - let read = `Record (Types.make_empty_open_row (`Any, `Base)) in - let write = `Record (Types.make_empty_open_row (`Any, `Base)) in - let needed = `Record (Types.make_empty_open_row (`Any, `Base)) in + let read = `Record (Types.make_empty_open_row (linAny, `Base)) in + let write = `Record (Types.make_empty_open_row (linAny, `Base)) in + let needed = `Record (Types.make_empty_open_row (linAny, `Base)) in let () = unify ~handle:Gripers.delete_table (pos_and_typ from, no_pos (`Table (read, write, needed))) in let () = unify ~handle:Gripers.delete_pattern (ppos_and_typ pat, no_pos read) in @@ -2449,7 +2450,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (* delete is wild *) let () = let outer_effects = - Types.make_singleton_open_row ("wild", `Present Types.unit_type) (`Any, `Any) + Types.make_singleton_open_row ("wild", `Present Types.unit_type) (linAny, `Any) in unify ~handle:Gripers.delete_outer (no_pos (`Record context.effect_row), no_pos (`Record outer_effects)) @@ -2460,9 +2461,9 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let into = tc into in let values = tc values in let id = opt_map tc id in - let read = `Record (Types.make_empty_open_row (`Any, `Base)) in - let write = `Record (Types.make_empty_open_row (`Any, `Base)) in - let needed = `Record (Types.make_empty_open_row (`Any, `Base)) in + let read = `Record (Types.make_empty_open_row (linAny, `Base)) in + let write = `Record (Types.make_empty_open_row (linAny, `Base)) in + let needed = `Record (Types.make_empty_open_row (linAny, `Base)) in let () = unify ~handle:Gripers.insert_table (pos_and_typ into, no_pos (`Table (read, write, needed))) in @@ -2472,7 +2473,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = if StringMap.mem name field_env then Gripers.die pos "Duplicate labels in insert expression." else - StringMap.add name (`Present (Types.fresh_type_variable (`Any, `Base))) field_env) + StringMap.add name (`Present (Types.fresh_type_variable (linAny, `Base))) field_env) labels StringMap.empty in (* check that the fields in the type of values match the declared labels *) @@ -2483,16 +2484,16 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let needed_env = StringMap.map - (fun _f -> Types.fresh_presence_variable (`Any, `Base)) + (fun _f -> Types.fresh_presence_variable (linAny, `Base)) field_env in (* all fields being inserted must be present in the read row *) let () = unify ~handle:Gripers.insert_read - (no_pos read, no_pos (`Record (field_env, Types.fresh_row_variable (`Any, `Base), false))) in + (no_pos read, no_pos (`Record (field_env, Types.fresh_row_variable (linAny, `Base), false))) in (* all fields being inserted must be present in the write row *) let () = unify ~handle:Gripers.insert_write - (no_pos write, no_pos (`Record (field_env, Types.fresh_row_variable (`Any, `Base), false))) in + (no_pos write, no_pos (`Record (field_env, Types.fresh_row_variable (linAny, `Base), false))) in (* all fields being inserted must be consistent with the needed row *) let () = unify ~handle:Gripers.insert_needed @@ -2514,7 +2515,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = unify ~handle:Gripers.insert_id (no_pos read, - no_pos (`Record (StringMap.singleton id (`Present Types.int_type), Types.fresh_row_variable (`Any, `Base), false))); + no_pos (`Record (StringMap.singleton id (`Present Types.int_type), Types.fresh_row_variable (linAny, `Base), false))); Types.int_type | _ -> assert false end in @@ -2522,7 +2523,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (* insert is wild *) let () = let outer_effects = - Types.make_singleton_open_row ("wild", `Present Types.unit_type) (`Any, `Any) + Types.make_singleton_open_row ("wild", `Present Types.unit_type) (linAny, `Any) in unify ~handle:Gripers.insert_outer (no_pos (`Record context.effect_row), no_pos (`Record outer_effects)) @@ -2532,9 +2533,9 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = | DBUpdate (pat, from, where, set) -> let pat = tpc pat in let from = tc from in - let read = `Record (Types.make_empty_open_row (`Any, `Base)) in - let write = `Record (Types.make_empty_open_row (`Any, `Base)) in - let needed = `Record (Types.make_empty_open_row (`Any, `Base)) in + let read = `Record (Types.make_empty_open_row (linAny, `Base)) in + let write = `Record (Types.make_empty_open_row (linAny, `Base)) in + let needed = `Record (Types.make_empty_open_row (linAny, `Base)) in let () = unify ~handle:Gripers.update_table (pos_and_typ from, no_pos (`Table (read, write, needed))) in @@ -2567,25 +2568,25 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let needed_env = StringMap.map - (fun _f -> Types.fresh_presence_variable (`Any, `Base)) + (fun _f -> Types.fresh_presence_variable (linAny, `Base)) field_env in (* all fields being updated must be present in the read row *) let () = unify ~handle:Gripers.update_read - (no_pos read, no_pos (`Record (field_env, Types.fresh_row_variable (`Any, `Base), false))) in + (no_pos read, no_pos (`Record (field_env, Types.fresh_row_variable (linAny, `Base), false))) in (* all fields being updated must be present in the write row *) let () = unify ~handle:Gripers.update_write - (no_pos write, no_pos (`Record (field_env, Types.fresh_row_variable (`Any, `Base), false))) in + (no_pos write, no_pos (`Record (field_env, Types.fresh_row_variable (linAny, `Base), false))) in (* all fields being updated must be consistent with the needed row *) let () = unify ~handle:Gripers.update_needed - (no_pos needed, no_pos (`Record (needed_env, Types.fresh_row_variable (`Any, `Base), false))) in + (no_pos needed, no_pos (`Record (needed_env, Types.fresh_row_variable (linAny, `Base), false))) in (* update is wild *) let () = let outer_effects = - Types.make_singleton_open_row ("wild", `Present Types.unit_type) (`Any, `Any) + Types.make_singleton_open_row ("wild", `Present Types.unit_type) (linAny, `Any) in unify ~handle:Gripers.update_outer (no_pos (`Record context.effect_row), no_pos (`Record outer_effects)) @@ -2596,14 +2597,14 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = | Query (range, p, _) -> let range, outer_effects, range_usages = match range with - | None -> None, Types.make_empty_open_row (`Any, `Any), StringMap.empty + | None -> None, Types.make_empty_open_row (linAny, `Any), StringMap.empty | Some (limit, offset) -> let limit = tc limit in let () = unify ~handle:Gripers.range_bound (pos_and_typ limit, no_pos Types.int_type) in let offset = tc offset in let () = unify ~handle:Gripers.range_bound (pos_and_typ offset, no_pos Types.int_type) in let outer_effects = - Types.make_singleton_open_row ("wild", `Present Types.unit_type) (`Any, `Any) + Types.make_singleton_open_row ("wild", `Present Types.unit_type) (linAny, `Any) in Some (erase limit, erase offset), outer_effects, merge_usages [usages limit; usages offset] in let inner_effects = Types.make_empty_closed_row () in @@ -2611,19 +2612,19 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (no_pos (`Record context.effect_row), no_pos (`Record outer_effects)) in let p = type_check (bind_effects context inner_effects) p in let () = if Settings.get_value Basicsettings.Shredding.relax_query_type_constraint then () - else let shape = Types.make_list_type (`Record (StringMap.empty, Types.fresh_row_variable (`Any, `Base), false)) in + else let shape = Types.make_list_type (`Record (StringMap.empty, Types.fresh_row_variable (linAny, `Base), false)) in unify ~handle:Gripers.query_base_row (pos_and_typ p, no_pos shape) in Query (range, erase p, Some (typ p)), typ p, merge_usages [range_usages; usages p] (* mailbox-based concurrency *) | Spawn (Wait, l, p, _) -> assert (l = NoSpawnLocation); (* (() -{b}-> d) -> d *) - let inner_effects = Types.make_empty_open_row (`Any, `Any) in + let inner_effects = Types.make_empty_open_row (linAny, `Any) in (* TODO: check if pid_type is actually needed somewhere *) (* let pid_type = `Application (Types.process, [`Row inner_effects]) in *) let () = let outer_effects = - Types.make_singleton_open_row ("wild", `Present Types.unit_type) (`Any, `Any) + Types.make_singleton_open_row ("wild", `Present Types.unit_type) (linAny, `Any) in unify ~handle:Gripers.spawn_wait_outer (no_pos (`Record context.effect_row), no_pos (`Record outer_effects)) in @@ -2640,11 +2641,11 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = | _ -> ()); (* (() -e-> _) -> Process (e) *) - let inner_effects = Types.make_empty_open_row (`Any, `Any) in + let inner_effects = Types.make_empty_open_row (linAny, `Any) in let pid_type = `Application (Types.process, [`Row inner_effects]) in let () = let outer_effects = - Types.make_singleton_open_row ("wild", `Present Types.unit_type) (`Any, `Any) + Types.make_singleton_open_row ("wild", `Present Types.unit_type) (linAny, `Any) in unify ~handle:Gripers.spawn_outer (no_pos (`Record context.effect_row), no_pos (`Record outer_effects)) in @@ -2653,10 +2654,10 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = Gripers.die pos ("Spawned processes cannot produce values of linear type (here " ^ Types.string_of_datatype (typ p) ^ ")"); Spawn (k, given_loc, erase p, Some inner_effects), pid_type, usages p | Receive (binders, _) -> - let mb_type = Types.fresh_type_variable (`Any, `Any) in + let mb_type = Types.fresh_type_variable (linAny, `Any) in let effects = Types.row_with ("wild", `Present Types.unit_type) - (Types.make_singleton_open_row ("hear", `Present mb_type) (`Any, `Any)) in + (Types.make_singleton_open_row ("hear", `Present mb_type) (linAny, `Any)) in let () = unify ~handle:Gripers.receive_mailbox (no_pos (`Record context.effect_row), no_pos (`Record effects)) in @@ -2680,16 +2681,16 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (* `Link (erase l, erase r), Types.unit_type, merge_usages [usages l; usages r] *) | Select (l, e) -> let e = tc e in - let selected_session = Types.fresh_type_variable (`Any, `Session) in + let selected_session = Types.fresh_type_variable (linAny, `Session) in unify ~handle:Gripers.selection (pos_and_typ e, no_pos (`Select (Types.make_singleton_open_row (l, `Present selected_session) - (`Any, `Session)))); + (linAny, `Session)))); Select (l, erase e), selected_session, usages e | Offer (e, branches, _) -> let e = tc e in let branches, pattern_type, body_type = type_cases branches in - let r = Types.make_empty_open_row (`Any, `Session) in + let r = Types.make_empty_open_row (linAny, `Session) in unify ~handle:Gripers.offer_variant (no_pos pattern_type, no_pos (`Variant r)); unify ~handle:Gripers.offer_patterns (pos_and_typ e, no_pos (`Choice r)); Offer (erase e, erase_cases branches, Some body_type), body_type, merge_usages [usages e; usages_cases branches] @@ -2703,7 +2704,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = | UnaryAppl ((_, op), p) -> let tyargs, opt, op_usage = type_unary_op context op and p = tc p - and rettyp = Types.fresh_type_variable (`Any, `Any) in + and rettyp = Types.fresh_type_variable (linAny, `Any) in unify ~handle:Gripers.unary_apply ((string_of_unary_op op, opt), no_pos (`Function (Types.make_tuple_type [typ p], context.effect_row, rettyp))); @@ -2712,7 +2713,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let tyargs, opt, op_usages = type_binary_op context op in let l = tc l and r = tc r - and rettyp = Types.fresh_type_variable (`Any, `Any) in + and rettyp = Types.fresh_type_variable (linAny, `Any) in unify ~handle:Gripers.infix_apply ((string_of_binop op, opt), no_pos (`Function (Types.make_tuple_type [typ l; typ r], @@ -2824,7 +2825,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = end | ft -> - let rettyp = Types.fresh_type_variable (`Any, `Any) in + let rettyp = Types.fresh_type_variable (linAny, `Any) in begin unify_or ~handle:Gripers.fun_apply ~pos ((exp_pos f, ft), no_pos (`Function (Types.make_tuple_type (List.map typ ps), @@ -2884,7 +2885,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = 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 | FormletPlacement (f, h, attributes) -> - let t = Types.fresh_type_variable (`Any, `Any) in + let t = Types.fresh_type_variable (linAny, `Any) in let f = tc f and h = tc h @@ -2906,7 +2907,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = | FormBinding (e, pattern) -> let e = tc e and pattern = tpc pattern in - let a = Types.fresh_type_variable (`Any, `Any) in + let a = Types.fresh_type_variable (linAny, `Any) in let ft = Instantiate.alias "Formlet" [`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)); @@ -2928,7 +2929,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (fun (generators, generator_usages, environments) -> function | List (pattern, e) -> - let a = Types.fresh_type_variable (`Any, `Any) in + let a = Types.fresh_type_variable (linAny, `Any) in let lt = Types.make_list_type a in let pattern = tpc pattern in let e = tc e in @@ -2939,8 +2940,8 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = usages e :: generator_usages, pattern_env pattern :: environments) | Table (pattern, e) -> - let a = Types.fresh_type_variable (`Any, `Any) in - let tt = Types.make_table_type (a, Types.fresh_type_variable (`Any, `Any), Types.fresh_type_variable (`Any, `Any)) in + let a = Types.fresh_type_variable (linAny, `Any) in + let tt = Types.make_table_type (a, Types.fresh_type_variable (linAny, `Any), Types.fresh_type_variable (linAny, `Any)) in let pattern = tpc pattern in let e = tc e in let () = unify ~handle:Gripers.iteration_table_body (pos_and_typ e, no_pos tt) in @@ -2957,7 +2958,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let orderby = opt_map tc orderby in let () = unify ~handle:Gripers.iteration_body - (pos_and_typ body, no_pos (Types.make_list_type (Types.fresh_type_variable (`Any, `Any)))) in + (pos_and_typ body, no_pos (Types.make_list_type (Types.fresh_type_variable (linAny, `Any)))) in let () = opt_iter (fun where -> unify ~handle:Gripers.iteration_where (pos_and_typ where, no_pos Types.bool_type)) where in @@ -2966,11 +2967,11 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = opt_iter (fun order -> unify ~handle:Gripers.iteration_base_order - (pos_and_typ order, no_pos (`Record (Types.make_empty_open_row (`Any, `Base))))) orderby in + (pos_and_typ order, no_pos (`Record (Types.make_empty_open_row (linAny, `Base))))) orderby in let () = if is_query && not (Settings.get_value Basicsettings.Shredding.relax_query_type_constraint) then unify ~handle:Gripers.iteration_base_body - (pos_and_typ body, no_pos (Types.make_list_type (`Record (Types.make_empty_open_row (`Any, `Base))))) in + (pos_and_typ body, no_pos (Types.make_list_type (`Record (Types.make_empty_open_row (linAny, `Base))))) in let e = Iteration (generators, erase body, opt_map erase where, opt_map erase orderby) in let vs = List.fold_left StringSet.union StringSet.empty (List.map Env.domain environments) in let us = merge_usages (List.append generator_usages @@ -3004,10 +3005,10 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (Also, should the mailbox type be generalised?) *) let name = name_of_binder bndr in - let f = Types.fresh_type_variable (`Any, `Any) in - let t = Types.fresh_type_variable (`Any, `Any) in + let f = Types.fresh_type_variable (linAny, `Any) in + let t = Types.fresh_type_variable (linAny, `Any) in - let eff = Types.make_singleton_open_row ("wild", `Present Types.unit_type) (`Any, `Any) in + let eff = Types.make_singleton_open_row ("wild", `Present Types.unit_type) (linAny, `Any) in let cont_type = `Function (Types.make_tuple_type [f], eff, t) in let context' = {context @@ -3016,7 +3017,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let () = let outer_effects = - Types.make_singleton_open_row ("wild", `Present Types.unit_type) (`Any, `Any) + Types.make_singleton_open_row ("wild", `Present Types.unit_type) (linAny, `Any) in unify ~handle:Gripers.escape_outer (no_pos (`Record context.effect_row), no_pos (`Record outer_effects)) in @@ -3104,30 +3105,30 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = unify ~handle:Gripers.projection ((exp_pos r, rt), no_pos (`Record (Types.make_singleton_closed_row - (l, `Present (Types.fresh_type_variable (`Any, `Any)))))); + (l, `Present (Types.fresh_type_variable (linAny, `Any)))))); let r' = erase r in let rn, rpos = r'.node, r'.pos in let e = tabstr (pqs, Projection (with_pos rpos (tappl (rn, tyargs)), l)) in e, fieldtype, usages r | Some (`Absent | `Var _) | None -> - let fieldtype = Types.fresh_type_variable (`Any, `Any) in + let fieldtype = Types.fresh_type_variable (linAny, `Any) in unify ~handle:Gripers.projection ((exp_pos r, rt), no_pos (`Record (Types.make_singleton_open_row (l, `Present fieldtype) - (`Unl, `Any)))); + (linUnl, `Any)))); let r' = erase r in let rn, rpos = r'.node, r'.pos in let e = Projection (with_pos rpos (tappl (rn, tyargs)), l) in e, fieldtype, usages r end | _ -> - let fieldtype = Types.fresh_type_variable (`Any, `Any) in + let fieldtype = Types.fresh_type_variable (linAny, `Any) in unify ~handle:Gripers.projection (pos_and_typ r, no_pos (`Record (Types.make_singleton_open_row (l, `Present fieldtype) - (`Unl, `Any)))); + (linUnl, `Any)))); Projection (erase r, l), fieldtype, usages r end | With (r, fields) -> @@ -3138,8 +3139,8 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let fields_type = `Record (List.fold_right (fun (lab, _) row -> - Types.row_with (lab, `Present (Types.fresh_type_variable (`Unl, `Any))) row) - fields (Types.make_empty_open_row (`Any, `Any))) in + Types.row_with (lab, `Present (Types.fresh_type_variable (linUnl, `Any))) row) + fields (Types.make_empty_open_row (linAny, `Any))) in unify ~handle:Gripers.record_with (pos_and_typ r, no_pos fields_type) in let (rfields, row_var, lr), _ = Types.unwrap_row (TypeUtils.extract_row (typ r)) in assert (not lr); @@ -3229,11 +3230,11 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = in let type_cases val_cases eff_cases = let wild_row () = - let fresh_row = Types.make_empty_open_row (`Unl, `Any) in + let fresh_row = Types.make_empty_open_row (linUnl, `Any) in allow_wild fresh_row in - let rt = Types.fresh_type_variable (`Unl, `Any) in - let bt = Types.fresh_type_variable (`Unl, `Any) in + let rt = Types.fresh_type_variable (linUnl, `Any) in + let bt = Types.fresh_type_variable (linUnl, `Any) in let inner_eff = wild_row () in let outer_eff = wild_row () in (* Type value patterns *) @@ -3303,10 +3304,10 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = | Any -> let kt = let domain = - (Types.fresh_type_variable (`Unl, `Any)) :: handler_params + (Types.fresh_type_variable (linUnl, `Any)) :: handler_params in - let effects = Types.make_empty_open_row (`Unl, `Any) in - let codomain = Types.fresh_type_variable (`Unl, `Any) in + let effects = Types.make_empty_open_row (linUnl, `Any) in + let codomain = Types.fresh_type_variable (linUnl, `Any) in Types.make_function_type domain effects codomain in (pat, env, effrow), (kpat, Env.empty, kt) @@ -3347,9 +3348,9 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = | Any -> let kt = Types.make_function_type - [Types.fresh_type_variable (`Unl, `Any)] - (Types.make_empty_open_row (`Unl, `Any)) - (Types.fresh_type_variable (`Unl, `Any)) + [Types.fresh_type_variable (linUnl, `Any)] + (Types.make_empty_open_row (linUnl, `Any)) + (Types.fresh_type_variable (linUnl, `Any)) in (pat, env, effrow), (kpat, Env.empty, kt) | _ -> assert false @@ -3414,13 +3415,13 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (fun name p -> if TypeUtils.is_builtin_effect name then p - else Types.fresh_presence_variable (`Unl, `Any)) (* It is questionable whether it is ever correct to + else Types.fresh_presence_variable (linUnl, `Any)) (* It is questionable whether it is ever correct to make absent operations polymorphic in their presence. *) operations in (operations', rho, dual) in - let m_context = { context with effect_row = Types.make_empty_open_row (`Unl, `Any) } in + let m_context = { context with effect_row = Types.make_empty_open_row (linUnl, `Any) } in let m = type_check m_context m in (* Type-check the input computation m under current context *) let m_effects = `Effect m_context.effect_row in (** Most of the work is done by `type_cases'. *) @@ -3474,9 +3475,9 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let (row, return_type, args) = let ps = List.map tc args in let inp_t = List.map typ ps in - let out_t = Types.fresh_type_variable (`Unl, `Any) in + let out_t = Types.fresh_type_variable (linUnl, `Any) in let optype = Types.make_pure_function_type inp_t out_t in - let effrow = Types.make_singleton_open_row (opname, `Present optype) (`Unl, `Effect) in + let effrow = Types.make_singleton_open_row (opname, `Present optype) (linUnl, `Effect) in (effrow, out_t, ps) in let (_,_,p) = SourceCode.resolve_pos pos in @@ -3559,7 +3560,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (erase try_phrase, erase_pat pat, erase in_phrase, erase unless_phrase, Some return_type), return_type, usages_res | QualifiedVar _ -> assert false - | Raise -> (Raise, Types.fresh_type_variable (`Any, `Any), StringMap.empty) + | Raise -> (Raise, Types.fresh_type_variable (linAny, `Any), StringMap.empty) in with_pos pos e, t, usages (** [type_binding] takes XXX YYY (FIXME) @@ -3633,8 +3634,8 @@ and type_binding : context -> binding -> binding * context * usagemap = let vs = name :: check_for_duplicate_names pos (List.flatten pats) in let pats = List.map (List.map tpc) pats in - let effects = Types.make_empty_open_row (`Any, `Any) in - let return_type = Types.fresh_type_variable (`Any, `Any) in + let effects = Types.make_empty_open_row (linAny, `Any) in + let return_type = Types.fresh_type_variable (linAny, `Any) in (** Check that any annotation matches the shape of the function *) let context', ft = @@ -3718,7 +3719,7 @@ and type_binding : context -> binding -> binding * context * usagemap = As well as the function types, the typed patterns are also returned here as a simple optimisation. *) - let fresh_wild () = Types.make_singleton_open_row ("wild", (`Present Types.unit_type)) (`Any, `Any) in + let fresh_wild () = Types.make_singleton_open_row ("wild", (`Present Types.unit_type)) (linAny, `Any) in let inner_env, patss = List.fold_left @@ -3740,10 +3741,10 @@ and type_binding : context -> binding -> binding * context * usagemap = f(x1)...(xk) } *) - make_ft_poly_curry lin pats (fresh_wild ()) (Types.fresh_type_variable (`Any, `Any)) + make_ft_poly_curry lin pats (fresh_wild ()) (Types.fresh_type_variable (linAny, `Any)) | Some (_, Some t) -> (* Debug.print ("t: " ^ Types.string_of_datatype t); *) - let shape = make_ft lin pats (fresh_wild ()) (Types.fresh_type_variable (`Any, `Any)) in + let shape = make_ft lin pats (fresh_wild ()) (Types.fresh_type_variable (linAny, `Any)) in let (_, ft) = Generalise.generalise_rigid context.var_env t in (* Debug.print ("ft: " ^ Types.string_of_datatype ft); *) (* make sure the annotation has the right shape *) @@ -3953,8 +3954,8 @@ and type_cp (context : context) = fun {node = p; pos} -> | CPGrab ((c, _), Some bndr, p) -> let x = name_of_binder bndr in let (_, t, _) = type_check context (with_pos pos (Sugartypes.Var c)) in - let a = Types.fresh_type_variable (`Any, `Any) in - let s = Types.fresh_session_variable `Any in + let a = Types.fresh_type_variable (linAny, `Any) in + let s = Types.fresh_session_variable linAny in let ctype = `Input (a, s) in unify ~pos:pos ~handle:(Gripers.cp_grab c) (t, ctype); @@ -3989,7 +3990,7 @@ and type_cp (context : context) = fun {node = p; pos} -> | CPGive ((c, _), Some e, p) -> let (_, t, _) = type_check context (with_pos pos (Sugartypes.Var c)) in let (e, t', u) = type_check context e in - let s = Types.fresh_session_variable `Any in + let s = Types.fresh_session_variable linAny in let ctype = `Output (t', s) in unify ~pos:pos ~handle:(Gripers.cp_give c) (t, ctype); @@ -4019,8 +4020,8 @@ and type_cp (context : context) = fun {node = p; pos} -> | CPSelect (bndr, label, p) -> let c = name_of_binder bndr in let (_, t, _) = type_check context (with_pos pos (Sugartypes.Var c)) in - let s = Types.fresh_session_variable `Any in - let r = Types.make_singleton_open_row (label, `Present s) (`Any, `Session) in + let s = Types.fresh_session_variable linAny in + let r = Types.make_singleton_open_row (label, `Present s) (linAny, `Session) in let ctype = `Select r in unify ~pos:pos ~handle:(Gripers.cp_select c) (t, ctype); @@ -4030,19 +4031,19 @@ and type_cp (context : context) = fun {node = p; pos} -> let c = name_of_binder bndr in let (_, t, _) = type_check context (with_pos pos (Sugartypes.Var c)) in (* - let crow = Types.make_empty_open_row (`Any, `Session) in + let crow = Types.make_empty_open_row (linAny, `Session) in let ctype = `Choice crow in unify ~pos:pos ~handle:(Gripers.cp_offer_choice c) (t, ctype); *) let check_branch (label, body) = - let s = Types.fresh_type_variable (`Any, `Session) in - let r = Types.make_singleton_open_row (label, `Present s) (`Any, `Session) in + let s = Types.fresh_type_variable (linAny, `Session) in + let r = Types.make_singleton_open_row (label, `Present s) (linAny, `Session) in unify ~pos:pos ~handle:(Gripers.cp_offer_choice c) (t, `Choice r); let (p, t, u) = with_channel c s (type_cp (bind_var context (c, s)) body) in (label, p), t, u in let branches = List.map check_branch branches in - let t' = Types.fresh_type_variable (`Any, `Any) in + let t' = Types.fresh_type_variable (linAny, `Any) in List.iter (fun (_, t, _) -> unify ~pos:pos ~handle:Gripers.cp_offer_branches (t, t')) branches; let u = usage_compat (List.map (fun (_, _, u) -> u) branches) in CPOffer (set_binder_type bndr t, List.map (fun (x, _, _) -> x) branches), t', use c u @@ -4052,14 +4053,14 @@ and type_cp (context : context) = fun {node = p; pos} -> let (_, tc, uc) = type_check context (with_pos pos (Sugartypes.Var c)) in let (_, td, ud) = type_check context (with_pos pos (Sugartypes.Var d)) in unify ~pos:pos ~handle:Gripers.cp_link_session - (tc, Types.fresh_type_variable (`Any, `Session)); + (tc, Types.fresh_type_variable (linAny, `Session)); unify ~pos:pos ~handle:Gripers.cp_link_session - (td, Types.fresh_type_variable (`Any, `Session)); + (td, Types.fresh_type_variable (linAny, `Session)); unify ~pos:pos ~handle:Gripers.cp_link_dual (Types.dual_type tc, td); CPLink (set_binder_type bndr1 tc, set_binder_type bndr1 td), Types.make_endbang_type, merge_usages [uc; ud] | CPComp (bndr, left, right) -> let c = name_of_binder bndr in - let s = Types.fresh_session_variable `Any in + let s = Types.fresh_session_variable linAny in let left, t, u = with_channel c s (type_cp (bind_var context (c, s)) left) in let right, t', u' = with_channel c (`Dual s) (type_cp (bind_var context (c, `Dual s)) right) in unify ~pos:pos ~handle:Gripers.cp_comp_left (Types.make_endbang_type, t); diff --git a/core/typeUtils.ml b/core/typeUtils.ml index d3345655c..7fd0ed83b 100644 --- a/core/typeUtils.ml +++ b/core/typeUtils.ml @@ -1,3 +1,4 @@ +open CommonTypes open Utility open Types @@ -214,7 +215,7 @@ let rec table_needed_type t = match concrete_type t with error ("Attempt to take needed type of non-table: " ^ string_of_datatype t) let inject_type name t = - `Variant (make_singleton_open_row (name, `Present t) (`Any, `Any)) + `Variant (make_singleton_open_row (name, `Present t) (linAny, `Any)) let abs_type _ = assert false let app_type _ _ = assert false diff --git a/core/types.ml b/core/types.ml index baf896634..6be7adaa9 100644 --- a/core/types.ml +++ b/core/types.ml @@ -1,4 +1,5 @@ open Utility +open CommonTypes [@@@ocaml.warning "-32"] (** disable warnings about unused functions in this module**) @@ -18,12 +19,10 @@ type 'a point = 'a Unionfind.point [@@deriving show] type primitive = [ `Bool | `Int | `Char | `Float | `XmlItem | `DB | `String] [@@deriving show] -type linearity = [ `Any | `Unl ] - [@@deriving eq,show] type restriction = [ `Any | `Base | `Session | `Effect ] [@@deriving eq,show] -type subkind = linearity * restriction +type subkind = Linearity.t * restriction [@@deriving eq,show] type freedom = [`Rigid | `Flexible] @@ -74,7 +73,7 @@ end let process = { Abstype.id = "Process" ; name = "Process" ; - arity = [`Row, (`Any, `Any)] ; + arity = [`Row, (linAny, `Any)] ; } (* Lists are currently unlimited because the only deconstructors are @@ -83,7 +82,7 @@ let process = { let list = { Abstype.id = "List" ; name = "List" ; - arity = [`Type, (`Unl, `Any)] ; + arity = [`Type, (linUnl, `Any)] ; } let event = { @@ -100,7 +99,7 @@ let dom_node = { let access_point = { Abstype.id = "AP" ; name = "AP" ; - arity = [`Type, (`Any, `Session)] ; + arity = [`Type, (linAny, `Session)] ; } let socket = { @@ -266,7 +265,7 @@ struct (IntMap.find var rec_types), o else let var' = fresh_raw_variable () in - let point' : meta_type_var = Unionfind.fresh (`Var (var', (`Any, `Any), `Flexible)) in + let point' : meta_type_var = Unionfind.fresh (`Var (var', (linAny, `Any), `Flexible)) in let rec_types' : (meta_type_var) IntMap.t = IntMap.add var point' rec_types in let o_extended_rec_env = {< rec_vars = (rec_types', rec_rows) >} in let (t', o') = o_extended_rec_env#typ t in @@ -286,7 +285,7 @@ struct (IntMap.find var rec_rows), o else let var' = fresh_raw_variable () in - let point' = Unionfind.fresh (`Var (var', (`Any, `Any), `Flexible)) in + let point' = Unionfind.fresh (`Var (var', (linAny, `Any), `Flexible)) in let rec_rows' = IntMap.add var point' rec_rows in let o_extended_rec_env = {< rec_vars = (rec_types, rec_rows') >} in let (r', o') = o_extended_rec_env#row r in @@ -439,7 +438,7 @@ struct method! meta_type_var point = match Unionfind.find point with | `Recursive (id, t) -> if Utility.IntSet.mem id mu_vars then - let newvar = `Var (id, (`Any, `Any), `Rigid) in + let newvar = `Var (id, (linAny, `Any), `Rigid) in (* Debug.print (Printf.sprintf "Saw rec var %d" id); *) (Unionfind.fresh newvar, o) else @@ -452,7 +451,7 @@ struct method! meta_row_var point = match Unionfind.find point with | `Recursive (id, t) -> if Utility.IntSet.mem id mu_vars then - let newvar = `Var (id, (`Any, `Any), `Rigid) in + let newvar = `Var (id, (linAny, `Any), `Rigid) in (* Debug.print (Printf.sprintf "Saw rec var %d" id); *) (Unionfind.fresh newvar, o) else @@ -645,7 +644,7 @@ let is_unl_point = begin match Unionfind.find point with | `Closed -> true - | `Var (var, (lin, _), _) -> IntSet.mem var quant_vars || lin=`Unl + | `Var (var, (lin, _), _) -> IntSet.mem var quant_vars || isUnl lin | `Body t -> f (rec_vars, quant_vars) t | `Recursive (var, t) -> check_rec var rec_vars true (fun rec_vars' -> f (rec_vars', quant_vars) t) @@ -694,7 +693,7 @@ let point_can_be_unl = begin match Unionfind.find point with | `Closed -> true - | `Var (v, (lin, _), `Rigid) -> IntSet.mem v quant_vars || lin=`Unl + | `Var (v, (lin, _), `Rigid) -> IntSet.mem v quant_vars || isUnl lin | `Var (_, _, `Flexible) -> true | `Body t -> f vars t | `Recursive (var, t) -> @@ -748,8 +747,8 @@ let make_point_unl : ((var_set * var_set) -> 'a -> unit) -> (var_set * var_set) fun f ((rec_vars, quant_vars) as vars) point -> match Unionfind.find point with | `Closed -> () - | `Var (v, (lin, _), `Rigid) -> if IntSet.mem v quant_vars || lin = `Unl then () else assert false - | `Var (var, (_, rest), `Flexible) -> Unionfind.change point (`Var (var, (`Unl, rest), `Flexible)) + | `Var (v, (lin, _), `Rigid) -> if IntSet.mem v quant_vars || isUnl lin then () else assert false + | `Var (var, (_, rest), `Flexible) -> Unionfind.change point (`Var (var, (linUnl, rest), `Flexible)) | `Body t -> f vars t | `Recursive (var, t) -> check_rec var rec_vars () (fun rec_vars' -> f (rec_vars', quant_vars) t) @@ -1403,7 +1402,7 @@ and flatten_row : row -> row = fun (field_env, row_var, dual) -> else (let row_var' = Unionfind.fresh (`Recursive (var, (FieldEnv.empty, - Unionfind.fresh (`Var (var, (`Any, `Any), `Flexible)), + Unionfind.fresh (`Var (var, (linAny, `Any), `Flexible)), false))) in let rec_row' = flatten_row' (IntMap.add var row_var' rec_env) rec_row in Unionfind.change row_var' (`Recursive (var, rec_row')); @@ -1890,16 +1889,13 @@ struct | s -> "::" ^ s let subkind : (policy * names) -> subkind -> string = - let linearity = function - | `Any -> "Any" - | `Unl -> "Unl" in let restriction = function | `Any -> "Any" | `Base -> "Base" | `Session -> "Session" | `Effect -> "Eff" in - let full (l, r) = "(" ^ linearity l ^ "," ^ restriction r ^ ")" in + let full (l, r) = "(" ^ string_of_linearity l ^ "," ^ restriction r ^ ")" in fun (policy, _vars) -> if policy.kinds = "full" then @@ -1908,11 +1904,11 @@ struct function (_, _) -> "" else function - | (`Unl, `Any) -> "" - | (`Any, `Any) -> "Any" - | (`Unl, `Base) -> restriction `Base - | (`Any, `Session) -> restriction `Session - | (`Unl, `Effect) -> restriction `Effect + | (Linearity.Unl, `Any) -> "" + | (Linearity.Any, `Any) -> "Any" + | (Linearity.Unl, `Base) -> restriction `Base + | (Linearity.Any, `Session) -> restriction `Session + | (Linearity.Unl, `Effect) -> restriction `Effect | (l, r) -> full (l, r) let primary_kind : primary_kind -> string = function @@ -1936,13 +1932,13 @@ struct primary_kind k else match (k, sk) with - | `Type, (`Unl, `Any) -> "" - | `Type, (`Unl, `Base) -> restriction `Base - | `Type, (`Any, `Session) -> restriction `Session + | `Type, (Linearity.Unl, `Any) -> "" + | `Type, (Linearity.Unl, `Base) -> restriction `Base + | `Type, (Linearity.Any, `Session) -> restriction `Session | `Type, sk -> subkind ({policy with kinds="full"}, _vars) sk - | `Row, (`Unl, `Any) -> primary_kind `Row - | `Row, (`Unl, `Effect) -> primary_kind `Row - | `Presence, (`Unl, `Any) -> primary_kind `Presence + | `Row, (Linearity.Unl, `Any) -> primary_kind `Row + | `Row, (Linearity.Unl, `Effect) -> primary_kind `Row + | `Presence, (Linearity.Unl, `Any) -> primary_kind `Presence | `Row, _ | `Presence, _ -> full ({policy with kinds="full"}, _vars) (k, sk) @@ -2524,15 +2520,15 @@ 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 (`Any, `Any)) tenv, - IntMap.map (fun _ -> (StringMap.empty, fresh_rigid_row_variable (`Any, `Any), false)) renv, - IntMap.map (fun _ -> fresh_rigid_presence_variable (`Any, `Any)) penv) + (IntMap.map (fun _ -> fresh_rigid_type_variable (Linearity.Any, `Any)) tenv, + IntMap.map (fun _ -> (StringMap.empty, fresh_rigid_row_variable (Linearity.Any, `Any), false)) renv, + IntMap.map (fun _ -> fresh_rigid_presence_variable (Linearity.Any, `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 (`Any, `Any)) tenv, - IntMap.map (fun _ -> (StringMap.empty, fresh_row_variable (`Any, `Any), false)) renv, - IntMap.map (fun _ -> fresh_presence_variable (`Any, `Any)) penv) + (IntMap.map (fun _ -> fresh_type_variable (Linearity.Any, `Any)) tenv, + IntMap.map (fun _ -> (StringMap.empty, fresh_row_variable (Linearity.Any, `Any), false)) renv, + IntMap.map (fun _ -> fresh_presence_variable (Linearity.Any, `Any)) penv) (* subtyping *) diff --git a/core/types.mli b/core/types.mli index 90cc1b9bb..8c047561c 100644 --- a/core/types.mli +++ b/core/types.mli @@ -16,10 +16,8 @@ type primitive = [ `Bool | `Int | `Char | `Float | `XmlItem | `DB | `String ] type restriction = [ `Any | `Base | `Session | `Effect ] [@@deriving eq,show] -type linearity = [ `Any | `Unl ] - [@@deriving eq,show] -type subkind = linearity * restriction +type subkind = CommonTypes.Linearity.t * restriction [@@deriving eq,show] type freedom = [`Rigid | `Flexible] @@ -263,7 +261,7 @@ val fresh_rigid_type_variable : subkind -> datatype val fresh_row_variable : subkind -> row_var val fresh_rigid_row_variable : subkind -> row_var -val fresh_session_variable : linearity -> datatype +val fresh_session_variable : CommonTypes.Linearity.t -> datatype val fresh_presence_variable : subkind -> field_spec val fresh_rigid_presence_variable : subkind -> field_spec diff --git a/core/unify.ml b/core/unify.ml index b13356845..cb939b6d7 100644 --- a/core/unify.ml +++ b/core/unify.ml @@ -1,3 +1,4 @@ +open CommonTypes open Utility open Types open Typevarcheck @@ -312,8 +313,8 @@ let rec unify' : unify_env -> (datatype * datatype) -> unit = begin let lin = match llin, rlin with - | `Unl, _ - | _, `Unl -> `Unl + | Linearity.Unl, _ + | _, Linearity.Unl -> Linearity.Unl | _ -> llin in let rest = match lrest, rrest with @@ -380,7 +381,7 @@ let rec unify' : unify_env -> (datatype * datatype) -> unit = else raise (Failure (`Msg ("Cannot unify the base type variable "^ string_of_int var ^ " with the non-base type "^ string_of_datatype t2))); - if lin = `Unl then + if isUnl lin then if Types.type_can_be_unl t2 then Types.make_type_unl t2 else @@ -420,7 +421,7 @@ let rec unify' : unify_env -> (datatype * datatype) -> unit = else raise (Failure (`Msg ("Cannot unify the base type variable "^ string_of_int var ^ " with the non-base type "^ string_of_datatype t1))); - if lin = `Unl then + if isUnl lin then if Types.type_can_be_unl t1 then Types.make_type_unl t1 else @@ -534,7 +535,7 @@ let rec unify' : unify_env -> (datatype * datatype) -> unit = else raise (Failure (`Msg ("Cannot unify the base type variable "^ string_of_int var ^ " with the non-base type "^ string_of_datatype t))); - if lin = `Unl then + if isUnl lin then if Types.type_can_be_unl t then Types.make_type_unl t else @@ -1029,7 +1030,7 @@ and unify_rows' : unify_env -> ((row * row) -> unit) = raise (Failure (`Msg ("Cannot unify the session row variable "^ string_of_int var ^ " with the non-session row "^ string_of_row extension_row))); - if lin = `Unl then + if isUnl lin then if Types.row_can_be_unl extension_row then Types.make_row_unl extension_row else @@ -1210,7 +1211,7 @@ and unify_rows' : unify_env -> ((row * row) -> unit) = unify_field_envs ~closed:false ~rigid:false rec_env (lfield_env', rfield_env'); (* a fresh row variable common to the left and the right *) - let fresh_row_var = fresh_row_variable (`Any, `Any) in + let fresh_row_var = fresh_row_variable (linAny, `Any) 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 From 294410213c1cce1f51a3c5d554d65ae8cad38b5d Mon Sep 17 00:00:00 2001 From: Jan Stolarek Date: Wed, 20 Feb 2019 17:12:28 +0000 Subject: [PATCH 17/28] Formatting only --- core/sugartypes.ml | 240 ++++++++++++++++++++++----------------------- 1 file changed, 120 insertions(+), 120 deletions(-) diff --git a/core/sugartypes.ml b/core/sugartypes.ml index 6b423a2b6..d9c8a2df6 100644 --- a/core/sugartypes.ml +++ b/core/sugartypes.ml @@ -183,19 +183,19 @@ type constant = Constant.constant module Pattern = struct type t = - | Any - | Nil - | Cons of with_pos * with_pos - | List of with_pos list - | Variant of name * with_pos option - | Effect of name * with_pos list * with_pos - | Negative of name list - | Record of (name * with_pos) list * with_pos option - | Tuple of with_pos list - | Constant of constant - | Variable of binder - | As of binder * with_pos - | HasType of with_pos * datatype' + | Any + | Nil + | Cons of with_pos * with_pos + | List of with_pos list + | Variant of name * with_pos option + | Effect of name * with_pos list * with_pos + | Negative of name list + | Record of (name * with_pos) list * with_pos option + | Tuple of with_pos list + | Constant of constant + | Variable of binder + | As of binder * with_pos + | HasType of with_pos * datatype' and with_pos = t WithPos.t [@@deriving show] end @@ -218,25 +218,25 @@ type handler_depth = Deep | Shallow [@@deriving show] type replace_rhs = -| Literal of string -| SpliceExpr of phrase + | Literal of string + | SpliceExpr of phrase and given_spawn_location = -| ExplicitSpawnLocation of phrase (* spawnAt function *) -| SpawnClient (* spawnClient function *) -| NoSpawnLocation (* spawn function *) + | ExplicitSpawnLocation of phrase (* spawnAt function *) + | SpawnClient (* spawnClient function *) + | NoSpawnLocation (* spawn function *) and regex = -| Range of (char * char) -| Simply of string -| Quote of regex -| Any -| StartAnchor -| EndAnchor -| Seq of regex list -| Alternate of (regex * regex) -| Group of regex -| Repeat of (Regex.repeat * regex) -| Splice of phrase -| Replace of (regex * replace_rhs) + | Range of (char * char) + | Simply of string + | Quote of regex + | Any + | StartAnchor + | EndAnchor + | Seq of regex list + | Alternate of (regex * regex) + | Group of regex + | Repeat of (Regex.repeat * regex) + | Splice of phrase + | Replace of (regex * replace_rhs) and clause = Pattern.with_pos * phrase and funlit = Pattern.with_pos list list * phrase and handlerlit = handler_depth * Pattern.with_pos * clause list * Pattern.with_pos list list option (* computation arg, cases, parameters *) @@ -257,108 +257,108 @@ and handler_parameterisation = { shp_types: Types.datatype list } and iterpatt = -| List of (Pattern.with_pos * phrase) -| Table of (Pattern.with_pos * phrase) + | List of (Pattern.with_pos * phrase) + | Table of (Pattern.with_pos * phrase) and phrasenode = -| Constant of constant -| Var of name -| QualifiedVar of name list -| FunLit of ((Types.datatype * Types.row) list) option * declared_linearity * funlit * location -| HandlerLit of handlerlit -(* Spawn kind, expression referring to spawn location (client n, server...), spawn block, row opt *) -| Spawn of spawn_kind * given_spawn_location * phrase * Types.row option -| Query of (phrase * phrase) option * phrase * Types.datatype option -| RangeLit of (phrase * phrase) -| ListLit of phrase list * Types.datatype option -| Iteration of iterpatt list * phrase - * (*where:*) phrase option - * (*orderby:*) phrase option -| Escape of binder * phrase -| Section of Section.t -| Conditional of phrase * phrase * phrase -| Block of block_body -| InfixAppl of (tyarg list * binop) * phrase * phrase -| Regex of regex -| UnaryAppl of (tyarg list * unary_op) * phrase -| FnAppl of phrase * phrase list -| TAbstr of tyvar list ref * phrase -| TAppl of phrase * tyarg list -| TupleLit of phrase list -| RecordLit of (name * phrase) list * phrase option -| Projection of phrase * name -| With of phrase * (name * phrase) list -| TypeAnnotation of phrase * datatype' -| Upcast of phrase * datatype' * datatype' -| ConstructorLit of name * phrase option * Types.datatype option -| DoOperation of name * phrase list * Types.datatype option -| Handle of handler -| Switch of phrase * (Pattern.with_pos * phrase) list * Types.datatype option -| Receive of (Pattern.with_pos * phrase) list * Types.datatype option -| DatabaseLit of phrase * (phrase option * phrase option) -| TableLit of phrase * (Datatype.with_pos * (Types.datatype * Types.datatype * Types.datatype) option) * (name * fieldconstraint list) list * phrase * phrase -| DBDelete of Pattern.with_pos * phrase * phrase option -| DBInsert of phrase * name list * phrase * phrase option -| DBUpdate of Pattern.with_pos * phrase * phrase option * (name * phrase) list -| LensLit of phrase * Types.lens_sort option -(* the lens keys lit is a literal that takes an expression and is converted into a LensLit + | Constant of constant + | Var of name + | QualifiedVar of name list + | FunLit of ((Types.datatype * Types.row) list) option * declared_linearity * funlit * location + | HandlerLit of handlerlit + (* Spawn kind, expression referring to spawn location (client n, server...), spawn block, row opt *) + | Spawn of spawn_kind * given_spawn_location * phrase * Types.row option + | Query of (phrase * phrase) option * phrase * Types.datatype option + | RangeLit of (phrase * phrase) + | ListLit of phrase list * Types.datatype option + | Iteration of iterpatt list * phrase + * (*where:*) phrase option + * (*orderby:*) phrase option + | Escape of binder * phrase + | Section of Section.t + | Conditional of phrase * phrase * phrase + | Block of block_body + | InfixAppl of (tyarg list * binop) * phrase * phrase + | Regex of regex + | UnaryAppl of (tyarg list * unary_op) * phrase + | FnAppl of phrase * phrase list + | TAbstr of tyvar list ref * phrase + | TAppl of phrase * tyarg list + | TupleLit of phrase list + | RecordLit of (name * phrase) list * phrase option + | Projection of phrase * name + | With of phrase * (name * phrase) list + | TypeAnnotation of phrase * datatype' + | Upcast of phrase * datatype' * datatype' + | ConstructorLit of name * phrase option * Types.datatype option + | DoOperation of name * phrase list * Types.datatype option + | Handle of handler + | Switch of phrase * (Pattern.with_pos * phrase) list * Types.datatype option + | Receive of (Pattern.with_pos * phrase) list * Types.datatype option + | DatabaseLit of phrase * (phrase option * phrase option) + | TableLit of phrase * (Datatype.with_pos * (Types.datatype * Types.datatype * Types.datatype) option) * (name * fieldconstraint list) list * phrase * phrase + | DBDelete of Pattern.with_pos * phrase * phrase option + | DBInsert of phrase * name list * phrase * phrase option + | DBUpdate of Pattern.with_pos * phrase * phrase option * (name * phrase) list + | LensLit of phrase * Types.lens_sort 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 * Types.lens_sort option -| LensFunDepsLit of phrase * (string list * string list) list * Types.lens_sort option -| LensDropLit of phrase * string * string * phrase * Types.lens_sort option -| LensSelectLit of phrase * phrase * Types.lens_sort option -| LensJoinLit of phrase * phrase * phrase * phrase * phrase * Types.lens_sort option -| LensGetLit of phrase * Types.datatype option -| LensPutLit of phrase * phrase * Types.datatype option -| Xml of name * (name * (phrase list)) list * phrase option * phrase list -| TextNode of string -| Formlet of phrase * phrase -| Page of phrase -| FormletPlacement of phrase * phrase * phrase -| PagePlacement of phrase -| FormBinding of phrase * Pattern.with_pos -(* choose *) -| Select of name * phrase -(* choice *) -| Offer of phrase * (Pattern.with_pos * phrase) list * Types.datatype option -| CP of cp_phrase -| TryInOtherwise of (phrase * Pattern.with_pos * phrase * phrase * Types.datatype option) -| Raise + | LensKeysLit of phrase * phrase * Types.lens_sort option + | LensFunDepsLit of phrase * (string list * string list) list * Types.lens_sort option + | LensDropLit of phrase * string * string * phrase * Types.lens_sort option + | LensSelectLit of phrase * phrase * Types.lens_sort option + | LensJoinLit of phrase * phrase * phrase * phrase * phrase * Types.lens_sort option + | LensGetLit of phrase * Types.datatype option + | LensPutLit of phrase * phrase * Types.datatype option + | Xml of name * (name * (phrase list)) list * phrase option * phrase list + | TextNode of string + | Formlet of phrase * phrase + | Page of phrase + | FormletPlacement of phrase * phrase * phrase + | PagePlacement of phrase + | FormBinding of phrase * Pattern.with_pos + (* choose *) + | Select of name * phrase + (* choice *) + | Offer of phrase * (Pattern.with_pos * phrase) list * Types.datatype option + | CP of cp_phrase + | TryInOtherwise of (phrase * Pattern.with_pos * phrase * phrase * Types.datatype option) + | Raise and phrase = phrasenode with_pos and bindingnode = -| Val of (Pattern.with_pos * (tyvar list * phrase) * location * datatype' option) -| Fun of (binder * declared_linearity * (tyvar list * funlit) * location * datatype' option) -| Funs of (binder * declared_linearity * - ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * - location * datatype' option * position) list -| Handler of (binder * handlerlit * datatype' option) -| Foreign of (binder * name * name * name * datatype') (* Binder, raw function name, language, external file, type *) -| QualifiedImport of name list -| Type of (name * (quantifier * tyvar option) list * datatype') -| Infix -| Exp of phrase -| Module of (name * binding list) -| AlienBlock of (name * name * ((binder * datatype') list)) + | Val of (Pattern.with_pos * (tyvar list * phrase) * location * datatype' option) + | Fun of (binder * declared_linearity * (tyvar list * funlit) * location * datatype' option) + | Funs of (binder * declared_linearity * + ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * + location * datatype' option * position) list + | Handler of (binder * handlerlit * datatype' option) + | Foreign of (binder * name * name * name * datatype') (* Binder, raw function name, language, external file, type *) + | QualifiedImport of name list + | Type of (name * (quantifier * tyvar option) list * datatype') + | Infix + | Exp of phrase + | Module of (name * binding list) + | AlienBlock of (name * name * ((binder * datatype') list)) and binding = bindingnode with_pos and block_body = binding list * phrase and cp_phrasenode = -| CPUnquote of (binding list * phrase) -| CPGrab of (string * (Types.datatype * tyarg list) option) * binder option * cp_phrase -| CPGive of (string * (Types.datatype * tyarg list) option) * phrase option * cp_phrase -| CPGiveNothing of binder -| CPSelect of (binder * string * cp_phrase) -| CPOffer of (binder * (string * cp_phrase) list) -| CPLink of (binder * binder) -| CPComp of (binder * cp_phrase * cp_phrase) + | CPUnquote of (binding list * phrase) + | CPGrab of (string * (Types.datatype * tyarg list) option) * binder option * cp_phrase + | CPGive of (string * (Types.datatype * tyarg list) option) * phrase option * cp_phrase + | CPGiveNothing of binder + | CPSelect of (binder * string * cp_phrase) + | CPOffer of (binder * (string * cp_phrase) list) + | CPLink of (binder * binder) + | CPComp of (binder * cp_phrase * cp_phrase) and cp_phrase = cp_phrasenode with_pos - [@@deriving show] + [@@deriving show] type directive = string * string list - [@@deriving show] + [@@deriving show] type sentence = -| Definitions of binding list -| Expression of phrase -| Directive of directive + | Definitions of binding list + | Expression of phrase + | Directive of directive [@@deriving show] type program = binding list * phrase option From a9b618350c525c542efef048c02623085736fc10 Mon Sep 17 00:00:00 2001 From: Jan Stolarek Date: Wed, 20 Feb 2019 17:29:17 +0000 Subject: [PATCH 18/28] Wrap Sugartypes.ml to 80 lines --- core/sugartypes.ml | 126 +++++++++++++++++++++++++++++---------------- 1 file changed, 82 insertions(+), 44 deletions(-) diff --git a/core/sugartypes.ml b/core/sugartypes.ml index d9c8a2df6..2239eba0a 100644 --- a/core/sugartypes.ml +++ b/core/sugartypes.ml @@ -19,9 +19,13 @@ type unary_op = [ | `FloatMinus | `Name of name ] -and regexflag = RegexList | RegexNative | RegexGlobal | RegexReplace +[@@deriving show] + +type regexflag = RegexList | RegexNative | RegexGlobal | RegexReplace [@@deriving show] -type binop = [ `Minus | `FloatMinus | `RegexMatch of regexflag list | `And | `Or | `Cons | `Name of name ] + +type binop = [ `Minus | `FloatMinus | `RegexMatch of regexflag list | `And | `Or + | `Cons | `Name of name ] [@@deriving show] let string_of_unary_op = @@ -49,11 +53,11 @@ let binop_of_string : string -> binop = | "::" -> `Cons | name -> `Name name - type position = SourceCode.pos let dummy_position = SourceCode.dummy_pos -let pp_position : Format.formatter -> position -> unit = fun fmt _ -> Utility.format_omission fmt +let pp_position : Format.formatter -> position -> unit = + fun fmt _ -> Utility.format_omission fmt type 'a with_pos = { node : 'a ; pos : position } @@ -77,7 +81,7 @@ let type_of_binder_exn {node=(_,ty);_} = let set_binder_name {node=(_ ,ty); pos} name = with_pos pos (name, ty ) let set_binder_type {node=(name,_ ); pos} ty = with_pos pos (name, Some ty) let erase_binder_type {node=(name,_ ); pos} = with_pos pos (name, None ) -let binder_has_type {node=(_ ,ty); _ } = Utility.OptionUtils.is_some ty +let binder_has_type {node=(_ ,ty); _ } = OptionUtils.is_some ty (* type variables *) type tyvar = Types.quantifier @@ -239,7 +243,9 @@ and regex = | Replace of (regex * replace_rhs) and clause = Pattern.with_pos * phrase and funlit = Pattern.with_pos list list * phrase -and handlerlit = handler_depth * Pattern.with_pos * clause list * Pattern.with_pos list list option (* computation arg, cases, parameters *) +and handlerlit = + handler_depth * Pattern.with_pos * clause list * + Pattern.with_pos list list option (* computation arg, cases, parameters *) and handler = { sh_expr: phrase; sh_effect_cases: clause list; @@ -263,11 +269,15 @@ and phrasenode = | Constant of constant | Var of name | QualifiedVar of name list - | FunLit of ((Types.datatype * Types.row) list) option * declared_linearity * funlit * location + | FunLit of ((Types.datatype * Types.row) list) option * + declared_linearity * funlit * location | HandlerLit of handlerlit - (* Spawn kind, expression referring to spawn location (client n, server...), spawn block, row opt *) - | Spawn of spawn_kind * given_spawn_location * phrase * Types.row option - | Query of (phrase * phrase) option * phrase * Types.datatype option + (* Spawn kind, expression referring to spawn location (client n, server...), + spawn block, row opt *) + | Spawn of spawn_kind * given_spawn_location * phrase * + Types.row option + | Query of (phrase * phrase) option * phrase * + Types.datatype option | RangeLit of (phrase * phrase) | ListLit of phrase list * Types.datatype option | Iteration of iterpatt list * phrase @@ -292,24 +302,32 @@ and phrasenode = | ConstructorLit of name * phrase option * Types.datatype option | DoOperation of name * phrase list * Types.datatype option | Handle of handler - | Switch of phrase * (Pattern.with_pos * phrase) list * Types.datatype option + | Switch of phrase * (Pattern.with_pos * phrase) list * + Types.datatype option | Receive of (Pattern.with_pos * phrase) list * Types.datatype option | DatabaseLit of phrase * (phrase option * phrase option) - | TableLit of phrase * (Datatype.with_pos * (Types.datatype * Types.datatype * Types.datatype) option) * (name * fieldconstraint list) list * phrase * phrase + | TableLit of phrase * (Datatype.with_pos * (Types.datatype * + Types.datatype * Types.datatype) option) * + (name * fieldconstraint list) list * phrase * phrase | DBDelete of Pattern.with_pos * phrase * phrase option | DBInsert of phrase * name list * phrase * phrase option - | DBUpdate of Pattern.with_pos * phrase * phrase option * (name * phrase) list + | DBUpdate of Pattern.with_pos * phrase * phrase option * + (name * phrase) list | LensLit of phrase * Types.lens_sort 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 *) + (* 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 * Types.lens_sort option - | LensFunDepsLit of phrase * (string list * string list) list * Types.lens_sort option - | LensDropLit of phrase * string * string * phrase * Types.lens_sort option + | LensFunDepsLit of phrase * (string list * string list) list * + Types.lens_sort option + | LensDropLit of phrase * string * string * phrase * + Types.lens_sort option | LensSelectLit of phrase * phrase * Types.lens_sort option - | LensJoinLit of phrase * phrase * phrase * phrase * phrase * Types.lens_sort option + | LensJoinLit of phrase * phrase * phrase * phrase * phrase * + Types.lens_sort option | LensGetLit of phrase * Types.datatype option | LensPutLit of phrase * phrase * Types.datatype option - | Xml of name * (name * (phrase list)) list * phrase option * phrase list + | Xml of name * (name * (phrase list)) list * phrase option * + phrase list | TextNode of string | Formlet of phrase * phrase | Page of phrase @@ -319,19 +337,25 @@ and phrasenode = (* choose *) | Select of name * phrase (* choice *) - | Offer of phrase * (Pattern.with_pos * phrase) list * Types.datatype option + | Offer of phrase * (Pattern.with_pos * phrase) list * + Types.datatype option | CP of cp_phrase - | TryInOtherwise of (phrase * Pattern.with_pos * phrase * phrase * Types.datatype option) + | TryInOtherwise of (phrase * Pattern.with_pos * phrase * phrase * + Types.datatype option) | Raise and phrase = phrasenode with_pos and bindingnode = - | Val of (Pattern.with_pos * (tyvar list * phrase) * location * datatype' option) - | Fun of (binder * declared_linearity * (tyvar list * funlit) * location * datatype' option) + | Val of (Pattern.with_pos * (tyvar list * phrase) * location * + datatype' option) + | Fun of (binder * declared_linearity * (tyvar list * funlit) * location * + datatype' option) | Funs of (binder * declared_linearity * - ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * - location * datatype' option * position) list + ((tyvar list * + (Types.datatype * Types.quantifier option list) option) + * funlit) * location * datatype' option * position) list | Handler of (binder * handlerlit * datatype' option) - | Foreign of (binder * name * name * name * datatype') (* Binder, raw function name, language, external file, type *) + | Foreign of (binder * name * name * name * datatype') + (* Binder, raw function name, language, external file, type *) | QualifiedImport of name list | Type of (name * (quantifier * tyvar option) list * datatype') | Infix @@ -342,8 +366,10 @@ and binding = bindingnode with_pos and block_body = binding list * phrase and cp_phrasenode = | CPUnquote of (binding list * phrase) - | CPGrab of (string * (Types.datatype * tyarg list) option) * binder option * cp_phrase - | CPGive of (string * (Types.datatype * tyarg list) option) * phrase option * cp_phrase + | CPGrab of (string * (Types.datatype * tyarg list) option) * + binder option * cp_phrase + | CPGive of (string * (Types.datatype * tyarg list) option) * + phrase option * cp_phrase | CPGiveNothing of binder | CPSelect of (binder * string * cp_phrase) | CPOffer of (binder * (string * cp_phrase) list) @@ -452,13 +478,15 @@ struct | LensPutLit (l, data, _) -> union_all [phrase l; phrase data] | Query (None, p, _) -> phrase p - | Query (Some (limit, offset), p, _) -> union_all [phrase limit; phrase offset; phrase p] + | Query (Some (limit, offset), p, _) -> + union_all [phrase limit; phrase offset; phrase p] | Escape (v, p) -> diff (phrase p) (singleton (name_of_binder v)) | FormletPlacement (p1, p2, p3) | Conditional (p1, p2, p3) -> union_map phrase [p1;p2;p3] | Block b -> block b - | InfixAppl ((_, `Name n), p1, p2) -> union (singleton n) (union_map phrase [p1;p2]) + | InfixAppl ((_, `Name n), p1, p2) -> + union (singleton n) (union_map phrase [p1;p2]) | InfixAppl (_, p1, p2) -> union_map phrase [p1;p2] | RangeLit (p1, p2) -> union_map phrase [p1;p2] | Regex r -> regex r @@ -488,16 +516,17 @@ struct | FunLit (_, _, fnlit, _) -> funlit fnlit | Iteration (generators, body, where, orderby) -> let xs = union_map (function - | List (_, source) - | Table (_, source) -> phrase source) generators in + | List (_, source) + | Table (_, source) -> phrase source) generators in let pat_bound = union_map (function - | List (pat, _) - | Table (pat, _) -> pattern pat) generators in + | List (pat, _) + | Table (pat, _) -> pattern pat) generators in union_all [xs; diff (phrase body) pat_bound; diff (option_map phrase where) pat_bound; diff (option_map phrase orderby) pat_bound] - | Handle { sh_expr = e; sh_effect_cases = eff_cases; sh_value_cases = val_cases; sh_descr = descr } -> + | Handle { sh_expr = e; sh_effect_cases = eff_cases; + sh_value_cases = val_cases; sh_descr = descr } -> let params_bound = option_map (fun params -> union_map (snd ->- pattern) params.shp_bindings) @@ -506,7 +535,9 @@ struct union_all [phrase e; union_map case eff_cases; union_map case val_cases; - diff (option_map (fun params -> union_map (fst ->- phrase) params.shp_bindings) descr.shd_params) params_bound] + diff (option_map (fun params -> union_map (fst ->- phrase) + params.shp_bindings) + descr.shd_params) params_bound] | Switch (p, cases, _) | Offer (p, cases, _) -> union (phrase p) (union_map case cases) | CP cp -> cp_phrase cp @@ -522,10 +553,12 @@ struct diff (union_map (snd ->- phrase) fields) pat_bound] | DoOperation (_, ps, _) -> union_map phrase ps | QualifiedVar _ -> empty - | TryInOtherwise (p1, pat, p2, p3, _ty) -> union (union_map phrase [p1; p2; p3]) (pattern pat) + | TryInOtherwise (p1, pat, p2, p3, _ty) -> + union (union_map phrase [p1; p2; p3]) (pattern pat) | Raise -> empty - and binding ({node = binding; _}: binding) : StringSet.t (* vars bound in the pattern *) - * StringSet.t (* free vars in the rhs *) = + and binding ({node = binding; _}: binding) + : StringSet.t (* vars bound in the pattern *) + * StringSet.t (* free vars in the rhs *) = match binding with | Val (pat, (_, rhs), _, _) -> pattern pat, phrase rhs | Handler (bndr, hnlit, _) -> @@ -558,7 +591,8 @@ struct and funlit (args, body : funlit) : StringSet.t = diff (phrase body) (union_map (union_map pattern) args) and handlerlit (_, m, cases, params : handlerlit) : StringSet.t = - union_all [diff (union_map case cases) (option_map (union_map (union_map pattern)) params); pattern m] + union_all [diff (union_map case cases) + (option_map (union_map (union_map pattern)) params); pattern m] and block (binds, expr : binding list * phrase) : StringSet.t = ListLabels.fold_right binds ~init:(phrase expr) ~f:(fun bind bodyfree -> @@ -584,14 +618,18 @@ struct | CPGrab ((c, _t), Some bndr, p) -> union (singleton c) (diff (cp_phrase p) (singleton (name_of_binder bndr))) | CPGrab ((c, _t), None, p) -> union (singleton c) (cp_phrase p) - | CPGive ((c, _t), e, p) -> union (singleton c) (union (option_map phrase e) (cp_phrase p)) + | CPGive ((c, _t), e, p) -> union (singleton c) (union (option_map phrase e) + (cp_phrase p)) | CPGiveNothing bndr -> singleton (name_of_binder bndr) | CPSelect (bndr, _label, p) -> union (singleton (name_of_binder bndr)) (cp_phrase p) | CPOffer (bndr, cases) -> - union (singleton (name_of_binder bndr)) (union_map (fun (_label, p) -> cp_phrase p) cases) + union (singleton (name_of_binder bndr)) + (union_map (fun (_label, p) -> cp_phrase p) cases) | CPLink (bndr1, bndr2) -> - union (singleton (name_of_binder bndr1)) (singleton (name_of_binder bndr2)) + union (singleton (name_of_binder bndr1)) + (singleton (name_of_binder bndr2)) | CPComp (bndr, left, right) -> - diff (union (cp_phrase left) (cp_phrase right)) (singleton (name_of_binder bndr)) + diff (union (cp_phrase left) (cp_phrase right)) + (singleton (name_of_binder bndr)) end From 3e7433a3e17a07f41c7084543c9c3cc46e1babcc Mon Sep 17 00:00:00 2001 From: Jan Stolarek Date: Wed, 20 Feb 2019 16:30:46 +0000 Subject: [PATCH 19/28] Redefine unary operators as a variant --- core/desugarInners.ml | 5 +++-- core/desugarModules.ml | 3 ++- core/lens/lens_operators.ml | 9 +++++---- core/operators.ml | 18 +++++++++++++++++ core/parser.mly | 9 +++++---- core/sugarConstructorsIntf.ml | 7 ++++--- core/sugarTraversals.ml | 37 ++++++++++++++++++----------------- core/sugarTraversals.mli | 13 ++++++------ core/sugartoir.ml | 9 +++++---- core/sugartypes.ml | 16 +++++---------- core/transformSugar.ml | 11 ++++++----- core/transformSugar.mli | 3 ++- core/typeSugar.ml | 8 ++++---- 13 files changed, 85 insertions(+), 63 deletions(-) create mode 100644 core/operators.ml diff --git a/core/desugarInners.ml b/core/desugarInners.ml index 3b66e3e6e..19adef8cd 100644 --- a/core/desugarInners.ml +++ b/core/desugarInners.ml @@ -1,4 +1,5 @@ open Utility +open Operators open Sugartypes (* Recursive functions must be used monomorphically inside their @@ -42,10 +43,10 @@ object (o : 'self_type) let extras = StringMap.find name extra_env in let tyargs = add_extras (extras, tyargs) in super#phrasenode (InfixAppl ((tyargs, `Name name), e1, e2)) - | UnaryAppl ((tyargs, `Name name), e) when StringMap.mem name extra_env -> + | UnaryAppl ((tyargs, UnaryOp.Name name), e) when StringMap.mem name extra_env -> let extras = StringMap.find name extra_env in let tyargs = add_extras (extras, tyargs) in - super#phrasenode (UnaryAppl ((tyargs, `Name name), e)) + super#phrasenode (UnaryAppl ((tyargs, UnaryOp.Name name), e)) (* HACK: manage the lexical scope of extras *) | Spawn _ as e -> let (o, e, t) = super#phrasenode e in diff --git a/core/desugarModules.ml b/core/desugarModules.ml index a3364f097..2a57ba9a4 100644 --- a/core/desugarModules.ml +++ b/core/desugarModules.ml @@ -24,6 +24,7 @@ * *) open Utility +open Operators open Sugartypes open Printf open ModuleUtils @@ -237,7 +238,7 @@ and perform_renaming module_table path term_ht type_ht = | bo -> super#binop bo method! unary_op = function - | `Name n -> (self, `Name (resolve n term_shadow_table)) + | UnaryOp.Name n -> (self, UnaryOp.Name (resolve n term_shadow_table)) | uo -> super#unary_op uo method! phrasenode = function diff --git a/core/lens/lens_operators.ml b/core/lens/lens_operators.ml index 1cf7df17e..d1a5d4c39 100644 --- a/core/lens/lens_operators.ml +++ b/core/lens/lens_operators.ml @@ -1,3 +1,5 @@ +open Operators + (* The operators named here are the ones that it is difficult or impossible to define as "user" infix operators: @@ -18,10 +20,9 @@ module Unary = struct let from_links v = match v with - | `Minus -> Minus - | `FloatMinus -> Minus - | `Not -> Not - | `Name name -> Name name + | UnaryOp.Minus -> Minus + | UnaryOp.FloatMinus -> Minus + | UnaryOp.Name name -> Name name let to_string = function diff --git a/core/operators.ml b/core/operators.ml new file mode 100644 index 000000000..ff4f6772f --- /dev/null +++ b/core/operators.ml @@ -0,0 +1,18 @@ +(* The operators named here are the ones that it is difficult or + impossible to define as "user" infix operators: + + - -. are both infix and prefix + && || have special evaluation + :: is also used in patterns + ~ triggers a lexer state switch +*) + +type name = string [@@deriving show] + +module UnaryOp = struct + type t = + | Minus + | FloatMinus + | Name of name + [@@deriving show] +end diff --git a/core/parser.mly b/core/parser.mly index 3329e74d6..a73527394 100644 --- a/core/parser.mly +++ b/core/parser.mly @@ -39,6 +39,7 @@ or Menhir it is no longer necessary. open CommonTypes open Utility +open Operators open Sugartypes open SugarConstructors @@ -514,7 +515,7 @@ spawn_expression: postfix_expression: | primary_expression | spawn_expression { $1 } -| primary_expression POSTFIXOP { unary_appl ~ppos:$loc (`Name $2) $1 } +| primary_expression POSTFIXOP { unary_appl ~ppos:$loc (UnaryOp.Name $2) $1 } | block { $1 } | QUERY block { query ~ppos:$loc None $2 } | QUERY LBRACKET exp RBRACKET block { query ~ppos:$loc (Some ($3, with_pos $loc (Constant (`Int 0)))) $5 } @@ -533,9 +534,9 @@ perhaps_exps: | loption(exps) { $1 } unary_expression: -| MINUS unary_expression { unary_appl ~ppos:$loc `Minus $2 } -| MINUSDOT unary_expression { unary_appl ~ppos:$loc `FloatMinus $2 } -| PREFIXOP unary_expression { unary_appl ~ppos:$loc (`Name $1) $2 } +| MINUS unary_expression { unary_appl ~ppos:$loc UnaryOp.Minus $2 } +| MINUSDOT unary_expression { unary_appl ~ppos:$loc UnaryOp.FloatMinus $2 } +| PREFIXOP 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)) } diff --git a/core/sugarConstructorsIntf.ml b/core/sugarConstructorsIntf.ml index a20984c1f..6f6e799d9 100644 --- a/core/sugarConstructorsIntf.ml +++ b/core/sugarConstructorsIntf.ml @@ -1,6 +1,7 @@ (* This module contains module signatures used by SugarConstructors module. Putting them here allows to avoid repetition. *) +open Operators open Sugartypes (* An abstract type of positions and operations on them. The core type of @@ -138,9 +139,9 @@ module type SugarConstructorsSig = sig : ?ppos:t -> (phrase * phrase) option -> phrase -> phrase (* Operator applications *) - val infix_appl' : ?ppos:t -> phrase -> binop -> phrase -> phrase - val infix_appl : ?ppos:t -> phrase -> string -> phrase -> phrase - val unary_appl : ?ppos:t -> unary_op -> phrase -> phrase + val infix_appl' : ?ppos:t -> phrase -> binop -> phrase -> phrase + val infix_appl : ?ppos:t -> phrase -> string -> phrase -> phrase + val unary_appl : ?ppos:t -> UnaryOp.t -> phrase -> phrase (* XML *) val xml diff --git a/core/sugarTraversals.ml b/core/sugarTraversals.ml index cf4c839e6..6b9c8560d 100644 --- a/core/sugarTraversals.ml +++ b/core/sugarTraversals.ml @@ -8,6 +8,7 @@ generate all this automatically instead of maintaining this file. *) +open Operators open Sugartypes class map = @@ -36,13 +37,13 @@ class map = method bool : bool -> bool = function | false -> false | true -> true - method unary_op : unary_op -> unary_op = - function - | `Minus -> `Minus - | `FloatMinus -> `FloatMinus - | `Name _x -> let _x = o#name _x in `Name _x + method unary_op : UnaryOp.t -> UnaryOp.t = + let open UnaryOp in function + | Minus -> Minus + | FloatMinus -> FloatMinus + | Name _x -> let _x = o#name _x in Name _x - method tyunary_op : tyarg list * unary_op -> tyarg list * unary_op = + method tyunary_op : tyarg list * UnaryOp.t -> tyarg list * UnaryOp.t = fun (_x, _x_i1) -> (_x, o#unary_op _x_i1) method binder : binder -> binder = @@ -753,13 +754,13 @@ class fold = method bool : bool -> 'self_type = function | false -> o | true -> o - method unary_op : unary_op -> 'self_type = - function - | `Minus -> o - | `FloatMinus -> o - | `Name _x -> let o = o#name _x in o + method unary_op : UnaryOp.t -> 'self_type = + let open UnaryOp in function + | Minus -> o + | FloatMinus -> o + | Name _x -> let o = o#name _x in o - method tyunary_op : tyarg list * unary_op -> 'self_type = + method tyunary_op : tyarg list * UnaryOp.t -> 'self_type = fun (_x, _x_i1) -> o#unary_op _x_i1 method binder : binder -> 'self_type = @@ -1422,13 +1423,13 @@ class fold_map = method bool : bool -> ('self_type * bool) = function | false -> (o, false) | true -> (o, true) - method unary_op : unary_op -> ('self_type * unary_op) = - function - | `Minus -> (o, `Minus) - | `FloatMinus -> (o, `FloatMinus) - | `Name _x -> let (o, _x) = o#name _x in (o, (`Name _x)) + method unary_op : UnaryOp.t -> ('self_type * UnaryOp.t) = + let open UnaryOp in function + | Minus -> (o, Minus) + | FloatMinus -> (o, FloatMinus) + | Name _x -> let (o, _x) = o#name _x in (o, Name _x) - method tyunary_op : tyarg list * unary_op -> 'self_type * (tyarg list * unary_op) = + method tyunary_op : tyarg list * UnaryOp.t -> 'self_type * (tyarg list * UnaryOp.t) = fun (_x, _x_i1) -> let (o, _x_i1) = o#unary_op _x_i1 in (o, (_x, _x_i1)) diff --git a/core/sugarTraversals.mli b/core/sugarTraversals.mli index 571a35cf5..6a00b40c1 100644 --- a/core/sugarTraversals.mli +++ b/core/sugarTraversals.mli @@ -1,3 +1,4 @@ +open Operators open Sugartypes (* Make a copy of a value. You can override any method(s) to get a @@ -22,8 +23,8 @@ class map : method float : float -> float method char : char -> char method bool : bool -> bool - method unary_op : unary_op -> unary_op - method tyunary_op : tyarg list * unary_op -> tyarg list * unary_op + method unary_op : UnaryOp.t -> UnaryOp.t + method tyunary_op : tyarg list * UnaryOp.t -> tyarg list * UnaryOp.t method binder : binder -> binder method sentence : sentence -> sentence method section : Section.t -> Section.t @@ -91,8 +92,8 @@ class fold : method float : float -> 'self method char : char -> 'self method bool : bool -> 'self - method unary_op : unary_op -> 'self - method tyunary_op : tyarg list * unary_op -> 'self + method unary_op : UnaryOp.t -> 'self + method tyunary_op : tyarg list * UnaryOp.t -> 'self method binder : binder -> 'self method sentence : sentence -> 'self method section : Section.t -> 'self @@ -199,7 +200,7 @@ object ('self) method type_variable : type_variable -> 'self * type_variable method known_type_variable : known_type_variable -> 'self * known_type_variable method type_arg : Datatype.type_arg -> 'self * Datatype.type_arg - method tyunary_op : tyarg list * unary_op -> 'self * (tyarg list * unary_op) - method unary_op : unary_op -> 'self * unary_op + method tyunary_op : tyarg list * UnaryOp.t -> 'self * (tyarg list * UnaryOp.t) + method unary_op : UnaryOp.t -> 'self * UnaryOp.t method unknown : 'a . 'a -> 'self * 'a end diff --git a/core/sugartoir.ml b/core/sugartoir.ml index 9af911642..d5f6cfd47 100644 --- a/core/sugartoir.ml +++ b/core/sugartoir.ml @@ -1,4 +1,5 @@ open CommonTypes +open Operators open Utility open Ir @@ -800,13 +801,13 @@ struct I.condition (ev e1, ec e2, cofv (I.constant (`Bool false))) | InfixAppl ((_tyargs, `Or), e1, e2) -> I.condition (ev e1, cofv (I.constant (`Bool true)), ec e2) - | UnaryAppl ((_tyargs, `Minus), e) -> + | UnaryAppl ((_tyargs, UnaryOp.Minus), e) -> cofv (I.apply_pure(instantiate_mb "negate", [ev e])) - | UnaryAppl ((_tyargs, `FloatMinus), e) -> + | UnaryAppl ((_tyargs, UnaryOp.FloatMinus), e) -> cofv (I.apply_pure(instantiate_mb "negatef", [ev e])) - | UnaryAppl ((tyargs, `Name n), e) when Lib.is_pure_primitive n -> + | UnaryAppl ((tyargs, UnaryOp.Name n), e) when Lib.is_pure_primitive n -> cofv (I.apply_pure(instantiate n tyargs, [ev e])) - | UnaryAppl ((tyargs, `Name n), e) -> + | UnaryAppl ((tyargs, UnaryOp.Name n), e) -> I.apply (instantiate n tyargs, [ev e]) | FnAppl ({node=Var f; _}, es) when Lib.is_pure_primitive f -> cofv (I.apply_pure (I.var (lookup_name_and_type f env), evs es)) diff --git a/core/sugartypes.ml b/core/sugartypes.ml index 2239eba0a..5dd438352 100644 --- a/core/sugartypes.ml +++ b/core/sugartypes.ml @@ -1,4 +1,5 @@ open CommonTypes +open Operators open Utility (** The syntax tree created by the parser. *) @@ -14,13 +15,6 @@ open Utility type name = string [@@deriving show] -type unary_op = [ -| `Minus -| `FloatMinus -| `Name of name -] -[@@deriving show] - type regexflag = RegexList | RegexNative | RegexGlobal | RegexReplace [@@deriving show] @@ -30,9 +24,9 @@ type binop = [ `Minus | `FloatMinus | `RegexMatch of regexflag list | `And | `Or let string_of_unary_op = function - | `Minus -> "-" - | `FloatMinus -> ".-" - | `Name name -> name + | UnaryOp.Minus -> "-" + | UnaryOp.FloatMinus -> ".-" + | UnaryOp.Name name -> name let string_of_binop = function @@ -289,7 +283,7 @@ and phrasenode = | Block of block_body | InfixAppl of (tyarg list * binop) * phrase * phrase | Regex of regex - | UnaryAppl of (tyarg list * unary_op) * phrase + | UnaryAppl of (tyarg list * UnaryOp.t) * phrase | FnAppl of phrase * phrase list | TAbstr of tyvar list ref * phrase | TAppl of phrase * tyarg list diff --git a/core/transformSugar.ml b/core/transformSugar.ml index cf3f201a5..16b18e80f 100644 --- a/core/transformSugar.ml +++ b/core/transformSugar.ml @@ -1,6 +1,7 @@ open CommonTypes -open Utility +open Operators open Sugartypes +open Utility module TyEnv = Env.String @@ -20,9 +21,9 @@ let type_section env = let type_unary_op env tycon_env = let datatype = DesugarDatatypes.read ~aliases:tycon_env in function - | `Minus -> datatype "(Int) -> Int" - | `FloatMinus -> datatype "(Float) -> Float" - | `Name n -> TyEnv.lookup env n + | UnaryOp.Minus -> datatype "(Int) -> Int" + | UnaryOp.FloatMinus -> datatype "(Float) -> Float" + | UnaryOp.Name n -> TyEnv.lookup env n let type_binary_op env tycon_env = let datatype = DesugarDatatypes.read ~aliases:tycon_env in function @@ -171,7 +172,7 @@ class transform (env : Types.typing_environment) = method row : Types.row -> ('self_type * Types.row) = fun row -> (o, row) - method unary_op : unary_op -> ('self_type * unary_op * Types.datatype) = + method unary_op : UnaryOp.t -> ('self_type * UnaryOp.t * Types.datatype) = fun op -> (o, op, type_unary_op var_env tycon_env op) diff --git a/core/transformSugar.mli b/core/transformSugar.mli index 8c731526a..1b8893f31 100644 --- a/core/transformSugar.mli +++ b/core/transformSugar.mli @@ -1,3 +1,4 @@ +open Operators open Sugartypes (* @@ -92,7 +93,7 @@ object ('self) method sentence' : sentence' -> 'self * sentence' method directive : directive -> 'self * directive *) - method unary_op : unary_op -> 'self * unary_op * Types.datatype + method unary_op : UnaryOp.t -> 'self * UnaryOp.t * Types.datatype end val fun_effects : Types.datatype -> Sugartypes.Pattern.with_pos list list -> Types.row diff --git a/core/typeSugar.ml b/core/typeSugar.ml index b2a1d568c..319e51005 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -1,6 +1,6 @@ open CommonTypes open Utility -open Types +open Operators open Sugartypes (* let constrain_absence_types = Basicsettings.Typing.contrain_absence_types *) @@ -1408,9 +1408,9 @@ let add_empty_usages (p, t) = (p, t, StringMap.empty) let type_unary_op env = let datatype = datatype env.tycon_env in function - | `Minus -> add_empty_usages (datatype "(Int) -> Int") - | `FloatMinus -> add_empty_usages (datatype "(Float) -> Float") - | `Name n -> add_usages (Utils.instantiate env.var_env n) (StringMap.singleton n 1) + | UnaryOp.Minus -> add_empty_usages (datatype "(Int) -> Int") + | UnaryOp.FloatMinus -> add_empty_usages (datatype "(Float) -> Float") + | UnaryOp.Name n -> add_usages (Utils.instantiate env.var_env n) (StringMap.singleton n 1) let type_binary_op ctxt = let datatype = datatype ctxt.tycon_env in function From a32e203102daaf11135db86683e45fb9644d569f Mon Sep 17 00:00:00 2001 From: Jan Stolarek Date: Thu, 21 Feb 2019 10:29:28 +0000 Subject: [PATCH 20/28] Redefine binary operators as a variant --- core/desugarHandlers.ml | 3 +- core/desugarInners.ml | 4 +-- core/desugarModules.ml | 2 +- core/desugarRegexes.ml | 7 ++-- core/lens/lens_operators.ml | 16 ++++----- core/operators.ml | 40 +++++++++++++++++++++ core/parser.mly | 18 +++++----- core/sugarConstructors.ml | 3 +- core/sugarConstructorsIntf.ml | 6 ++-- core/sugarTraversals.ml | 68 +++++++++++++++++------------------ core/sugarTraversals.mli | 12 +++---- core/sugartoir.ml | 22 ++++++------ core/sugartypes.ml | 45 ++--------------------- core/transformSugar.ml | 33 ++++++++--------- core/transformSugar.mli | 2 +- core/typeSugar.ml | 31 ++++++++-------- 16 files changed, 159 insertions(+), 153 deletions(-) diff --git a/core/desugarHandlers.ml b/core/desugarHandlers.ml index aeb7623ee..a1498d5e6 100644 --- a/core/desugarHandlers.ml +++ b/core/desugarHandlers.ml @@ -1,4 +1,5 @@ open Utility +open Operators open Sugartypes open SugarConstructors.Make @@ -130,7 +131,7 @@ let rec phrase_of_pattern : Pattern.with_pos -> phrase match pat.node with Any -> assert false (* can never happen after the fresh name generation pass *) | Nil -> list [] - | Cons (hd, tl) -> infix_appl' (phrase_of_pattern hd) `Cons (phrase_of_pattern tl) + | Cons (hd, tl) -> infix_appl' (phrase_of_pattern hd) BinaryOp.Cons (phrase_of_pattern tl) | List ps -> list (List.map phrase_of_pattern ps) | Effect _ -> assert false | Variant (name, pat_opt) -> constructor name ?body:(opt_map phrase_of_pattern pat_opt) diff --git a/core/desugarInners.ml b/core/desugarInners.ml index 19adef8cd..d28a55d9a 100644 --- a/core/desugarInners.ml +++ b/core/desugarInners.ml @@ -39,10 +39,10 @@ object (o : 'self_type) let extras = StringMap.find name extra_env in let tyargs = add_extras (extras, tyargs) in super#phrasenode (TAppl (phn, tyargs)) - | InfixAppl ((tyargs, `Name name), e1, e2) when StringMap.mem name extra_env -> + | InfixAppl ((tyargs, BinaryOp.Name name), e1, e2) when StringMap.mem name extra_env -> let extras = StringMap.find name extra_env in let tyargs = add_extras (extras, tyargs) in - super#phrasenode (InfixAppl ((tyargs, `Name name), e1, e2)) + super#phrasenode (InfixAppl ((tyargs, BinaryOp.Name name), e1, e2)) | UnaryAppl ((tyargs, UnaryOp.Name name), e) when StringMap.mem name extra_env -> let extras = StringMap.find name extra_env in let tyargs = add_extras (extras, tyargs) in diff --git a/core/desugarModules.ml b/core/desugarModules.ml index 2a57ba9a4..ec074072e 100644 --- a/core/desugarModules.ml +++ b/core/desugarModules.ml @@ -234,7 +234,7 @@ and perform_renaming module_table path term_ht type_ht = | b -> super#bindingnode b method! binop = function - | `Name n -> (self, `Name (resolve n term_shadow_table)) + | BinaryOp.Name n -> (self, BinaryOp.Name (resolve n term_shadow_table)) | bo -> super#binop bo method! unary_op = function diff --git a/core/desugarRegexes.ml b/core/desugarRegexes.ml index aa2e63641..1d2dd1abc 100644 --- a/core/desugarRegexes.ml +++ b/core/desugarRegexes.ml @@ -1,3 +1,4 @@ +open Operators open Sugartypes open SugarConstructors.Make @@ -70,14 +71,14 @@ object(self) val regex_type = Instantiate.alias "Regex" [] env.Types.tycon_env method! phrase ({node=p; pos} as ph) = match p with - | InfixAppl ((tyargs, `RegexMatch flags), e1, {node=Regex((Replace(_,_) as r)); _}) -> + | InfixAppl ((tyargs, BinaryOp.RegexMatch flags), e1, {node=Regex((Replace(_,_) as r)); _}) -> let libfn = if List.exists ((=)RegexNative) flags then "sntilde" else "stilde" in self#phrase (fn_appl libfn tyargs [e1; desugar_regex self#phrase regex_type r]) - | InfixAppl ((tyargs, `RegexMatch flags), e1, {node=Regex r; _}) -> + | InfixAppl ((tyargs, BinaryOp.RegexMatch flags), e1, {node=Regex r; _}) -> let nativep = List.exists ((=) RegexNative) flags and listp = List.exists ((=) RegexList) flags in let libfn = match listp, nativep with @@ -87,7 +88,7 @@ object(self) | false, true -> "ntilde" in self#phrase (fn_appl libfn tyargs [e1; desugar_regex self#phrase regex_type r]) - | InfixAppl ((_tyargs, `RegexMatch _), _, _) -> + | InfixAppl ((_tyargs, BinaryOp.RegexMatch _), _, _) -> raise (Errors.SugarError (pos, "Internal error: unexpected rhs of regex operator")) | _ -> super#phrase ph end diff --git a/core/lens/lens_operators.ml b/core/lens/lens_operators.ml index d1a5d4c39..9cca86c4f 100644 --- a/core/lens/lens_operators.ml +++ b/core/lens/lens_operators.ml @@ -60,14 +60,14 @@ module Binary = struct let of_supertype_operator v = match v with - | `Minus -> Minus - | `FloatMinus -> Minus - | `Cons -> Cons - | `And -> Logical Logical_binop.And - | `Or -> Logical Logical_binop.Or - | `Name "==" -> Equal - | `Name name -> Name name - | `RegexMatch _ -> failwith "Regex not supported in relational lenses." + | BinaryOp.Minus -> Minus + | BinaryOp.FloatMinus -> Minus + | BinaryOp.Cons -> Cons + | BinaryOp.And -> Logical Logical_binop.And + | BinaryOp.Or -> Logical Logical_binop.Or + | BinaryOp.Name "==" -> Equal + | BinaryOp.Name name -> Name name + | BinaryOp.RegexMatch _ -> failwith "Regex not supported in relational lenses." let to_string = function diff --git a/core/operators.ml b/core/operators.ml index ff4f6772f..e4a119bc5 100644 --- a/core/operators.ml +++ b/core/operators.ml @@ -9,6 +9,9 @@ type name = string [@@deriving show] +type regexflag = RegexList | RegexNative | RegexGlobal | RegexReplace + [@@deriving show] + module UnaryOp = struct type t = | Minus @@ -16,3 +19,40 @@ module UnaryOp = struct | Name of name [@@deriving show] end + +let string_of_unary_op = + function + | UnaryOp.Minus -> "-" + | UnaryOp.FloatMinus -> ".-" + | UnaryOp.Name name -> name + +module BinaryOp = struct + type t = + | Minus + | FloatMinus + | RegexMatch of regexflag list + | And + | Or + | Cons + | Name of name + [@@deriving show] +end + +let string_of_binop = + let open BinaryOp in function + | Minus -> "-" + | FloatMinus -> ".-" + | RegexMatch _ -> "" + | And -> "&&" + | Or -> "||" + | Cons -> "::" + | Name name -> name + +let binop_of_string : string -> BinaryOp.t = + let open BinaryOp in function + | "-" -> Minus + | ".-" -> FloatMinus + | "&&" -> And + | "||" -> Or + | "::" -> Cons + | name -> Name name diff --git a/core/parser.mly b/core/parser.mly index a73527394..b398d2827 100644 --- a/core/parser.mly +++ b/core/parser.mly @@ -45,9 +45,11 @@ open SugarConstructors module Links_core = (* See Note [Dune "wrapped" workaround] *) struct + module CommonTypes = CommonTypes module Sugartypes = Sugartypes module SugarConstructors = SugarConstructors module Types = Types + module Operators = Operators end (* Construction of nodes using positions produced by Menhir parser *) @@ -553,8 +555,8 @@ infixl_9: infixr_8: | infixl_9 { $1 } | infixl_9 INFIX8 infixl_9 -| infixl_9 INFIXR8 infixr_8 { infix_appl ~ppos:$loc $1 $2 $3 } -| infixl_9 COLONCOLON infixr_8 { infix_appl' ~ppos:$loc $1 `Cons $3 } +| infixl_9 INFIXR8 infixr_8 { infix_appl ~ppos:$loc $1 $2 $3 } +| infixl_9 COLONCOLON infixr_8 { infix_appl' ~ppos:$loc $1 BinaryOp.Cons $3 } infixl_8: | infixr_8 { $1 } @@ -576,9 +578,9 @@ infixr_6: infixl_6: | infixr_6 { $1 } -| infixl_6 INFIXL6 infixr_6 { infix_appl ~ppos:$loc $1 $2 $3 } -| infixl_6 MINUS infixr_6 { infix_appl' ~ppos:$loc $1 `Minus $3 } -| infixl_6 MINUSDOT infixr_6 { infix_appl' ~ppos:$loc $1 `FloatMinus $3 } +| infixl_6 INFIXL6 infixr_6 { infix_appl ~ppos:$loc $1 $2 $3 } +| infixl_6 MINUS infixr_6 { infix_appl' ~ppos:$loc $1 BinaryOp.Minus $3 } +| infixl_6 MINUSDOT infixr_6 { infix_appl' ~ppos:$loc $1 BinaryOp.FloatMinus $3 } /* HACK: the type variables should get inserted later... */ | infixl_6 BANG infixr_6 { infix_appl ~ppos:$loc $1 "!" $3 } @@ -596,7 +598,7 @@ infixr_4: | infixl_5 INFIX4 infixl_5 | infixl_5 INFIXR4 infixr_4 { infix_appl ~ppos:$loc $1 $2 $3 } | infixr_5 EQUALSTILDE regex { let r, flags = $3 in - infix_appl' ~ppos:$loc $1 (`RegexMatch flags) r } + infix_appl' ~ppos:$loc $1 (BinaryOp.RegexMatch flags) r } infixl_4: | infixr_4 { $1 } @@ -640,8 +642,8 @@ infixl_0: logical_expression: | infixl_0 { $1 } -| logical_expression BARBAR infixl_0 { infix_appl' ~ppos:$loc $1 `Or $3 } -| logical_expression AMPAMP infixl_0 { infix_appl' ~ppos:$loc $1 `And $3 } +| logical_expression BARBAR infixl_0 { infix_appl' ~ppos:$loc $1 BinaryOp.Or $3 } +| logical_expression AMPAMP infixl_0 { infix_appl' ~ppos:$loc $1 BinaryOp.And $3 } typed_expression: | logical_expression { $1 } diff --git a/core/sugarConstructors.ml b/core/sugarConstructors.ml index 7df47e5c5..432ed9b9c 100644 --- a/core/sugarConstructors.ml +++ b/core/sugarConstructors.ml @@ -1,3 +1,4 @@ +open Operators open Sugartypes open Utility.OptionUtils @@ -239,7 +240,7 @@ module SugarConstructors (Position : Pos) (* Apply a binary infix operator with a specified name. *) let infix_appl ?(ppos=dp) arg1 op arg2 = - infix_appl' ~ppos arg1 (`Name op) arg2 + infix_appl' ~ppos arg1 (BinaryOp.Name op) arg2 (* Apply an unary operator. *) let unary_appl ?(ppos=dp) op arg = diff --git a/core/sugarConstructorsIntf.ml b/core/sugarConstructorsIntf.ml index 6f6e799d9..b47d5b57a 100644 --- a/core/sugarConstructorsIntf.ml +++ b/core/sugarConstructorsIntf.ml @@ -139,9 +139,9 @@ module type SugarConstructorsSig = sig : ?ppos:t -> (phrase * phrase) option -> phrase -> phrase (* Operator applications *) - val infix_appl' : ?ppos:t -> phrase -> binop -> phrase -> phrase - val infix_appl : ?ppos:t -> phrase -> string -> phrase -> phrase - val unary_appl : ?ppos:t -> UnaryOp.t -> phrase -> phrase + val infix_appl' : ?ppos:t -> phrase -> BinaryOp.t -> phrase -> phrase + val infix_appl : ?ppos:t -> phrase -> string -> phrase -> phrase + val unary_appl : ?ppos:t -> UnaryOp.t -> phrase -> phrase (* XML *) val xml diff --git a/core/sugarTraversals.ml b/core/sugarTraversals.ml index 6b9c8560d..61d0cc513 100644 --- a/core/sugarTraversals.ml +++ b/core/sugarTraversals.ml @@ -636,18 +636,18 @@ class map = | `Bool _x -> let _x = o#bool _x in `Bool _x | `Char _x -> let _x = o#char _x in `Char _x - method binop : binop -> binop = - function - | `Minus -> `Minus - | `FloatMinus -> `FloatMinus - | `RegexMatch _x -> - let _x = o#list (fun o -> o#regexflag) _x in `RegexMatch _x - | `And -> `And - | `Or -> `Or - | `Cons -> `Cons - | `Name _x -> let _x = o#name _x in `Name _x - - method tybinop : tyarg list * binop -> tyarg list * binop = + method binop : BinaryOp.t -> BinaryOp.t = + let open BinaryOp in function + | Minus -> Minus + | FloatMinus -> FloatMinus + | RegexMatch _x -> + let _x = o#list (fun o -> o#regexflag) _x in RegexMatch _x + | And -> And + | Or -> Or + | Cons -> Cons + | Name _x -> let _x = o#name _x in Name _x + + method tybinop : tyarg list * BinaryOp.t -> tyarg list * BinaryOp.t = fun (_x, _x_i1) -> (_x, o#binop _x_i1) method bindingnode : bindingnode -> bindingnode = @@ -1293,17 +1293,17 @@ class fold = | `Bool _x -> let o = o#bool _x in o | `Char _x -> let o = o#char _x in o - method binop : binop -> 'self_type = - function - | `Minus -> o - | `FloatMinus -> o - | `RegexMatch _x -> let o = o#list (fun o -> o#regexflag) _x in o - | `And -> o - | `Or -> o - | `Cons -> o - | `Name _x -> let o = o#name _x in o - - method tybinop : tyarg list * binop -> 'self_type = + method binop : BinaryOp.t -> 'self_type = + let open BinaryOp in function + | Minus -> o + | FloatMinus -> o + | RegexMatch _x -> let o = o#list (fun o -> o#regexflag) _x in o + | And -> o + | Or -> o + | Cons -> o + | Name _x -> let o = o#name _x in o + + method tybinop : tyarg list * BinaryOp.t -> 'self_type = fun (_x, _x_i1) -> o#binop _x_i1 method bindingnode : bindingnode -> 'self_type = @@ -2072,19 +2072,19 @@ class fold_map = | `Bool _x -> let (o, _x) = o#bool _x in (o, (`Bool _x)) | `Char _x -> let (o, _x) = o#char _x in (o, (`Char _x)) - method binop : binop -> ('self_type * binop) = - function - | `Minus -> (o, `Minus) - | `FloatMinus -> (o, `FloatMinus) - | `RegexMatch _x -> + method binop : BinaryOp.t -> ('self_type * BinaryOp.t) = + let open BinaryOp in function + | Minus -> (o, Minus) + | FloatMinus -> (o, FloatMinus) + | RegexMatch _x -> let (o, _x) = o#list (fun o -> o#regexflag) _x - in (o, (`RegexMatch _x)) - | `And -> (o, `And) - | `Or -> (o, `Or) - | `Cons -> (o, `Cons) - | `Name _x -> let (o, _x) = o#name _x in (o, (`Name _x)) + in (o, (RegexMatch _x)) + | And -> (o, And) + | Or -> (o, Or) + | Cons -> (o, Cons) + | Name _x -> let (o, _x) = o#name _x in (o, (Name _x)) - method tybinop : tyarg list * binop -> 'self_type * (tyarg list * binop) = + method tybinop : tyarg list * BinaryOp.t -> 'self_type * (tyarg list * BinaryOp.t) = fun (_x, _x_i1) -> let (o, _x_i1) = o#binop _x_i1 in (o, (_x, _x_i1)) diff --git a/core/sugarTraversals.mli b/core/sugarTraversals.mli index 6a00b40c1..f2ac20df3 100644 --- a/core/sugarTraversals.mli +++ b/core/sugarTraversals.mli @@ -60,8 +60,8 @@ class map : method datatype' : datatype' -> datatype' method type_arg : Datatype.type_arg -> Datatype.type_arg method constant : constant -> constant - method binop : binop -> binop - method tybinop : tyarg list * binop -> tyarg list * binop + method binop : BinaryOp.t -> BinaryOp.t + method tybinop : tyarg list * BinaryOp.t -> tyarg list * BinaryOp.t method bindingnode : bindingnode -> bindingnode method binding : binding -> binding method program : program -> program @@ -131,8 +131,8 @@ class fold : method datatype' : datatype' -> 'self method type_arg : Datatype.type_arg -> 'self method constant : constant -> 'self - method binop : binop -> 'self - method tybinop : tyarg list * binop -> 'self + method binop : BinaryOp.t -> 'self + method tybinop : tyarg list * BinaryOp.t -> 'self method bindingnode : bindingnode -> 'self method binding : binding -> 'self method program : program -> 'self @@ -155,8 +155,8 @@ object ('self) method binder : binder -> 'self * binder method binding : binding -> 'self * binding method bindingnode : bindingnode -> 'self * bindingnode - method binop : binop -> 'self * binop - method tybinop : tyarg list * binop -> 'self * (tyarg list * binop) + method binop : BinaryOp.t -> 'self * BinaryOp.t + method tybinop : tyarg list * BinaryOp.t -> 'self * (tyarg list * BinaryOp.t) method bool : bool -> 'self * bool method char : char -> 'self * char method constant : constant -> 'self * constant diff --git a/core/sugartoir.ml b/core/sugartoir.ml index d5f6cfd47..dacd49944 100644 --- a/core/sugartoir.ml +++ b/core/sugartoir.ml @@ -778,28 +778,28 @@ struct | Section (Section.Name name) -> cofv (lookup_var name) | Conditional (p, e1, e2) -> I.condition (ev p, ec e1, ec e2) - | InfixAppl ((tyargs, `Name ((">" | ">=" | "==" | "<" | "<=" | "<>") as op)), e1, e2) -> + | InfixAppl ((tyargs, BinaryOp.Name ((">" | ">=" | "==" | "<" | "<=" | "<>") as op)), e1, e2) -> cofv (I.apply_pure (instantiate op tyargs, [ev e1; ev e2])) - | InfixAppl ((tyargs, `Name "++"), e1, e2) -> + | InfixAppl ((tyargs, BinaryOp.Name "++"), e1, e2) -> cofv (I.apply_pure (instantiate "Concat" tyargs, [ev e1; ev e2])) - | InfixAppl ((tyargs, `Name "!"), e1, e2) -> + | InfixAppl ((tyargs, BinaryOp.Name "!"), e1, e2) -> I.apply (instantiate "Send" tyargs, [ev e1; ev e2]) - | InfixAppl ((tyargs, `Name n), e1, e2) when Lib.is_pure_primitive n -> + | InfixAppl ((tyargs, BinaryOp.Name n), e1, e2) when Lib.is_pure_primitive n -> cofv (I.apply_pure (instantiate n tyargs, [ev e1; ev e2])) - | InfixAppl ((tyargs, `Name n), e1, e2) -> + | InfixAppl ((tyargs, BinaryOp.Name n), e1, e2) -> I.apply (instantiate n tyargs, [ev e1; ev e2]) - | InfixAppl ((tyargs, `Cons), e1, e2) -> + | InfixAppl ((tyargs, BinaryOp.Cons), e1, e2) -> cofv (I.apply_pure (instantiate "Cons" tyargs, [ev e1; ev e2])) - | InfixAppl ((tyargs, `FloatMinus), e1, e2) -> + | InfixAppl ((tyargs, BinaryOp.FloatMinus), e1, e2) -> cofv (I.apply_pure (instantiate "-." tyargs, [ev e1; ev e2])) - | InfixAppl ((tyargs, `Minus), e1, e2) -> + | InfixAppl ((tyargs, BinaryOp.Minus), e1, e2) -> cofv (I.apply_pure (instantiate "-" tyargs, [ev e1; ev e2])) - | InfixAppl ((_tyargs, `And), e1, e2) -> + | InfixAppl ((_tyargs, BinaryOp.And), e1, e2) -> (* IMPORTANT: we compile boolean expressions to conditionals in order to faithfully capture short-circuit evaluation *) I.condition (ev e1, ec e2, cofv (I.constant (`Bool false))) - | InfixAppl ((_tyargs, `Or), e1, e2) -> + | InfixAppl ((_tyargs, BinaryOp.Or), e1, e2) -> I.condition (ev e1, cofv (I.constant (`Bool true)), ec e2) | UnaryAppl ((_tyargs, UnaryOp.Minus), e) -> cofv (I.apply_pure(instantiate_mb "negate", [ev e])) @@ -1029,7 +1029,7 @@ struct | Section (Section.Project _) | FunLit _ | Iteration _ - | InfixAppl ((_, `RegexMatch _), _, _) + | InfixAppl ((_, BinaryOp.RegexMatch _), _, _) | DBInsert _ | Regex _ | Formlet _ diff --git a/core/sugartypes.ml b/core/sugartypes.ml index 5dd438352..fb6e64b12 100644 --- a/core/sugartypes.ml +++ b/core/sugartypes.ml @@ -4,49 +4,8 @@ open Utility (** The syntax tree created by the parser. *) -(* The operators named here are the ones that it is difficult or - impossible to define as "user" infix operators: - - - -. are both infix and prefix - && || have special evaluation - :: is also used in patterns - ~ triggers a lexer state switch -*) - type name = string [@@deriving show] -type regexflag = RegexList | RegexNative | RegexGlobal | RegexReplace - [@@deriving show] - -type binop = [ `Minus | `FloatMinus | `RegexMatch of regexflag list | `And | `Or - | `Cons | `Name of name ] - [@@deriving show] - -let string_of_unary_op = - function - | UnaryOp.Minus -> "-" - | UnaryOp.FloatMinus -> ".-" - | UnaryOp.Name name -> name - -let string_of_binop = - function - | `Minus -> "-" - | `FloatMinus -> ".-" - | `RegexMatch _ -> "" - | `And -> "&&" - | `Or -> "||" - | `Cons -> "::" - | `Name name -> name - -let binop_of_string : string -> binop = - function - | "-" -> `Minus - | ".-" -> `FloatMinus - | "&&" -> `And - | "||" -> `Or - | "::" -> `Cons - | name -> `Name name - type position = SourceCode.pos let dummy_position = SourceCode.dummy_pos @@ -281,7 +240,7 @@ and phrasenode = | Section of Section.t | Conditional of phrase * phrase * phrase | Block of block_body - | InfixAppl of (tyarg list * binop) * phrase * phrase + | InfixAppl of (tyarg list * BinaryOp.t) * phrase * phrase | Regex of regex | UnaryAppl of (tyarg list * UnaryOp.t) * phrase | FnAppl of phrase * phrase list @@ -479,7 +438,7 @@ struct | FormletPlacement (p1, p2, p3) | Conditional (p1, p2, p3) -> union_map phrase [p1;p2;p3] | Block b -> block b - | InfixAppl ((_, `Name n), p1, p2) -> + | InfixAppl ((_, BinaryOp.Name n), p1, p2) -> union (singleton n) (union_map phrase [p1;p2]) | InfixAppl (_, p1, p2) -> union_map phrase [p1;p2] | RangeLit (p1, p2) -> union_map phrase [p1;p2] diff --git a/core/transformSugar.ml b/core/transformSugar.ml index 16b18e80f..d6c1934b4 100644 --- a/core/transformSugar.ml +++ b/core/transformSugar.ml @@ -26,10 +26,11 @@ let type_unary_op env tycon_env = | UnaryOp.Name n -> TyEnv.lookup env n let type_binary_op env tycon_env = + let open BinaryOp in let datatype = DesugarDatatypes.read ~aliases:tycon_env in function - | `Minus -> TyEnv.lookup env "-" - | `FloatMinus -> TyEnv.lookup env "-." - | `RegexMatch flags -> + | Minus -> TyEnv.lookup env "-" + | FloatMinus -> TyEnv.lookup env "-." + | RegexMatch flags -> let nativep = List.exists ((=) RegexNative) flags and listp = List.exists ((=) RegexList) flags and replacep = List.exists ((=) RegexReplace) flags in @@ -39,22 +40,22 @@ let type_binary_op env tycon_env = | false, false, false -> (* tilde *) datatype "(String, Regex) -> Bool" | _, _, true -> assert false) - | `And - | `Or -> datatype "(Bool,Bool) -> Bool" - | `Cons -> TyEnv.lookup env "Cons" - | `Name "++" -> TyEnv.lookup env "Concat" - | `Name ">" - | `Name ">=" - | `Name "==" - | `Name "<" - | `Name "<=" - | `Name "<>" -> + | And + | Or -> datatype "(Bool,Bool) -> Bool" + | Cons -> TyEnv.lookup env "Cons" + | Name "++" -> TyEnv.lookup env "Concat" + | Name ">" + | Name ">=" + | Name "==" + | Name "<" + | Name "<=" + | Name "<>" -> let ab, a = Types.fresh_type_quantifier (linAny, `Any) in let eb, e = Types.fresh_row_quantifier (linAny, `Any) in `ForAll (Types.box_quantifiers [ab; eb], `Function (Types.make_tuple_type [a; a], e, `Primitive `Bool)) - | `Name "!" -> TyEnv.lookup env "Send" - | `Name n -> TyEnv.lookup env n + | Name "!" -> TyEnv.lookup env "Send" + | Name n -> TyEnv.lookup env n let fun_effects t pss = let rec get_eff = @@ -176,7 +177,7 @@ class transform (env : Types.typing_environment) = fun op -> (o, op, type_unary_op var_env tycon_env op) - method binop : binop -> ('self_type * binop * Types.datatype) = + method binop : BinaryOp.t -> ('self_type * BinaryOp.t * Types.datatype) = fun op -> (o, op, type_binary_op var_env tycon_env op) diff --git a/core/transformSugar.mli b/core/transformSugar.mli index 1b8893f31..6f3a88c03 100644 --- a/core/transformSugar.mli +++ b/core/transformSugar.mli @@ -50,7 +50,7 @@ object ('self) method binder : binder -> 'self * binder method binding : binding -> 'self * binding method bindingnode : bindingnode -> 'self * bindingnode - method binop : binop -> 'self * binop * Types.datatype + method binop : BinaryOp.t -> 'self * BinaryOp.t * Types.datatype method constant : constant -> 'self * constant * Types.datatype method funlit : Types.row -> funlit -> 'self * funlit * Types.datatype method handlerlit : Types.datatype -> handlerlit -> 'self * handlerlit * Types.datatype diff --git a/core/typeSugar.ml b/core/typeSugar.ml index 319e51005..36305cc38 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -1413,10 +1413,11 @@ let type_unary_op env = | UnaryOp.Name n -> add_usages (Utils.instantiate env.var_env n) (StringMap.singleton n 1) let type_binary_op ctxt = + let open BinaryOp in 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 -> + | Minus -> add_empty_usages (Utils.instantiate ctxt.var_env "-") + | FloatMinus -> add_empty_usages (Utils.instantiate ctxt.var_env "-.") + | RegexMatch flags -> let nativep = List.exists ((=) RegexNative) flags and listp = List.exists ((=) RegexList) flags and replacep = List.exists ((=) RegexReplace) flags in @@ -1427,23 +1428,23 @@ let type_binary_op ctxt = | false, false, false -> (* tilde *) add_empty_usages (datatype "(String, Regex) -> Bool") | _ , _ , true -> assert false end - | `And - | `Or -> add_empty_usages (datatype "(Bool,Bool) -> Bool") - | `Cons -> add_empty_usages (Utils.instantiate ctxt.var_env "Cons") - | `Name "++" -> add_empty_usages (Utils.instantiate ctxt.var_env "Concat") - | `Name ">" - | `Name ">=" - | `Name "==" - | `Name "<" - | `Name "<=" - | `Name "<>" -> + | And + | Or -> add_empty_usages (datatype "(Bool,Bool) -> Bool") + | Cons -> add_empty_usages (Utils.instantiate ctxt.var_env "Cons") + | Name "++" -> add_empty_usages (Utils.instantiate ctxt.var_env "Concat") + | Name ">" + | Name ">=" + | Name "==" + | Name "<" + | Name "<=" + | Name "<>" -> let a = Types.fresh_type_variable (linAny, `Any) in let eff = (StringMap.empty, Types.fresh_row_variable (linAny, `Any), false) in ([`Type a; `Row eff], `Function (Types.make_tuple_type [a; a], eff, `Primitive `Bool), StringMap.empty) - | `Name "!" -> add_empty_usages (Utils.instantiate ctxt.var_env "Send") - | `Name n -> add_usages (Utils.instantiate ctxt.var_env n) (StringMap.singleton n 1) + | Name "!" -> add_empty_usages (Utils.instantiate ctxt.var_env "Send") + | Name n -> add_usages (Utils.instantiate ctxt.var_env n) (StringMap.singleton n 1) (** close a pattern type relative to a list of patterns From bbbdb04b61b7c914ec0c5ae29dc09b55e14cefbb Mon Sep 17 00:00:00 2001 From: Jan Stolarek Date: Thu, 21 Feb 2019 11:03:58 +0000 Subject: [PATCH 21/28] Redefine restriction as a variant --- core/commonTypes.ml | 32 ++++++ core/compilePatterns.ml | 2 +- core/desugarDatatypes.ml | 3 +- core/desugarDbs.ml | 2 +- core/desugarFormlets.ml | 2 +- core/desugarFuns.ml | 6 +- core/desugarPages.ml | 4 +- core/instantiate.ml | 4 +- core/lib.ml | 2 +- core/parser.mly | 26 ++--- core/sugartoir.ml | 2 +- core/sugartypes.ml | 7 +- core/transformSugar.ml | 10 +- core/typeSugar.ml | 228 +++++++++++++++++++-------------------- core/typeUtils.ml | 2 +- core/types.ml | 109 +++++++++---------- core/types.mli | 5 +- core/unify.ml | 39 ++++--- 18 files changed, 244 insertions(+), 241 deletions(-) diff --git a/core/commonTypes.ml b/core/commonTypes.ml index ed42cd319..c20bc1dfa 100644 --- a/core/commonTypes.ml +++ b/core/commonTypes.ml @@ -10,3 +10,35 @@ let string_of_linearity = function let linUnl = Linearity.Unl let linAny = Linearity.Any let isUnl lin = lin == Linearity.Unl + +module Restriction = struct + type t = + | Any + | Base + | Session + | Effect + [@@deriving eq,show] + + let isAny = function + | Any -> true + | _ -> false + + let isBase = function + | Base -> true + | _ -> false + + let isSession = function + | Session -> true + | _ -> false +end + +let resAny = Restriction.Any +let resBase = Restriction.Base +let resSession = Restriction.Session +let resEffect = Restriction.Effect + +let string_of_restriction = function + | Restriction.Any -> "Any" + | Restriction.Base -> "Base" + | Restriction.Session -> "Session" + | Restriction.Effect -> "Eff" diff --git a/core/compilePatterns.ml b/core/compilePatterns.ml index 723b70d81..cb8272c1b 100644 --- a/core/compilePatterns.ml +++ b/core/compilePatterns.ml @@ -78,7 +78,7 @@ let lookup_effects (_nenv, _tenv, eff, _penv) = eff let rec desugar_pattern : Ir.scope -> Sugartypes.Pattern.with_pos -> pattern * raw_env = fun scope {Sugartypes.node=p; Sugartypes.pos} -> let desugar_pat = desugar_pattern scope in - let empty = (NEnv.empty, TEnv.empty, Types.make_empty_open_row (linAny, `Any)) in + let empty = (NEnv.empty, TEnv.empty, Types.make_empty_open_row (linAny, resAny)) in let (++) (nenv, tenv, _) (nenv', tenv', eff') = (NEnv.extend nenv nenv', TEnv.extend tenv tenv', eff') in let fresh_binder (nenv, tenv, eff) bndr = assert (Sugartypes.binder_has_type bndr); diff --git a/core/desugarDatatypes.ml b/core/desugarDatatypes.ml index ca65451f2..8b0f31408 100644 --- a/core/desugarDatatypes.ml +++ b/core/desugarDatatypes.ml @@ -1,3 +1,4 @@ +open CommonTypes open Types open Sugartypes open Utility @@ -202,7 +203,7 @@ struct (fun (q,t) -> let (q, t) = match_kinds (q, t) in match subkind_of_quantifier q with - | (_, `Effect) -> type_arg' var_env alias_env t + | (_, Restriction.Effect) -> type_arg' var_env alias_env t | _ -> type_arg var_env alias_env t) ts in diff --git a/core/desugarDbs.ml b/core/desugarDbs.ml index 164014d89..c7764ff63 100644 --- a/core/desugarDbs.ml +++ b/core/desugarDbs.ml @@ -64,7 +64,7 @@ object (o : 'self_type) from well-typed insert expressions. An alternative approach would be to maintain some kind of insert expression in the IR. *) - let value_type = `Record (Types.make_empty_open_row (linAny, `Any)) in + let value_type = `Record (Types.make_empty_open_row (linAny, resAny)) in let o, rows, _ = o#phrase rows in let tyvars = [`Type read_type; `Type write_type; `Type needed_type; `Type value_type; `Row eff] in diff --git a/core/desugarFormlets.ml b/core/desugarFormlets.ml index f60260388..d6006e8a4 100644 --- a/core/desugarFormlets.ml +++ b/core/desugarFormlets.ml @@ -41,7 +41,7 @@ object (o : 'self_type) [tuple_pat []], [tuple []], [Types.unit_type] | FormBinding (f, p) -> let (_o, _f, ft) = o#phrase f in - let t = Types.fresh_type_variable (linAny, `Any) in + let t = Types.fresh_type_variable (linAny, resAny) in let () = Unify.datatypes (ft, Instantiate.alias "Formlet" [`Type t] tycon_env) in diff --git a/core/desugarFuns.ml b/core/desugarFuns.ml index f3ad2995b..1414efdc1 100644 --- a/core/desugarFuns.ml +++ b/core/desugarFuns.ml @@ -84,9 +84,9 @@ object (o : 'self_type) in (o, e, ft) | Section (Section.Project name) -> - let ab, a = Types.fresh_type_quantifier (linAny, `Any) in - let rhob, (fields, rho, _) = Types.fresh_row_quantifier (linAny, `Any) in - let effb, eff = Types.fresh_row_quantifier (linAny, `Any) in + let ab, a = Types.fresh_type_quantifier (linAny, resAny) in + let rhob, (fields, rho, _) = Types.fresh_row_quantifier (linAny, resAny) in + let effb, eff = Types.fresh_row_quantifier (linAny, resAny) in let r = `Record (StringMap.add name (`Present a) fields, rho, false) in diff --git a/core/desugarPages.ml b/core/desugarPages.ml index bfe0437dc..261b02ca9 100644 --- a/core/desugarPages.ml +++ b/core/desugarPages.ml @@ -37,8 +37,8 @@ let rec desugar_page (o, page_type) = | FormletPlacement (formlet, handler, attributes) -> let (_, formlet, formlet_type) = o#phrase formlet in let formlet_type = Types.concrete_type formlet_type in - let a = Types.fresh_type_variable (linAny, `Any) in - let b = Types.fresh_type_variable (linAny, `Any) in + let a = Types.fresh_type_variable (linAny, resAny) in + let b = Types.fresh_type_variable (linAny, resAny) in Unify.datatypes (`Alias (("Formlet", [`Type a]), b), formlet_type); fn_appl "formP" [`Type a; `Row (o#lookup_effects)] [formlet; handler; attributes] diff --git a/core/instantiate.ml b/core/instantiate.ml index c4a238bdf..529cd5358 100644 --- a/core/instantiate.ml +++ b/core/instantiate.ml @@ -50,7 +50,7 @@ let instantiate_datatype : instantiation_maps -> datatype -> datatype = else begin let var' = Types.fresh_raw_variable () in - let point' = Unionfind.fresh (`Var (var', (linAny, `Any), `Flexible)) in + let point' = Unionfind.fresh (`Var (var', (linAny, resAny), `Flexible)) in let t' = inst (IntMap.add var point' rec_type_env, rec_row_env) t in let _ = Unionfind.change point' (`Recursive (var', t')) in `MetaTypeVar point' @@ -150,7 +150,7 @@ let instantiate_datatype : instantiation_maps -> datatype -> datatype = else begin let var' = Types.fresh_raw_variable () in - let point' = Unionfind.fresh (`Var (var', (linAny, `Any), `Flexible)) in + let point' = Unionfind.fresh (`Var (var', (linAny, resAny), `Flexible)) in let rec_row' = inst_row (rec_type_env, IntMap.add var point' rec_row_env) rec_row in let _ = Unionfind.change point' (`Recursive (var', rec_row')) in (StringMap.empty, point', dual) diff --git a/core/lib.ml b/core/lib.ml index 1cd728bef..cec0b8daa 100644 --- a/core/lib.ml +++ b/core/lib.ml @@ -72,7 +72,7 @@ let conversion_op' ~unbox ~conv ~(box :'a->Value.t): Value.t list -> Value.t = f let conversion_op ~from ~unbox ~conv ~(box :'a->Value.t) ~into pure : located_primitive * Types.datatype * pure = ((`PFun (fun _ x -> conversion_op' ~unbox:unbox ~conv:conv ~box:box x) : located_primitive), - (let q, r = Types.fresh_row_quantifier (linAny, `Any) in + (let q, r = Types.fresh_row_quantifier (linAny, resAny) in (`ForAll (Types.box_quantifiers [q], `Function (make_tuple_type [from], r, into)) : Types.datatype)), pure) diff --git a/core/parser.mly b/core/parser.mly index b398d2827..32cc01321 100644 --- a/core/parser.mly +++ b/core/parser.mly @@ -82,16 +82,16 @@ let primary_kind_of_string p = let linearity_of_string p = function - | "Any" -> Linearity.Any - | "Unl" -> Linearity.Unl + | "Any" -> linAny + | "Unl" -> linUnl | lin -> raise (ConcreteSyntaxError ("Invalid kind linearity: " ^ lin, pos p)) let restriction_of_string p = function - | "Any" -> `Any - | "Base" -> `Base - | "Session" -> `Session + | "Any" -> resAny + | "Base" -> resBase + | "Session" -> resSession | rest -> raise (ConcreteSyntaxError ("Invalid kind restriction: " ^ rest, pos p)) @@ -122,19 +122,19 @@ let kind_of p = | "Row" -> (`Row, None) | "Presence" -> (`Presence, None) (* subkind of type abbreviations *) - | "Any" -> (`Type, Some (Linearity.Any, `Any)) - | "Base" -> (`Type, Some (Linearity.Unl, `Base)) - | "Session" -> (`Type, Some (Linearity.Any, `Session)) - | "Eff" -> (`Row , Some (Linearity.Unl, `Effect)) + | "Any" -> (`Type, Some (linAny, resAny)) + | "Base" -> (`Type, Some (linUnl, resBase)) + | "Session" -> (`Type, Some (linAny, resSession)) + | "Eff" -> (`Row , Some (linUnl, resEffect)) | k -> raise (ConcreteSyntaxError ("Invalid kind: " ^ k, pos p)) let subkind_of p = function (* subkind abbreviations *) - | "Any" -> Some (Linearity.Any, `Any) - | "Base" -> Some (Linearity.Unl, `Base) - | "Session" -> Some (Linearity.Any, `Session) - | "Eff" -> Some (Linearity.Unl, `Effect) + | "Any" -> Some (linAny, resAny) + | "Base" -> Some (linUnl, resBase) + | "Session" -> Some (linAny, resSession) + | "Eff" -> Some (linUnl, resEffect) | sk -> raise (ConcreteSyntaxError ("Invalid subkind: " ^ sk, pos p)) let attach_kind (t, k) = (t, k, `Rigid) diff --git a/core/sugartoir.ml b/core/sugartoir.ml index dacd49944..6b718e8e7 100644 --- a/core/sugartoir.ml +++ b/core/sugartoir.ml @@ -870,7 +870,7 @@ struct I.do_operation (name, vs, t) | Handle { sh_expr; sh_effect_cases; sh_value_cases; sh_descr } -> let henv, params = - let empty_env = (NEnv.empty, TEnv.empty, Types.make_empty_open_row (linAny, `Any)) in + let empty_env = (NEnv.empty, TEnv.empty, Types.make_empty_open_row (linAny, resAny)) in match (sh_descr.shd_params) with | None -> empty_env, [] | Some { shp_bindings = bindings; shp_types = types } -> diff --git a/core/sugartypes.ml b/core/sugartypes.ml index fb6e64b12..e66812cab 100644 --- a/core/sugartypes.ml +++ b/core/sugartypes.ml @@ -58,13 +58,10 @@ let string_of_location = function | `Native -> "native" | `Unknown -> "unknown" -type restriction = [ `Any | `Base | `Session | `Effect ] +type subkind = Linearity.t * Restriction.t [@@deriving eq,show] -type subkind = Linearity.t * restriction - [@@deriving eq,show] - -let default_subkind : subkind = (Linearity.Unl, `Any) +let default_subkind : subkind = (linUnl, resAny) type freedom = [`Flexible | `Rigid] [@@deriving show] diff --git a/core/transformSugar.ml b/core/transformSugar.ml index d6c1934b4..2dd038d48 100644 --- a/core/transformSugar.ml +++ b/core/transformSugar.ml @@ -10,9 +10,9 @@ let type_section env = | Minus -> TyEnv.lookup env "-" | FloatMinus -> TyEnv.lookup env "-." | Project label -> - let ab, a = Types.fresh_type_quantifier (linAny, `Any) in - let rhob, (fields, rho, _) = Types.fresh_row_quantifier (linAny, `Any) in - let eb, e = Types.fresh_row_quantifier (linAny, `Any) in + let ab, a = Types.fresh_type_quantifier (linAny, resAny) in + let rhob, (fields, rho, _) = Types.fresh_row_quantifier (linAny, resAny) in + let eb, e = Types.fresh_row_quantifier (linAny, resAny) in let r = `Record (StringMap.add label (`Present a) fields, rho, false) in `ForAll (Types.box_quantifiers [ab; rhob; eb], @@ -50,8 +50,8 @@ let type_binary_op env tycon_env = | Name "<" | Name "<=" | Name "<>" -> - let ab, a = Types.fresh_type_quantifier (linAny, `Any) in - let eb, e = Types.fresh_row_quantifier (linAny, `Any) in + let ab, a = Types.fresh_type_quantifier (linAny, resAny) in + let eb, e = Types.fresh_row_quantifier (linAny, resAny) in `ForAll (Types.box_quantifiers [ab; eb], `Function (Types.make_tuple_type [a; a], e, `Primitive `Bool)) | Name "!" -> TyEnv.lookup env "Send" diff --git a/core/typeSugar.ml b/core/typeSugar.ml index 36305cc38..dda0496c0 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -970,8 +970,8 @@ end let iteration_table_pattern ~pos ~t1:l ~t2:(rexpr,rt) ~error:_ = build_tyvar_names [snd l; rt]; let rt = Types.make_table_type - (rt, Types.fresh_type_variable (linAny, `Any) - , Types.fresh_type_variable (linAny, `Any)) in + (rt, Types.fresh_type_variable (linAny, resAny) + , Types.fresh_type_variable (linAny, resAny)) in with_but2things pos ("The binding must match the table in a table generator") ("pattern", l) ("expression", (rexpr, rt)) @@ -1387,9 +1387,9 @@ let type_section context = function | Minus -> Utils.instantiate env "-", StringMap.empty | FloatMinus -> Utils.instantiate env "-.", StringMap.empty | Project label -> - let a = Types.fresh_type_variable (linAny, `Any) in - let rho = Types.fresh_row_variable (linAny, `Any) in - let effects = Types.make_empty_open_row (linAny, `Any) in (* projection is pure! *) + let a = Types.fresh_type_variable (linAny, resAny) in + let rho = Types.fresh_row_variable (linAny, resAny) in + let effects = Types.make_empty_open_row (linAny, resAny) in (* projection is pure! *) let r = `Record (StringMap.add label (`Present a) StringMap.empty, rho, false) in ([`Type a; `Row (StringMap.empty, rho, false); `Row effects], `Function (Types.make_tuple_type [r], effects, a)), StringMap.empty | Name var -> Utils.instantiate env var, StringMap.singleton var 1 @@ -1438,8 +1438,8 @@ let type_binary_op ctxt = | Name "<" | Name "<=" | Name "<>" -> - let a = Types.fresh_type_variable (linAny, `Any) in - let eff = (StringMap.empty, Types.fresh_row_variable (linAny, `Any), false) in + let a = Types.fresh_type_variable (linAny, resAny) in + let eff = (StringMap.empty, Types.fresh_row_variable (linAny, resAny), false) in ([`Type a; `Row eff], `Function (Types.make_tuple_type [a; a], eff, `Primitive `Bool), StringMap.empty) @@ -1763,7 +1763,7 @@ let type_pattern closed : Pattern.with_pos -> Pattern.with_pos * Types.environme let make_singleton_row = match closed with | `Closed -> Types.make_singleton_closed_row - | `Open -> (fun var -> Types.make_singleton_open_row var (linAny, `Any)) in + | `Open -> (fun var -> Types.make_singleton_open_row var (linAny, resAny)) in (* type_pattern p types the pattern p returning a typed pattern, a type environment for the variables bound by the pattern and two @@ -1790,16 +1790,16 @@ let type_pattern closed : Pattern.with_pos -> Pattern.with_pos * Types.environme let open Pattern in match pattern with | Nil -> - let t = Types.make_list_type (Types.fresh_type_variable (linAny, `Any)) in + let t = Types.make_list_type (Types.fresh_type_variable (linAny, resAny)) in Nil, Env.empty, (t, t) | Any -> - let t = Types.fresh_type_variable (linUnl, `Any) in + let t = Types.fresh_type_variable (linUnl, resAny) in Any, Env.empty, (t, t) | Constant c as c' -> let t = Constant.constant_type c in c', Env.empty, (t, t) | Variable bndr -> - let xtype = Types.fresh_type_variable (linAny, `Any) in + let xtype = Types.fresh_type_variable (linAny, resAny) in (Variable (set_binder_type bndr xtype), Env.bind Env.empty (name_of_binder bndr, xtype), (xtype, xtype)) @@ -1820,7 +1820,7 @@ let type_pattern closed : Pattern.with_pos -> Pattern.with_pos * Types.environme Types.make_list_type (typ p) in let ts = match ps' with - | [] -> let t = Types.fresh_type_variable (linAny, `Any) in t, t + | [] -> let t = Types.fresh_type_variable (linAny, resAny) in t, t | p::ps -> list_type p ps ot, list_type p ps it in @@ -1836,9 +1836,9 @@ let type_pattern closed : Pattern.with_pos -> Pattern.with_pos * Types.environme (* Auxiliary machinery for typing effect patterns *) let rec type_resumption_pat (kpat : Pattern.with_pos) : Pattern.with_pos * Types.environment * (Types.datatype * Types.datatype) = let fresh_resumption_type () = - let domain = Types.fresh_type_variable (linUnl, `Any) in - let codomain = Types.fresh_type_variable (linUnl, `Any) in - let effrow = Types.make_empty_open_row (linUnl, `Any) in + let domain = Types.fresh_type_variable (linUnl, resAny) in + let codomain = Types.fresh_type_variable (linUnl, resAny) in + let effrow = Types.make_empty_open_row (linUnl, resAny) in Types.make_function_type [domain] effrow codomain in let pos' = kpat.pos in @@ -1891,12 +1891,12 @@ let type_pattern closed : Pattern.with_pos -> Pattern.with_pos * Types.environme in Effect (name, List.map erase ps, erase k), env, (eff ot, eff it) | Negative names -> - let row_var = Types.fresh_row_variable (linAny, `Any) in + let row_var = Types.fresh_row_variable (linAny, resAny) in let positive, negative = List.fold_right (fun name (positive, negative) -> - let a = Types.fresh_type_variable (linAny, `Any) in + let a = Types.fresh_type_variable (linAny, resAny) in (StringMap.add name (`Present a) positive, StringMap.add name `Absent negative)) names (StringMap.empty, StringMap.empty) in @@ -1918,7 +1918,7 @@ let type_pattern closed : Pattern.with_pos -> Pattern.with_pos * Types.environme List.fold_right (fun (label, _) -> Types.row_with (label, `Absent)) - ps (Types.make_empty_open_row (linAny, `Any)) in + ps (Types.make_empty_open_row (linAny, resAny)) in let () = unify ~handle:Gripers.record_pattern (("", `Record row), (pos r, typ r)) in @@ -2027,7 +2027,7 @@ let make_ft declared_linearity ps effects return_type = let rec ft = function | [p] -> ftcon (args p, effects, return_type) - | p::ps -> ftcon (args p, (StringMap.empty, Types.fresh_row_variable (linAny, `Any), false), ft ps) + | p::ps -> ftcon (args p, (StringMap.empty, Types.fresh_row_variable (linAny, resAny), false), ft ps) | [] -> assert false in ft ps @@ -2042,7 +2042,7 @@ let make_ft_poly_curry declared_linearity ps effects return_type = | [p] -> [], ftcon (args p, effects, return_type) | p::ps -> let qs, t = ft ps in - let q, eff = Types.fresh_row_quantifier (linAny, `Any) in + let q, eff = Types.fresh_row_quantifier (linAny, resAny) in q::qs, ftcon (args p, eff, t) | [] -> assert false in @@ -2124,8 +2124,8 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let (_,_,e) = SourceCode.resolve_pos p.pos in e and erase_cases = List.map (fun ((p, _, _t), (e, _, _)) -> p, e) in let type_cases binders = - let pt = Types.fresh_type_variable (linAny, `Any) in - let bt = Types.fresh_type_variable (linAny, `Any) in + let pt = Types.fresh_type_variable (linAny, resAny) in + let bt = Types.fresh_type_variable (linAny, resAny) in let binders, pats = List.fold_right (fun (pat, body) (binders, pats) -> @@ -2229,7 +2229,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (* make sure rtype is a record type that doesn't match any of the existing fields *) let () = unify ~handle:Gripers.extend_record - (pos_and_typ r, no_pos (`Record (absent_field_env, Types.fresh_row_variable (linAny, `Any), false))) in + (pos_and_typ r, no_pos (`Record (absent_field_env, Types.fresh_row_variable (linAny, resAny), false))) in let (rfield_env, rrow_var, lr), _ = Types.unwrap_row (TypeUtils.extract_row rtype) in assert (lr = false); @@ -2260,7 +2260,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = | ListLit (es, _) -> begin match List.map tc es with | [] -> - let t = Types.fresh_type_variable (linAny, `Any) in + let t = Types.fresh_type_variable (linAny, resAny) in ListLit ([], Some t), `Application (Types.list, [`Type t]), StringMap.empty | e :: es -> List.iter (fun e' -> unify ~handle:Gripers.list_lit (pos_and_typ e, pos_and_typ e')) es; @@ -2274,7 +2274,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let env' = Env.extend context.var_env pat_env in (* type of the effects in the body of the lambda *) - let effects = (StringMap.empty, Types.fresh_row_variable (linAny, `Any), false) in + let effects = (StringMap.empty, Types.fresh_row_variable (linAny, resAny), false) in let body = type_check ({context with var_env = env'; effect_row = effects}) body in @@ -2338,14 +2338,14 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = | ConstructorLit (c, None, _) -> let type' = `Variant (Types.make_singleton_open_row (c, `Present Types.unit_type) - (linAny, `Any)) in + (linAny, resAny)) in ConstructorLit (c, None, Some type'), type', StringMap.empty | ConstructorLit (c, Some v, _) -> let v = tc v in let type' = `Variant (Types.make_singleton_open_row (c, `Present (typ v)) - (linAny, `Any)) in + (linAny, resAny)) in ConstructorLit (c, Some (erase v), Some type'), type', usages v (* database *) @@ -2429,9 +2429,9 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = | DBDelete (pat, from, where) -> let pat = tpc pat in let from = tc from in - let read = `Record (Types.make_empty_open_row (linAny, `Base)) in - let write = `Record (Types.make_empty_open_row (linAny, `Base)) in - let needed = `Record (Types.make_empty_open_row (linAny, `Base)) in + let read = `Record (Types.make_empty_open_row (linAny, resBase)) in + let write = `Record (Types.make_empty_open_row (linAny, resBase)) in + let needed = `Record (Types.make_empty_open_row (linAny, resBase)) in let () = unify ~handle:Gripers.delete_table (pos_and_typ from, no_pos (`Table (read, write, needed))) in let () = unify ~handle:Gripers.delete_pattern (ppos_and_typ pat, no_pos read) in @@ -2451,7 +2451,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (* delete is wild *) let () = let outer_effects = - Types.make_singleton_open_row ("wild", `Present Types.unit_type) (linAny, `Any) + Types.make_singleton_open_row ("wild", `Present Types.unit_type) (linAny, resAny) in unify ~handle:Gripers.delete_outer (no_pos (`Record context.effect_row), no_pos (`Record outer_effects)) @@ -2462,9 +2462,9 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let into = tc into in let values = tc values in let id = opt_map tc id in - let read = `Record (Types.make_empty_open_row (linAny, `Base)) in - let write = `Record (Types.make_empty_open_row (linAny, `Base)) in - let needed = `Record (Types.make_empty_open_row (linAny, `Base)) in + let read = `Record (Types.make_empty_open_row (linAny, resBase)) in + let write = `Record (Types.make_empty_open_row (linAny, resBase)) in + let needed = `Record (Types.make_empty_open_row (linAny, resBase)) in let () = unify ~handle:Gripers.insert_table (pos_and_typ into, no_pos (`Table (read, write, needed))) in @@ -2474,7 +2474,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = if StringMap.mem name field_env then Gripers.die pos "Duplicate labels in insert expression." else - StringMap.add name (`Present (Types.fresh_type_variable (linAny, `Base))) field_env) + StringMap.add name (`Present (Types.fresh_type_variable (linAny, resBase))) field_env) labels StringMap.empty in (* check that the fields in the type of values match the declared labels *) @@ -2485,16 +2485,16 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let needed_env = StringMap.map - (fun _f -> Types.fresh_presence_variable (linAny, `Base)) + (fun _f -> Types.fresh_presence_variable (linAny, resBase)) field_env in (* all fields being inserted must be present in the read row *) let () = unify ~handle:Gripers.insert_read - (no_pos read, no_pos (`Record (field_env, Types.fresh_row_variable (linAny, `Base), false))) in + (no_pos read, no_pos (`Record (field_env, Types.fresh_row_variable (linAny, resBase), false))) in (* all fields being inserted must be present in the write row *) let () = unify ~handle:Gripers.insert_write - (no_pos write, no_pos (`Record (field_env, Types.fresh_row_variable (linAny, `Base), false))) in + (no_pos write, no_pos (`Record (field_env, Types.fresh_row_variable (linAny, resBase), false))) in (* all fields being inserted must be consistent with the needed row *) let () = unify ~handle:Gripers.insert_needed @@ -2516,7 +2516,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = unify ~handle:Gripers.insert_id (no_pos read, - no_pos (`Record (StringMap.singleton id (`Present Types.int_type), Types.fresh_row_variable (linAny, `Base), false))); + no_pos (`Record (StringMap.singleton id (`Present Types.int_type), Types.fresh_row_variable (linAny, resBase), false))); Types.int_type | _ -> assert false end in @@ -2524,7 +2524,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (* insert is wild *) let () = let outer_effects = - Types.make_singleton_open_row ("wild", `Present Types.unit_type) (linAny, `Any) + Types.make_singleton_open_row ("wild", `Present Types.unit_type) (linAny, resAny) in unify ~handle:Gripers.insert_outer (no_pos (`Record context.effect_row), no_pos (`Record outer_effects)) @@ -2534,9 +2534,9 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = | DBUpdate (pat, from, where, set) -> let pat = tpc pat in let from = tc from in - let read = `Record (Types.make_empty_open_row (linAny, `Base)) in - let write = `Record (Types.make_empty_open_row (linAny, `Base)) in - let needed = `Record (Types.make_empty_open_row (linAny, `Base)) in + let read = `Record (Types.make_empty_open_row (linAny, resBase)) in + let write = `Record (Types.make_empty_open_row (linAny, resBase)) in + let needed = `Record (Types.make_empty_open_row (linAny, resBase)) in let () = unify ~handle:Gripers.update_table (pos_and_typ from, no_pos (`Table (read, write, needed))) in @@ -2569,25 +2569,25 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let needed_env = StringMap.map - (fun _f -> Types.fresh_presence_variable (linAny, `Base)) + (fun _f -> Types.fresh_presence_variable (linAny, resBase)) field_env in (* all fields being updated must be present in the read row *) let () = unify ~handle:Gripers.update_read - (no_pos read, no_pos (`Record (field_env, Types.fresh_row_variable (linAny, `Base), false))) in + (no_pos read, no_pos (`Record (field_env, Types.fresh_row_variable (linAny, resBase), false))) in (* all fields being updated must be present in the write row *) let () = unify ~handle:Gripers.update_write - (no_pos write, no_pos (`Record (field_env, Types.fresh_row_variable (linAny, `Base), false))) in + (no_pos write, no_pos (`Record (field_env, Types.fresh_row_variable (linAny, resBase), false))) in (* all fields being updated must be consistent with the needed row *) let () = unify ~handle:Gripers.update_needed - (no_pos needed, no_pos (`Record (needed_env, Types.fresh_row_variable (linAny, `Base), false))) in + (no_pos needed, no_pos (`Record (needed_env, Types.fresh_row_variable (linAny, resBase), false))) in (* update is wild *) let () = let outer_effects = - Types.make_singleton_open_row ("wild", `Present Types.unit_type) (linAny, `Any) + Types.make_singleton_open_row ("wild", `Present Types.unit_type) (linAny, resAny) in unify ~handle:Gripers.update_outer (no_pos (`Record context.effect_row), no_pos (`Record outer_effects)) @@ -2598,14 +2598,14 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = | Query (range, p, _) -> let range, outer_effects, range_usages = match range with - | None -> None, Types.make_empty_open_row (linAny, `Any), StringMap.empty + | None -> None, Types.make_empty_open_row (linAny, resAny), StringMap.empty | Some (limit, offset) -> let limit = tc limit in let () = unify ~handle:Gripers.range_bound (pos_and_typ limit, no_pos Types.int_type) in let offset = tc offset in let () = unify ~handle:Gripers.range_bound (pos_and_typ offset, no_pos Types.int_type) in let outer_effects = - Types.make_singleton_open_row ("wild", `Present Types.unit_type) (linAny, `Any) + Types.make_singleton_open_row ("wild", `Present Types.unit_type) (linAny, resAny) in Some (erase limit, erase offset), outer_effects, merge_usages [usages limit; usages offset] in let inner_effects = Types.make_empty_closed_row () in @@ -2613,19 +2613,19 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (no_pos (`Record context.effect_row), no_pos (`Record outer_effects)) in let p = type_check (bind_effects context inner_effects) p in let () = if Settings.get_value Basicsettings.Shredding.relax_query_type_constraint then () - else let shape = Types.make_list_type (`Record (StringMap.empty, Types.fresh_row_variable (linAny, `Base), false)) in + else let shape = Types.make_list_type (`Record (StringMap.empty, Types.fresh_row_variable (linAny, resBase), false)) in unify ~handle:Gripers.query_base_row (pos_and_typ p, no_pos shape) in Query (range, erase p, Some (typ p)), typ p, merge_usages [range_usages; usages p] (* mailbox-based concurrency *) | Spawn (Wait, l, p, _) -> assert (l = NoSpawnLocation); (* (() -{b}-> d) -> d *) - let inner_effects = Types.make_empty_open_row (linAny, `Any) in + let inner_effects = Types.make_empty_open_row (linAny, resAny) in (* TODO: check if pid_type is actually needed somewhere *) (* let pid_type = `Application (Types.process, [`Row inner_effects]) in *) let () = let outer_effects = - Types.make_singleton_open_row ("wild", `Present Types.unit_type) (linAny, `Any) + Types.make_singleton_open_row ("wild", `Present Types.unit_type) (linAny, resAny) in unify ~handle:Gripers.spawn_wait_outer (no_pos (`Record context.effect_row), no_pos (`Record outer_effects)) in @@ -2642,11 +2642,11 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = | _ -> ()); (* (() -e-> _) -> Process (e) *) - let inner_effects = Types.make_empty_open_row (linAny, `Any) in + let inner_effects = Types.make_empty_open_row (linAny, resAny) in let pid_type = `Application (Types.process, [`Row inner_effects]) in let () = let outer_effects = - Types.make_singleton_open_row ("wild", `Present Types.unit_type) (linAny, `Any) + Types.make_singleton_open_row ("wild", `Present Types.unit_type) (linAny, resAny) in unify ~handle:Gripers.spawn_outer (no_pos (`Record context.effect_row), no_pos (`Record outer_effects)) in @@ -2655,10 +2655,10 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = Gripers.die pos ("Spawned processes cannot produce values of linear type (here " ^ Types.string_of_datatype (typ p) ^ ")"); Spawn (k, given_loc, erase p, Some inner_effects), pid_type, usages p | Receive (binders, _) -> - let mb_type = Types.fresh_type_variable (linAny, `Any) in + let mb_type = Types.fresh_type_variable (linAny, resAny) in let effects = Types.row_with ("wild", `Present Types.unit_type) - (Types.make_singleton_open_row ("hear", `Present mb_type) (linAny, `Any)) in + (Types.make_singleton_open_row ("hear", `Present mb_type) (linAny, resAny)) in let () = unify ~handle:Gripers.receive_mailbox (no_pos (`Record context.effect_row), no_pos (`Record effects)) in @@ -2670,28 +2670,18 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = Receive (erase_cases binders, Some body_type), body_type, usages_cases binders (* session-based concurrency *) - (* | `Link (l, r) -> *) - (* let l = tc l in *) - (* let r = tc r in *) - (* unify ~handle:Gripers.cp_link_session *) - (* (pos_and_typ l, no_pos (Types.fresh_type_variable (`Any, `Session))); *) - (* unify ~handle:Gripers.cp_link_session *) - (* (pos_and_typ r, no_pos (Types.fresh_type_variable (`Any, `Session))); *) - (* unify ~handle:Gripers.cp_link_dual *) - (* ((exp_pos l, Types.dual_type (typ l)), pos_and_typ r); *) - (* `Link (erase l, erase r), Types.unit_type, merge_usages [usages l; usages r] *) | Select (l, e) -> let e = tc e in - let selected_session = Types.fresh_type_variable (linAny, `Session) in + let selected_session = Types.fresh_type_variable (linAny, resSession) in unify ~handle:Gripers.selection (pos_and_typ e, no_pos (`Select (Types.make_singleton_open_row (l, `Present selected_session) - (linAny, `Session)))); + (linAny, resSession)))); Select (l, erase e), selected_session, usages e | Offer (e, branches, _) -> let e = tc e in let branches, pattern_type, body_type = type_cases branches in - let r = Types.make_empty_open_row (linAny, `Session) in + let r = Types.make_empty_open_row (linAny, resSession) in unify ~handle:Gripers.offer_variant (no_pos pattern_type, no_pos (`Variant r)); unify ~handle:Gripers.offer_patterns (pos_and_typ e, no_pos (`Choice r)); Offer (erase e, erase_cases branches, Some body_type), body_type, merge_usages [usages e; usages_cases branches] @@ -2705,7 +2695,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = | UnaryAppl ((_, op), p) -> let tyargs, opt, op_usage = type_unary_op context op and p = tc p - and rettyp = Types.fresh_type_variable (linAny, `Any) in + and rettyp = Types.fresh_type_variable (linAny, resAny) in unify ~handle:Gripers.unary_apply ((string_of_unary_op op, opt), no_pos (`Function (Types.make_tuple_type [typ p], context.effect_row, rettyp))); @@ -2714,7 +2704,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let tyargs, opt, op_usages = type_binary_op context op in let l = tc l and r = tc r - and rettyp = Types.fresh_type_variable (linAny, `Any) in + and rettyp = Types.fresh_type_variable (linAny, resAny) in unify ~handle:Gripers.infix_apply ((string_of_binop op, opt), no_pos (`Function (Types.make_tuple_type [typ l; typ r], @@ -2826,7 +2816,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = end | ft -> - let rettyp = Types.fresh_type_variable (linAny, `Any) in + let rettyp = Types.fresh_type_variable (linAny, resAny) in begin unify_or ~handle:Gripers.fun_apply ~pos ((exp_pos f, ft), no_pos (`Function (Types.make_tuple_type (List.map typ ps), @@ -2886,7 +2876,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = 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 | FormletPlacement (f, h, attributes) -> - let t = Types.fresh_type_variable (linAny, `Any) in + let t = Types.fresh_type_variable (linAny, resAny) in let f = tc f and h = tc h @@ -2908,7 +2898,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = | FormBinding (e, pattern) -> let e = tc e and pattern = tpc pattern in - let a = Types.fresh_type_variable (linAny, `Any) in + let a = Types.fresh_type_variable (linAny, resAny) in let ft = Instantiate.alias "Formlet" [`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)); @@ -2930,7 +2920,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (fun (generators, generator_usages, environments) -> function | List (pattern, e) -> - let a = Types.fresh_type_variable (linAny, `Any) in + let a = Types.fresh_type_variable (linAny, resAny) in let lt = Types.make_list_type a in let pattern = tpc pattern in let e = tc e in @@ -2941,8 +2931,8 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = usages e :: generator_usages, pattern_env pattern :: environments) | Table (pattern, e) -> - let a = Types.fresh_type_variable (linAny, `Any) in - let tt = Types.make_table_type (a, Types.fresh_type_variable (linAny, `Any), Types.fresh_type_variable (linAny, `Any)) in + let a = Types.fresh_type_variable (linAny, resAny) in + let tt = Types.make_table_type (a, Types.fresh_type_variable (linAny, resAny), Types.fresh_type_variable (linAny, resAny)) in let pattern = tpc pattern in let e = tc e in let () = unify ~handle:Gripers.iteration_table_body (pos_and_typ e, no_pos tt) in @@ -2959,7 +2949,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let orderby = opt_map tc orderby in let () = unify ~handle:Gripers.iteration_body - (pos_and_typ body, no_pos (Types.make_list_type (Types.fresh_type_variable (linAny, `Any)))) in + (pos_and_typ body, no_pos (Types.make_list_type (Types.fresh_type_variable (linAny, resAny)))) in let () = opt_iter (fun where -> unify ~handle:Gripers.iteration_where (pos_and_typ where, no_pos Types.bool_type)) where in @@ -2968,11 +2958,11 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = opt_iter (fun order -> unify ~handle:Gripers.iteration_base_order - (pos_and_typ order, no_pos (`Record (Types.make_empty_open_row (linAny, `Base))))) orderby in + (pos_and_typ order, no_pos (`Record (Types.make_empty_open_row (linAny, resBase))))) orderby in let () = if is_query && not (Settings.get_value Basicsettings.Shredding.relax_query_type_constraint) then unify ~handle:Gripers.iteration_base_body - (pos_and_typ body, no_pos (Types.make_list_type (`Record (Types.make_empty_open_row (linAny, `Base))))) in + (pos_and_typ body, no_pos (Types.make_list_type (`Record (Types.make_empty_open_row (linAny, resBase))))) in let e = Iteration (generators, erase body, opt_map erase where, opt_map erase orderby) in let vs = List.fold_left StringSet.union StringSet.empty (List.map Env.domain environments) in let us = merge_usages (List.append generator_usages @@ -3006,10 +2996,10 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (Also, should the mailbox type be generalised?) *) let name = name_of_binder bndr in - let f = Types.fresh_type_variable (linAny, `Any) in - let t = Types.fresh_type_variable (linAny, `Any) in + let f = Types.fresh_type_variable (linAny, resAny) in + let t = Types.fresh_type_variable (linAny, resAny) in - let eff = Types.make_singleton_open_row ("wild", `Present Types.unit_type) (linAny, `Any) in + let eff = Types.make_singleton_open_row ("wild", `Present Types.unit_type) (linAny, resAny) in let cont_type = `Function (Types.make_tuple_type [f], eff, t) in let context' = {context @@ -3018,7 +3008,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let () = let outer_effects = - Types.make_singleton_open_row ("wild", `Present Types.unit_type) (linAny, `Any) + Types.make_singleton_open_row ("wild", `Present Types.unit_type) (linAny, resAny) in unify ~handle:Gripers.escape_outer (no_pos (`Record context.effect_row), no_pos (`Record outer_effects)) in @@ -3106,30 +3096,30 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = unify ~handle:Gripers.projection ((exp_pos r, rt), no_pos (`Record (Types.make_singleton_closed_row - (l, `Present (Types.fresh_type_variable (linAny, `Any)))))); + (l, `Present (Types.fresh_type_variable (linAny, resAny)))))); let r' = erase r in let rn, rpos = r'.node, r'.pos in let e = tabstr (pqs, Projection (with_pos rpos (tappl (rn, tyargs)), l)) in e, fieldtype, usages r | Some (`Absent | `Var _) | None -> - let fieldtype = Types.fresh_type_variable (linAny, `Any) in + let fieldtype = Types.fresh_type_variable (linAny, resAny) in unify ~handle:Gripers.projection ((exp_pos r, rt), no_pos (`Record (Types.make_singleton_open_row (l, `Present fieldtype) - (linUnl, `Any)))); + (linUnl, resAny)))); let r' = erase r in let rn, rpos = r'.node, r'.pos in let e = Projection (with_pos rpos (tappl (rn, tyargs)), l) in e, fieldtype, usages r end | _ -> - let fieldtype = Types.fresh_type_variable (linAny, `Any) in + let fieldtype = Types.fresh_type_variable (linAny, resAny) in unify ~handle:Gripers.projection (pos_and_typ r, no_pos (`Record (Types.make_singleton_open_row (l, `Present fieldtype) - (linUnl, `Any)))); + (linUnl, resAny)))); Projection (erase r, l), fieldtype, usages r end | With (r, fields) -> @@ -3140,8 +3130,8 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let fields_type = `Record (List.fold_right (fun (lab, _) row -> - Types.row_with (lab, `Present (Types.fresh_type_variable (linUnl, `Any))) row) - fields (Types.make_empty_open_row (linAny, `Any))) in + Types.row_with (lab, `Present (Types.fresh_type_variable (linUnl, resAny))) row) + fields (Types.make_empty_open_row (linAny, resAny))) in unify ~handle:Gripers.record_with (pos_and_typ r, no_pos fields_type) in let (rfields, row_var, lr), _ = Types.unwrap_row (TypeUtils.extract_row (typ r)) in assert (not lr); @@ -3231,11 +3221,11 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = in let type_cases val_cases eff_cases = let wild_row () = - let fresh_row = Types.make_empty_open_row (linUnl, `Any) in + let fresh_row = Types.make_empty_open_row (linUnl, resAny) in allow_wild fresh_row in - let rt = Types.fresh_type_variable (linUnl, `Any) in - let bt = Types.fresh_type_variable (linUnl, `Any) in + let rt = Types.fresh_type_variable (linUnl, resAny) in + let bt = Types.fresh_type_variable (linUnl, resAny) in let inner_eff = wild_row () in let outer_eff = wild_row () in (* Type value patterns *) @@ -3305,10 +3295,10 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = | Any -> let kt = let domain = - (Types.fresh_type_variable (linUnl, `Any)) :: handler_params + (Types.fresh_type_variable (linUnl, resAny)) :: handler_params in - let effects = Types.make_empty_open_row (linUnl, `Any) in - let codomain = Types.fresh_type_variable (linUnl, `Any) in + let effects = Types.make_empty_open_row (linUnl, resAny) in + let codomain = Types.fresh_type_variable (linUnl, resAny) in Types.make_function_type domain effects codomain in (pat, env, effrow), (kpat, Env.empty, kt) @@ -3349,9 +3339,9 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = | Any -> let kt = Types.make_function_type - [Types.fresh_type_variable (linUnl, `Any)] - (Types.make_empty_open_row (linUnl, `Any)) - (Types.fresh_type_variable (linUnl, `Any)) + [Types.fresh_type_variable (linUnl, resAny)] + (Types.make_empty_open_row (linUnl, resAny)) + (Types.fresh_type_variable (linUnl, resAny)) in (pat, env, effrow), (kpat, Env.empty, kt) | _ -> assert false @@ -3416,13 +3406,13 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (fun name p -> if TypeUtils.is_builtin_effect name then p - else Types.fresh_presence_variable (linUnl, `Any)) (* It is questionable whether it is ever correct to + else Types.fresh_presence_variable (linUnl, resAny)) (* It is questionable whether it is ever correct to make absent operations polymorphic in their presence. *) operations in (operations', rho, dual) in - let m_context = { context with effect_row = Types.make_empty_open_row (linUnl, `Any) } in + let m_context = { context with effect_row = Types.make_empty_open_row (linUnl, resAny) } in let m = type_check m_context m in (* Type-check the input computation m under current context *) let m_effects = `Effect m_context.effect_row in (** Most of the work is done by `type_cases'. *) @@ -3476,9 +3466,9 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let (row, return_type, args) = let ps = List.map tc args in let inp_t = List.map typ ps in - let out_t = Types.fresh_type_variable (linUnl, `Any) in + let out_t = Types.fresh_type_variable (linUnl, resAny) in let optype = Types.make_pure_function_type inp_t out_t in - let effrow = Types.make_singleton_open_row (opname, `Present optype) (linUnl, `Effect) in + let effrow = Types.make_singleton_open_row (opname, `Present optype) (linUnl, resEffect) in (effrow, out_t, ps) in let (_,_,p) = SourceCode.resolve_pos pos in @@ -3561,7 +3551,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (erase try_phrase, erase_pat pat, erase in_phrase, erase unless_phrase, Some return_type), return_type, usages_res | QualifiedVar _ -> assert false - | Raise -> (Raise, Types.fresh_type_variable (linAny, `Any), StringMap.empty) + | Raise -> (Raise, Types.fresh_type_variable (linAny, resAny), StringMap.empty) in with_pos pos e, t, usages (** [type_binding] takes XXX YYY (FIXME) @@ -3635,8 +3625,8 @@ and type_binding : context -> binding -> binding * context * usagemap = let vs = name :: check_for_duplicate_names pos (List.flatten pats) in let pats = List.map (List.map tpc) pats in - let effects = Types.make_empty_open_row (linAny, `Any) in - let return_type = Types.fresh_type_variable (linAny, `Any) in + let effects = Types.make_empty_open_row (linAny, resAny) in + let return_type = Types.fresh_type_variable (linAny, resAny) in (** Check that any annotation matches the shape of the function *) let context', ft = @@ -3720,7 +3710,7 @@ and type_binding : context -> binding -> binding * context * usagemap = As well as the function types, the typed patterns are also returned here as a simple optimisation. *) - let fresh_wild () = Types.make_singleton_open_row ("wild", (`Present Types.unit_type)) (linAny, `Any) in + let fresh_wild () = Types.make_singleton_open_row ("wild", (`Present Types.unit_type)) (linAny, resAny) in let inner_env, patss = List.fold_left @@ -3742,10 +3732,10 @@ and type_binding : context -> binding -> binding * context * usagemap = f(x1)...(xk) } *) - make_ft_poly_curry lin pats (fresh_wild ()) (Types.fresh_type_variable (linAny, `Any)) + make_ft_poly_curry lin pats (fresh_wild ()) (Types.fresh_type_variable (linAny, resAny)) | Some (_, Some t) -> (* Debug.print ("t: " ^ Types.string_of_datatype t); *) - let shape = make_ft lin pats (fresh_wild ()) (Types.fresh_type_variable (linAny, `Any)) in + let shape = make_ft lin pats (fresh_wild ()) (Types.fresh_type_variable (linAny, resAny)) in let (_, ft) = Generalise.generalise_rigid context.var_env t in (* Debug.print ("ft: " ^ Types.string_of_datatype ft); *) (* make sure the annotation has the right shape *) @@ -3955,7 +3945,7 @@ and type_cp (context : context) = fun {node = p; pos} -> | CPGrab ((c, _), Some bndr, p) -> let x = name_of_binder bndr in let (_, t, _) = type_check context (with_pos pos (Sugartypes.Var c)) in - let a = Types.fresh_type_variable (linAny, `Any) in + let a = Types.fresh_type_variable (linAny, resAny) in let s = Types.fresh_session_variable linAny in let ctype = `Input (a, s) in unify ~pos:pos ~handle:(Gripers.cp_grab c) @@ -4022,7 +4012,7 @@ and type_cp (context : context) = fun {node = p; pos} -> let c = name_of_binder bndr in let (_, t, _) = type_check context (with_pos pos (Sugartypes.Var c)) in let s = Types.fresh_session_variable linAny in - let r = Types.make_singleton_open_row (label, `Present s) (linAny, `Session) in + let r = Types.make_singleton_open_row (label, `Present s) (linAny, resSession) in let ctype = `Select r in unify ~pos:pos ~handle:(Gripers.cp_select c) (t, ctype); @@ -4032,19 +4022,19 @@ and type_cp (context : context) = fun {node = p; pos} -> let c = name_of_binder bndr in let (_, t, _) = type_check context (with_pos pos (Sugartypes.Var c)) in (* - let crow = Types.make_empty_open_row (linAny, `Session) in + let crow = Types.make_empty_open_row (linAny, resSession) in let ctype = `Choice crow in unify ~pos:pos ~handle:(Gripers.cp_offer_choice c) (t, ctype); *) let check_branch (label, body) = - let s = Types.fresh_type_variable (linAny, `Session) in - let r = Types.make_singleton_open_row (label, `Present s) (linAny, `Session) in + let s = Types.fresh_type_variable (linAny, resSession) in + let r = Types.make_singleton_open_row (label, `Present s) (linAny, resSession) in unify ~pos:pos ~handle:(Gripers.cp_offer_choice c) (t, `Choice r); let (p, t, u) = with_channel c s (type_cp (bind_var context (c, s)) body) in (label, p), t, u in let branches = List.map check_branch branches in - let t' = Types.fresh_type_variable (linAny, `Any) in + let t' = Types.fresh_type_variable (linAny, resAny) in List.iter (fun (_, t, _) -> unify ~pos:pos ~handle:Gripers.cp_offer_branches (t, t')) branches; let u = usage_compat (List.map (fun (_, _, u) -> u) branches) in CPOffer (set_binder_type bndr t, List.map (fun (x, _, _) -> x) branches), t', use c u @@ -4054,9 +4044,9 @@ and type_cp (context : context) = fun {node = p; pos} -> let (_, tc, uc) = type_check context (with_pos pos (Sugartypes.Var c)) in let (_, td, ud) = type_check context (with_pos pos (Sugartypes.Var d)) in unify ~pos:pos ~handle:Gripers.cp_link_session - (tc, Types.fresh_type_variable (linAny, `Session)); + (tc, Types.fresh_type_variable (linAny, resSession)); unify ~pos:pos ~handle:Gripers.cp_link_session - (td, Types.fresh_type_variable (linAny, `Session)); + (td, Types.fresh_type_variable (linAny, resSession)); unify ~pos:pos ~handle:Gripers.cp_link_dual (Types.dual_type tc, td); CPLink (set_binder_type bndr1 tc, set_binder_type bndr1 td), Types.make_endbang_type, merge_usages [uc; ud] | CPComp (bndr, left, right) -> diff --git a/core/typeUtils.ml b/core/typeUtils.ml index 7fd0ed83b..26a37dbe6 100644 --- a/core/typeUtils.ml +++ b/core/typeUtils.ml @@ -215,7 +215,7 @@ let rec table_needed_type t = match concrete_type t with error ("Attempt to take needed type of non-table: " ^ string_of_datatype t) let inject_type name t = - `Variant (make_singleton_open_row (name, `Present t) (linAny, `Any)) + `Variant (make_singleton_open_row (name, `Present t) (linAny, resAny)) let abs_type _ = assert false let app_type _ _ = assert false diff --git a/core/types.ml b/core/types.ml index 6be7adaa9..7fb8c45c7 100644 --- a/core/types.ml +++ b/core/types.ml @@ -19,10 +19,7 @@ type 'a point = 'a Unionfind.point [@@deriving show] type primitive = [ `Bool | `Int | `Char | `Float | `XmlItem | `DB | `String] [@@deriving show] -type restriction = [ `Any | `Base | `Session | `Effect ] - [@@deriving eq,show] - -type subkind = Linearity.t * restriction +type subkind = Linearity.t * Restriction.t [@@deriving eq,show] type freedom = [`Rigid | `Flexible] @@ -73,7 +70,7 @@ end let process = { Abstype.id = "Process" ; name = "Process" ; - arity = [`Row, (linAny, `Any)] ; + arity = [`Row, (linAny, resAny)] ; } (* Lists are currently unlimited because the only deconstructors are @@ -82,7 +79,7 @@ let process = { let list = { Abstype.id = "List" ; name = "List" ; - arity = [`Type, (linUnl, `Any)] ; + arity = [`Type, (linUnl, resAny)] ; } let event = { @@ -99,7 +96,7 @@ let dom_node = { let access_point = { Abstype.id = "AP" ; name = "AP" ; - arity = [`Type, (linAny, `Session)] ; + arity = [`Type, (linAny, resSession)] ; } let socket = { @@ -265,7 +262,7 @@ struct (IntMap.find var rec_types), o else let var' = fresh_raw_variable () in - let point' : meta_type_var = Unionfind.fresh (`Var (var', (linAny, `Any), `Flexible)) in + let point' : meta_type_var = Unionfind.fresh (`Var (var', (linAny, resAny), `Flexible)) in let rec_types' : (meta_type_var) IntMap.t = IntMap.add var point' rec_types in let o_extended_rec_env = {< rec_vars = (rec_types', rec_rows) >} in let (t', o') = o_extended_rec_env#typ t in @@ -285,7 +282,7 @@ struct (IntMap.find var rec_rows), o else let var' = fresh_raw_variable () in - let point' = Unionfind.fresh (`Var (var', (linAny, `Any), `Flexible)) in + let point' = Unionfind.fresh (`Var (var', (linAny, resAny), `Flexible)) in let rec_rows' = IntMap.add var point' rec_rows in let o_extended_rec_env = {< rec_vars = (rec_types, rec_rows') >} in let (r', o') = o_extended_rec_env#row r in @@ -438,7 +435,7 @@ struct method! meta_type_var point = match Unionfind.find point with | `Recursive (id, t) -> if Utility.IntSet.mem id mu_vars then - let newvar = `Var (id, (linAny, `Any), `Rigid) in + let newvar = `Var (id, (linAny, resAny), `Rigid) in (* Debug.print (Printf.sprintf "Saw rec var %d" id); *) (Unionfind.fresh newvar, o) else @@ -451,7 +448,7 @@ struct method! meta_row_var point = match Unionfind.find point with | `Recursive (id, t) -> if Utility.IntSet.mem id mu_vars then - let newvar = `Var (id, (linAny, `Any), `Rigid) in + let newvar = `Var (id, (linAny, resAny), `Rigid) in (* Debug.print (Printf.sprintf "Saw rec var %d" id); *) (Unionfind.fresh newvar, o) else @@ -493,7 +490,7 @@ let rec is_base_type : typ -> bool = | `MetaTypeVar point -> begin match Unionfind.find point with - | `Var (_, (_, `Base), _) -> true + | `Var (_, (_, Restriction.Base), _) -> true | `Var _ -> false | `Body t -> is_base_type t | `Recursive _ -> false @@ -504,7 +501,7 @@ let rec is_base_row (fields, row_var, _) = let base_row_var = match Unionfind.find row_var with | `Closed - | `Var (_, (_, `Base), _) -> true + | `Var (_, (_, Restriction.Base), _) -> true | `Var _ -> false | `Body row -> is_base_row row | `Recursive _ -> false in @@ -526,7 +523,7 @@ let rec is_baseable_type : typ -> bool = | `MetaTypeVar point -> begin match Unionfind.find point with - | `Var (_, (_, `Base), `Rigid) + | `Var (_, (_, Restriction.Base), `Rigid) | `Var (_, _, `Flexible) -> true | `Var (_, _, `Rigid) -> false | `Body t -> is_baseable_type t @@ -538,7 +535,7 @@ let rec is_baseable_row (fields, row_var, _) = let base_row_var = match Unionfind.find row_var with | `Closed - | `Var (_, (_, `Base), `Rigid) + | `Var (_, (_, Restriction.Base), `Rigid) | `Var (_, _, `Flexible) -> true | `Var (_, _, `Rigid) -> false | `Body row -> is_baseable_row row @@ -561,9 +558,9 @@ let rec basify_type : typ -> unit = | `MetaTypeVar point -> begin match Unionfind.find point with - | `Var (_, (_, `Base), _) -> () + | `Var (_, (_, Restriction.Base), _) -> () | `Var (_, _, `Rigid) -> assert false - | `Var (var, (lin, `Any), `Flexible) -> Unionfind.change point (`Var (var, (lin, `Base), `Flexible)) + | `Var (var, (lin, Restriction.Any), `Flexible) -> Unionfind.change point (`Var (var, (lin, resBase), `Flexible)) | `Var (_, _, `Flexible) -> assert false | `Body t -> basify_type t | `Recursive _ -> assert false @@ -574,8 +571,8 @@ let rec basify_row (fields, row_var, _) = begin match Unionfind.find row_var with | `Closed - | `Var (_, (_, `Base), _) -> () - | `Var (var, (lin, `Any), `Flexible) -> Unionfind.change row_var (`Var (var, (lin, `Base), `Flexible)) + | `Var (_, (_, Restriction.Base), _) -> () + | `Var (var, (lin, Restriction.Any), `Flexible) -> Unionfind.change row_var (`Var (var, (lin, resBase), `Flexible)) | `Var _ -> assert false | `Body row -> basify_row row | `Recursive _ -> assert false @@ -782,7 +779,7 @@ let is_session_point : (var_set -> 'a -> bool) -> var_set -> [< 'a meta_max_basi fun f rec_vars point -> match Unionfind.find point with | `Closed - | `Var (_, (_, `Session), _) -> true + | `Var (_, (_, Restriction.Session), _) -> true | `Var _ -> false | `Body t -> f rec_vars t | `Recursive (var, t) -> @@ -817,13 +814,13 @@ let is_sessionable_point : (var_set -> 'a -> bool) -> var_set -> [< 'a meta_max_ fun f rec_vars point -> match Unionfind.find point with | `Closed - | `Var (_, (_, `Session), _) - | `Var (_, (_, `Any), `Flexible) -> true - | `Var (_, (_, `Base), `Rigid) - | `Var (_, (_, `Any), `Rigid) - | `Var (_, (_, `Effect), `Rigid) - | `Var (_, (_, `Effect), `Flexible) - | `Var (_, (_, `Base), `Flexible) -> false + | `Var (_, (_, Restriction.Session), _) + | `Var (_, (_, Restriction.Any), `Flexible) -> true + | `Var (_, (_, Restriction.Base), `Rigid) + | `Var (_, (_, Restriction.Any), `Rigid) + | `Var (_, (_, Restriction.Effect), `Rigid) + | `Var (_, (_, Restriction.Effect), `Flexible) + | `Var (_, (_, Restriction.Base), `Flexible) -> false | `Body t -> f rec_vars t | `Recursive (var, t) -> check_rec var rec_vars true (flip f t) @@ -857,8 +854,9 @@ let sessionify_point : (var_set -> 'a -> unit) -> var_set -> [< 'a meta_max_basi fun f rec_vars point -> match Unionfind.find point with | `Closed - | `Var (_, (_, `Session), _) -> () - | `Var (var, (lin, `Any), `Flexible) -> Unionfind.change point (`Var (var, (lin, `Session), `Flexible)) + | `Var (_, (_, Restriction.Session), _) -> () + | `Var (var, (lin, Restriction.Any), `Flexible) -> + Unionfind.change point (`Var (var, (lin, Restriction.Session), `Flexible)) | `Var _ -> assert false | `Body t -> f rec_vars t | `Recursive (var, t) -> check_rec var rec_vars () (flip f t) @@ -957,7 +955,7 @@ module Env = Env.String let fresh_rigid_type_variable subkind = make_rigid_type_variable (fresh_raw_variable ()) subkind let fresh_row_variable subkind = make_row_variable (fresh_raw_variable ()) subkind let fresh_rigid_row_variable subkind = make_rigid_row_variable (fresh_raw_variable ()) subkind - let fresh_session_variable linearity = make_type_variable (fresh_raw_variable ()) (linearity, `Session) + let fresh_session_variable linearity = make_type_variable (fresh_raw_variable ()) (linearity, resSession) let fresh_presence_variable subkind = make_presence_variable (fresh_raw_variable ()) subkind let fresh_rigid_presence_variable subkind = make_rigid_presence_variable (fresh_raw_variable ()) subkind @@ -1402,7 +1400,7 @@ and flatten_row : row -> row = fun (field_env, row_var, dual) -> else (let row_var' = Unionfind.fresh (`Recursive (var, (FieldEnv.empty, - Unionfind.fresh (`Var (var, (linAny, `Any), `Flexible)), + Unionfind.fresh (`Var (var, (linAny, resAny), `Flexible)), false))) in let rec_row' = flatten_row' (IntMap.add var row_var' rec_env) rec_row in Unionfind.change row_var' (`Recursive (var, rec_row')); @@ -1889,13 +1887,8 @@ struct | s -> "::" ^ s let subkind : (policy * names) -> subkind -> string = - let restriction = function - | `Any -> "Any" - | `Base -> "Base" - | `Session -> "Session" - | `Effect -> "Eff" - in - let full (l, r) = "(" ^ string_of_linearity l ^ "," ^ restriction r ^ ")" in + let full (l, r) = "(" ^ string_of_linearity l ^ "," ^ + string_of_restriction r ^ ")" in fun (policy, _vars) -> if policy.kinds = "full" then @@ -1904,11 +1897,11 @@ struct function (_, _) -> "" else function - | (Linearity.Unl, `Any) -> "" - | (Linearity.Any, `Any) -> "Any" - | (Linearity.Unl, `Base) -> restriction `Base - | (Linearity.Any, `Session) -> restriction `Session - | (Linearity.Unl, `Effect) -> restriction `Effect + | (Linearity.Unl, Restriction.Any) -> "" + | (Linearity.Any, Restriction.Any) -> "Any" + | (Linearity.Unl, Restriction.Base) -> string_of_restriction resBase + | (Linearity.Any, Restriction.Session) -> string_of_restriction resSession + | (Linearity.Unl, Restriction.Effect) -> string_of_restriction resEffect | (l, r) -> full (l, r) let primary_kind : primary_kind -> string = function @@ -1917,12 +1910,6 @@ struct | `Presence -> "Presence" let kind : (policy * names) -> kind -> string = - let restriction = function - | `Any -> "Any" - | `Base -> "Base" - | `Session -> "Session" - | `Effect -> "Eff" - in let full (policy, _vars) (k, sk) = primary_kind k ^ subkind (policy, _vars) sk in fun (policy, _vars) (k, sk) -> @@ -1932,13 +1919,13 @@ struct primary_kind k else match (k, sk) with - | `Type, (Linearity.Unl, `Any) -> "" - | `Type, (Linearity.Unl, `Base) -> restriction `Base - | `Type, (Linearity.Any, `Session) -> restriction `Session + | `Type, (Linearity.Unl, Restriction.Any) -> "" + | `Type, (Linearity.Unl, Restriction.Base) -> string_of_restriction resBase + | `Type, (Linearity.Any, Restriction.Session) -> string_of_restriction resSession | `Type, sk -> subkind ({policy with kinds="full"}, _vars) sk - | `Row, (Linearity.Unl, `Any) -> primary_kind `Row - | `Row, (Linearity.Unl, `Effect) -> primary_kind `Row - | `Presence, (Linearity.Unl, `Any) -> primary_kind `Presence + | `Row, (Linearity.Unl, Restriction.Any) -> primary_kind `Row + | `Row, (Linearity.Unl, Restriction.Effect) -> primary_kind `Row + | `Presence, (Linearity.Unl, Restriction.Any) -> primary_kind `Presence | `Row, _ | `Presence, _ -> full ({policy with kinds="full"}, _vars) (k, sk) @@ -2520,15 +2507,15 @@ 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 (Linearity.Any, `Any)) tenv, - IntMap.map (fun _ -> (StringMap.empty, fresh_rigid_row_variable (Linearity.Any, `Any), false)) renv, - IntMap.map (fun _ -> fresh_rigid_presence_variable (Linearity.Any, `Any)) penv) + (IntMap.map (fun _ -> fresh_rigid_type_variable (linAny, resAny)) tenv, + IntMap.map (fun _ -> (StringMap.empty, fresh_rigid_row_variable (linAny, resAny), false)) renv, + IntMap.map (fun _ -> fresh_rigid_presence_variable (linAny, resAny)) 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 (Linearity.Any, `Any)) tenv, - IntMap.map (fun _ -> (StringMap.empty, fresh_row_variable (Linearity.Any, `Any), false)) renv, - IntMap.map (fun _ -> fresh_presence_variable (Linearity.Any, `Any)) penv) + (IntMap.map (fun _ -> fresh_type_variable (linAny, resAny)) tenv, + IntMap.map (fun _ -> (StringMap.empty, fresh_row_variable (linAny, resAny), false)) renv, + IntMap.map (fun _ -> fresh_presence_variable (linAny, resAny)) penv) (* subtyping *) diff --git a/core/types.mli b/core/types.mli index 8c047561c..15d39fd81 100644 --- a/core/types.mli +++ b/core/types.mli @@ -14,10 +14,7 @@ type 'a point = 'a Unionfind.point type primitive = [ `Bool | `Int | `Char | `Float | `XmlItem | `DB | `String ] [@@deriving show] -type restriction = [ `Any | `Base | `Session | `Effect ] - [@@deriving eq,show] - -type subkind = CommonTypes.Linearity.t * restriction +type subkind = CommonTypes.Linearity.t * CommonTypes.Restriction.t [@@deriving eq,show] type freedom = [`Rigid | `Flexible] diff --git a/core/unify.ml b/core/unify.ml index cb939b6d7..0761ee0f4 100644 --- a/core/unify.ml +++ b/core/unify.ml @@ -317,15 +317,14 @@ let rec unify' : unify_env -> (datatype * datatype) -> unit = | _, Linearity.Unl -> Linearity.Unl | _ -> llin in let rest = + let open Restriction in match lrest, rrest with - | `Base, `Any - | `Any, `Base -> `Base - | `Any, `Session - | `Session, `Any -> `Session - | `Base, `Session -> + | Base, Any | Any, Base -> Base + | Any, Session | Session, Any -> Session + | Base, Session -> raise (Failure (`Msg ("Cannot unify base type variable " ^ string_of_int lvar ^ " with session type variable " ^ string_of_int rvar))) - | `Session, `Base -> + | Session, Base -> raise (Failure (`Msg ("Cannot unify session type variable " ^ string_of_int lvar ^ " with base type variable " ^ string_of_int rvar))) (* in the default case lrest and rrest must be identical *) @@ -364,7 +363,7 @@ let rec unify' : unify_env -> (datatype * datatype) -> unit = | Some t2 -> unify' rec_env (t1, t2); false | None -> Debug.if_set (show_recursion) (fun () -> "rec intro1 (" ^ (string_of_int var) ^ ")"); - if rest = `Base then + if Restriction.isBase rest then raise (Failure (`Msg ("Cannot infer a recursive type for the base type variable "^ string_of_int var ^ " with the body "^ string_of_datatype t2))); rec_intro rpoint (var, Types.concrete_type t2); @@ -375,7 +374,7 @@ let rec unify' : unify_env -> (datatype * datatype) -> unit = (* FIXME: does this really still need to happen if we've just introduced a recursive type? *) if tidy then begin - if rest = `Base then + if Restriction.isBase rest then if Types.is_baseable_type t2 then Types.basify_type t2 else @@ -387,7 +386,7 @@ let rec unify' : unify_env -> (datatype * datatype) -> unit = else raise (Failure (`Msg ("Cannot unify the unlimited type variable " ^ string_of_int var ^ " with the linear type " ^ string_of_datatype t2))); - if rest = `Session then + if Restriction.isSession rest then if Types.is_sessionable_type t2 then Types.sessionify_type t2 else @@ -404,7 +403,7 @@ let rec unify' : unify_env -> (datatype * datatype) -> unit = | Some t1 -> unify' rec_env (t1, t2); false | None -> Debug.if_set (show_recursion) (fun () -> "rec intro2 (" ^ (string_of_int var) ^ ")"); - if rest = `Base then + if Restriction.isBase rest then raise (Failure (`Msg ("Cannot infer a recursive type for the base type variable "^ string_of_int var ^ " with the body "^ string_of_datatype t1))); rec_intro lpoint (var, Types.concrete_type t1); @@ -415,7 +414,7 @@ let rec unify' : unify_env -> (datatype * datatype) -> unit = (* FIXME: does this really still need to happen if we've just introduced a recursive type? *) if tidy then begin - if rest = `Base then + if Restriction.isBase rest then if Types.is_baseable_type t1 then Types.basify_type t1 else @@ -427,7 +426,7 @@ let rec unify' : unify_env -> (datatype * datatype) -> unit = else raise (Failure (`Msg ("Cannot unify the unlimited type variable " ^ string_of_int var ^ " with the linear type " ^ string_of_datatype t1))); - if rest = `Session then + if Restriction.isSession rest then if Types.is_sessionable_type t1 then Types.sessionify_type t1 else @@ -520,7 +519,7 @@ let rec unify' : unify_env -> (datatype * datatype) -> unit = Debug.if_set (show_recursion) (fun () -> "rec intro3 ("^string_of_int var^","^string_of_datatype t^")"); - if rest = `Base then + if Restriction.isBase rest then raise (Failure (`Msg ("Cannot infer a recursive type for the type variable "^ string_of_int var ^ " with the body "^ string_of_datatype t))); let point' = Unionfind.fresh (`Body t) in @@ -529,7 +528,7 @@ let rec unify' : unify_env -> (datatype * datatype) -> unit = end else (Debug.if_set (show_recursion) (fun () -> "non-rec intro (" ^ string_of_int var ^ ")"); - if rest = `Base then + if Restriction.isBase rest then if Types.is_baseable_type t then Types.basify_type t else @@ -541,7 +540,7 @@ let rec unify' : unify_env -> (datatype * datatype) -> unit = else raise (Failure (`Msg ("Cannot unify the unlimited type variable " ^ string_of_int var ^ " with the linear type "^ string_of_datatype t))); - if rest = `Session then + if Restriction.isSession rest then if Types.is_sessionable_type t then Types.sessionify_type t else @@ -981,7 +980,7 @@ and unify_rows' : unify_env -> ((row * row) -> unit) = | `Closed -> raise (Failure (`Msg ("Rigid row var cannot be unified with empty closed row\n"))) | `Var (_, (_, rest'), `Flexible) -> - if rest = `Any && rest' = `Base then + if Restriction.isAny rest && Restriction.isBase rest' then raise (Failure (`Msg ("Rigid non-base row var cannot be unified with empty base row\n"))); Unionfind.change point' (`Var (var, (lin, rest), `Rigid)) | `Var (var', _, `Rigid) when var=var' -> () @@ -1010,20 +1009,20 @@ and unify_rows' : unify_env -> ((row * row) -> unit) = if not (StringMap.is_empty extension_field_env) && TypeVarSet.mem var (free_row_type_vars extension_row) then begin - if rest = `Base then + if Restriction.isBase rest then raise (Failure (`Msg ("Cannot infer a recursive type for the base row variable "^ string_of_int var ^ " with the body "^ string_of_row extension_row))); rec_row_intro point (var, extension_row) end else begin - if rest = `Base then + if Restriction.isBase rest then if Types.is_baseable_row extension_row then Types.basify_row extension_row else raise (Failure (`Msg ("Cannot unify the base row variable "^ string_of_int var ^ " with the non-base row "^ string_of_row extension_row))); - if rest = `Session then + if Restriction.isSession rest then if Types.is_sessionable_row extension_row then Types.sessionify_row extension_row else @@ -1211,7 +1210,7 @@ and unify_rows' : unify_env -> ((row * row) -> unit) = unify_field_envs ~closed:false ~rigid:false rec_env (lfield_env', rfield_env'); (* a fresh row variable common to the left and the right *) - let fresh_row_var = fresh_row_variable (linAny, `Any) in + let fresh_row_var = fresh_row_variable (linAny, resAny) 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 From 4f806cbb16996854fbb6fa5dab70ff66d0576aef Mon Sep 17 00:00:00 2001 From: Jan Stolarek Date: Thu, 21 Feb 2019 11:09:27 +0000 Subject: [PATCH 22/28] Refactor linearity and restriction functions --- core/commonTypes.ml | 24 +++++++++++++----------- core/types.ml | 20 ++++++++++---------- core/unify.ml | 11 +++++------ 3 files changed, 28 insertions(+), 27 deletions(-) diff --git a/core/commonTypes.ml b/core/commonTypes.ml index c20bc1dfa..dbc6a01a8 100644 --- a/core/commonTypes.ml +++ b/core/commonTypes.ml @@ -1,15 +1,17 @@ module Linearity = struct type t = Any | Unl [@@deriving eq,show] -end -let string_of_linearity = function - | Linearity.Any -> "Any" - | Linearity.Unl -> "Unl" + let isAny lin = lin == Any + let isUnl lin = lin == Unl + + let string_of = function + | Any -> "Any" + | Unl -> "Unl" +end let linUnl = Linearity.Unl let linAny = Linearity.Any -let isUnl lin = lin == Linearity.Unl module Restriction = struct type t = @@ -30,15 +32,15 @@ module Restriction = struct let isSession = function | Session -> true | _ -> false + + let string_of = function + | Any -> "Any" + | Base -> "Base" + | Session -> "Session" + | Effect -> "Eff" end let resAny = Restriction.Any let resBase = Restriction.Base let resSession = Restriction.Session let resEffect = Restriction.Effect - -let string_of_restriction = function - | Restriction.Any -> "Any" - | Restriction.Base -> "Base" - | Restriction.Session -> "Session" - | Restriction.Effect -> "Eff" diff --git a/core/types.ml b/core/types.ml index 7fb8c45c7..6333f4979 100644 --- a/core/types.ml +++ b/core/types.ml @@ -641,7 +641,7 @@ let is_unl_point = begin match Unionfind.find point with | `Closed -> true - | `Var (var, (lin, _), _) -> IntSet.mem var quant_vars || isUnl lin + | `Var (var, (lin, _), _) -> IntSet.mem var quant_vars || Linearity.isUnl lin | `Body t -> f (rec_vars, quant_vars) t | `Recursive (var, t) -> check_rec var rec_vars true (fun rec_vars' -> f (rec_vars', quant_vars) t) @@ -690,7 +690,7 @@ let point_can_be_unl = begin match Unionfind.find point with | `Closed -> true - | `Var (v, (lin, _), `Rigid) -> IntSet.mem v quant_vars || isUnl lin + | `Var (v, (lin, _), `Rigid) -> IntSet.mem v quant_vars || Linearity.isUnl lin | `Var (_, _, `Flexible) -> true | `Body t -> f vars t | `Recursive (var, t) -> @@ -744,7 +744,7 @@ let make_point_unl : ((var_set * var_set) -> 'a -> unit) -> (var_set * var_set) fun f ((rec_vars, quant_vars) as vars) point -> match Unionfind.find point with | `Closed -> () - | `Var (v, (lin, _), `Rigid) -> if IntSet.mem v quant_vars || isUnl lin then () else assert false + | `Var (v, (lin, _), `Rigid) -> if IntSet.mem v quant_vars || Linearity.isUnl lin then () else assert false | `Var (var, (_, rest), `Flexible) -> Unionfind.change point (`Var (var, (linUnl, rest), `Flexible)) | `Body t -> f vars t | `Recursive (var, t) -> @@ -1887,8 +1887,8 @@ struct | s -> "::" ^ s let subkind : (policy * names) -> subkind -> string = - let full (l, r) = "(" ^ string_of_linearity l ^ "," ^ - string_of_restriction r ^ ")" in + let full (l, r) = "(" ^ Linearity.string_of l ^ "," ^ + Restriction.string_of r ^ ")" in fun (policy, _vars) -> if policy.kinds = "full" then @@ -1899,9 +1899,9 @@ struct function | (Linearity.Unl, Restriction.Any) -> "" | (Linearity.Any, Restriction.Any) -> "Any" - | (Linearity.Unl, Restriction.Base) -> string_of_restriction resBase - | (Linearity.Any, Restriction.Session) -> string_of_restriction resSession - | (Linearity.Unl, Restriction.Effect) -> string_of_restriction resEffect + | (Linearity.Unl, Restriction.Base) -> Restriction.string_of resBase + | (Linearity.Any, Restriction.Session) -> Restriction.string_of resSession + | (Linearity.Unl, Restriction.Effect) -> Restriction.string_of resEffect | (l, r) -> full (l, r) let primary_kind : primary_kind -> string = function @@ -1920,8 +1920,8 @@ struct else match (k, sk) with | `Type, (Linearity.Unl, Restriction.Any) -> "" - | `Type, (Linearity.Unl, Restriction.Base) -> string_of_restriction resBase - | `Type, (Linearity.Any, Restriction.Session) -> string_of_restriction resSession + | `Type, (Linearity.Unl, Restriction.Base) -> Restriction.string_of resBase + | `Type, (Linearity.Any, Restriction.Session) -> Restriction.string_of resSession | `Type, sk -> subkind ({policy with kinds="full"}, _vars) sk | `Row, (Linearity.Unl, Restriction.Any) -> primary_kind `Row | `Row, (Linearity.Unl, Restriction.Effect) -> primary_kind `Row diff --git a/core/unify.ml b/core/unify.ml index 0761ee0f4..d1630b568 100644 --- a/core/unify.ml +++ b/core/unify.ml @@ -313,8 +313,7 @@ let rec unify' : unify_env -> (datatype * datatype) -> unit = begin let lin = match llin, rlin with - | Linearity.Unl, _ - | _, Linearity.Unl -> Linearity.Unl + | Linearity.Unl, _ | _, Linearity.Unl -> Linearity.Unl | _ -> llin in let rest = let open Restriction in @@ -380,7 +379,7 @@ let rec unify' : unify_env -> (datatype * datatype) -> unit = else raise (Failure (`Msg ("Cannot unify the base type variable "^ string_of_int var ^ " with the non-base type "^ string_of_datatype t2))); - if isUnl lin then + if Linearity.isUnl lin then if Types.type_can_be_unl t2 then Types.make_type_unl t2 else @@ -420,7 +419,7 @@ let rec unify' : unify_env -> (datatype * datatype) -> unit = else raise (Failure (`Msg ("Cannot unify the base type variable "^ string_of_int var ^ " with the non-base type "^ string_of_datatype t1))); - if isUnl lin then + if Linearity.isUnl lin then if Types.type_can_be_unl t1 then Types.make_type_unl t1 else @@ -534,7 +533,7 @@ let rec unify' : unify_env -> (datatype * datatype) -> unit = else raise (Failure (`Msg ("Cannot unify the base type variable "^ string_of_int var ^ " with the non-base type "^ string_of_datatype t))); - if isUnl lin then + if Linearity.isUnl lin then if Types.type_can_be_unl t then Types.make_type_unl t else @@ -1029,7 +1028,7 @@ and unify_rows' : unify_env -> ((row * row) -> unit) = raise (Failure (`Msg ("Cannot unify the session row variable "^ string_of_int var ^ " with the non-session row "^ string_of_row extension_row))); - if isUnl lin then + if Linearity.isUnl lin then if Types.row_can_be_unl extension_row then Types.make_row_unl extension_row else From 7a6be88449f921cad175a39bee72734f794567dc Mon Sep 17 00:00:00 2001 From: Jan Stolarek Date: Thu, 21 Feb 2019 11:24:41 +0000 Subject: [PATCH 23/28] Redefine declared linearity as a variant --- core/commonTypes.ml | 8 ++++++++ core/desugarFormlets.ml | 6 +++--- core/desugarFors.ml | 12 +++++++----- core/desugarHandlers.ml | 5 +++-- core/desugarLAttributes.ml | 7 ++++--- core/desugarPages.ml | 2 +- core/desugarProcesses.ml | 5 +++-- core/parser.mly | 20 ++++++++++---------- core/sugarConstructors.ml | 3 ++- core/sugarConstructorsIntf.ml | 7 ++++--- core/sugartypes.ml | 9 +++------ core/transformSugar.ml | 10 +++++----- core/transformSugar.mli | 11 ++++++----- core/typeSugar.ml | 10 +++++----- 14 files changed, 64 insertions(+), 51 deletions(-) diff --git a/core/commonTypes.ml b/core/commonTypes.ml index dbc6a01a8..0b2b3c7fa 100644 --- a/core/commonTypes.ml +++ b/core/commonTypes.ml @@ -13,6 +13,14 @@ end let linUnl = Linearity.Unl let linAny = Linearity.Any +module DeclaredLinearity = struct + type t = Lin | Unl + [@@deriving show] + + let isLin lin = lin == Lin + let isUnl lin = lin == Unl +end + module Restriction = struct type t = | Any diff --git a/core/desugarFormlets.ml b/core/desugarFormlets.ml index d6006e8a4..81f98a61d 100644 --- a/core/desugarFormlets.ml +++ b/core/desugarFormlets.ml @@ -120,7 +120,7 @@ object (o : 'self_type) let mb = `Row (o#lookup_effects) in let base : phrase = fn_appl pure_str [`Type ft; mb] - [fun_lit ~args:(List.rev args) `Unl (List.rev pss) + [fun_lit ~args:(List.rev args) DeclaredLinearity.Unl (List.rev pss) (tuple vs)] in let p, et = List.fold_right @@ -142,7 +142,7 @@ object (o : 'self_type) let context : phrase = let name = Utility.gensym ~prefix:"_formlet_" () in fun_lit ~args:[Types.make_tuple_type [Types.xml_type], eff] - `Unl + DeclaredLinearity.Unl [[variable_pat ~ty:(Types.xml_type) name]] (xml tag attrs attrexp [block ([], var name)]) in let (o, e, t) = o#formlet_body (xml "#" [] None contents) in @@ -177,7 +177,7 @@ object (o : 'self_type) [`Type arg_type; `Type yields_type; mb] [body; fn_appl pure_str [`Type (`Function (Types.make_tuple_type [arg_type], empty_eff, yields_type)); mb] - [fun_lit ~args:[Types.make_tuple_type [arg_type], empty_eff] `Unl pss yields]] + [fun_lit ~args:[Types.make_tuple_type [arg_type], empty_eff] DeclaredLinearity.Unl pss yields]] in (o, e, Instantiate.alias "Formlet" [`Type yields_type] tycon_env) | e -> super#phrasenode e diff --git a/core/desugarFors.ml b/core/desugarFors.ml index 895119bc9..92e17ae8f 100644 --- a/core/desugarFors.ml +++ b/core/desugarFors.ml @@ -1,4 +1,5 @@ open Utility +open CommonTypes open Sugartypes open SugarConstructors.Make @@ -76,12 +77,13 @@ let results : Types.row -> | [t] -> Types.make_tuple_type [t] | ts -> Types.make_tuple_type [Types.make_tuple_type ts] in - fun_lit ~args:[a, eff] `Unl [ps] (tuple (q::qs)) in + fun_lit ~args:[a, eff] DeclaredLinearity.Unl [ps] (tuple (q::qs)) in let outer : Sugartypes.phrase = let a = `Type qst in let b = `Type (Types.make_tuple_type (t :: ts)) in - fun_lit ~args:[Types.make_tuple_type [t], eff] `Unl [[qb]] - (fn_appl "map" [a; `Row eff; b] [inner; r]) in + fun_lit ~args:[Types.make_tuple_type [t], eff] + DeclaredLinearity.Unl [[qb]] + (fn_appl "map" [a; `Row eff; b] [inner; r]) in let a = `Type qt in let b = `Type (Types.make_tuple_type (t :: ts)) in fn_appl "concatMap" [a; `Row eff; b] [outer; e] @@ -166,7 +168,7 @@ object (o : 'self_type) | ts -> Types.make_tuple_type ts in let f : phrase = fun_lit ~args:[Types.make_tuple_type [arg_type], eff] - `Unl [arg] body in + DeclaredLinearity.Unl [arg] body in let results = results eff (es, xs, ts) in let results = @@ -178,7 +180,7 @@ object (o : 'self_type) let g : phrase = fun_lit ~args:[Types.make_tuple_type [arg_type], eff] - `Unl [arg] sort + DeclaredLinearity.Unl [arg] sort in fn_appl sort_by [`Type arg_type; `Row eff; sort_type_arg] [g; results] diff --git a/core/desugarHandlers.ml b/core/desugarHandlers.ml index a1498d5e6..a96889820 100644 --- a/core/desugarHandlers.ml +++ b/core/desugarHandlers.ml @@ -1,4 +1,5 @@ open Utility +open CommonTypes open Operators open Sugartypes open SugarConstructors.Make @@ -98,7 +99,7 @@ let parameterize : (Pattern.with_pos * phrase) list -> Pattern.with_pos list lis StringSet.inter (StringSet.from_list pat_names) (StringSet.from_list param_names) in let params = List.map (List.map (fun p -> resolve_name_conflicts p name_conflicts)) params in - (pat, fun_lit `Unl params body) + (pat, fun_lit DeclaredLinearity.Unl params body) ) cases @@ -201,7 +202,7 @@ object method! phrasenode = function | HandlerLit hnlit -> let (fnparams, body) = funlit_of_handlerlit hnlit in - let funlit : Sugartypes.phrasenode = (fun_lit `Unl fnparams body).node in + let funlit : Sugartypes.phrasenode = (fun_lit DeclaredLinearity.Unl fnparams body).node in super#phrasenode funlit | e -> super#phrasenode e diff --git a/core/desugarLAttributes.ml b/core/desugarLAttributes.ml index ab69865b9..a58a4d0ee 100644 --- a/core/desugarLAttributes.ml +++ b/core/desugarLAttributes.ml @@ -1,4 +1,5 @@ open Utility +open CommonTypes open Sugartypes open List open SugarConstructors.Make @@ -35,7 +36,7 @@ let desugar_lhref : phrasenode -> phrasenode = function | [_,[target]], rest -> ("href", [constant_str "?_k="; - apply "pickleCont" [fun_lit ~location:`Server `Unl [[]] target]]) + apply "pickleCont" [fun_lit ~location:`Server DeclaredLinearity.Unl [[]] target]]) :: rest | _ -> assert false (* multiple l:hrefs, or an invalid rhs; NOTE: this is a user error and should @@ -53,7 +54,7 @@ let desugar_laction : phrasenode -> phrasenode = function ["type", [constant_str "hidden"]; "name", [constant_str "_k"]; "value", [apply "pickleCont" - [fun_lit ~location:`Server `Unl [[]] action_expr]]] + [fun_lit ~location:`Server DeclaredLinearity.Unl [[]] action_expr]]] None [] and action = ("action", [constant_str "#"]) in Xml (form, action::rest, attrexp, hidden::children) @@ -68,7 +69,7 @@ let desugar_lonevent : phrasenode -> phrasenode = | (name, [rhs]) -> let event_name = StringLabels.sub ~pos:4 ~len:(String.length name - 4) name in tuple [constant_str event_name; - fun_lit ~location:`Client `Unl [[variable_pat "event"]] rhs] + fun_lit ~location:`Client DeclaredLinearity.Unl [[variable_pat "event"]] rhs] | _ -> assert false in function | Xml (tag, attrs, attrexp, children) diff --git a/core/desugarPages.ml b/core/desugarPages.ml index 261b02ca9..36c681ce1 100644 --- a/core/desugarPages.ml +++ b/core/desugarPages.ml @@ -49,7 +49,7 @@ let rec desugar_page (o, page_type) = let x = Utility.gensym ~prefix:"xml" () in fn_appl "plugP" [`Row (o#lookup_effects)] [fun_lit ~args:[Types.make_tuple_type [Types.xml_type], o#lookup_effects] - `Unl [[variable_pat ~ty:Types.xml_type x]] + DeclaredLinearity.Unl [[variable_pat ~ty:Types.xml_type x]] (xml name attrs dynattrs [block ([], var x)]); desugar_nodes children] | _ -> diff --git a/core/desugarProcesses.ml b/core/desugarProcesses.ml index 8b2406f13..787f74d82 100644 --- a/core/desugarProcesses.ml +++ b/core/desugarProcesses.ml @@ -1,4 +1,5 @@ open Utility +open CommonTypes open Sugartypes open SugarConstructors.Make @@ -30,7 +31,7 @@ object (o : 'self_type) let e : phrasenode = fn_appl_node "spawnWait" [`Row inner_eff; `Type body_type; `Row outer_eff] - [fun_lit ~args:[(Types.make_tuple_type [], inner_eff)] `Unl [[]] body] + [fun_lit ~args:[(Types.make_tuple_type [], inner_eff)] DeclaredLinearity.Unl [[]] body] in (o, e, body_type) | Spawn (k, spawn_loc, body, Some inner_eff) -> @@ -62,7 +63,7 @@ object (o : 'self_type) let e : phrasenode = fn_appl_node spawn_fun [`Row inner_eff; `Type body_type; `Row outer_eff] - [fun_lit ~args:[(Types.make_tuple_type [], inner_eff)] `Unl [[]] body; + [fun_lit ~args:[(Types.make_tuple_type [], inner_eff)] DeclaredLinearity.Unl [[]] body; spawn_loc_phr] in (o, e, process_type) diff --git a/core/parser.mly b/core/parser.mly index 32cc01321..f94234902 100644 --- a/core/parser.mly +++ b/core/parser.mly @@ -108,10 +108,10 @@ let full_subkind_of pos lin rest = (* In kind and subkind abbreviations, we aim to provide the most common case. For everything except session types, the default -linearity is `Unl and the default restriction is `Any. For session -types the default linearity is `Any. *) +linearity is Unl and the default restriction is Any. For session +types the default linearity is Any. *) -(* Currently "Any" means `Any,`Any, but it is probably advisable to +(* Currently "Any" means Any,Any, but it is probably advisable to change "Any" to something more evocative of linearity - "Lin" perhaps. *) @@ -245,7 +245,7 @@ let parseRegexFlags f = %type regex_pattern %type regex_pattern_sequence %type pattern -%type tlfunbinding %type postfix_expression @@ -349,14 +349,14 @@ perhaps_uinteger: | UINTEGER? { $1 } linearity: -| FUN { `Unl } -| LINFUN { `Lin } +| FUN { DeclaredLinearity.Unl } +| LINFUN { DeclaredLinearity.Lin } tlfunbinding: -| linearity VARIABLE arg_lists perhaps_location block { ($1, $2, $3, $4, $5) } -| OP pattern op pattern perhaps_location block { (`Unl, $3.node, [[$2; $4]], $5, $6) } -| OP PREFIXOP pattern perhaps_location block { (`Unl, $2, [[$3]], $4, $5) } -| OP pattern POSTFIXOP perhaps_location block { (`Unl, $3, [[$2]], $4, $5) } +| linearity VARIABLE arg_lists perhaps_location block { ($1, $2, $3, $4, $5) } +| OP pattern op pattern perhaps_location block { (DeclaredLinearity.Unl, $3.node, [[$2; $4]], $5, $6) } +| OP PREFIXOP pattern perhaps_location block { (DeclaredLinearity.Unl, $2, [[$3]], $4, $5) } +| OP pattern POSTFIXOP perhaps_location block { (DeclaredLinearity.Unl, $3, [[$2]], $4, $5) } tlvarbinding: | VAR VARIABLE perhaps_location EQ exp { (PatName $2, $5, $3) } diff --git a/core/sugarConstructors.ml b/core/sugarConstructors.ml index 432ed9b9c..b72e471b4 100644 --- a/core/sugarConstructors.ml +++ b/core/sugarConstructors.ml @@ -1,3 +1,4 @@ +open CommonTypes open Operators open Sugartypes open Utility.OptionUtils @@ -177,7 +178,7 @@ module SugarConstructors (Position : Pos) with_pos ppos (Fun (binder bndr, linearity, ([], (args, blk)), location, datatype)) - let fun_binding' ?(ppos=dp) ?(linearity=`Unl) ?(tyvars=[]) + let fun_binding' ?(ppos=dp) ?(linearity=DeclaredLinearity.Unl) ?(tyvars=[]) ?(location=`Unknown) ?annotation bndr fnlit = with_pos ppos (Fun (bndr, linearity, (tyvars, fnlit), location, annotation)) diff --git a/core/sugarConstructorsIntf.ml b/core/sugarConstructorsIntf.ml index b47d5b57a..9128026d6 100644 --- a/core/sugarConstructorsIntf.ml +++ b/core/sugarConstructorsIntf.ml @@ -1,6 +1,7 @@ (* This module contains module signatures used by SugarConstructors module. Putting them here allows to avoid repetition. *) +open CommonTypes open Operators open Sugartypes @@ -92,7 +93,7 @@ module type SugarConstructorsSig = sig (* Various phrases *) val fun_lit : ?ppos:t -> ?args:((Types.datatype * Types.row) list) - -> ?location:location -> declared_linearity -> Pattern.with_pos list list -> phrase + -> ?location:location -> DeclaredLinearity.t -> Pattern.with_pos list list -> phrase -> phrase val hnlit_arg : handler_depth -> Pattern.with_pos -> clause list * Pattern.with_pos list list option @@ -113,10 +114,10 @@ module type SugarConstructorsSig = sig (* Bindings *) val fun_binding : ?ppos:t -> signature - -> (declared_linearity * name * Pattern.with_pos list list * location * phrase) + -> (DeclaredLinearity.t * name * Pattern.with_pos list list * location * phrase) -> binding val fun_binding' - : ?ppos:t -> ?linearity:declared_linearity -> ?tyvars:tyvar list + : ?ppos:t -> ?linearity:DeclaredLinearity.t -> ?tyvars:tyvar list -> ?location:location -> ?annotation:datatype' -> binder -> funlit -> binding val handler_binding diff --git a/core/sugartypes.ml b/core/sugartypes.ml index e66812cab..28a039ad0 100644 --- a/core/sugartypes.ml +++ b/core/sugartypes.ml @@ -162,9 +162,6 @@ module Section = struct [@@deriving show] end -type declared_linearity = [ `Lin | `Unl ] - [@@deriving show] - type fn_dep = string * string [@@deriving show] @@ -220,7 +217,7 @@ and phrasenode = | Var of name | QualifiedVar of name list | FunLit of ((Types.datatype * Types.row) list) option * - declared_linearity * funlit * location + DeclaredLinearity.t * funlit * location | HandlerLit of handlerlit (* Spawn kind, expression referring to spawn location (client n, server...), spawn block, row opt *) @@ -297,9 +294,9 @@ and phrase = phrasenode with_pos and bindingnode = | Val of (Pattern.with_pos * (tyvar list * phrase) * location * datatype' option) - | Fun of (binder * declared_linearity * (tyvar list * funlit) * location * + | Fun of (binder * DeclaredLinearity.t * (tyvar list * funlit) * location * datatype' option) - | Funs of (binder * declared_linearity * + | Funs of (binder * DeclaredLinearity.t * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * location * datatype' option * position) list diff --git a/core/transformSugar.ml b/core/transformSugar.ml index 2dd038d48..61126e253 100644 --- a/core/transformSugar.ml +++ b/core/transformSugar.ml @@ -717,9 +717,9 @@ class transform (env : Types.typing_environment) = method restore_quantifiers : IntSet.t -> 'self_type = fun _ -> o method rec_bodies : - (binder * declared_linearity * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * location * datatype' option * position) list -> + (binder * DeclaredLinearity.t * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * location * datatype' option * position) list -> ('self_type * - (binder * declared_linearity * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * location * datatype' option * position) list) = + (binder * DeclaredLinearity.t * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * location * datatype' option * position) list) = let outer_tyvars = o#backup_quantifiers in let rec list o = function @@ -737,9 +737,9 @@ class transform (env : Types.typing_environment) = list o method rec_activate_outer_bindings : - (binder * declared_linearity * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * location * datatype' option * position) list -> + (binder * DeclaredLinearity.t * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * location * datatype' option * position) list -> ('self_type * - (binder * declared_linearity * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * location * datatype' option * position) list) = + (binder * DeclaredLinearity.t * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * location * datatype' option * position) list) = let rec list o = function | [] -> o, [] @@ -752,7 +752,7 @@ class transform (env : Types.typing_environment) = list o method rec_activate_inner_bindings : - (binder * declared_linearity * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * location * datatype' option * position) list -> + (binder * DeclaredLinearity.t * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * location * datatype' option * position) list -> 'self_type = let rec list o = function diff --git a/core/transformSugar.mli b/core/transformSugar.mli index 6f3a88c03..f4f0ba5ac 100644 --- a/core/transformSugar.mli +++ b/core/transformSugar.mli @@ -1,4 +1,5 @@ open Operators +open CommonTypes open Sugartypes (* @@ -61,15 +62,15 @@ object ('self) method restore_quantifiers : Utility.IntSet.t -> 'self method rec_bodies : - (binder * declared_linearity * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * location * datatype' option * position) list -> + (binder * DeclaredLinearity.t * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * location * datatype' option * position) list -> ('self * - (binder * declared_linearity * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * location * datatype' option * position) list) + (binder * DeclaredLinearity.t * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * location * datatype' option * position) list) method rec_activate_outer_bindings : - (binder * declared_linearity * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * location * datatype' option * position) list -> + (binder * DeclaredLinearity.t * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * location * datatype' option * position) list -> ('self * - (binder * declared_linearity * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * location * datatype' option * position) list) + (binder * DeclaredLinearity.t * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * location * datatype' option * position) list) method rec_activate_inner_bindings : - (binder * declared_linearity * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * location * datatype' option * position) list -> + (binder * DeclaredLinearity.t * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * location * datatype' option * position) list -> 'self method sugar_datatype : Datatype.with_pos -> 'self * Datatype.with_pos diff --git a/core/typeSugar.ml b/core/typeSugar.ml index dda0496c0..c34f08718 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -2023,7 +2023,7 @@ let make_ft declared_linearity ps effects return_type = let pattern_typ (_, _, t) = t in let args = Types.make_tuple_type -<- List.map pattern_typ in - let ftcon = fun p -> if declared_linearity=`Lin then `Lolli p else `Function p in + let ftcon = fun p -> if DeclaredLinearity.isLin declared_linearity then `Lolli p else `Function p in let rec ft = function | [p] -> ftcon (args p, effects, return_type) @@ -2036,7 +2036,7 @@ let make_ft_poly_curry declared_linearity ps effects return_type = let pattern_typ (_, _, t) = t in let args = Types.make_tuple_type -<- List.map pattern_typ in - let ftcon = fun p -> if declared_linearity=`Lin then `Lolli p else `Function p in + let ftcon = fun p -> if DeclaredLinearity.isLin declared_linearity then `Lolli p else `Function p in let rec ft = function | [p] -> [], ftcon (args p, effects, return_type) @@ -2290,7 +2290,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = pat_env in let () = - if lin=`Unl then + if DeclaredLinearity.isUnl lin then StringMap.iter (fun v _ -> if not (List.mem v vs) then let t = Env.lookup env' v in @@ -3674,7 +3674,7 @@ and type_binding : context -> binding -> binding * context * usagemap = (List.flatten pats) in let () = - if lin = `Unl then + if DeclaredLinearity.isUnl lin then StringMap.iter (fun v _ -> if not (List.mem v vs) then let t = Env.lookup context'.var_env v in @@ -3779,7 +3779,7 @@ and type_binding : context -> binding -> binding * context * usagemap = pat_env in let used = let vs = StringSet.add name (Env.domain pat_env) in - if lin=`Unl then + if DeclaredLinearity.isUnl lin then StringMap.iter (fun v _ -> if not (StringSet.mem v vs) then let t = Env.lookup context'.var_env v in From 281aa5eda5a44209625b20e4539f8c0cf10ffd49 Mon Sep 17 00:00:00 2001 From: Jan Stolarek Date: Thu, 21 Feb 2019 11:27:09 +0000 Subject: [PATCH 24/28] Documentation --- core/sugartypes.ml | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/core/sugartypes.ml b/core/sugartypes.ml index 28a039ad0..d974d47c3 100644 --- a/core/sugartypes.ml +++ b/core/sugartypes.ml @@ -19,7 +19,9 @@ type 'a with_pos = { node : 'a let with_pos pos node = { node; pos } let with_dummy_pos node = { node; pos = dummy_position } -(* JSTOLAREK: document *) +(* A type alias to be used inside modules that define a node t and a with_pos + type, which is a node with attached position. Alias is required due to + with_pos name inside the module overlapping with top-level with_pos type. *) module WithPos = struct type 'a t = 'a with_pos [@@deriving show] end @@ -31,10 +33,10 @@ let name_of_binder {node=(n,_ );_} = n let type_of_binder {node=(_,ty);_} = ty let type_of_binder_exn {node=(_,ty);_} = OptionUtils.val_of ty (* raises exception when ty = None *) -let set_binder_name {node=(_ ,ty); pos} name = with_pos pos (name, ty ) -let set_binder_type {node=(name,_ ); pos} ty = with_pos pos (name, Some ty) -let erase_binder_type {node=(name,_ ); pos} = with_pos pos (name, None ) -let binder_has_type {node=(_ ,ty); _ } = OptionUtils.is_some ty +let set_binder_name {node=(_ ,ty); pos} name = with_pos pos (name, ty ) +let set_binder_type {node=(name,_ ); pos} ty = with_pos pos (name, Some ty) +let erase_binder_type {node=(name,_ ); pos} = with_pos pos (name, None ) +let binder_has_type {node=(_ ,ty); _ } = OptionUtils.is_some ty (* type variables *) type tyvar = Types.quantifier From 2b14409a2e5d7b1b8796d552d6726146fb8f6fd5 Mon Sep 17 00:00:00 2001 From: Jan Stolarek Date: Thu, 21 Feb 2019 11:53:33 +0000 Subject: [PATCH 25/28] Define primary kind as a variant And some minor refactorings --- core/closures.ml | 7 ++-- core/commonTypes.ml | 24 +++++++++++ core/desugarDatatypes.ml | 37 ++++++++--------- core/desugarFormlets.ml | 6 +-- core/desugarFors.ml | 8 ++-- core/desugarHandlers.ml | 4 +- core/desugarLAttributes.ml | 6 +-- core/desugarPages.ml | 2 +- core/desugarProcesses.ml | 4 +- core/instantiate.ml | 5 ++- core/irCheck.ml | 7 ++-- core/operators.ml | 2 + core/parser.mly | 34 +++++++-------- core/sugarConstructors.ml | 2 +- core/sugartypes.ml | 5 +-- core/types.ml | 85 ++++++++++++++++++-------------------- core/types.mli | 15 +++---- 17 files changed, 136 insertions(+), 117 deletions(-) diff --git a/core/closures.ml b/core/closures.ml index 480863761..35e31a451 100644 --- a/core/closures.ml +++ b/core/closures.ml @@ -1,4 +1,5 @@ open Utility +open CommonTypes type freevars = {termvars: (Ir.binder list) ; typevars: Types.quantifier list} [@@deriving show] type fenv = freevars IntMap.t [@@deriving show] @@ -585,15 +586,15 @@ struct let newvar = Types.fresh_raw_variable () in let make_new_type_variable () = Unionfind.fresh (`Var (newvar, subkind, `Rigid)) in let new_meta_var, updated_maps = match primary_kind with - | `Type -> + | PrimaryKind.Type -> let new_type_variable = make_new_type_variable () in let t = `MetaTypeVar new_type_variable in (`Type new_type_variable, (IntMap.add typevar t type_map, row_map, presence_map)) - | `Row -> + | PrimaryKind.Row -> let new_type_variable = make_new_type_variable () in let r = (Types.empty_field_env, new_type_variable, false) in (`Row new_type_variable, (type_map, IntMap.add typevar r row_map, presence_map)) - | `Presence -> + | PrimaryKind.Presence -> let new_type_variable = make_new_type_variable () in let p = `Var new_type_variable in (`Presence new_type_variable, (type_map, row_map, IntMap.add typevar p presence_map)) in diff --git a/core/commonTypes.ml b/core/commonTypes.ml index 0b2b3c7fa..f2a2c9717 100644 --- a/core/commonTypes.ml +++ b/core/commonTypes.ml @@ -10,6 +10,7 @@ module Linearity = struct | Unl -> "Unl" end +(* Convenient aliases for constructing values *) let linUnl = Linearity.Unl let linAny = Linearity.Any @@ -21,6 +22,10 @@ module DeclaredLinearity = struct let isUnl lin = lin == Unl end +(* Convenient aliases for constructing values *) +let dlLin = DeclaredLinearity.Lin +let dlUnl = DeclaredLinearity.Unl + module Restriction = struct type t = | Any @@ -48,7 +53,26 @@ module Restriction = struct | Effect -> "Eff" end +(* Convenient aliases for constructing values *) let resAny = Restriction.Any let resBase = Restriction.Base let resSession = Restriction.Session let resEffect = Restriction.Effect + +module PrimaryKind = struct + type t = + | Type + | Row + | Presence + [@@deriving show,eq] + + let string_of = function + | Type -> "Type" + | Row -> "Row" + | Presence -> "Presence" +end + +(* Convenient aliases for constructing values *) +let pkType = PrimaryKind.Type +let pkRow = PrimaryKind.Row +let pkPresence = PrimaryKind.Presence diff --git a/core/desugarDatatypes.ml b/core/desugarDatatypes.ml index 8b0f31408..9bf64ceeb 100644 --- a/core/desugarDatatypes.ml +++ b/core/desugarDatatypes.ml @@ -79,8 +79,8 @@ object (self) method! datatypenode = let open Datatype in function - | TypeVar (x, k, freedom) -> self#add (x, (`Type, k), freedom) - | Mu (v, t) -> let o = self#bind (v, (`Type, None), `Rigid) in o#datatype t + | TypeVar (x, k, freedom) -> self#add (x, (pkType, k), freedom) + | Mu (v, t) -> let o = self#bind (v, (pkType, None), `Rigid) in o#datatype t | Forall (qs, t) -> let o = List.fold_left (fun o q -> o#bind (rigidify q)) self qs in o#datatype t @@ -88,13 +88,13 @@ object (self) method! row_var = let open Datatype in function | Closed -> self - | Open (x, k, freedom) -> self#add (x, (`Row, k), freedom) - | Recursive (s, r) -> let o = self#bind (s, (`Row, None), `Rigid) in o#row r + | Open (x, k, freedom) -> self#add (x, (pkRow, k), freedom) + | Recursive (s, r) -> let o = self#bind (s, (pkRow, None), `Rigid) in o#row r method! fieldspec = let open Datatype in function | Absent -> self | Present t -> self#datatype t - | Var (x, k, freedom) -> self#add (x, (`Presence, k), freedom) + | Var (x, k, freedom) -> self#add (x, (pkPresence, k), freedom) end type var_env = { tenv : Types.meta_type_var StringMap.t; @@ -137,21 +137,21 @@ struct let desugar_quantifier (var_env, qs) = fun (name, kind, _freedom) -> match kind with - | `Type, subkind -> + | PrimaryKind.Type, subkind -> let subkind = concrete_subkind subkind in let var = Types.fresh_raw_variable () in let point = Unionfind.fresh (`Var (var, subkind, `Rigid)) in let q = (var, subkind, `Type point) in let var_env = {var_env with tenv=StringMap.add name point var_env.tenv} in var_env, q::qs - | `Row, subkind -> + | PrimaryKind.Row, subkind -> let subkind = concrete_subkind subkind in let var = Types.fresh_raw_variable () in let point = Unionfind.fresh (`Var (var, subkind, `Rigid)) in let q = (var, subkind, `Row point) in let var_env = {var_env with renv=StringMap.add name point var_env.renv} in var_env, q::qs - | `Presence, subkind -> + | PrimaryKind.Presence, subkind -> let subkind = concrete_subkind subkind in let var = Types.fresh_raw_variable () in let point = Unionfind.fresh (`Var (var, subkind, `Rigid)) in @@ -180,14 +180,13 @@ struct begin match SEnv.find alias_env tycon with | None -> raise (UnboundTyCon (pos,tycon)) | Some (`Alias (qs, _dt)) -> - let open Datatype in let exception Kind_mismatch (* TODO add more information *) in let match_kinds (q, t) = - let primary_kind_of_type_arg : Datatype.type_arg -> primary_kind = + let primary_kind_of_type_arg : Datatype.type_arg -> PrimaryKind.t = function - | Type _ -> `Type - | Row _ -> `Row - | Presence _ -> `Presence + | Datatype.Type _ -> pkType + | Datatype.Row _ -> pkRow + | Datatype.Presence _ -> pkPresence in if primary_kind_of_quantifier q <> primary_kind_of_type_arg t then raise Kind_mismatch @@ -321,13 +320,13 @@ struct let var = Types.fresh_raw_variable () in fun (x, kind, freedom) -> match (kind, freedom) with - | (`Type, Some subkind), freedom -> + | (PrimaryKind.Type, Some subkind), freedom -> let t = Unionfind.fresh (`Var (var, subkind, freedom)) in (var, subkind, `Type t)::vars, addt x t envs - | (`Row, Some subkind), freedom -> + | (PrimaryKind.Row, Some subkind), freedom -> let r = Unionfind.fresh (`Var (var, subkind, freedom)) in (var, subkind, `Row r)::vars, addr x r envs - | (`Presence, Some subkind), freedom -> + | (PrimaryKind.Presence, Some subkind), freedom -> let f = Unionfind.fresh (`Var (var, subkind, freedom)) in (var, subkind, `Presence f)::vars, addf x f envs | (_, None), _ -> @@ -353,17 +352,17 @@ struct ~f:(fun (q, _) (args, {tenv=tenv; renv=renv; penv=penv}) -> let var = Types.fresh_raw_variable () in match q with - | (name, (`Type, subkind), _freedom) -> + | (name, (PrimaryKind.Type, subkind), _freedom) -> let subkind = concrete_subkind subkind in let point = Unionfind.fresh (`Var (var, subkind, `Rigid)) in ((q, Some (var, subkind, `Type point))::args, {tenv=StringMap.add name point tenv; renv=renv; penv=penv}) - | (name, (`Row, subkind), _freedom) -> + | (name, (PrimaryKind.Row, subkind), _freedom) -> let subkind = concrete_subkind subkind in let point = Unionfind.fresh (`Var (var, subkind, `Rigid)) in ((q, Some (var, subkind, `Row point))::args, {tenv=tenv; renv=StringMap.add name point renv; penv=penv}) - | (name, (`Presence, subkind), _freedom) -> + | (name, (PrimaryKind.Presence, subkind), _freedom) -> let subkind = concrete_subkind subkind in let point = Unionfind.fresh (`Var (var, subkind, `Rigid)) in ((q, Some (var, subkind, `Presence point))::args, diff --git a/core/desugarFormlets.ml b/core/desugarFormlets.ml index 81f98a61d..1ae37a750 100644 --- a/core/desugarFormlets.ml +++ b/core/desugarFormlets.ml @@ -120,7 +120,7 @@ object (o : 'self_type) let mb = `Row (o#lookup_effects) in let base : phrase = fn_appl pure_str [`Type ft; mb] - [fun_lit ~args:(List.rev args) DeclaredLinearity.Unl (List.rev pss) + [fun_lit ~args:(List.rev args) dlUnl (List.rev pss) (tuple vs)] in let p, et = List.fold_right @@ -142,7 +142,7 @@ object (o : 'self_type) let context : phrase = let name = Utility.gensym ~prefix:"_formlet_" () in fun_lit ~args:[Types.make_tuple_type [Types.xml_type], eff] - DeclaredLinearity.Unl + dlUnl [[variable_pat ~ty:(Types.xml_type) name]] (xml tag attrs attrexp [block ([], var name)]) in let (o, e, t) = o#formlet_body (xml "#" [] None contents) in @@ -177,7 +177,7 @@ object (o : 'self_type) [`Type arg_type; `Type yields_type; mb] [body; fn_appl pure_str [`Type (`Function (Types.make_tuple_type [arg_type], empty_eff, yields_type)); mb] - [fun_lit ~args:[Types.make_tuple_type [arg_type], empty_eff] DeclaredLinearity.Unl pss yields]] + [fun_lit ~args:[Types.make_tuple_type [arg_type], empty_eff] dlUnl pss yields]] in (o, e, Instantiate.alias "Formlet" [`Type yields_type] tycon_env) | e -> super#phrasenode e diff --git a/core/desugarFors.ml b/core/desugarFors.ml index 92e17ae8f..3da1a5c59 100644 --- a/core/desugarFors.ml +++ b/core/desugarFors.ml @@ -77,12 +77,12 @@ let results : Types.row -> | [t] -> Types.make_tuple_type [t] | ts -> Types.make_tuple_type [Types.make_tuple_type ts] in - fun_lit ~args:[a, eff] DeclaredLinearity.Unl [ps] (tuple (q::qs)) in + fun_lit ~args:[a, eff] dlUnl [ps] (tuple (q::qs)) in let outer : Sugartypes.phrase = let a = `Type qst in let b = `Type (Types.make_tuple_type (t :: ts)) in fun_lit ~args:[Types.make_tuple_type [t], eff] - DeclaredLinearity.Unl [[qb]] + dlUnl [[qb]] (fn_appl "map" [a; `Row eff; b] [inner; r]) in let a = `Type qt in let b = `Type (Types.make_tuple_type (t :: ts)) in @@ -168,7 +168,7 @@ object (o : 'self_type) | ts -> Types.make_tuple_type ts in let f : phrase = fun_lit ~args:[Types.make_tuple_type [arg_type], eff] - DeclaredLinearity.Unl [arg] body in + dlUnl [arg] body in let results = results eff (es, xs, ts) in let results = @@ -180,7 +180,7 @@ object (o : 'self_type) let g : phrase = fun_lit ~args:[Types.make_tuple_type [arg_type], eff] - DeclaredLinearity.Unl [arg] sort + dlUnl [arg] sort in fn_appl sort_by [`Type arg_type; `Row eff; sort_type_arg] [g; results] diff --git a/core/desugarHandlers.ml b/core/desugarHandlers.ml index a96889820..22988c028 100644 --- a/core/desugarHandlers.ml +++ b/core/desugarHandlers.ml @@ -99,7 +99,7 @@ let parameterize : (Pattern.with_pos * phrase) list -> Pattern.with_pos list lis StringSet.inter (StringSet.from_list pat_names) (StringSet.from_list param_names) in let params = List.map (List.map (fun p -> resolve_name_conflicts p name_conflicts)) params in - (pat, fun_lit DeclaredLinearity.Unl params body) + (pat, fun_lit dlUnl params body) ) cases @@ -202,7 +202,7 @@ object method! phrasenode = function | HandlerLit hnlit -> let (fnparams, body) = funlit_of_handlerlit hnlit in - let funlit : Sugartypes.phrasenode = (fun_lit DeclaredLinearity.Unl fnparams body).node in + let funlit : Sugartypes.phrasenode = (fun_lit dlUnl fnparams body).node in super#phrasenode funlit | e -> super#phrasenode e diff --git a/core/desugarLAttributes.ml b/core/desugarLAttributes.ml index a58a4d0ee..d94feb17f 100644 --- a/core/desugarLAttributes.ml +++ b/core/desugarLAttributes.ml @@ -36,7 +36,7 @@ let desugar_lhref : phrasenode -> phrasenode = function | [_,[target]], rest -> ("href", [constant_str "?_k="; - apply "pickleCont" [fun_lit ~location:`Server DeclaredLinearity.Unl [[]] target]]) + apply "pickleCont" [fun_lit ~location:`Server dlUnl [[]] target]]) :: rest | _ -> assert false (* multiple l:hrefs, or an invalid rhs; NOTE: this is a user error and should @@ -54,7 +54,7 @@ let desugar_laction : phrasenode -> phrasenode = function ["type", [constant_str "hidden"]; "name", [constant_str "_k"]; "value", [apply "pickleCont" - [fun_lit ~location:`Server DeclaredLinearity.Unl [[]] action_expr]]] + [fun_lit ~location:`Server dlUnl [[]] action_expr]]] None [] and action = ("action", [constant_str "#"]) in Xml (form, action::rest, attrexp, hidden::children) @@ -69,7 +69,7 @@ let desugar_lonevent : phrasenode -> phrasenode = | (name, [rhs]) -> let event_name = StringLabels.sub ~pos:4 ~len:(String.length name - 4) name in tuple [constant_str event_name; - fun_lit ~location:`Client DeclaredLinearity.Unl [[variable_pat "event"]] rhs] + fun_lit ~location:`Client dlUnl [[variable_pat "event"]] rhs] | _ -> assert false in function | Xml (tag, attrs, attrexp, children) diff --git a/core/desugarPages.ml b/core/desugarPages.ml index 36c681ce1..0cf398f09 100644 --- a/core/desugarPages.ml +++ b/core/desugarPages.ml @@ -49,7 +49,7 @@ let rec desugar_page (o, page_type) = let x = Utility.gensym ~prefix:"xml" () in fn_appl "plugP" [`Row (o#lookup_effects)] [fun_lit ~args:[Types.make_tuple_type [Types.xml_type], o#lookup_effects] - DeclaredLinearity.Unl [[variable_pat ~ty:Types.xml_type x]] + dlUnl [[variable_pat ~ty:Types.xml_type x]] (xml name attrs dynattrs [block ([], var x)]); desugar_nodes children] | _ -> diff --git a/core/desugarProcesses.ml b/core/desugarProcesses.ml index 787f74d82..34b468ded 100644 --- a/core/desugarProcesses.ml +++ b/core/desugarProcesses.ml @@ -31,7 +31,7 @@ object (o : 'self_type) let e : phrasenode = fn_appl_node "spawnWait" [`Row inner_eff; `Type body_type; `Row outer_eff] - [fun_lit ~args:[(Types.make_tuple_type [], inner_eff)] DeclaredLinearity.Unl [[]] body] + [fun_lit ~args:[(Types.make_tuple_type [], inner_eff)] dlUnl [[]] body] in (o, e, body_type) | Spawn (k, spawn_loc, body, Some inner_eff) -> @@ -63,7 +63,7 @@ object (o : 'self_type) let e : phrasenode = fn_appl_node spawn_fun [`Row inner_eff; `Type body_type; `Row outer_eff] - [fun_lit ~args:[(Types.make_tuple_type [], inner_eff)] DeclaredLinearity.Unl [[]] body; + [fun_lit ~args:[(Types.make_tuple_type [], inner_eff)] dlUnl [[]] body; spawn_loc_phr] in (o, e, process_type) diff --git a/core/instantiate.ml b/core/instantiate.ml index 529cd5358..089c4897f 100644 --- a/core/instantiate.ml +++ b/core/instantiate.ml @@ -420,7 +420,10 @@ let alias name tyargs env = (fun q arg (tenv, renv, penv) -> if not (primary_kind_of_quantifier q = primary_kind_of_type_arg arg) then failwith (Printf.sprintf -"Argument '%s' to type alias '%s' has the wrong kind ('%s' instead of '%s')" (Types.string_of_type_arg arg) name (Types.string_of_primary_kind (primary_kind_of_type_arg arg)) (Types.string_of_primary_kind (primary_kind_of_quantifier q))); + "Argument '%s' to type alias '%s' has the wrong kind ('%s' instead of '%s')" + (Types.string_of_type_arg arg) name + (PrimaryKind.string_of (primary_kind_of_type_arg arg)) + (PrimaryKind.string_of (primary_kind_of_quantifier q))); let x = var_of_quantifier q in match arg with | `Type t -> diff --git a/core/irCheck.ml b/core/irCheck.ml index c401ecffd..b3d0336e5 100644 --- a/core/irCheck.ml +++ b/core/irCheck.ml @@ -1,3 +1,4 @@ +open CommonTypes open Utility open Ir @@ -164,7 +165,7 @@ let eq_types occurrence : type_eq_context -> (Types.datatype * Types.datatype) - begin match t2 with `MetaTypeVar rpoint -> begin match lpoint_cont, Unionfind.find rpoint with - | `Var lv, `Var rv -> handle_variable `Type lv rv context + | `Var lv, `Var rv -> handle_variable pkType lv rv context | `Body _, `Body _ -> failwith "Should have removed `Body by now" | _ -> (context, false) end @@ -281,7 +282,7 @@ let eq_types occurrence : type_eq_context -> (Types.datatype * Types.datatype) - | `Var lpoint, `Var rpoint -> begin match Unionfind.find lpoint, Unionfind.find rpoint with | `Body _, _ | _, `Body _ -> failwith "should have removed all `Body variants by now" - | `Var lv, `Var rv -> handle_variable `Presence lv rv context + | `Var lv, `Var rv -> handle_variable pkPresence lv rv context end | _, _ -> (context, false) and eq_field_envs (context, lfield_env, rfield_env) = @@ -295,7 +296,7 @@ let eq_types occurrence : type_eq_context -> (Types.datatype * Types.datatype) - and eq_row_vars (context, lpoint, rpoint) = match Unionfind.find lpoint, Unionfind.find rpoint with | `Closed, `Closed -> (context, true) - | `Var lv, `Var rv -> handle_variable `Row lv rv context + | `Var lv, `Var rv -> handle_variable pkRow lv rv context | `Recursive _, _ | _, `Recursive _ -> Debug.print "IR typechecker encountered recursive type"; (context, true) | _ -> (context, false) diff --git a/core/operators.ml b/core/operators.ml index e4a119bc5..1924e20e6 100644 --- a/core/operators.ml +++ b/core/operators.ml @@ -7,6 +7,8 @@ ~ triggers a lexer state switch *) +(*JSTOLAREK: define fixity *) + type name = string [@@deriving show] type regexflag = RegexList | RegexNative | RegexGlobal | RegexReplace diff --git a/core/parser.mly b/core/parser.mly index f94234902..787137309 100644 --- a/core/parser.mly +++ b/core/parser.mly @@ -74,9 +74,9 @@ let default_fixity = 9 let primary_kind_of_string p = function - | "Type" -> `Type - | "Row" -> `Row - | "Presence" -> `Presence + | "Type" -> pkType + | "Row" -> pkRow + | "Presence" -> pkPresence | pk -> raise (ConcreteSyntaxError ("Invalid primary kind: " ^ pk, pos p)) @@ -118,14 +118,14 @@ perhaps. *) let kind_of p = function (* primary kind abbreviation *) - | "Type" -> (`Type, None) - | "Row" -> (`Row, None) - | "Presence" -> (`Presence, None) + | "Type" -> (pkType, None) + | "Row" -> (pkRow, None) + | "Presence" -> (pkPresence, None) (* subkind of type abbreviations *) - | "Any" -> (`Type, Some (linAny, resAny)) - | "Base" -> (`Type, Some (linUnl, resBase)) - | "Session" -> (`Type, Some (linAny, resSession)) - | "Eff" -> (`Row , Some (linUnl, resEffect)) + | "Any" -> (pkType, Some (linAny, resAny)) + | "Base" -> (pkType, Some (linUnl, resBase)) + | "Session" -> (pkType, Some (linAny, resSession)) + | "Eff" -> (pkRow , Some (linUnl, resEffect)) | k -> raise (ConcreteSyntaxError ("Invalid kind: " ^ k, pos p)) let subkind_of p = @@ -349,14 +349,14 @@ perhaps_uinteger: | UINTEGER? { $1 } linearity: -| FUN { DeclaredLinearity.Unl } -| LINFUN { DeclaredLinearity.Lin } +| FUN { dlUnl } +| LINFUN { dlLin } tlfunbinding: -| linearity VARIABLE arg_lists perhaps_location block { ($1, $2, $3, $4, $5) } -| OP pattern op pattern perhaps_location block { (DeclaredLinearity.Unl, $3.node, [[$2; $4]], $5, $6) } -| OP PREFIXOP pattern perhaps_location block { (DeclaredLinearity.Unl, $2, [[$3]], $4, $5) } -| OP pattern POSTFIXOP perhaps_location block { (DeclaredLinearity.Unl, $3, [[$2]], $4, $5) } +| linearity VARIABLE arg_lists perhaps_location block { ($1, $2, $3, $4, $5) } +| OP pattern op pattern perhaps_location block { (dlUnl, $3.node, [[$2; $4]], $5, $6) } +| OP PREFIXOP pattern perhaps_location block { (dlUnl, $2, [[$3]], $4, $5) } +| OP pattern POSTFIXOP perhaps_location block { (dlUnl, $3, [[$2]], $4, $5) } tlvarbinding: | VAR VARIABLE perhaps_location EQ exp { (PatName $2, $5, $3) } @@ -382,7 +382,7 @@ subkind: | COLONCOLON CONSTRUCTOR { subkind_of $loc($2) $2 } typearg: -| VARIABLE { (($1, (`Type, None), `Rigid), None) } +| VARIABLE { (($1, (PrimaryKind.Type, None), `Rigid), None) } | VARIABLE kind { (attach_kind ($1, $2), None) } varlist: diff --git a/core/sugarConstructors.ml b/core/sugarConstructors.ml index b72e471b4..04b45ec5a 100644 --- a/core/sugarConstructors.ml +++ b/core/sugarConstructors.ml @@ -178,7 +178,7 @@ module SugarConstructors (Position : Pos) with_pos ppos (Fun (binder bndr, linearity, ([], (args, blk)), location, datatype)) - let fun_binding' ?(ppos=dp) ?(linearity=DeclaredLinearity.Unl) ?(tyvars=[]) + let fun_binding' ?(ppos=dp) ?(linearity=dlUnl) ?(tyvars=[]) ?(location=`Unknown) ?annotation bndr fnlit = with_pos ppos (Fun (bndr, linearity, (tyvars, fnlit), location, annotation)) diff --git a/core/sugartypes.ml b/core/sugartypes.ml index d974d47c3..cab71734c 100644 --- a/core/sugartypes.ml +++ b/core/sugartypes.ml @@ -68,10 +68,7 @@ let default_subkind : subkind = (linUnl, resAny) type freedom = [`Flexible | `Rigid] [@@deriving show] -type primary_kind = [`Type | `Row | `Presence] - [@@deriving show] - -type kind = primary_kind * subkind option +type kind = PrimaryKind.t * subkind option [@@deriving show] type type_variable = name * kind * freedom diff --git a/core/types.ml b/core/types.ml index 6333f4979..8baa9aa12 100644 --- a/core/types.ml +++ b/core/types.ml @@ -25,10 +25,7 @@ type subkind = Linearity.t * Restriction.t type freedom = [`Rigid | `Flexible] [@@deriving eq,show] -type primary_kind = [ `Type | `Row | `Presence ] - [@@deriving eq,show] - -type kind = primary_kind * subkind +type kind = PrimaryKind.t * subkind [@@deriving eq,show] type 't meta_type_var_non_rec_basis = @@ -70,7 +67,7 @@ end let process = { Abstype.id = "Process" ; name = "Process" ; - arity = [`Row, (linAny, resAny)] ; + arity = [pkRow, (linAny, resAny)] ; } (* Lists are currently unlimited because the only deconstructors are @@ -79,7 +76,7 @@ let process = { let list = { Abstype.id = "List" ; name = "List" ; - arity = [`Type, (linUnl, resAny)] ; + arity = [pkType, (linUnl, resAny)] ; } let event = { @@ -96,7 +93,7 @@ let dom_node = { let access_point = { Abstype.id = "AP" ; name = "AP" ; - arity = [`Type, (linAny, resSession)] ; + arity = [pkType, (linAny, resSession)] ; } let socket = { @@ -605,9 +602,9 @@ let var_of_quantifier : quantifier -> int = let kind_of_quantifier : quantifier -> kind = function - | _, sk, `Type _ -> `Type, sk - | _, sk, `Row _ -> `Row, sk - | _, sk, `Presence _ -> `Presence, sk + | _, sk, `Type _ -> pkType, sk + | _, sk, `Row _ -> pkRow, sk + | _, sk, `Presence _ -> pkPresence, sk let type_arg_of_quantifier : quantifier -> type_arg = function @@ -615,21 +612,21 @@ let type_arg_of_quantifier : quantifier -> type_arg = | _, _, `Row row_var -> `Row (FieldEnv.empty, row_var, false) | _, _, `Presence point -> `Presence (`Var point) -let primary_kind_of_quantifier : quantifier -> primary_kind = +let primary_kind_of_quantifier : quantifier -> PrimaryKind.t = function - | _, _, `Type _ -> `Type - | _, _, `Row _ -> `Row - | _, _, `Presence _ -> `Presence + | _, _, `Type _ -> pkType + | _, _, `Row _ -> pkRow + | _, _, `Presence _ -> pkPresence let subkind_of_quantifier : quantifier -> subkind = fun q -> snd (kind_of_quantifier q) -let primary_kind_of_type_arg : type_arg -> primary_kind = +let primary_kind_of_type_arg : type_arg -> PrimaryKind.t = function - | `Type _ -> `Type - | `Row _ -> `Row - | `Presence _ -> `Presence + | `Type _ -> pkType + | `Row _ -> pkRow + | `Presence _ -> pkPresence let add_quantified_vars qs vars = List.fold_right IntSet.add (List.map var_of_quantifier qs) vars @@ -1667,7 +1664,7 @@ let show_raw_type_vars = Basicsettings.Types.show_raw_type_vars module Vars = struct type flavour = [`Rigid | `Flexible | `Recursive] - type kind = primary_kind + type kind = PrimaryKind.t type scope = [`Free | `Bound] type spec = flavour * kind * int @@ -1703,12 +1700,12 @@ struct begin match Unionfind.find point with | `Var (var, _, freedom) -> - [var, ((freedom :> flavour), `Type, `Free)] + [var, ((freedom :> flavour), pkType, `Free)] | `Recursive (var, body) -> if TypeVarSet.mem var bound_vars then - [var, (`Recursive, `Type, `Bound)] + [var, (`Recursive, pkType, `Bound)] else - (var, (`Recursive, `Type, `Bound))::(free_bound_type_vars ~include_aliases (TypeVarSet.add var bound_vars) body) + (var, (`Recursive, pkType, `Bound))::(free_bound_type_vars ~include_aliases (TypeVarSet.add var bound_vars) body) | `Body t -> fbtv t end | `Function (f, m, t) -> @@ -1750,7 +1747,7 @@ struct begin match Unionfind.find point with | `Var (var, _, freedom) -> - [var, ((freedom :> flavour), `Presence, `Free)] + [var, ((freedom :> flavour), pkPresence, `Free)] | `Body f -> free_bound_field_spec_type_vars ~include_aliases bound_vars f end and free_bound_row_type_vars ~include_aliases bound_vars (field_env, row_var, _) = @@ -1765,12 +1762,12 @@ struct match Unionfind.find row_var with | `Closed -> [] | `Var (var, _, freedom) -> - [var, ((freedom :> flavour), `Row, `Free)] + [var, ((freedom :> flavour), pkRow, `Free)] | `Recursive (var, row) -> if TypeVarSet.mem var bound_vars then - [var, (`Recursive, `Row, `Bound)] + [var, (`Recursive, pkRow, `Bound)] else - (var, (`Recursive, `Row, `Bound))::(free_bound_row_type_vars ~include_aliases (TypeVarSet.add var bound_vars) row) + (var, (`Recursive, pkRow, `Bound))::(free_bound_row_type_vars ~include_aliases (TypeVarSet.add var bound_vars) row) | `Body row -> free_bound_row_type_vars ~include_aliases bound_vars row and free_bound_tyarg_vars ~include_aliases bound_vars = function @@ -1904,30 +1901,31 @@ struct | (Linearity.Unl, Restriction.Effect) -> Restriction.string_of resEffect | (l, r) -> full (l, r) - let primary_kind : primary_kind -> string = function - | `Type -> "Type" - | `Row -> "Row" - | `Presence -> "Presence" - let kind : (policy * names) -> kind -> string = let full (policy, _vars) (k, sk) = - primary_kind k ^ subkind (policy, _vars) sk in + PrimaryKind.string_of k ^ subkind (policy, _vars) sk in fun (policy, _vars) (k, sk) -> if policy.kinds = "full" then full (policy, _vars) (k, sk) else if policy.kinds = "hide" then - primary_kind k + PrimaryKind.string_of k else match (k, sk) with - | `Type, (Linearity.Unl, Restriction.Any) -> "" - | `Type, (Linearity.Unl, Restriction.Base) -> Restriction.string_of resBase - | `Type, (Linearity.Any, Restriction.Session) -> Restriction.string_of resSession - | `Type, sk -> subkind ({policy with kinds="full"}, _vars) sk - | `Row, (Linearity.Unl, Restriction.Any) -> primary_kind `Row - | `Row, (Linearity.Unl, Restriction.Effect) -> primary_kind `Row - | `Presence, (Linearity.Unl, Restriction.Any) -> primary_kind `Presence - | `Row, _ - | `Presence, _ -> full ({policy with kinds="full"}, _vars) (k, sk) + | PrimaryKind.Type, (Linearity.Unl, Restriction.Any) -> "" + | PrimaryKind.Type, (Linearity.Unl, Restriction.Base) -> + Restriction.string_of resBase + | PrimaryKind.Type, (Linearity.Any, Restriction.Session) -> + Restriction.string_of resSession + | PrimaryKind.Type, sk -> + subkind ({policy with kinds="full"}, _vars) sk + | PrimaryKind.Row, (Linearity.Unl, Restriction.Any) -> + PrimaryKind.string_of pkRow + | PrimaryKind.Row, (Linearity.Unl, Restriction.Effect) -> + PrimaryKind.string_of pkRow + | PrimaryKind.Presence, (Linearity.Unl, Restriction.Any) -> + PrimaryKind.string_of pkPresence + | PrimaryKind.Row, _ | PrimaryKind.Presence, _ -> + full ({policy with kinds="full"}, _vars) (k, sk) let quantifier : (policy * names) -> quantifier -> string = fun (policy, vars) q -> @@ -2383,9 +2381,6 @@ let string_of_tycon_spec ?(policy=Print.default_policy) ?(refresh_tyvar_names=tr build_tyvar_names (fun x -> free_bound_tycon_type_vars x) [tycon]; Print.tycon_spec TypeVarSet.empty (policy (), Vars.tyvar_name_map) tycon -let string_of_primary_kind primary_kind = - Print.primary_kind primary_kind - let string_of_quantifier ?(policy=Print.default_policy) ?(refresh_tyvar_names=true) (quant : quantifier) = if refresh_tyvar_names then build_tyvar_names (fun x -> free_bound_quantifier_vars x) [quant]; diff --git a/core/types.mli b/core/types.mli index 15d39fd81..75c1e916b 100644 --- a/core/types.mli +++ b/core/types.mli @@ -1,4 +1,5 @@ (** Core types *) +open CommonTypes (* field environments *) type 'a stringmap = 'a Utility.StringMap.t [@@deriving show] @@ -14,16 +15,13 @@ type 'a point = 'a Unionfind.point type primitive = [ `Bool | `Int | `Char | `Float | `XmlItem | `DB | `String ] [@@deriving show] -type subkind = CommonTypes.Linearity.t * CommonTypes.Restriction.t +type subkind = Linearity.t * Restriction.t [@@deriving eq,show] type freedom = [`Rigid | `Flexible] [@@deriving eq,show] -type primary_kind = [ `Type | `Row | `Presence ] - [@@deriving eq,show] - -type kind = primary_kind * subkind +type kind = PrimaryKind.t * subkind [@@deriving eq,show] type 't meta_type_var_non_rec_basis = @@ -52,7 +50,7 @@ end module Vars : sig type flavour = [`Rigid | `Flexible | `Recursive] - type kind = primary_kind + type kind = PrimaryKind.t type scope = [`Free | `Bound] type vars_list = (int * (flavour * kind * scope)) list end @@ -228,14 +226,14 @@ val free_bound_type_vars : ?include_aliases:bool -> typ -> Vars.vars_list val free_bound_row_type_vars : ?include_aliases:bool -> row -> Vars.vars_list val var_of_quantifier : quantifier -> int -val primary_kind_of_quantifier : quantifier -> primary_kind +val primary_kind_of_quantifier : quantifier -> PrimaryKind.t val kind_of_quantifier : quantifier -> kind val subkind_of_quantifier : quantifier -> subkind val type_arg_of_quantifier : quantifier -> type_arg val freshen_quantifier : quantifier -> quantifier * type_arg val freshen_quantifier_flexible : quantifier -> quantifier * type_arg -val primary_kind_of_type_arg : type_arg -> primary_kind +val primary_kind_of_type_arg : type_arg -> PrimaryKind.t val quantifiers_of_type_args : type_arg list -> quantifier list @@ -377,7 +375,6 @@ val string_of_row_var : ?policy:(unit -> Print.policy) -> ?refresh_tyvar_names:bool -> row_var -> string val string_of_tycon_spec : ?policy:(unit -> Print.policy) -> ?refresh_tyvar_names:bool -> tycon_spec -> string -val string_of_primary_kind : primary_kind -> string val string_of_environment : environment -> string val string_of_typing_environment : typing_environment -> string From a9304fd6d0dacb36a34cef80c57e7b1c954e6af0 Mon Sep 17 00:00:00 2001 From: Jan Stolarek Date: Thu, 21 Feb 2019 14:00:05 +0000 Subject: [PATCH 26/28] Redefine location as a variant --- bin/repl.ml | 7 ++++--- core/commonTypes.ml | 33 +++++++++++++++++++++++++++++++++ core/desugarLAttributes.ml | 8 ++++---- core/evalir.ml | 7 ++++--- core/ir.ml | 2 +- core/ir.mli | 2 +- core/irtojs.ml | 19 ++++++++++--------- core/json.ml | 9 +++++---- core/lib.ml | 6 +++--- core/lib.mli | 2 +- core/parser.mly | 14 +++++++------- core/query/query.ml | 9 +++++---- core/sugarConstructors.ml | 6 +++--- core/sugarConstructorsIntf.ml | 16 ++++++++++------ core/sugarTraversals.ml | 7 ++++--- core/sugarTraversals.mli | 7 ++++--- core/sugartoir.ml | 2 +- core/sugartypes.ml | 17 ++++------------- core/transformSugar.ml | 10 +++++----- core/transformSugar.mli | 10 +++++----- 20 files changed, 114 insertions(+), 79 deletions(-) diff --git a/bin/repl.ml b/bin/repl.ml index 9a1b0f772..e65d5eefc 100644 --- a/bin/repl.ml +++ b/bin/repl.ml @@ -2,6 +2,7 @@ open Links_core open Utility open List open Sugartypes +open CommonTypes module BS = Basicsettings @@ -227,11 +228,11 @@ let evaluate_parse_result envs parse_result = | Some (finfo, _, None, location) -> let v = match location with - | `Server | `Unknown -> + | Location.Server | Location.Unknown -> `FunctionPtr (var, None) - | `Client -> + | Location.Client -> `ClientFunction (Js.var_name_binder (var, finfo)) - | `Native -> assert false in + | Location.Native -> assert false in let t = Var.info_type finfo in v, t | _ -> assert false in diff --git a/core/commonTypes.ml b/core/commonTypes.ml index f2a2c9717..0c9bff632 100644 --- a/core/commonTypes.ml +++ b/core/commonTypes.ml @@ -76,3 +76,36 @@ end let pkType = PrimaryKind.Type let pkRow = PrimaryKind.Row let pkPresence = PrimaryKind.Presence + +module Location = struct + type t = Client | Server | Native | Unknown + [@@deriving show] + + let isClient = function + | Client -> true + | _ -> false + + let isServer = function + | Server -> true + | _ -> false + + let isNative = function + | Native -> true + | _ -> false + + let isUnknown = function + | Unknown -> true + | _ -> false + + let string_of = function + | Client -> "client" + | Server -> "server" + | Native -> "native" + | Unknown -> "unknown" +end + +(* Convenient aliases for constructing values *) +let locClient = Location.Client +let locServer = Location.Server +let locNative = Location.Native +let locUnknown = Location.Unknown diff --git a/core/desugarLAttributes.ml b/core/desugarLAttributes.ml index d94feb17f..0a6374ea0 100644 --- a/core/desugarLAttributes.ml +++ b/core/desugarLAttributes.ml @@ -36,7 +36,7 @@ let desugar_lhref : phrasenode -> phrasenode = function | [_,[target]], rest -> ("href", [constant_str "?_k="; - apply "pickleCont" [fun_lit ~location:`Server dlUnl [[]] target]]) + apply "pickleCont" [fun_lit ~location:locServer dlUnl [[]] target]]) :: rest | _ -> assert false (* multiple l:hrefs, or an invalid rhs; NOTE: this is a user error and should @@ -54,7 +54,7 @@ let desugar_laction : phrasenode -> phrasenode = function ["type", [constant_str "hidden"]; "name", [constant_str "_k"]; "value", [apply "pickleCont" - [fun_lit ~location:`Server dlUnl [[]] action_expr]]] + [fun_lit ~location:locServer dlUnl [[]] action_expr]]] None [] and action = ("action", [constant_str "#"]) in Xml (form, action::rest, attrexp, hidden::children) @@ -69,7 +69,7 @@ let desugar_lonevent : phrasenode -> phrasenode = | (name, [rhs]) -> let event_name = StringLabels.sub ~pos:4 ~len:(String.length name - 4) name in tuple [constant_str event_name; - fun_lit ~location:`Client dlUnl [[variable_pat "event"]] rhs] + fun_lit ~location:locClient dlUnl [[variable_pat "event"]] rhs] | _ -> assert false in function | Xml (tag, attrs, attrexp, children) @@ -105,7 +105,7 @@ let desugar_lnames (p : phrasenode) : phrasenode * (string * string) StringMap.t p', !lnames let let_in name rhs body : phrase = - block ([val_binding' NoSig (PatName name, rhs, `Unknown)], body) + block ([val_binding' NoSig (PatName name, rhs, locUnknown)], body) let bind_lname_vars lnames = function | "l:action" as attr, es -> diff --git a/core/evalir.ml b/core/evalir.ml index 5b2c923d1..abb7dbe71 100644 --- a/core/evalir.ml +++ b/core/evalir.ml @@ -1,3 +1,4 @@ +open CommonTypes open Webserver_types open Ir open Lwt @@ -68,14 +69,14 @@ struct | Some (finfo, _, None, location) -> begin match location with - | `Server | `Unknown -> + | Location.Server | Location.Unknown -> (* TODO: perhaps we should actually use env here - and make sure we only call this function when it is sufficiently small *) Some (`FunctionPtr (f, None)) - | `Client -> + | Location.Client -> Some (`ClientFunction (Js.var_name_binder (f, finfo))) - | `Native -> assert false + | Location.Native -> assert false end | _ -> assert false diff --git a/core/ir.ml b/core/ir.ml index 866431a79..4743aed55 100644 --- a/core/ir.ml +++ b/core/ir.ml @@ -36,7 +36,7 @@ type language = string type constant = Constant.constant [@@deriving show] -type location = Sugartypes.location +type location = CommonTypes.Location.t [@@deriving show] type value = diff --git a/core/ir.mli b/core/ir.mli index b5a537660..8b2da6804 100644 --- a/core/ir.mli +++ b/core/ir.mli @@ -36,7 +36,7 @@ type language = string type constant = Constant.constant [@@deriving show] -type location = Sugartypes.location +type location = CommonTypes.Location.t [@@deriving show] (* INVARIANT: all IR binders have unique names *) diff --git a/core/irtojs.ml b/core/irtojs.ml index d108d092d..5594ebe6e 100644 --- a/core/irtojs.ml +++ b/core/irtojs.ml @@ -1,6 +1,7 @@ (** JavaScript generation *) open Utility +open CommonTypes let _ = ParseSettings.config_file @@ -690,7 +691,7 @@ end = functor (K : CONTINUATION) -> struct | _ -> if Lib.is_primitive f_name && not (List.mem f_name cps_prims) - && Lib.primitive_location f_name <> `Server + && not (Location.isServer (Lib.primitive_location f_name)) then Call (Var ("_" ^ f_name), List.map gv vs) else @@ -743,7 +744,7 @@ end = functor (K : CONTINUATION) -> struct advantage of dynamic scoping *) match location with - | `Client | `Native | `Unknown -> + | Location.Client | Location.Native | Location.Unknown -> let xs_names'' = xs_names'@[__kappa] in LetFun ((Js.var_name_binder fb, xs_names'', @@ -751,7 +752,7 @@ end = functor (K : CONTINUATION) -> struct List.map (fun x -> Var x) xs_names''), location), code) - | `Server -> + | Location.Server -> LetFun ((Js.var_name_binder fb, xs_names'@[__kappa], generate_remote_call f_var xs_names env, @@ -786,7 +787,7 @@ end = functor (K : CONTINUATION) -> struct (Env.Int.fold (fun var _v funcs -> let name = Lib.primitive_name var in - if Lib.primitive_location name = `Server then + if Location.isServer (Lib.primitive_location name) then (name, var)::funcs else funcs) @@ -811,7 +812,7 @@ end = functor (K : CONTINUATION) -> struct ((name, args @ [__kappa], body, - `Server), + locServer), code)) prim_server_calls code @@ -843,7 +844,7 @@ end = functor (K : CONTINUATION) -> struct | _ -> if Lib.is_primitive f_name && not (List.mem f_name cps_prims) - && Lib.primitive_location f_name <> `Server + && not (Location.isServer (Lib.primitive_location f_name)) then let arg = Call (Var ("_" ^ f_name), List.map gv vs) in K.apply ~strategy:`Direct kappa arg @@ -1159,10 +1160,10 @@ end = functor (K : CONTINUATION) -> struct let body_env = List.fold_left VEnv.bind env (fs @ bs) in let body = match location with - | `Client | `Unknown -> + | Location.Client | Location.Unknown -> snd (generate_computation body_env body (K.reflect (Var __kappa))) - | `Server -> generate_remote_call f xs_names (Dict []) - | `Native -> failwith ("Not implemented native calls yet") + | Location.Server -> generate_remote_call f xs_names (Dict []) + | Location.Native -> failwith ("Not implemented native calls yet") in (f_name, xs_names @ [__kappa], diff --git a/core/json.ml b/core/json.ml index beee88dd9..77391456b 100644 --- a/core/json.ml +++ b/core/json.ml @@ -1,5 +1,6 @@ (* Side-effect-free JSON operations. *) open ProcessTypes +open CommonTypes open Utility (* Setting *) @@ -58,10 +59,10 @@ let js_dq_escape_char = | ch -> String.make 1 ch let jsonize_location : Ir.location -> string = function - | `Client -> "client" - | `Server -> "server" - | `Native -> "native" - | `Unknown -> "unknown" + | Location.Client -> "client" + | Location.Server -> "server" + | Location.Native -> "native" + | Location.Unknown -> "unknown" let rec string_listify : string list -> string = function | [] -> nil_literal diff --git a/core/lib.ml b/core/lib.ml index cec0b8daa..110155857 100644 --- a/core/lib.ml +++ b/core/lib.ml @@ -1656,9 +1656,9 @@ let primitive_name = Env.Int.lookup venv let primitive_location (name:string) = match fst3 (List.assoc name env) with - | `Client -> `Client - | `Server _ -> `Server - | #primitive -> `Unknown + | `Client -> Location.Client + | `Server _ -> Location.Server + | #primitive -> Location.Unknown let rec function_arity = function diff --git a/core/lib.mli b/core/lib.mli index 55ee53918..4702b24db 100644 --- a/core/lib.mli +++ b/core/lib.mli @@ -28,7 +28,7 @@ val apply_pfun_by_code : Var.var -> Value.t list -> RequestData.request_data -> val primitive_stub_by_code : Var.var -> Value.t val primitive_name : Var.var -> string -val primitive_location : string -> Sugartypes.location +val primitive_location : string -> CommonTypes.Location.t val primitive_arity : string -> int option val cohttp_server_response : (string * string) list -> string -> RequestData.request_data -> (Cohttp.Response.t * Cohttp_lwt.Body.t) Lwt.t diff --git a/core/parser.mly b/core/parser.mly index 787137309..511f4a614 100644 --- a/core/parser.mly +++ b/core/parser.mly @@ -246,7 +246,7 @@ let parseRegexFlags f = %type regex_pattern_sequence %type pattern %type tlfunbinding %type postfix_expression %type primary_expression @@ -396,10 +396,10 @@ fixity: | POSTFIX { (`Post , $1) } perhaps_location: -| SERVER { `Server } -| CLIENT { `Client } -| NATIVE { `Native } -| /* empty */ { `Unknown } +| SERVER { locServer } +| CLIENT { locClient } +| NATIVE { locNative } +| /* empty */ { locUnknown } constant: | UINTEGER { `Int $1 } @@ -845,8 +845,8 @@ links_open: binding: | VAR pattern EQ exp SEMICOLON { val_binding ~ppos:$loc $2 $4 } | exp SEMICOLON { with_pos $loc (Exp $1) } -| signature linearity VARIABLE arg_lists block { fun_binding ~ppos:$loc (Sig $1) ($2, $3, $4, `Unknown, $5) } -| linearity VARIABLE arg_lists block { fun_binding ~ppos:$loc NoSig ($1, $2, $3, `Unknown, $4) } +| signature linearity VARIABLE arg_lists block { fun_binding ~ppos:$loc (Sig $1) ($2, $3, $4, locUnknown, $5) } +| linearity VARIABLE arg_lists block { fun_binding ~ppos:$loc NoSig ($1, $2, $3, locUnknown, $4) } | typed_handler_binding { handler_binding ~ppos:$loc NoSig $1 } | typedecl SEMICOLON | links_module | alien_block | links_open { $1 } diff --git a/core/query/query.ml b/core/query/query.ml index 37a4f6bce..0bfe30911 100644 --- a/core/query/query.ml +++ b/core/query/query.ml @@ -1,4 +1,5 @@ open Utility +open CommonTypes type base_type = [ `Bool | `Char | `Float | `Int | `String ] @@ -301,16 +302,16 @@ struct | _ -> begin match location with - | `Server | `Unknown -> + | Location.Server | Location.Unknown -> let env = match z, fvs with | None, None -> Value.Env.empty | Some z, Some fvs -> Value.Env.bind z (fvs, `Local) Value.Env.empty | _, _ -> assert false in `Closure ((xs, body), env_of_value_env env) - | `Client -> + | Location.Client -> failwith ("Attempt to use client function: " ^ Js.var_name_binder (f, finfo) ^ " in query") - | `Native -> + | Location.Native -> failwith ("Attempt to use native function: " ^ Var.show_binder (f, finfo) ^ " in query") end end @@ -608,7 +609,7 @@ struct | `Let (xb, (_, tc)) -> let x = Var.var_of_binder xb in computation (bind env (x, tail_computation env tc)) (bs, tailcomp) - | `Fun (_, _, _, (`Client | `Native)) -> + | `Fun (_, _, _, (Location.Client | Location.Native)) -> eval_error "Client function" | `Fun ((f, _), _, _, _) -> (* This should never happen now that we have closure conversion*) diff --git a/core/sugarConstructors.ml b/core/sugarConstructors.ml index 04b45ec5a..52c6739f3 100644 --- a/core/sugarConstructors.ml +++ b/core/sugarConstructors.ml @@ -146,7 +146,7 @@ module SugarConstructors (Position : Pos) (** Various phrases *) (* Create a FunLit. *) - let fun_lit ?(ppos=dp) ?args ?(location=`Unknown) linearity pats blk = + let fun_lit ?(ppos=dp) ?args ?(location=locUnknown) linearity pats blk = with_pos ppos (FunLit (args, linearity, (pats, blk), location)) (* Create an argument used by Handler and HandlerLit. *) @@ -179,7 +179,7 @@ module SugarConstructors (Position : Pos) ([], (args, blk)), location, datatype)) let fun_binding' ?(ppos=dp) ?(linearity=dlUnl) ?(tyvars=[]) - ?(location=`Unknown) ?annotation bndr fnlit = + ?(location=locUnknown) ?annotation bndr fnlit = with_pos ppos (Fun (bndr, linearity, (tyvars, fnlit), location, annotation)) @@ -204,7 +204,7 @@ module SugarConstructors (Position : Pos) (* A commonly used wrapper around val_binding *) let val_binding ?(ppos=dp) pat phrase = - val_binding' ~ppos NoSig (Pat pat, phrase, `Unknown) + val_binding' ~ppos NoSig (Pat pat, phrase, locUnknown) (** Database queries *) diff --git a/core/sugarConstructorsIntf.ml b/core/sugarConstructorsIntf.ml index 9128026d6..f9f81fed5 100644 --- a/core/sugarConstructorsIntf.ml +++ b/core/sugarConstructorsIntf.ml @@ -93,10 +93,12 @@ module type SugarConstructorsSig = sig (* Various phrases *) val fun_lit : ?ppos:t -> ?args:((Types.datatype * Types.row) list) - -> ?location:location -> DeclaredLinearity.t -> Pattern.with_pos list list -> phrase + -> ?location:Location.t -> DeclaredLinearity.t + -> Pattern.with_pos list list -> phrase -> phrase val hnlit_arg - : handler_depth -> Pattern.with_pos -> clause list * Pattern.with_pos list list option + : handler_depth -> Pattern.with_pos + -> clause list * Pattern.with_pos list list option -> handlerlit val handler_lit : ?ppos:t -> handlerlit -> phrase @@ -114,17 +116,18 @@ module type SugarConstructorsSig = sig (* Bindings *) val fun_binding : ?ppos:t -> signature - -> (DeclaredLinearity.t * name * Pattern.with_pos list list * location * phrase) + -> (DeclaredLinearity.t * name * Pattern.with_pos list list * Location.t * + phrase) -> binding val fun_binding' : ?ppos:t -> ?linearity:DeclaredLinearity.t -> ?tyvars:tyvar list - -> ?location:location -> ?annotation:datatype' -> binder -> funlit + -> ?location:Location.t -> ?annotation:datatype' -> binder -> funlit -> binding val handler_binding : ?ppos:t -> signature -> (name * handlerlit) -> binding val val_binding' - : ?ppos:t -> signature -> (name_or_pat * phrase * location) + : ?ppos:t -> signature -> (name_or_pat * phrase * Location.t) -> binding val val_binding : ?ppos:t -> Pattern.with_pos -> phrase @@ -152,7 +155,8 @@ module type SugarConstructorsSig = sig (* Handlers *) val untyped_handler - : ?val_cases:(clause list) -> ?parameters:((phrase * Pattern.with_pos) list) + : ?val_cases:(clause list) + -> ?parameters:((phrase * Pattern.with_pos) list) -> phrase -> clause list -> handler_depth -> handler end diff --git a/core/sugarTraversals.ml b/core/sugarTraversals.ml index 61d0cc513..973282542 100644 --- a/core/sugarTraversals.ml +++ b/core/sugarTraversals.ml @@ -9,6 +9,7 @@ *) open Operators +open CommonTypes open Sugartypes class map = @@ -498,7 +499,7 @@ class map = method name : name -> name = o#string - method location : location -> location = o#unknown + method location : Location.t -> Location.t = o#unknown method iterpatt : iterpatt -> iterpatt = function @@ -1167,7 +1168,7 @@ class fold = method name : name -> 'self_type = o#string - method location : location -> 'self_type = o#unknown + method location : Location.t -> 'self_type = o#unknown method iterpatt : iterpatt -> 'self_type = function @@ -1924,7 +1925,7 @@ class fold_map = method name : name -> ('self_type * name) = o#string - method location : location -> ('self_type * location) = o#unknown + method location : Location.t -> ('self_type * Location.t) = o#unknown method iterpatt : iterpatt -> ('self_type * iterpatt) = function diff --git a/core/sugarTraversals.mli b/core/sugarTraversals.mli index f2ac20df3..89c35c259 100644 --- a/core/sugarTraversals.mli +++ b/core/sugarTraversals.mli @@ -1,4 +1,5 @@ open Operators +open CommonTypes open Sugartypes (* Make a copy of a value. You can override any method(s) to get a @@ -47,7 +48,7 @@ class map : method patternnode : Pattern.t -> Pattern.t method pattern : Pattern.with_pos -> Pattern.with_pos method name : name -> name - method location : location -> location + method location : Location.t -> Location.t method iterpatt : iterpatt -> iterpatt method funlit : funlit -> funlit method handlerlit : handlerlit -> handlerlit @@ -116,7 +117,7 @@ class fold : method patternnode : Pattern.t -> 'self method pattern : Pattern.with_pos -> 'self method name : name -> 'self - method location : location -> 'self + method location : Location.t -> 'self method iterpatt : iterpatt -> 'self method funlit : funlit -> 'self method handlerlit : handlerlit -> 'self @@ -173,7 +174,7 @@ object ('self) method handle_params : handler_parameterisation -> 'self * handler_parameterisation method iterpatt : iterpatt -> 'self * iterpatt method list : 'a . ('self -> 'a -> 'self * 'a) -> 'a list -> 'self * 'a list - method location : location -> 'self * location + method location : Location.t -> 'self * Location.t method name : name -> 'self * name method option : 'a . ('self -> 'a -> 'self * 'a) -> 'a option -> 'self * 'a option method patternnode : Pattern.t -> 'self * Pattern.t diff --git a/core/sugartoir.ml b/core/sugartoir.ml index 6b718e8e7..bc2a2a786 100644 --- a/core/sugartoir.ml +++ b/core/sugartoir.ml @@ -598,7 +598,7 @@ struct let f_info = (ft, "", `Local) in let rest f : tail_computation sem = lift (`Special (`CallCC (`Variable f)), body_type) in - M.bind (fun_binding (f_info, ([], [kb], body), `Unknown)) rest + M.bind (fun_binding (f_info, ([], [kb], body), locUnknown)) rest let letfun env ((ft, _, _) as f_info, (tyvars, (ps, body)), location) rest = let xsb : binder list = diff --git a/core/sugartypes.ml b/core/sugartypes.ml index cab71734c..9fef0e57a 100644 --- a/core/sugartypes.ml +++ b/core/sugartypes.ml @@ -51,15 +51,6 @@ type tyarg = Types.type_arg i.e. in let-bindings. *) -type location = [`Client | `Server | `Native | `Unknown] - [@@deriving show] - -let string_of_location = function -| `Client -> "client" -| `Server -> "server" -| `Native -> "native" -| `Unknown -> "unknown" - type subkind = Linearity.t * Restriction.t [@@deriving eq,show] @@ -216,7 +207,7 @@ and phrasenode = | Var of name | QualifiedVar of name list | FunLit of ((Types.datatype * Types.row) list) option * - DeclaredLinearity.t * funlit * location + DeclaredLinearity.t * funlit * Location.t | HandlerLit of handlerlit (* Spawn kind, expression referring to spawn location (client n, server...), spawn block, row opt *) @@ -291,14 +282,14 @@ and phrasenode = | Raise and phrase = phrasenode with_pos and bindingnode = - | Val of (Pattern.with_pos * (tyvar list * phrase) * location * + | Val of (Pattern.with_pos * (tyvar list * phrase) * Location.t * datatype' option) - | Fun of (binder * DeclaredLinearity.t * (tyvar list * funlit) * location * + | Fun of (binder * DeclaredLinearity.t * (tyvar list * funlit) * Location.t * datatype' option) | Funs of (binder * DeclaredLinearity.t * ((tyvar list * (Types.datatype * Types.quantifier option list) option) - * funlit) * location * datatype' option * position) list + * funlit) * Location.t * datatype' option * position) list | Handler of (binder * handlerlit * datatype' option) | Foreign of (binder * name * name * name * datatype') (* Binder, raw function name, language, external file, type *) diff --git a/core/transformSugar.ml b/core/transformSugar.ml index 61126e253..d344a202b 100644 --- a/core/transformSugar.ml +++ b/core/transformSugar.ml @@ -717,9 +717,9 @@ class transform (env : Types.typing_environment) = method restore_quantifiers : IntSet.t -> 'self_type = fun _ -> o method rec_bodies : - (binder * DeclaredLinearity.t * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * location * datatype' option * position) list -> + (binder * DeclaredLinearity.t * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * Location.t * datatype' option * position) list -> ('self_type * - (binder * DeclaredLinearity.t * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * location * datatype' option * position) list) = + (binder * DeclaredLinearity.t * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * Location.t * datatype' option * position) list) = let outer_tyvars = o#backup_quantifiers in let rec list o = function @@ -737,9 +737,9 @@ class transform (env : Types.typing_environment) = list o method rec_activate_outer_bindings : - (binder * DeclaredLinearity.t * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * location * datatype' option * position) list -> + (binder * DeclaredLinearity.t * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * Location.t * datatype' option * position) list -> ('self_type * - (binder * DeclaredLinearity.t * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * location * datatype' option * position) list) = + (binder * DeclaredLinearity.t * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * Location.t * datatype' option * position) list) = let rec list o = function | [] -> o, [] @@ -752,7 +752,7 @@ class transform (env : Types.typing_environment) = list o method rec_activate_inner_bindings : - (binder * DeclaredLinearity.t * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * location * datatype' option * position) list -> + (binder * DeclaredLinearity.t * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * Location.t * datatype' option * position) list -> 'self_type = let rec list o = function diff --git a/core/transformSugar.mli b/core/transformSugar.mli index f4f0ba5ac..3a781a0be 100644 --- a/core/transformSugar.mli +++ b/core/transformSugar.mli @@ -62,15 +62,15 @@ object ('self) method restore_quantifiers : Utility.IntSet.t -> 'self method rec_bodies : - (binder * DeclaredLinearity.t * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * location * datatype' option * position) list -> + (binder * DeclaredLinearity.t * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * Location.t * datatype' option * position) list -> ('self * - (binder * DeclaredLinearity.t * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * location * datatype' option * position) list) + (binder * DeclaredLinearity.t * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * Location.t * datatype' option * position) list) method rec_activate_outer_bindings : - (binder * DeclaredLinearity.t * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * location * datatype' option * position) list -> + (binder * DeclaredLinearity.t * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * Location.t * datatype' option * position) list -> ('self * - (binder * DeclaredLinearity.t * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * location * datatype' option * position) list) + (binder * DeclaredLinearity.t * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * Location.t * datatype' option * position) list) method rec_activate_inner_bindings : - (binder * DeclaredLinearity.t * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * location * datatype' option * position) list -> + (binder * DeclaredLinearity.t * ((tyvar list * (Types.datatype * Types.quantifier option list) option) * funlit) * Location.t * datatype' option * position) list -> 'self method sugar_datatype : Datatype.with_pos -> 'self * Datatype.with_pos From ac15a9a72bb06f2e1ae43380ad116a2b98d8a98a Mon Sep 17 00:00:00 2001 From: Jan Stolarek Date: Thu, 21 Feb 2019 16:27:42 +0000 Subject: [PATCH 27/28] Remove redundant code --- core/sugarTraversals.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/core/sugarTraversals.ml b/core/sugarTraversals.ml index 973282542..08024d416 100644 --- a/core/sugarTraversals.ml +++ b/core/sugarTraversals.ml @@ -581,7 +581,6 @@ class map = let _x = o#name _x in let _x_i1 = o#datatype _x_i1 in Mu (_x, _x_i1) | Forall (_x, _x_i1) -> - let _x = _x in let _x_i1 = o#datatype _x_i1 in Forall (_x, _x_i1) | Unit -> Unit | Tuple _x -> From 35691e76866db8dea0a523a6a698cbd606d7f68b Mon Sep 17 00:00:00 2001 From: Jan Stolarek Date: Fri, 22 Feb 2019 09:04:11 +0000 Subject: [PATCH 28/28] Address @dhil's feedback --- core/commonTypes.ml | 78 +++++++----- core/compilePatterns.ml | 2 +- core/desugarDatatypes.ml | 16 +-- core/desugarDbs.ml | 2 +- core/desugarFormlets.ml | 8 +- core/desugarFors.ml | 8 +- core/desugarFuns.ml | 6 +- core/desugarHandlers.ml | 4 +- core/desugarLAttributes.ml | 8 +- core/desugarPages.ml | 6 +- core/desugarProcesses.ml | 4 +- core/instantiate.ml | 8 +- core/irCheck.ml | 6 +- core/irtojs.ml | 8 +- core/lib.ml | 2 +- core/parser.mly | 60 +++++----- core/sugarConstructors.ml | 8 +- core/sugartoir.ml | 4 +- core/sugartypes.ml | 2 +- core/transformSugar.ml | 10 +- core/typeSugar.ml | 236 ++++++++++++++++++------------------- core/typeUtils.ml | 2 +- core/types.ml | 98 +++++++-------- core/unify.ml | 36 +++--- 24 files changed, 318 insertions(+), 304 deletions(-) diff --git a/core/commonTypes.ml b/core/commonTypes.ml index 0c9bff632..3e1d6ac30 100644 --- a/core/commonTypes.ml +++ b/core/commonTypes.ml @@ -2,29 +2,39 @@ module Linearity = struct type t = Any | Unl [@@deriving eq,show] - let isAny lin = lin == Any - let isUnl lin = lin == Unl + let is_any = function + | Any -> true + | _ -> false - let string_of = function + let is_nonlinear = function + | Unl -> true + | _ -> false + + let to_string = function | Any -> "Any" | Unl -> "Unl" end (* Convenient aliases for constructing values *) -let linUnl = Linearity.Unl -let linAny = Linearity.Any +let lin_any = Linearity.Any +let lin_unl = Linearity.Unl module DeclaredLinearity = struct type t = Lin | Unl [@@deriving show] - let isLin lin = lin == Lin - let isUnl lin = lin == Unl + let is_linear = function + | Lin -> true + | _ -> false + + let is_nonlinear = function + | Unl -> true + | _ -> false end (* Convenient aliases for constructing values *) -let dlLin = DeclaredLinearity.Lin -let dlUnl = DeclaredLinearity.Unl +let dl_lin = DeclaredLinearity.Lin +let dl_unl = DeclaredLinearity.Unl module Restriction = struct type t = @@ -34,19 +44,23 @@ module Restriction = struct | Effect [@@deriving eq,show] - let isAny = function + let is_any = function | Any -> true | _ -> false - let isBase = function + let is_base = function | Base -> true | _ -> false - let isSession = function + let is_session = function | Session -> true | _ -> false - let string_of = function + let is_effect = function + | Effect -> true + | _ -> false + + let to_string = function | Any -> "Any" | Base -> "Base" | Session -> "Session" @@ -54,10 +68,10 @@ module Restriction = struct end (* Convenient aliases for constructing values *) -let resAny = Restriction.Any -let resBase = Restriction.Base -let resSession = Restriction.Session -let resEffect = Restriction.Effect +let res_any = Restriction.Any +let res_base = Restriction.Base +let res_session = Restriction.Session +let res_effect = Restriction.Effect module PrimaryKind = struct type t = @@ -66,38 +80,38 @@ module PrimaryKind = struct | Presence [@@deriving show,eq] - let string_of = function - | Type -> "Type" - | Row -> "Row" + let to_string = function + | Type -> "Type" + | Row -> "Row" | Presence -> "Presence" end (* Convenient aliases for constructing values *) -let pkType = PrimaryKind.Type -let pkRow = PrimaryKind.Row -let pkPresence = PrimaryKind.Presence +let pk_type = PrimaryKind.Type +let pk_row = PrimaryKind.Row +let pk_presence = PrimaryKind.Presence module Location = struct type t = Client | Server | Native | Unknown [@@deriving show] - let isClient = function + let is_client = function | Client -> true | _ -> false - let isServer = function + let is_server = function | Server -> true | _ -> false - let isNative = function + let is_native = function | Native -> true | _ -> false - let isUnknown = function + let is_unknown = function | Unknown -> true | _ -> false - let string_of = function + let to_string = function | Client -> "client" | Server -> "server" | Native -> "native" @@ -105,7 +119,7 @@ module Location = struct end (* Convenient aliases for constructing values *) -let locClient = Location.Client -let locServer = Location.Server -let locNative = Location.Native -let locUnknown = Location.Unknown +let loc_client = Location.Client +let loc_server = Location.Server +let loc_native = Location.Native +let loc_unknown = Location.Unknown diff --git a/core/compilePatterns.ml b/core/compilePatterns.ml index cb8272c1b..e891f9758 100644 --- a/core/compilePatterns.ml +++ b/core/compilePatterns.ml @@ -78,7 +78,7 @@ let lookup_effects (_nenv, _tenv, eff, _penv) = eff let rec desugar_pattern : Ir.scope -> Sugartypes.Pattern.with_pos -> pattern * raw_env = fun scope {Sugartypes.node=p; Sugartypes.pos} -> let desugar_pat = desugar_pattern scope in - let empty = (NEnv.empty, TEnv.empty, Types.make_empty_open_row (linAny, resAny)) in + let empty = (NEnv.empty, TEnv.empty, Types.make_empty_open_row (lin_any, res_any)) in let (++) (nenv, tenv, _) (nenv', tenv', eff') = (NEnv.extend nenv nenv', TEnv.extend tenv tenv', eff') in let fresh_binder (nenv, tenv, eff) bndr = assert (Sugartypes.binder_has_type bndr); diff --git a/core/desugarDatatypes.ml b/core/desugarDatatypes.ml index 9bf64ceeb..5343b0c63 100644 --- a/core/desugarDatatypes.ml +++ b/core/desugarDatatypes.ml @@ -79,8 +79,8 @@ object (self) method! datatypenode = let open Datatype in function - | TypeVar (x, k, freedom) -> self#add (x, (pkType, k), freedom) - | Mu (v, t) -> let o = self#bind (v, (pkType, None), `Rigid) in o#datatype t + | TypeVar (x, k, freedom) -> self#add (x, (pk_type, k), freedom) + | Mu (v, t) -> let o = self#bind (v, (pk_type, None), `Rigid) in o#datatype t | Forall (qs, t) -> let o = List.fold_left (fun o q -> o#bind (rigidify q)) self qs in o#datatype t @@ -88,13 +88,13 @@ object (self) method! row_var = let open Datatype in function | Closed -> self - | Open (x, k, freedom) -> self#add (x, (pkRow, k), freedom) - | Recursive (s, r) -> let o = self#bind (s, (pkRow, None), `Rigid) in o#row r + | Open (x, k, freedom) -> self#add (x, (pk_row, k), freedom) + | Recursive (s, r) -> let o = self#bind (s, (pk_row, None), `Rigid) in o#row r method! fieldspec = let open Datatype in function | Absent -> self | Present t -> self#datatype t - | Var (x, k, freedom) -> self#add (x, (pkPresence, k), freedom) + | Var (x, k, freedom) -> self#add (x, (pk_presence, k), freedom) end type var_env = { tenv : Types.meta_type_var StringMap.t; @@ -184,9 +184,9 @@ struct let match_kinds (q, t) = let primary_kind_of_type_arg : Datatype.type_arg -> PrimaryKind.t = function - | Datatype.Type _ -> pkType - | Datatype.Row _ -> pkRow - | Datatype.Presence _ -> pkPresence + | Datatype.Type _ -> pk_type + | Datatype.Row _ -> pk_row + | Datatype.Presence _ -> pk_presence in if primary_kind_of_quantifier q <> primary_kind_of_type_arg t then raise Kind_mismatch diff --git a/core/desugarDbs.ml b/core/desugarDbs.ml index c7764ff63..9b1681355 100644 --- a/core/desugarDbs.ml +++ b/core/desugarDbs.ml @@ -64,7 +64,7 @@ object (o : 'self_type) from well-typed insert expressions. An alternative approach would be to maintain some kind of insert expression in the IR. *) - let value_type = `Record (Types.make_empty_open_row (linAny, resAny)) in + let value_type = `Record (Types.make_empty_open_row (lin_any, res_any)) in let o, rows, _ = o#phrase rows in let tyvars = [`Type read_type; `Type write_type; `Type needed_type; `Type value_type; `Row eff] in diff --git a/core/desugarFormlets.ml b/core/desugarFormlets.ml index 1ae37a750..d0ff83b75 100644 --- a/core/desugarFormlets.ml +++ b/core/desugarFormlets.ml @@ -41,7 +41,7 @@ object (o : 'self_type) [tuple_pat []], [tuple []], [Types.unit_type] | FormBinding (f, p) -> let (_o, _f, ft) = o#phrase f in - let t = Types.fresh_type_variable (linAny, resAny) in + let t = Types.fresh_type_variable (lin_any, res_any) in let () = Unify.datatypes (ft, Instantiate.alias "Formlet" [`Type t] tycon_env) in @@ -120,7 +120,7 @@ object (o : 'self_type) let mb = `Row (o#lookup_effects) in let base : phrase = fn_appl pure_str [`Type ft; mb] - [fun_lit ~args:(List.rev args) dlUnl (List.rev pss) + [fun_lit ~args:(List.rev args) dl_unl (List.rev pss) (tuple vs)] in let p, et = List.fold_right @@ -142,7 +142,7 @@ object (o : 'self_type) let context : phrase = let name = Utility.gensym ~prefix:"_formlet_" () in fun_lit ~args:[Types.make_tuple_type [Types.xml_type], eff] - dlUnl + dl_unl [[variable_pat ~ty:(Types.xml_type) name]] (xml tag attrs attrexp [block ([], var name)]) in let (o, e, t) = o#formlet_body (xml "#" [] None contents) in @@ -177,7 +177,7 @@ object (o : 'self_type) [`Type arg_type; `Type yields_type; mb] [body; fn_appl pure_str [`Type (`Function (Types.make_tuple_type [arg_type], empty_eff, yields_type)); mb] - [fun_lit ~args:[Types.make_tuple_type [arg_type], empty_eff] dlUnl pss yields]] + [fun_lit ~args:[Types.make_tuple_type [arg_type], empty_eff] dl_unl pss yields]] in (o, e, Instantiate.alias "Formlet" [`Type yields_type] tycon_env) | e -> super#phrasenode e diff --git a/core/desugarFors.ml b/core/desugarFors.ml index 3da1a5c59..957fa9e85 100644 --- a/core/desugarFors.ml +++ b/core/desugarFors.ml @@ -77,12 +77,12 @@ let results : Types.row -> | [t] -> Types.make_tuple_type [t] | ts -> Types.make_tuple_type [Types.make_tuple_type ts] in - fun_lit ~args:[a, eff] dlUnl [ps] (tuple (q::qs)) in + fun_lit ~args:[a, eff] dl_unl [ps] (tuple (q::qs)) in let outer : Sugartypes.phrase = let a = `Type qst in let b = `Type (Types.make_tuple_type (t :: ts)) in fun_lit ~args:[Types.make_tuple_type [t], eff] - dlUnl [[qb]] + dl_unl [[qb]] (fn_appl "map" [a; `Row eff; b] [inner; r]) in let a = `Type qt in let b = `Type (Types.make_tuple_type (t :: ts)) in @@ -168,7 +168,7 @@ object (o : 'self_type) | ts -> Types.make_tuple_type ts in let f : phrase = fun_lit ~args:[Types.make_tuple_type [arg_type], eff] - dlUnl [arg] body in + dl_unl [arg] body in let results = results eff (es, xs, ts) in let results = @@ -180,7 +180,7 @@ object (o : 'self_type) let g : phrase = fun_lit ~args:[Types.make_tuple_type [arg_type], eff] - dlUnl [arg] sort + dl_unl [arg] sort in fn_appl sort_by [`Type arg_type; `Row eff; sort_type_arg] [g; results] diff --git a/core/desugarFuns.ml b/core/desugarFuns.ml index 1414efdc1..75dc42e7a 100644 --- a/core/desugarFuns.ml +++ b/core/desugarFuns.ml @@ -84,9 +84,9 @@ object (o : 'self_type) in (o, e, ft) | Section (Section.Project name) -> - let ab, a = Types.fresh_type_quantifier (linAny, resAny) in - let rhob, (fields, rho, _) = Types.fresh_row_quantifier (linAny, resAny) in - let effb, eff = Types.fresh_row_quantifier (linAny, resAny) in + let ab, a = Types.fresh_type_quantifier (lin_any, res_any) in + let rhob, (fields, rho, _) = Types.fresh_row_quantifier (lin_any, res_any) in + let effb, eff = Types.fresh_row_quantifier (lin_any, res_any) in let r = `Record (StringMap.add name (`Present a) fields, rho, false) in diff --git a/core/desugarHandlers.ml b/core/desugarHandlers.ml index 22988c028..2937db9bd 100644 --- a/core/desugarHandlers.ml +++ b/core/desugarHandlers.ml @@ -99,7 +99,7 @@ let parameterize : (Pattern.with_pos * phrase) list -> Pattern.with_pos list lis StringSet.inter (StringSet.from_list pat_names) (StringSet.from_list param_names) in let params = List.map (List.map (fun p -> resolve_name_conflicts p name_conflicts)) params in - (pat, fun_lit dlUnl params body) + (pat, fun_lit dl_unl params body) ) cases @@ -202,7 +202,7 @@ object method! phrasenode = function | HandlerLit hnlit -> let (fnparams, body) = funlit_of_handlerlit hnlit in - let funlit : Sugartypes.phrasenode = (fun_lit dlUnl fnparams body).node in + let funlit : Sugartypes.phrasenode = (fun_lit dl_unl fnparams body).node in super#phrasenode funlit | e -> super#phrasenode e diff --git a/core/desugarLAttributes.ml b/core/desugarLAttributes.ml index 0a6374ea0..7e69eb398 100644 --- a/core/desugarLAttributes.ml +++ b/core/desugarLAttributes.ml @@ -36,7 +36,7 @@ let desugar_lhref : phrasenode -> phrasenode = function | [_,[target]], rest -> ("href", [constant_str "?_k="; - apply "pickleCont" [fun_lit ~location:locServer dlUnl [[]] target]]) + apply "pickleCont" [fun_lit ~location:loc_server dl_unl [[]] target]]) :: rest | _ -> assert false (* multiple l:hrefs, or an invalid rhs; NOTE: this is a user error and should @@ -54,7 +54,7 @@ let desugar_laction : phrasenode -> phrasenode = function ["type", [constant_str "hidden"]; "name", [constant_str "_k"]; "value", [apply "pickleCont" - [fun_lit ~location:locServer dlUnl [[]] action_expr]]] + [fun_lit ~location:loc_server dl_unl [[]] action_expr]]] None [] and action = ("action", [constant_str "#"]) in Xml (form, action::rest, attrexp, hidden::children) @@ -69,7 +69,7 @@ let desugar_lonevent : phrasenode -> phrasenode = | (name, [rhs]) -> let event_name = StringLabels.sub ~pos:4 ~len:(String.length name - 4) name in tuple [constant_str event_name; - fun_lit ~location:locClient dlUnl [[variable_pat "event"]] rhs] + fun_lit ~location:loc_client dl_unl [[variable_pat "event"]] rhs] | _ -> assert false in function | Xml (tag, attrs, attrexp, children) @@ -105,7 +105,7 @@ let desugar_lnames (p : phrasenode) : phrasenode * (string * string) StringMap.t p', !lnames let let_in name rhs body : phrase = - block ([val_binding' NoSig (PatName name, rhs, locUnknown)], body) + block ([val_binding' NoSig (PatName name, rhs, loc_unknown)], body) let bind_lname_vars lnames = function | "l:action" as attr, es -> diff --git a/core/desugarPages.ml b/core/desugarPages.ml index 0cf398f09..316b5f1b8 100644 --- a/core/desugarPages.ml +++ b/core/desugarPages.ml @@ -37,8 +37,8 @@ let rec desugar_page (o, page_type) = | FormletPlacement (formlet, handler, attributes) -> let (_, formlet, formlet_type) = o#phrase formlet in let formlet_type = Types.concrete_type formlet_type in - let a = Types.fresh_type_variable (linAny, resAny) in - let b = Types.fresh_type_variable (linAny, resAny) 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 (`Alias (("Formlet", [`Type a]), b), formlet_type); fn_appl "formP" [`Type a; `Row (o#lookup_effects)] [formlet; handler; attributes] @@ -49,7 +49,7 @@ let rec desugar_page (o, page_type) = let x = Utility.gensym ~prefix:"xml" () in fn_appl "plugP" [`Row (o#lookup_effects)] [fun_lit ~args:[Types.make_tuple_type [Types.xml_type], o#lookup_effects] - dlUnl [[variable_pat ~ty:Types.xml_type x]] + dl_unl [[variable_pat ~ty:Types.xml_type x]] (xml name attrs dynattrs [block ([], var x)]); desugar_nodes children] | _ -> diff --git a/core/desugarProcesses.ml b/core/desugarProcesses.ml index 34b468ded..8ef4f3e07 100644 --- a/core/desugarProcesses.ml +++ b/core/desugarProcesses.ml @@ -31,7 +31,7 @@ object (o : 'self_type) let e : phrasenode = fn_appl_node "spawnWait" [`Row inner_eff; `Type body_type; `Row outer_eff] - [fun_lit ~args:[(Types.make_tuple_type [], inner_eff)] dlUnl [[]] body] + [fun_lit ~args:[(Types.make_tuple_type [], inner_eff)] dl_unl [[]] body] in (o, e, body_type) | Spawn (k, spawn_loc, body, Some inner_eff) -> @@ -63,7 +63,7 @@ object (o : 'self_type) let e : phrasenode = fn_appl_node spawn_fun [`Row inner_eff; `Type body_type; `Row outer_eff] - [fun_lit ~args:[(Types.make_tuple_type [], inner_eff)] dlUnl [[]] body; + [fun_lit ~args:[(Types.make_tuple_type [], inner_eff)] dl_unl [[]] body; spawn_loc_phr] in (o, e, process_type) diff --git a/core/instantiate.ml b/core/instantiate.ml index 089c4897f..1fafe2283 100644 --- a/core/instantiate.ml +++ b/core/instantiate.ml @@ -50,7 +50,7 @@ let instantiate_datatype : instantiation_maps -> datatype -> datatype = else begin let var' = Types.fresh_raw_variable () in - let point' = Unionfind.fresh (`Var (var', (linAny, resAny), `Flexible)) in + let point' = Unionfind.fresh (`Var (var', (lin_any, res_any), `Flexible)) in let t' = inst (IntMap.add var point' rec_type_env, rec_row_env) t in let _ = Unionfind.change point' (`Recursive (var', t')) in `MetaTypeVar point' @@ -150,7 +150,7 @@ let instantiate_datatype : instantiation_maps -> datatype -> datatype = else begin let var' = Types.fresh_raw_variable () in - let point' = Unionfind.fresh (`Var (var', (linAny, resAny), `Flexible)) in + let point' = Unionfind.fresh (`Var (var', (lin_any, res_any), `Flexible)) in let rec_row' = inst_row (rec_type_env, IntMap.add var point' rec_row_env) rec_row in let _ = Unionfind.change point' (`Recursive (var', rec_row')) in (StringMap.empty, point', dual) @@ -422,8 +422,8 @@ let alias name tyargs env = then failwith (Printf.sprintf "Argument '%s' to type alias '%s' has the wrong kind ('%s' instead of '%s')" (Types.string_of_type_arg arg) name - (PrimaryKind.string_of (primary_kind_of_type_arg arg)) - (PrimaryKind.string_of (primary_kind_of_quantifier q))); + (PrimaryKind.to_string (primary_kind_of_type_arg arg)) + (PrimaryKind.to_string (primary_kind_of_quantifier q))); let x = var_of_quantifier q in match arg with | `Type t -> diff --git a/core/irCheck.ml b/core/irCheck.ml index b3d0336e5..33fb8c232 100644 --- a/core/irCheck.ml +++ b/core/irCheck.ml @@ -165,7 +165,7 @@ let eq_types occurrence : type_eq_context -> (Types.datatype * Types.datatype) - begin match t2 with `MetaTypeVar rpoint -> begin match lpoint_cont, Unionfind.find rpoint with - | `Var lv, `Var rv -> handle_variable pkType lv rv context + | `Var lv, `Var rv -> handle_variable pk_type lv rv context | `Body _, `Body _ -> failwith "Should have removed `Body by now" | _ -> (context, false) end @@ -282,7 +282,7 @@ let eq_types occurrence : type_eq_context -> (Types.datatype * Types.datatype) - | `Var lpoint, `Var rpoint -> begin match Unionfind.find lpoint, Unionfind.find rpoint with | `Body _, _ | _, `Body _ -> failwith "should have removed all `Body variants by now" - | `Var lv, `Var rv -> handle_variable pkPresence lv rv context + | `Var lv, `Var rv -> handle_variable pk_presence lv rv context end | _, _ -> (context, false) and eq_field_envs (context, lfield_env, rfield_env) = @@ -296,7 +296,7 @@ let eq_types occurrence : type_eq_context -> (Types.datatype * Types.datatype) - and eq_row_vars (context, lpoint, rpoint) = match Unionfind.find lpoint, Unionfind.find rpoint with | `Closed, `Closed -> (context, true) - | `Var lv, `Var rv -> handle_variable pkRow lv rv context + | `Var lv, `Var rv -> handle_variable pk_row lv rv context | `Recursive _, _ | _, `Recursive _ -> Debug.print "IR typechecker encountered recursive type"; (context, true) | _ -> (context, false) diff --git a/core/irtojs.ml b/core/irtojs.ml index 5594ebe6e..2c9d14363 100644 --- a/core/irtojs.ml +++ b/core/irtojs.ml @@ -691,7 +691,7 @@ end = functor (K : CONTINUATION) -> struct | _ -> if Lib.is_primitive f_name && not (List.mem f_name cps_prims) - && not (Location.isServer (Lib.primitive_location f_name)) + && not (Location.is_server (Lib.primitive_location f_name)) then Call (Var ("_" ^ f_name), List.map gv vs) else @@ -787,7 +787,7 @@ end = functor (K : CONTINUATION) -> struct (Env.Int.fold (fun var _v funcs -> let name = Lib.primitive_name var in - if Location.isServer (Lib.primitive_location name) then + if Location.is_server (Lib.primitive_location name) then (name, var)::funcs else funcs) @@ -812,7 +812,7 @@ end = functor (K : CONTINUATION) -> struct ((name, args @ [__kappa], body, - locServer), + loc_server), code)) prim_server_calls code @@ -844,7 +844,7 @@ end = functor (K : CONTINUATION) -> struct | _ -> if Lib.is_primitive f_name && not (List.mem f_name cps_prims) - && not (Location.isServer (Lib.primitive_location f_name)) + && not (Location.is_server (Lib.primitive_location f_name)) then let arg = Call (Var ("_" ^ f_name), List.map gv vs) in K.apply ~strategy:`Direct kappa arg diff --git a/core/lib.ml b/core/lib.ml index 110155857..9d79d3c9e 100644 --- a/core/lib.ml +++ b/core/lib.ml @@ -72,7 +72,7 @@ let conversion_op' ~unbox ~conv ~(box :'a->Value.t): Value.t list -> Value.t = f let conversion_op ~from ~unbox ~conv ~(box :'a->Value.t) ~into pure : located_primitive * Types.datatype * pure = ((`PFun (fun _ x -> conversion_op' ~unbox:unbox ~conv:conv ~box:box x) : located_primitive), - (let q, r = Types.fresh_row_quantifier (linAny, resAny) in + (let q, r = Types.fresh_row_quantifier (lin_any, res_any) in (`ForAll (Types.box_quantifiers [q], `Function (make_tuple_type [from], r, into)) : Types.datatype)), pure) diff --git a/core/parser.mly b/core/parser.mly index 511f4a614..4b98cacb0 100644 --- a/core/parser.mly +++ b/core/parser.mly @@ -74,24 +74,24 @@ let default_fixity = 9 let primary_kind_of_string p = function - | "Type" -> pkType - | "Row" -> pkRow - | "Presence" -> pkPresence + | "Type" -> pk_type + | "Row" -> pk_row + | "Presence" -> pk_presence | pk -> raise (ConcreteSyntaxError ("Invalid primary kind: " ^ pk, pos p)) let linearity_of_string p = function - | "Any" -> linAny - | "Unl" -> linUnl + | "Any" -> lin_any + | "Unl" -> lin_unl | lin -> raise (ConcreteSyntaxError ("Invalid kind linearity: " ^ lin, pos p)) let restriction_of_string p = function - | "Any" -> resAny - | "Base" -> resBase - | "Session" -> resSession + | "Any" -> res_any + | "Base" -> res_base + | "Session" -> res_session | rest -> raise (ConcreteSyntaxError ("Invalid kind restriction: " ^ rest, pos p)) @@ -118,23 +118,23 @@ perhaps. *) let kind_of p = function (* primary kind abbreviation *) - | "Type" -> (pkType, None) - | "Row" -> (pkRow, None) - | "Presence" -> (pkPresence, None) + | "Type" -> (pk_type, None) + | "Row" -> (pk_row, None) + | "Presence" -> (pk_presence, None) (* subkind of type abbreviations *) - | "Any" -> (pkType, Some (linAny, resAny)) - | "Base" -> (pkType, Some (linUnl, resBase)) - | "Session" -> (pkType, Some (linAny, resSession)) - | "Eff" -> (pkRow , Some (linUnl, resEffect)) + | "Any" -> (pk_type, Some (lin_any, res_any)) + | "Base" -> (pk_type, Some (lin_unl, res_base)) + | "Session" -> (pk_type, Some (lin_any, res_session)) + | "Eff" -> (pk_row , Some (lin_unl, res_effect)) | k -> raise (ConcreteSyntaxError ("Invalid kind: " ^ k, pos p)) let subkind_of p = function (* subkind abbreviations *) - | "Any" -> Some (linAny, resAny) - | "Base" -> Some (linUnl, resBase) - | "Session" -> Some (linAny, resSession) - | "Eff" -> Some (linUnl, resEffect) + | "Any" -> Some (lin_any, res_any) + | "Base" -> Some (lin_unl, res_base) + | "Session" -> Some (lin_any, res_session) + | "Eff" -> Some (lin_unl, res_effect) | sk -> raise (ConcreteSyntaxError ("Invalid subkind: " ^ sk, pos p)) let attach_kind (t, k) = (t, k, `Rigid) @@ -349,14 +349,14 @@ perhaps_uinteger: | UINTEGER? { $1 } linearity: -| FUN { dlUnl } -| LINFUN { dlLin } +| FUN { dl_unl } +| LINFUN { dl_lin } tlfunbinding: | linearity VARIABLE arg_lists perhaps_location block { ($1, $2, $3, $4, $5) } -| OP pattern op pattern perhaps_location block { (dlUnl, $3.node, [[$2; $4]], $5, $6) } -| OP PREFIXOP pattern perhaps_location block { (dlUnl, $2, [[$3]], $4, $5) } -| OP pattern POSTFIXOP perhaps_location block { (dlUnl, $3, [[$2]], $4, $5) } +| OP pattern op pattern perhaps_location block { (dl_unl, $3.node, [[$2; $4]], $5, $6) } +| OP PREFIXOP pattern perhaps_location block { (dl_unl, $2, [[$3]], $4, $5) } +| OP pattern POSTFIXOP perhaps_location block { (dl_unl, $3, [[$2]], $4, $5) } tlvarbinding: | VAR VARIABLE perhaps_location EQ exp { (PatName $2, $5, $3) } @@ -396,10 +396,10 @@ fixity: | POSTFIX { (`Post , $1) } perhaps_location: -| SERVER { locServer } -| CLIENT { locClient } -| NATIVE { locNative } -| /* empty */ { locUnknown } +| SERVER { loc_server } +| CLIENT { loc_client } +| NATIVE { loc_native } +| /* empty */ { loc_unknown } constant: | UINTEGER { `Int $1 } @@ -845,8 +845,8 @@ links_open: binding: | VAR pattern EQ exp SEMICOLON { val_binding ~ppos:$loc $2 $4 } | exp SEMICOLON { with_pos $loc (Exp $1) } -| signature linearity VARIABLE arg_lists block { fun_binding ~ppos:$loc (Sig $1) ($2, $3, $4, locUnknown, $5) } -| linearity VARIABLE arg_lists block { fun_binding ~ppos:$loc NoSig ($1, $2, $3, locUnknown, $4) } +| signature linearity VARIABLE arg_lists block { fun_binding ~ppos:$loc (Sig $1) ($2, $3, $4, loc_unknown, $5) } +| linearity VARIABLE arg_lists block { fun_binding ~ppos:$loc NoSig ($1, $2, $3, loc_unknown, $4) } | typed_handler_binding { handler_binding ~ppos:$loc NoSig $1 } | typedecl SEMICOLON | links_module | alien_block | links_open { $1 } diff --git a/core/sugarConstructors.ml b/core/sugarConstructors.ml index 52c6739f3..53088e1bf 100644 --- a/core/sugarConstructors.ml +++ b/core/sugarConstructors.ml @@ -146,7 +146,7 @@ module SugarConstructors (Position : Pos) (** Various phrases *) (* Create a FunLit. *) - let fun_lit ?(ppos=dp) ?args ?(location=locUnknown) linearity pats blk = + let fun_lit ?(ppos=dp) ?args ?(location=loc_unknown) linearity pats blk = with_pos ppos (FunLit (args, linearity, (pats, blk), location)) (* Create an argument used by Handler and HandlerLit. *) @@ -178,8 +178,8 @@ module SugarConstructors (Position : Pos) with_pos ppos (Fun (binder bndr, linearity, ([], (args, blk)), location, datatype)) - let fun_binding' ?(ppos=dp) ?(linearity=dlUnl) ?(tyvars=[]) - ?(location=locUnknown) ?annotation bndr fnlit = + let fun_binding' ?(ppos=dp) ?(linearity=dl_unl) ?(tyvars=[]) + ?(location=loc_unknown) ?annotation bndr fnlit = with_pos ppos (Fun (bndr, linearity, (tyvars, fnlit), location, annotation)) @@ -204,7 +204,7 @@ module SugarConstructors (Position : Pos) (* A commonly used wrapper around val_binding *) let val_binding ?(ppos=dp) pat phrase = - val_binding' ~ppos NoSig (Pat pat, phrase, locUnknown) + val_binding' ~ppos NoSig (Pat pat, phrase, loc_unknown) (** Database queries *) diff --git a/core/sugartoir.ml b/core/sugartoir.ml index bc2a2a786..b24cb84c9 100644 --- a/core/sugartoir.ml +++ b/core/sugartoir.ml @@ -598,7 +598,7 @@ struct let f_info = (ft, "", `Local) in let rest f : tail_computation sem = lift (`Special (`CallCC (`Variable f)), body_type) in - M.bind (fun_binding (f_info, ([], [kb], body), locUnknown)) rest + M.bind (fun_binding (f_info, ([], [kb], body), loc_unknown)) rest let letfun env ((ft, _, _) as f_info, (tyvars, (ps, body)), location) rest = let xsb : binder list = @@ -870,7 +870,7 @@ struct I.do_operation (name, vs, t) | Handle { sh_expr; sh_effect_cases; sh_value_cases; sh_descr } -> let henv, params = - let empty_env = (NEnv.empty, TEnv.empty, Types.make_empty_open_row (linAny, resAny)) in + let empty_env = (NEnv.empty, TEnv.empty, Types.make_empty_open_row (lin_any, res_any)) in match (sh_descr.shd_params) with | None -> empty_env, [] | Some { shp_bindings = bindings; shp_types = types } -> diff --git a/core/sugartypes.ml b/core/sugartypes.ml index 9fef0e57a..78f034487 100644 --- a/core/sugartypes.ml +++ b/core/sugartypes.ml @@ -54,7 +54,7 @@ type tyarg = Types.type_arg type subkind = Linearity.t * Restriction.t [@@deriving eq,show] -let default_subkind : subkind = (linUnl, resAny) +let default_subkind : subkind = (lin_unl, res_any) type freedom = [`Flexible | `Rigid] [@@deriving show] diff --git a/core/transformSugar.ml b/core/transformSugar.ml index d344a202b..75704037b 100644 --- a/core/transformSugar.ml +++ b/core/transformSugar.ml @@ -10,9 +10,9 @@ let type_section env = | Minus -> TyEnv.lookup env "-" | FloatMinus -> TyEnv.lookup env "-." | Project label -> - let ab, a = Types.fresh_type_quantifier (linAny, resAny) in - let rhob, (fields, rho, _) = Types.fresh_row_quantifier (linAny, resAny) in - let eb, e = Types.fresh_row_quantifier (linAny, resAny) in + let ab, a = Types.fresh_type_quantifier (lin_any, res_any) in + let rhob, (fields, rho, _) = Types.fresh_row_quantifier (lin_any, res_any) in + let eb, e = Types.fresh_row_quantifier (lin_any, res_any) in let r = `Record (StringMap.add label (`Present a) fields, rho, false) in `ForAll (Types.box_quantifiers [ab; rhob; eb], @@ -50,8 +50,8 @@ let type_binary_op env tycon_env = | Name "<" | Name "<=" | Name "<>" -> - let ab, a = Types.fresh_type_quantifier (linAny, resAny) in - let eb, e = Types.fresh_row_quantifier (linAny, resAny) in + let ab, a = Types.fresh_type_quantifier (lin_any, res_any) in + let eb, e = Types.fresh_row_quantifier (lin_any, res_any) in `ForAll (Types.box_quantifiers [ab; eb], `Function (Types.make_tuple_type [a; a], e, `Primitive `Bool)) | Name "!" -> TyEnv.lookup env "Send" diff --git a/core/typeSugar.ml b/core/typeSugar.ml index c34f08718..5cd03382f 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -970,8 +970,8 @@ end let iteration_table_pattern ~pos ~t1:l ~t2:(rexpr,rt) ~error:_ = build_tyvar_names [snd l; rt]; let rt = Types.make_table_type - (rt, Types.fresh_type_variable (linAny, resAny) - , Types.fresh_type_variable (linAny, resAny)) in + (rt, Types.fresh_type_variable (lin_any, res_any) + , Types.fresh_type_variable (lin_any, res_any)) in with_but2things pos ("The binding must match the table in a table generator") ("pattern", l) ("expression", (rexpr, rt)) @@ -1387,9 +1387,9 @@ let type_section context = function | Minus -> Utils.instantiate env "-", StringMap.empty | FloatMinus -> Utils.instantiate env "-.", StringMap.empty | Project label -> - let a = Types.fresh_type_variable (linAny, resAny) in - let rho = Types.fresh_row_variable (linAny, resAny) in - let effects = Types.make_empty_open_row (linAny, resAny) in (* projection is pure! *) + let a = Types.fresh_type_variable (lin_any, res_any) in + let rho = Types.fresh_row_variable (lin_any, res_any) in + let effects = Types.make_empty_open_row (lin_any, res_any) in (* projection is pure! *) let r = `Record (StringMap.add label (`Present a) StringMap.empty, rho, false) in ([`Type a; `Row (StringMap.empty, rho, false); `Row effects], `Function (Types.make_tuple_type [r], effects, a)), StringMap.empty | Name var -> Utils.instantiate env var, StringMap.singleton var 1 @@ -1438,8 +1438,8 @@ let type_binary_op ctxt = | Name "<" | Name "<=" | Name "<>" -> - let a = Types.fresh_type_variable (linAny, resAny) in - let eff = (StringMap.empty, Types.fresh_row_variable (linAny, resAny), false) in + let a = Types.fresh_type_variable (lin_any, res_any) in + let eff = (StringMap.empty, Types.fresh_row_variable (lin_any, res_any), false) in ([`Type a; `Row eff], `Function (Types.make_tuple_type [a; a], eff, `Primitive `Bool), StringMap.empty) @@ -1763,7 +1763,7 @@ let type_pattern closed : Pattern.with_pos -> Pattern.with_pos * Types.environme let make_singleton_row = match closed with | `Closed -> Types.make_singleton_closed_row - | `Open -> (fun var -> Types.make_singleton_open_row var (linAny, resAny)) in + | `Open -> (fun var -> Types.make_singleton_open_row var (lin_any, res_any)) in (* type_pattern p types the pattern p returning a typed pattern, a type environment for the variables bound by the pattern and two @@ -1790,16 +1790,16 @@ let type_pattern closed : Pattern.with_pos -> Pattern.with_pos * Types.environme let open Pattern in match pattern with | Nil -> - let t = Types.make_list_type (Types.fresh_type_variable (linAny, resAny)) in + let t = Types.make_list_type (Types.fresh_type_variable (lin_any, res_any)) in Nil, Env.empty, (t, t) | Any -> - let t = Types.fresh_type_variable (linUnl, resAny) in + let t = Types.fresh_type_variable (lin_unl, res_any) in Any, Env.empty, (t, t) | Constant c as c' -> let t = Constant.constant_type c in c', Env.empty, (t, t) | Variable bndr -> - let xtype = Types.fresh_type_variable (linAny, resAny) in + let xtype = Types.fresh_type_variable (lin_any, res_any) in (Variable (set_binder_type bndr xtype), Env.bind Env.empty (name_of_binder bndr, xtype), (xtype, xtype)) @@ -1820,7 +1820,7 @@ let type_pattern closed : Pattern.with_pos -> Pattern.with_pos * Types.environme Types.make_list_type (typ p) in let ts = match ps' with - | [] -> let t = Types.fresh_type_variable (linAny, resAny) in t, t + | [] -> let t = Types.fresh_type_variable (lin_any, res_any) in t, t | p::ps -> list_type p ps ot, list_type p ps it in @@ -1836,9 +1836,9 @@ let type_pattern closed : Pattern.with_pos -> Pattern.with_pos * Types.environme (* Auxiliary machinery for typing effect patterns *) let rec type_resumption_pat (kpat : Pattern.with_pos) : Pattern.with_pos * Types.environment * (Types.datatype * Types.datatype) = let fresh_resumption_type () = - let domain = Types.fresh_type_variable (linUnl, resAny) in - let codomain = Types.fresh_type_variable (linUnl, resAny) in - let effrow = Types.make_empty_open_row (linUnl, resAny) in + let domain = Types.fresh_type_variable (lin_unl, res_any) in + let codomain = Types.fresh_type_variable (lin_unl, res_any) in + let effrow = Types.make_empty_open_row (lin_unl, res_any) in Types.make_function_type [domain] effrow codomain in let pos' = kpat.pos in @@ -1891,12 +1891,12 @@ let type_pattern closed : Pattern.with_pos -> Pattern.with_pos * Types.environme in Effect (name, List.map erase ps, erase k), env, (eff ot, eff it) | Negative names -> - let row_var = Types.fresh_row_variable (linAny, resAny) in + let row_var = Types.fresh_row_variable (lin_any, res_any) in let positive, negative = List.fold_right (fun name (positive, negative) -> - let a = Types.fresh_type_variable (linAny, resAny) in + let a = Types.fresh_type_variable (lin_any, res_any) in (StringMap.add name (`Present a) positive, StringMap.add name `Absent negative)) names (StringMap.empty, StringMap.empty) in @@ -1918,7 +1918,7 @@ let type_pattern closed : Pattern.with_pos -> Pattern.with_pos * Types.environme List.fold_right (fun (label, _) -> Types.row_with (label, `Absent)) - ps (Types.make_empty_open_row (linAny, resAny)) in + ps (Types.make_empty_open_row (lin_any, res_any)) in let () = unify ~handle:Gripers.record_pattern (("", `Record row), (pos r, typ r)) in @@ -2023,11 +2023,11 @@ let make_ft declared_linearity ps effects return_type = let pattern_typ (_, _, t) = t in let args = Types.make_tuple_type -<- List.map pattern_typ in - let ftcon = fun p -> if DeclaredLinearity.isLin declared_linearity then `Lolli p else `Function p in + let ftcon = fun p -> if DeclaredLinearity.is_linear declared_linearity then `Lolli p else `Function p in let rec ft = function | [p] -> ftcon (args p, effects, return_type) - | p::ps -> ftcon (args p, (StringMap.empty, Types.fresh_row_variable (linAny, resAny), false), ft ps) + | p::ps -> ftcon (args p, (StringMap.empty, Types.fresh_row_variable (lin_any, res_any), false), ft ps) | [] -> assert false in ft ps @@ -2036,13 +2036,13 @@ let make_ft_poly_curry declared_linearity ps effects return_type = let pattern_typ (_, _, t) = t in let args = Types.make_tuple_type -<- List.map pattern_typ in - let ftcon = fun p -> if DeclaredLinearity.isLin declared_linearity then `Lolli p else `Function p in + let ftcon = fun p -> if DeclaredLinearity.is_linear declared_linearity then `Lolli p else `Function p in let rec ft = function | [p] -> [], ftcon (args p, effects, return_type) | p::ps -> let qs, t = ft ps in - let q, eff = Types.fresh_row_quantifier (linAny, resAny) in + let q, eff = Types.fresh_row_quantifier (lin_any, res_any) in q::qs, ftcon (args p, eff, t) | [] -> assert false in @@ -2124,8 +2124,8 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let (_,_,e) = SourceCode.resolve_pos p.pos in e and erase_cases = List.map (fun ((p, _, _t), (e, _, _)) -> p, e) in let type_cases binders = - let pt = Types.fresh_type_variable (linAny, resAny) in - let bt = Types.fresh_type_variable (linAny, resAny) in + let pt = Types.fresh_type_variable (lin_any, res_any) in + let bt = Types.fresh_type_variable (lin_any, res_any) in let binders, pats = List.fold_right (fun (pat, body) (binders, pats) -> @@ -2229,7 +2229,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (* make sure rtype is a record type that doesn't match any of the existing fields *) let () = unify ~handle:Gripers.extend_record - (pos_and_typ r, no_pos (`Record (absent_field_env, Types.fresh_row_variable (linAny, resAny), false))) in + (pos_and_typ r, no_pos (`Record (absent_field_env, Types.fresh_row_variable (lin_any, res_any), false))) in let (rfield_env, rrow_var, lr), _ = Types.unwrap_row (TypeUtils.extract_row rtype) in assert (lr = false); @@ -2260,7 +2260,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = | ListLit (es, _) -> begin match List.map tc es with | [] -> - let t = Types.fresh_type_variable (linAny, resAny) in + let t = Types.fresh_type_variable (lin_any, res_any) in ListLit ([], Some t), `Application (Types.list, [`Type t]), StringMap.empty | e :: es -> List.iter (fun e' -> unify ~handle:Gripers.list_lit (pos_and_typ e, pos_and_typ e')) es; @@ -2274,7 +2274,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let env' = Env.extend context.var_env pat_env in (* type of the effects in the body of the lambda *) - let effects = (StringMap.empty, Types.fresh_row_variable (linAny, resAny), false) in + let effects = (StringMap.empty, Types.fresh_row_variable (lin_any, res_any), false) in let body = type_check ({context with var_env = env'; effect_row = effects}) body in @@ -2290,7 +2290,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = pat_env in let () = - if DeclaredLinearity.isUnl lin then + if DeclaredLinearity.is_nonlinear lin then StringMap.iter (fun v _ -> if not (List.mem v vs) then let t = Env.lookup env' v in @@ -2338,14 +2338,14 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = | ConstructorLit (c, None, _) -> let type' = `Variant (Types.make_singleton_open_row (c, `Present Types.unit_type) - (linAny, resAny)) in + (lin_any, res_any)) in ConstructorLit (c, None, Some type'), type', StringMap.empty | ConstructorLit (c, Some v, _) -> let v = tc v in let type' = `Variant (Types.make_singleton_open_row (c, `Present (typ v)) - (linAny, resAny)) in + (lin_any, res_any)) in ConstructorLit (c, Some (erase v), Some type'), type', usages v (* database *) @@ -2429,9 +2429,9 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = | DBDelete (pat, from, where) -> let pat = tpc pat in let from = tc from in - let read = `Record (Types.make_empty_open_row (linAny, resBase)) in - let write = `Record (Types.make_empty_open_row (linAny, resBase)) in - let needed = `Record (Types.make_empty_open_row (linAny, resBase)) in + let read = `Record (Types.make_empty_open_row (lin_any, res_base)) in + let write = `Record (Types.make_empty_open_row (lin_any, res_base)) in + let needed = `Record (Types.make_empty_open_row (lin_any, res_base)) in let () = unify ~handle:Gripers.delete_table (pos_and_typ from, no_pos (`Table (read, write, needed))) in let () = unify ~handle:Gripers.delete_pattern (ppos_and_typ pat, no_pos read) in @@ -2451,7 +2451,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (* delete is wild *) let () = let outer_effects = - Types.make_singleton_open_row ("wild", `Present Types.unit_type) (linAny, resAny) + Types.make_singleton_open_row ("wild", `Present Types.unit_type) (lin_any, res_any) in unify ~handle:Gripers.delete_outer (no_pos (`Record context.effect_row), no_pos (`Record outer_effects)) @@ -2462,9 +2462,9 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let into = tc into in let values = tc values in let id = opt_map tc id in - let read = `Record (Types.make_empty_open_row (linAny, resBase)) in - let write = `Record (Types.make_empty_open_row (linAny, resBase)) in - let needed = `Record (Types.make_empty_open_row (linAny, resBase)) in + let read = `Record (Types.make_empty_open_row (lin_any, res_base)) in + let write = `Record (Types.make_empty_open_row (lin_any, res_base)) in + let needed = `Record (Types.make_empty_open_row (lin_any, res_base)) in let () = unify ~handle:Gripers.insert_table (pos_and_typ into, no_pos (`Table (read, write, needed))) in @@ -2474,7 +2474,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = if StringMap.mem name field_env then Gripers.die pos "Duplicate labels in insert expression." else - StringMap.add name (`Present (Types.fresh_type_variable (linAny, resBase))) field_env) + StringMap.add name (`Present (Types.fresh_type_variable (lin_any, res_base))) field_env) labels StringMap.empty in (* check that the fields in the type of values match the declared labels *) @@ -2485,16 +2485,16 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let needed_env = StringMap.map - (fun _f -> Types.fresh_presence_variable (linAny, resBase)) + (fun _f -> Types.fresh_presence_variable (lin_any, res_base)) field_env in (* all fields being inserted must be present in the read row *) let () = unify ~handle:Gripers.insert_read - (no_pos read, no_pos (`Record (field_env, Types.fresh_row_variable (linAny, resBase), false))) in + (no_pos read, no_pos (`Record (field_env, Types.fresh_row_variable (lin_any, res_base), false))) in (* all fields being inserted must be present in the write row *) let () = unify ~handle:Gripers.insert_write - (no_pos write, no_pos (`Record (field_env, Types.fresh_row_variable (linAny, resBase), false))) in + (no_pos write, no_pos (`Record (field_env, Types.fresh_row_variable (lin_any, res_base), false))) in (* all fields being inserted must be consistent with the needed row *) let () = unify ~handle:Gripers.insert_needed @@ -2516,7 +2516,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = unify ~handle:Gripers.insert_id (no_pos read, - no_pos (`Record (StringMap.singleton id (`Present Types.int_type), Types.fresh_row_variable (linAny, resBase), false))); + no_pos (`Record (StringMap.singleton id (`Present Types.int_type), Types.fresh_row_variable (lin_any, res_base), false))); Types.int_type | _ -> assert false end in @@ -2524,7 +2524,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (* insert is wild *) let () = let outer_effects = - Types.make_singleton_open_row ("wild", `Present Types.unit_type) (linAny, resAny) + Types.make_singleton_open_row ("wild", `Present Types.unit_type) (lin_any, res_any) in unify ~handle:Gripers.insert_outer (no_pos (`Record context.effect_row), no_pos (`Record outer_effects)) @@ -2534,9 +2534,9 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = | DBUpdate (pat, from, where, set) -> let pat = tpc pat in let from = tc from in - let read = `Record (Types.make_empty_open_row (linAny, resBase)) in - let write = `Record (Types.make_empty_open_row (linAny, resBase)) in - let needed = `Record (Types.make_empty_open_row (linAny, resBase)) in + let read = `Record (Types.make_empty_open_row (lin_any, res_base)) in + let write = `Record (Types.make_empty_open_row (lin_any, res_base)) in + let needed = `Record (Types.make_empty_open_row (lin_any, res_base)) in let () = unify ~handle:Gripers.update_table (pos_and_typ from, no_pos (`Table (read, write, needed))) in @@ -2569,25 +2569,25 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let needed_env = StringMap.map - (fun _f -> Types.fresh_presence_variable (linAny, resBase)) + (fun _f -> Types.fresh_presence_variable (lin_any, res_base)) field_env in (* all fields being updated must be present in the read row *) let () = unify ~handle:Gripers.update_read - (no_pos read, no_pos (`Record (field_env, Types.fresh_row_variable (linAny, resBase), false))) in + (no_pos read, no_pos (`Record (field_env, Types.fresh_row_variable (lin_any, res_base), false))) in (* all fields being updated must be present in the write row *) let () = unify ~handle:Gripers.update_write - (no_pos write, no_pos (`Record (field_env, Types.fresh_row_variable (linAny, resBase), false))) in + (no_pos write, no_pos (`Record (field_env, Types.fresh_row_variable (lin_any, res_base), false))) in (* all fields being updated must be consistent with the needed row *) let () = unify ~handle:Gripers.update_needed - (no_pos needed, no_pos (`Record (needed_env, Types.fresh_row_variable (linAny, resBase), false))) in + (no_pos needed, no_pos (`Record (needed_env, Types.fresh_row_variable (lin_any, res_base), false))) in (* update is wild *) let () = let outer_effects = - Types.make_singleton_open_row ("wild", `Present Types.unit_type) (linAny, resAny) + Types.make_singleton_open_row ("wild", `Present Types.unit_type) (lin_any, res_any) in unify ~handle:Gripers.update_outer (no_pos (`Record context.effect_row), no_pos (`Record outer_effects)) @@ -2598,14 +2598,14 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = | Query (range, p, _) -> let range, outer_effects, range_usages = match range with - | None -> None, Types.make_empty_open_row (linAny, resAny), StringMap.empty + | None -> None, Types.make_empty_open_row (lin_any, res_any), StringMap.empty | Some (limit, offset) -> let limit = tc limit in let () = unify ~handle:Gripers.range_bound (pos_and_typ limit, no_pos Types.int_type) in let offset = tc offset in let () = unify ~handle:Gripers.range_bound (pos_and_typ offset, no_pos Types.int_type) in let outer_effects = - Types.make_singleton_open_row ("wild", `Present Types.unit_type) (linAny, resAny) + Types.make_singleton_open_row ("wild", `Present Types.unit_type) (lin_any, res_any) in Some (erase limit, erase offset), outer_effects, merge_usages [usages limit; usages offset] in let inner_effects = Types.make_empty_closed_row () in @@ -2613,19 +2613,19 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (no_pos (`Record context.effect_row), no_pos (`Record outer_effects)) in let p = type_check (bind_effects context inner_effects) p in let () = if Settings.get_value Basicsettings.Shredding.relax_query_type_constraint then () - else let shape = Types.make_list_type (`Record (StringMap.empty, Types.fresh_row_variable (linAny, resBase), false)) in + else let shape = Types.make_list_type (`Record (StringMap.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 Query (range, erase p, Some (typ p)), typ p, merge_usages [range_usages; usages p] (* mailbox-based concurrency *) | Spawn (Wait, l, p, _) -> assert (l = NoSpawnLocation); (* (() -{b}-> d) -> d *) - let inner_effects = Types.make_empty_open_row (linAny, resAny) in + let inner_effects = Types.make_empty_open_row (lin_any, res_any) in (* TODO: check if pid_type is actually needed somewhere *) (* let pid_type = `Application (Types.process, [`Row inner_effects]) in *) let () = let outer_effects = - Types.make_singleton_open_row ("wild", `Present Types.unit_type) (linAny, resAny) + Types.make_singleton_open_row ("wild", `Present Types.unit_type) (lin_any, res_any) in unify ~handle:Gripers.spawn_wait_outer (no_pos (`Record context.effect_row), no_pos (`Record outer_effects)) in @@ -2642,11 +2642,11 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = | _ -> ()); (* (() -e-> _) -> Process (e) *) - let inner_effects = Types.make_empty_open_row (linAny, resAny) in + let inner_effects = Types.make_empty_open_row (lin_any, res_any) in let pid_type = `Application (Types.process, [`Row inner_effects]) in let () = let outer_effects = - Types.make_singleton_open_row ("wild", `Present Types.unit_type) (linAny, resAny) + Types.make_singleton_open_row ("wild", `Present Types.unit_type) (lin_any, res_any) in unify ~handle:Gripers.spawn_outer (no_pos (`Record context.effect_row), no_pos (`Record outer_effects)) in @@ -2655,10 +2655,10 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = Gripers.die pos ("Spawned processes cannot produce values of linear type (here " ^ Types.string_of_datatype (typ p) ^ ")"); Spawn (k, given_loc, erase p, Some inner_effects), pid_type, usages p | Receive (binders, _) -> - let mb_type = Types.fresh_type_variable (linAny, resAny) in + let mb_type = Types.fresh_type_variable (lin_any, res_any) in let effects = Types.row_with ("wild", `Present Types.unit_type) - (Types.make_singleton_open_row ("hear", `Present mb_type) (linAny, resAny)) in + (Types.make_singleton_open_row ("hear", `Present mb_type) (lin_any, res_any)) in let () = unify ~handle:Gripers.receive_mailbox (no_pos (`Record context.effect_row), no_pos (`Record effects)) in @@ -2672,16 +2672,16 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (* session-based concurrency *) | Select (l, e) -> let e = tc e in - let selected_session = Types.fresh_type_variable (linAny, resSession) in + let selected_session = Types.fresh_type_variable (lin_any, res_session) in unify ~handle:Gripers.selection (pos_and_typ e, no_pos (`Select (Types.make_singleton_open_row (l, `Present selected_session) - (linAny, resSession)))); + (lin_any, res_session)))); Select (l, erase e), selected_session, usages e | Offer (e, branches, _) -> let e = tc e in let branches, pattern_type, body_type = type_cases branches in - let r = Types.make_empty_open_row (linAny, resSession) in + let r = Types.make_empty_open_row (lin_any, res_session) in unify ~handle:Gripers.offer_variant (no_pos pattern_type, no_pos (`Variant r)); unify ~handle:Gripers.offer_patterns (pos_and_typ e, no_pos (`Choice r)); Offer (erase e, erase_cases branches, Some body_type), body_type, merge_usages [usages e; usages_cases branches] @@ -2695,7 +2695,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = | UnaryAppl ((_, op), p) -> let tyargs, opt, op_usage = type_unary_op context op and p = tc p - and rettyp = Types.fresh_type_variable (linAny, resAny) in + and rettyp = Types.fresh_type_variable (lin_any, res_any) in unify ~handle:Gripers.unary_apply ((string_of_unary_op op, opt), no_pos (`Function (Types.make_tuple_type [typ p], context.effect_row, rettyp))); @@ -2704,7 +2704,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let tyargs, opt, op_usages = type_binary_op context op in let l = tc l and r = tc r - and rettyp = Types.fresh_type_variable (linAny, resAny) in + and rettyp = Types.fresh_type_variable (lin_any, res_any) in unify ~handle:Gripers.infix_apply ((string_of_binop op, opt), no_pos (`Function (Types.make_tuple_type [typ l; typ r], @@ -2816,7 +2816,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = end | ft -> - let rettyp = Types.fresh_type_variable (linAny, resAny) in + let rettyp = Types.fresh_type_variable (lin_any, res_any) in begin unify_or ~handle:Gripers.fun_apply ~pos ((exp_pos f, ft), no_pos (`Function (Types.make_tuple_type (List.map typ ps), @@ -2876,7 +2876,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = 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 | FormletPlacement (f, h, attributes) -> - let t = Types.fresh_type_variable (linAny, resAny) in + let t = Types.fresh_type_variable (lin_any, res_any) in let f = tc f and h = tc h @@ -2898,7 +2898,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = | FormBinding (e, pattern) -> let e = tc e and pattern = tpc pattern in - let a = Types.fresh_type_variable (linAny, resAny) in + let a = Types.fresh_type_variable (lin_any, res_any) in let ft = Instantiate.alias "Formlet" [`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)); @@ -2920,7 +2920,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (fun (generators, generator_usages, environments) -> function | List (pattern, e) -> - let a = Types.fresh_type_variable (linAny, resAny) in + let a = Types.fresh_type_variable (lin_any, res_any) in let lt = Types.make_list_type a in let pattern = tpc pattern in let e = tc e in @@ -2931,8 +2931,8 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = usages e :: generator_usages, pattern_env pattern :: environments) | Table (pattern, e) -> - let a = Types.fresh_type_variable (linAny, resAny) in - let tt = Types.make_table_type (a, Types.fresh_type_variable (linAny, resAny), Types.fresh_type_variable (linAny, resAny)) in + let a = Types.fresh_type_variable (lin_any, res_any) in + let tt = Types.make_table_type (a, Types.fresh_type_variable (lin_any, res_any), Types.fresh_type_variable (lin_any, res_any)) in let pattern = tpc pattern in let e = tc e in let () = unify ~handle:Gripers.iteration_table_body (pos_and_typ e, no_pos tt) in @@ -2949,7 +2949,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let orderby = opt_map tc orderby in let () = unify ~handle:Gripers.iteration_body - (pos_and_typ body, no_pos (Types.make_list_type (Types.fresh_type_variable (linAny, resAny)))) in + (pos_and_typ body, no_pos (Types.make_list_type (Types.fresh_type_variable (lin_any, res_any)))) in let () = opt_iter (fun where -> unify ~handle:Gripers.iteration_where (pos_and_typ where, no_pos Types.bool_type)) where in @@ -2958,11 +2958,11 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = opt_iter (fun order -> unify ~handle:Gripers.iteration_base_order - (pos_and_typ order, no_pos (`Record (Types.make_empty_open_row (linAny, resBase))))) orderby in + (pos_and_typ order, no_pos (`Record (Types.make_empty_open_row (lin_any, res_base))))) orderby in let () = if is_query && not (Settings.get_value Basicsettings.Shredding.relax_query_type_constraint) then unify ~handle:Gripers.iteration_base_body - (pos_and_typ body, no_pos (Types.make_list_type (`Record (Types.make_empty_open_row (linAny, resBase))))) in + (pos_and_typ body, no_pos (Types.make_list_type (`Record (Types.make_empty_open_row (lin_any, res_base))))) in let e = Iteration (generators, erase body, opt_map erase where, opt_map erase orderby) in let vs = List.fold_left StringSet.union StringSet.empty (List.map Env.domain environments) in let us = merge_usages (List.append generator_usages @@ -2996,10 +2996,10 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (Also, should the mailbox type be generalised?) *) let name = name_of_binder bndr in - let f = Types.fresh_type_variable (linAny, resAny) in - let t = Types.fresh_type_variable (linAny, resAny) in + let f = Types.fresh_type_variable (lin_any, res_any) in + let t = Types.fresh_type_variable (lin_any, res_any) in - let eff = Types.make_singleton_open_row ("wild", `Present Types.unit_type) (linAny, resAny) in + let eff = Types.make_singleton_open_row ("wild", `Present Types.unit_type) (lin_any, res_any) in let cont_type = `Function (Types.make_tuple_type [f], eff, t) in let context' = {context @@ -3008,7 +3008,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let () = let outer_effects = - Types.make_singleton_open_row ("wild", `Present Types.unit_type) (linAny, resAny) + Types.make_singleton_open_row ("wild", `Present Types.unit_type) (lin_any, res_any) in unify ~handle:Gripers.escape_outer (no_pos (`Record context.effect_row), no_pos (`Record outer_effects)) in @@ -3096,30 +3096,30 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = unify ~handle:Gripers.projection ((exp_pos r, rt), no_pos (`Record (Types.make_singleton_closed_row - (l, `Present (Types.fresh_type_variable (linAny, resAny)))))); + (l, `Present (Types.fresh_type_variable (lin_any, res_any)))))); let r' = erase r in let rn, rpos = r'.node, r'.pos in let e = tabstr (pqs, Projection (with_pos rpos (tappl (rn, tyargs)), l)) in e, fieldtype, usages r | Some (`Absent | `Var _) | None -> - let fieldtype = Types.fresh_type_variable (linAny, resAny) in + let fieldtype = Types.fresh_type_variable (lin_any, res_any) in unify ~handle:Gripers.projection ((exp_pos r, rt), no_pos (`Record (Types.make_singleton_open_row (l, `Present fieldtype) - (linUnl, resAny)))); + (lin_unl, res_any)))); let r' = erase r in let rn, rpos = r'.node, r'.pos in let e = Projection (with_pos rpos (tappl (rn, tyargs)), l) in e, fieldtype, usages r end | _ -> - let fieldtype = Types.fresh_type_variable (linAny, resAny) in + let fieldtype = Types.fresh_type_variable (lin_any, res_any) in unify ~handle:Gripers.projection (pos_and_typ r, no_pos (`Record (Types.make_singleton_open_row (l, `Present fieldtype) - (linUnl, resAny)))); + (lin_unl, res_any)))); Projection (erase r, l), fieldtype, usages r end | With (r, fields) -> @@ -3130,8 +3130,8 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let fields_type = `Record (List.fold_right (fun (lab, _) row -> - Types.row_with (lab, `Present (Types.fresh_type_variable (linUnl, resAny))) row) - fields (Types.make_empty_open_row (linAny, resAny))) in + Types.row_with (lab, `Present (Types.fresh_type_variable (lin_unl, res_any))) row) + fields (Types.make_empty_open_row (lin_any, res_any))) in unify ~handle:Gripers.record_with (pos_and_typ r, no_pos fields_type) in let (rfields, row_var, lr), _ = Types.unwrap_row (TypeUtils.extract_row (typ r)) in assert (not lr); @@ -3221,11 +3221,11 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = in let type_cases val_cases eff_cases = let wild_row () = - let fresh_row = Types.make_empty_open_row (linUnl, resAny) in + let fresh_row = Types.make_empty_open_row (lin_unl, res_any) in allow_wild fresh_row in - let rt = Types.fresh_type_variable (linUnl, resAny) in - let bt = Types.fresh_type_variable (linUnl, resAny) in + let rt = Types.fresh_type_variable (lin_unl, res_any) in + let bt = Types.fresh_type_variable (lin_unl, res_any) in let inner_eff = wild_row () in let outer_eff = wild_row () in (* Type value patterns *) @@ -3295,10 +3295,10 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = | Any -> let kt = let domain = - (Types.fresh_type_variable (linUnl, resAny)) :: handler_params + (Types.fresh_type_variable (lin_unl, res_any)) :: handler_params in - let effects = Types.make_empty_open_row (linUnl, resAny) in - let codomain = Types.fresh_type_variable (linUnl, resAny) in + let effects = Types.make_empty_open_row (lin_unl, res_any) in + let codomain = Types.fresh_type_variable (lin_unl, res_any) in Types.make_function_type domain effects codomain in (pat, env, effrow), (kpat, Env.empty, kt) @@ -3339,9 +3339,9 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = | Any -> let kt = Types.make_function_type - [Types.fresh_type_variable (linUnl, resAny)] - (Types.make_empty_open_row (linUnl, resAny)) - (Types.fresh_type_variable (linUnl, resAny)) + [Types.fresh_type_variable (lin_unl, res_any)] + (Types.make_empty_open_row (lin_unl, res_any)) + (Types.fresh_type_variable (lin_unl, res_any)) in (pat, env, effrow), (kpat, Env.empty, kt) | _ -> assert false @@ -3406,13 +3406,13 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (fun name p -> if TypeUtils.is_builtin_effect name then p - else Types.fresh_presence_variable (linUnl, resAny)) (* It is questionable whether it is ever correct to + else Types.fresh_presence_variable (lin_unl, res_any)) (* It is questionable whether it is ever correct to make absent operations polymorphic in their presence. *) operations in (operations', rho, dual) in - let m_context = { context with effect_row = Types.make_empty_open_row (linUnl, resAny) } in + let m_context = { context with effect_row = Types.make_empty_open_row (lin_unl, res_any) } in let m = type_check m_context m in (* Type-check the input computation m under current context *) let m_effects = `Effect m_context.effect_row in (** Most of the work is done by `type_cases'. *) @@ -3466,9 +3466,9 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = let (row, return_type, args) = let ps = List.map tc args in let inp_t = List.map typ ps in - let out_t = Types.fresh_type_variable (linUnl, resAny) in + let out_t = Types.fresh_type_variable (lin_unl, res_any) in let optype = Types.make_pure_function_type inp_t out_t in - let effrow = Types.make_singleton_open_row (opname, `Present optype) (linUnl, resEffect) in + let effrow = Types.make_singleton_open_row (opname, `Present optype) (lin_unl, res_effect) in (effrow, out_t, ps) in let (_,_,p) = SourceCode.resolve_pos pos in @@ -3551,7 +3551,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = (erase try_phrase, erase_pat pat, erase in_phrase, erase unless_phrase, Some return_type), return_type, usages_res | QualifiedVar _ -> assert false - | Raise -> (Raise, Types.fresh_type_variable (linAny, resAny), StringMap.empty) + | Raise -> (Raise, Types.fresh_type_variable (lin_any, res_any), StringMap.empty) in with_pos pos e, t, usages (** [type_binding] takes XXX YYY (FIXME) @@ -3625,8 +3625,8 @@ and type_binding : context -> binding -> binding * context * usagemap = let vs = name :: check_for_duplicate_names pos (List.flatten pats) in let pats = List.map (List.map tpc) pats in - let effects = Types.make_empty_open_row (linAny, resAny) in - let return_type = Types.fresh_type_variable (linAny, resAny) in + let effects = Types.make_empty_open_row (lin_any, res_any) in + let return_type = Types.fresh_type_variable (lin_any, res_any) in (** Check that any annotation matches the shape of the function *) let context', ft = @@ -3674,7 +3674,7 @@ and type_binding : context -> binding -> binding * context * usagemap = (List.flatten pats) in let () = - if DeclaredLinearity.isUnl lin then + if DeclaredLinearity.is_nonlinear lin then StringMap.iter (fun v _ -> if not (List.mem v vs) then let t = Env.lookup context'.var_env v in @@ -3710,7 +3710,7 @@ and type_binding : context -> binding -> binding * context * usagemap = As well as the function types, the typed patterns are also returned here as a simple optimisation. *) - let fresh_wild () = Types.make_singleton_open_row ("wild", (`Present Types.unit_type)) (linAny, resAny) in + let fresh_wild () = Types.make_singleton_open_row ("wild", (`Present Types.unit_type)) (lin_any, res_any) in let inner_env, patss = List.fold_left @@ -3732,10 +3732,10 @@ and type_binding : context -> binding -> binding * context * usagemap = f(x1)...(xk) } *) - make_ft_poly_curry lin pats (fresh_wild ()) (Types.fresh_type_variable (linAny, resAny)) + make_ft_poly_curry lin pats (fresh_wild ()) (Types.fresh_type_variable (lin_any, res_any)) | Some (_, Some t) -> (* Debug.print ("t: " ^ Types.string_of_datatype t); *) - let shape = make_ft lin pats (fresh_wild ()) (Types.fresh_type_variable (linAny, resAny)) in + let shape = make_ft lin pats (fresh_wild ()) (Types.fresh_type_variable (lin_any, res_any)) in let (_, ft) = Generalise.generalise_rigid context.var_env t in (* Debug.print ("ft: " ^ Types.string_of_datatype ft); *) (* make sure the annotation has the right shape *) @@ -3779,7 +3779,7 @@ and type_binding : context -> binding -> binding * context * usagemap = pat_env in let used = let vs = StringSet.add name (Env.domain pat_env) in - if DeclaredLinearity.isUnl lin then + if DeclaredLinearity.is_nonlinear lin then StringMap.iter (fun v _ -> if not (StringSet.mem v vs) then let t = Env.lookup context'.var_env v in @@ -3945,8 +3945,8 @@ and type_cp (context : context) = fun {node = p; pos} -> | CPGrab ((c, _), Some bndr, p) -> let x = name_of_binder bndr in let (_, t, _) = type_check context (with_pos pos (Sugartypes.Var c)) in - let a = Types.fresh_type_variable (linAny, resAny) in - let s = Types.fresh_session_variable linAny in + let a = Types.fresh_type_variable (lin_any, res_any) in + let s = Types.fresh_session_variable lin_any in let ctype = `Input (a, s) in unify ~pos:pos ~handle:(Gripers.cp_grab c) (t, ctype); @@ -3981,7 +3981,7 @@ and type_cp (context : context) = fun {node = p; pos} -> | CPGive ((c, _), Some e, p) -> let (_, t, _) = type_check context (with_pos pos (Sugartypes.Var c)) in let (e, t', u) = type_check context e in - let s = Types.fresh_session_variable linAny in + let s = Types.fresh_session_variable lin_any in let ctype = `Output (t', s) in unify ~pos:pos ~handle:(Gripers.cp_give c) (t, ctype); @@ -4011,8 +4011,8 @@ and type_cp (context : context) = fun {node = p; pos} -> | CPSelect (bndr, label, p) -> let c = name_of_binder bndr in let (_, t, _) = type_check context (with_pos pos (Sugartypes.Var c)) in - let s = Types.fresh_session_variable linAny in - let r = Types.make_singleton_open_row (label, `Present s) (linAny, resSession) in + let s = Types.fresh_session_variable lin_any in + let r = Types.make_singleton_open_row (label, `Present s) (lin_any, res_session) in let ctype = `Select r in unify ~pos:pos ~handle:(Gripers.cp_select c) (t, ctype); @@ -4022,19 +4022,19 @@ and type_cp (context : context) = fun {node = p; pos} -> let c = name_of_binder bndr in let (_, t, _) = type_check context (with_pos pos (Sugartypes.Var c)) in (* - let crow = Types.make_empty_open_row (linAny, resSession) in + let crow = Types.make_empty_open_row (lin_any, res_session) in let ctype = `Choice crow in unify ~pos:pos ~handle:(Gripers.cp_offer_choice c) (t, ctype); *) let check_branch (label, body) = - let s = Types.fresh_type_variable (linAny, resSession) in - let r = Types.make_singleton_open_row (label, `Present s) (linAny, resSession) in + let s = Types.fresh_type_variable (lin_any, res_session) in + let r = Types.make_singleton_open_row (label, `Present s) (lin_any, res_session) in unify ~pos:pos ~handle:(Gripers.cp_offer_choice c) (t, `Choice r); let (p, t, u) = with_channel c s (type_cp (bind_var context (c, s)) body) in (label, p), t, u in let branches = List.map check_branch branches in - let t' = Types.fresh_type_variable (linAny, resAny) in + let t' = Types.fresh_type_variable (lin_any, res_any) in List.iter (fun (_, t, _) -> unify ~pos:pos ~handle:Gripers.cp_offer_branches (t, t')) branches; let u = usage_compat (List.map (fun (_, _, u) -> u) branches) in CPOffer (set_binder_type bndr t, List.map (fun (x, _, _) -> x) branches), t', use c u @@ -4044,14 +4044,14 @@ and type_cp (context : context) = fun {node = p; pos} -> let (_, tc, uc) = type_check context (with_pos pos (Sugartypes.Var c)) in let (_, td, ud) = type_check context (with_pos pos (Sugartypes.Var d)) in unify ~pos:pos ~handle:Gripers.cp_link_session - (tc, Types.fresh_type_variable (linAny, resSession)); + (tc, Types.fresh_type_variable (lin_any, res_session)); unify ~pos:pos ~handle:Gripers.cp_link_session - (td, Types.fresh_type_variable (linAny, resSession)); + (td, Types.fresh_type_variable (lin_any, res_session)); unify ~pos:pos ~handle:Gripers.cp_link_dual (Types.dual_type tc, td); CPLink (set_binder_type bndr1 tc, set_binder_type bndr1 td), Types.make_endbang_type, merge_usages [uc; ud] | CPComp (bndr, left, right) -> let c = name_of_binder bndr in - let s = Types.fresh_session_variable linAny in + let s = Types.fresh_session_variable lin_any in let left, t, u = with_channel c s (type_cp (bind_var context (c, s)) left) in let right, t', u' = with_channel c (`Dual s) (type_cp (bind_var context (c, `Dual s)) right) in unify ~pos:pos ~handle:Gripers.cp_comp_left (Types.make_endbang_type, t); diff --git a/core/typeUtils.ml b/core/typeUtils.ml index 26a37dbe6..fa6e44b19 100644 --- a/core/typeUtils.ml +++ b/core/typeUtils.ml @@ -215,7 +215,7 @@ let rec table_needed_type t = match concrete_type t with error ("Attempt to take needed type of non-table: " ^ string_of_datatype t) let inject_type name t = - `Variant (make_singleton_open_row (name, `Present t) (linAny, resAny)) + `Variant (make_singleton_open_row (name, `Present t) (lin_any, res_any)) let abs_type _ = assert false let app_type _ _ = assert false diff --git a/core/types.ml b/core/types.ml index 8baa9aa12..ec9646d92 100644 --- a/core/types.ml +++ b/core/types.ml @@ -67,7 +67,7 @@ end let process = { Abstype.id = "Process" ; name = "Process" ; - arity = [pkRow, (linAny, resAny)] ; + arity = [pk_row, (lin_any, res_any)] ; } (* Lists are currently unlimited because the only deconstructors are @@ -76,7 +76,7 @@ let process = { let list = { Abstype.id = "List" ; name = "List" ; - arity = [pkType, (linUnl, resAny)] ; + arity = [pk_type, (lin_unl, res_any)] ; } let event = { @@ -93,7 +93,7 @@ let dom_node = { let access_point = { Abstype.id = "AP" ; name = "AP" ; - arity = [pkType, (linAny, resSession)] ; + arity = [pk_type, (lin_any, res_session)] ; } let socket = { @@ -259,7 +259,7 @@ struct (IntMap.find var rec_types), o else let var' = fresh_raw_variable () in - let point' : meta_type_var = Unionfind.fresh (`Var (var', (linAny, resAny), `Flexible)) in + let point' : meta_type_var = Unionfind.fresh (`Var (var', (lin_any, res_any), `Flexible)) in let rec_types' : (meta_type_var) IntMap.t = IntMap.add var point' rec_types in let o_extended_rec_env = {< rec_vars = (rec_types', rec_rows) >} in let (t', o') = o_extended_rec_env#typ t in @@ -279,7 +279,7 @@ struct (IntMap.find var rec_rows), o else let var' = fresh_raw_variable () in - let point' = Unionfind.fresh (`Var (var', (linAny, resAny), `Flexible)) in + let point' = Unionfind.fresh (`Var (var', (lin_any, res_any), `Flexible)) in let rec_rows' = IntMap.add var point' rec_rows in let o_extended_rec_env = {< rec_vars = (rec_types, rec_rows') >} in let (r', o') = o_extended_rec_env#row r in @@ -432,7 +432,7 @@ struct method! meta_type_var point = match Unionfind.find point with | `Recursive (id, t) -> if Utility.IntSet.mem id mu_vars then - let newvar = `Var (id, (linAny, resAny), `Rigid) in + let newvar = `Var (id, (lin_any, res_any), `Rigid) in (* Debug.print (Printf.sprintf "Saw rec var %d" id); *) (Unionfind.fresh newvar, o) else @@ -445,7 +445,7 @@ struct method! meta_row_var point = match Unionfind.find point with | `Recursive (id, t) -> if Utility.IntSet.mem id mu_vars then - let newvar = `Var (id, (linAny, resAny), `Rigid) in + let newvar = `Var (id, (lin_any, res_any), `Rigid) in (* Debug.print (Printf.sprintf "Saw rec var %d" id); *) (Unionfind.fresh newvar, o) else @@ -557,7 +557,7 @@ let rec basify_type : typ -> unit = match Unionfind.find point with | `Var (_, (_, Restriction.Base), _) -> () | `Var (_, _, `Rigid) -> assert false - | `Var (var, (lin, Restriction.Any), `Flexible) -> Unionfind.change point (`Var (var, (lin, resBase), `Flexible)) + | `Var (var, (lin, Restriction.Any), `Flexible) -> Unionfind.change point (`Var (var, (lin, res_base), `Flexible)) | `Var (_, _, `Flexible) -> assert false | `Body t -> basify_type t | `Recursive _ -> assert false @@ -569,7 +569,7 @@ let rec basify_row (fields, row_var, _) = match Unionfind.find row_var with | `Closed | `Var (_, (_, Restriction.Base), _) -> () - | `Var (var, (lin, Restriction.Any), `Flexible) -> Unionfind.change row_var (`Var (var, (lin, resBase), `Flexible)) + | `Var (var, (lin, Restriction.Any), `Flexible) -> Unionfind.change row_var (`Var (var, (lin, res_base), `Flexible)) | `Var _ -> assert false | `Body row -> basify_row row | `Recursive _ -> assert false @@ -602,9 +602,9 @@ let var_of_quantifier : quantifier -> int = let kind_of_quantifier : quantifier -> kind = function - | _, sk, `Type _ -> pkType, sk - | _, sk, `Row _ -> pkRow, sk - | _, sk, `Presence _ -> pkPresence, sk + | _, sk, `Type _ -> pk_type, sk + | _, sk, `Row _ -> pk_row, sk + | _, sk, `Presence _ -> pk_presence, sk let type_arg_of_quantifier : quantifier -> type_arg = function @@ -614,9 +614,9 @@ let type_arg_of_quantifier : quantifier -> type_arg = let primary_kind_of_quantifier : quantifier -> PrimaryKind.t = function - | _, _, `Type _ -> pkType - | _, _, `Row _ -> pkRow - | _, _, `Presence _ -> pkPresence + | _, _, `Type _ -> pk_type + | _, _, `Row _ -> pk_row + | _, _, `Presence _ -> pk_presence let subkind_of_quantifier : quantifier -> subkind = fun q -> @@ -624,9 +624,9 @@ let subkind_of_quantifier : quantifier -> subkind let primary_kind_of_type_arg : type_arg -> PrimaryKind.t = function - | `Type _ -> pkType - | `Row _ -> pkRow - | `Presence _ -> pkPresence + | `Type _ -> pk_type + | `Row _ -> pk_row + | `Presence _ -> pk_presence let add_quantified_vars qs vars = List.fold_right IntSet.add (List.map var_of_quantifier qs) vars @@ -638,7 +638,7 @@ let is_unl_point = begin match Unionfind.find point with | `Closed -> true - | `Var (var, (lin, _), _) -> IntSet.mem var quant_vars || Linearity.isUnl lin + | `Var (var, (lin, _), _) -> IntSet.mem var quant_vars || Linearity.is_nonlinear lin | `Body t -> f (rec_vars, quant_vars) t | `Recursive (var, t) -> check_rec var rec_vars true (fun rec_vars' -> f (rec_vars', quant_vars) t) @@ -687,7 +687,7 @@ let point_can_be_unl = begin match Unionfind.find point with | `Closed -> true - | `Var (v, (lin, _), `Rigid) -> IntSet.mem v quant_vars || Linearity.isUnl lin + | `Var (v, (lin, _), `Rigid) -> IntSet.mem v quant_vars || Linearity.is_nonlinear lin | `Var (_, _, `Flexible) -> true | `Body t -> f vars t | `Recursive (var, t) -> @@ -741,8 +741,8 @@ let make_point_unl : ((var_set * var_set) -> 'a -> unit) -> (var_set * var_set) fun f ((rec_vars, quant_vars) as vars) point -> match Unionfind.find point with | `Closed -> () - | `Var (v, (lin, _), `Rigid) -> if IntSet.mem v quant_vars || Linearity.isUnl lin then () else assert false - | `Var (var, (_, rest), `Flexible) -> Unionfind.change point (`Var (var, (linUnl, rest), `Flexible)) + | `Var (v, (lin, _), `Rigid) -> if IntSet.mem v quant_vars || Linearity.is_nonlinear lin then () else assert false + | `Var (var, (_, rest), `Flexible) -> Unionfind.change point (`Var (var, (lin_unl, rest), `Flexible)) | `Body t -> f vars t | `Recursive (var, t) -> check_rec var rec_vars () (fun rec_vars' -> f (rec_vars', quant_vars) t) @@ -952,7 +952,7 @@ module Env = Env.String let fresh_rigid_type_variable subkind = make_rigid_type_variable (fresh_raw_variable ()) subkind let fresh_row_variable subkind = make_row_variable (fresh_raw_variable ()) subkind let fresh_rigid_row_variable subkind = make_rigid_row_variable (fresh_raw_variable ()) subkind - let fresh_session_variable linearity = make_type_variable (fresh_raw_variable ()) (linearity, resSession) + let fresh_session_variable linearity = make_type_variable (fresh_raw_variable ()) (linearity, res_session) let fresh_presence_variable subkind = make_presence_variable (fresh_raw_variable ()) subkind let fresh_rigid_presence_variable subkind = make_rigid_presence_variable (fresh_raw_variable ()) subkind @@ -1397,7 +1397,7 @@ and flatten_row : row -> row = fun (field_env, row_var, dual) -> else (let row_var' = Unionfind.fresh (`Recursive (var, (FieldEnv.empty, - Unionfind.fresh (`Var (var, (linAny, resAny), `Flexible)), + Unionfind.fresh (`Var (var, (lin_any, res_any), `Flexible)), false))) in let rec_row' = flatten_row' (IntMap.add var row_var' rec_env) rec_row in Unionfind.change row_var' (`Recursive (var, rec_row')); @@ -1700,12 +1700,12 @@ struct begin match Unionfind.find point with | `Var (var, _, freedom) -> - [var, ((freedom :> flavour), pkType, `Free)] + [var, ((freedom :> flavour), pk_type, `Free)] | `Recursive (var, body) -> if TypeVarSet.mem var bound_vars then - [var, (`Recursive, pkType, `Bound)] + [var, (`Recursive, pk_type, `Bound)] else - (var, (`Recursive, pkType, `Bound))::(free_bound_type_vars ~include_aliases (TypeVarSet.add var bound_vars) body) + (var, (`Recursive, pk_type, `Bound))::(free_bound_type_vars ~include_aliases (TypeVarSet.add var bound_vars) body) | `Body t -> fbtv t end | `Function (f, m, t) -> @@ -1747,7 +1747,7 @@ struct begin match Unionfind.find point with | `Var (var, _, freedom) -> - [var, ((freedom :> flavour), pkPresence, `Free)] + [var, ((freedom :> flavour), pk_presence, `Free)] | `Body f -> free_bound_field_spec_type_vars ~include_aliases bound_vars f end and free_bound_row_type_vars ~include_aliases bound_vars (field_env, row_var, _) = @@ -1762,12 +1762,12 @@ struct match Unionfind.find row_var with | `Closed -> [] | `Var (var, _, freedom) -> - [var, ((freedom :> flavour), pkRow, `Free)] + [var, ((freedom :> flavour), pk_row, `Free)] | `Recursive (var, row) -> if TypeVarSet.mem var bound_vars then - [var, (`Recursive, pkRow, `Bound)] + [var, (`Recursive, pk_row, `Bound)] else - (var, (`Recursive, pkRow, `Bound))::(free_bound_row_type_vars ~include_aliases (TypeVarSet.add var bound_vars) row) + (var, (`Recursive, pk_row, `Bound))::(free_bound_row_type_vars ~include_aliases (TypeVarSet.add var bound_vars) row) | `Body row -> free_bound_row_type_vars ~include_aliases bound_vars row and free_bound_tyarg_vars ~include_aliases bound_vars = function @@ -1884,8 +1884,8 @@ struct | s -> "::" ^ s let subkind : (policy * names) -> subkind -> string = - let full (l, r) = "(" ^ Linearity.string_of l ^ "," ^ - Restriction.string_of r ^ ")" in + let full (l, r) = "(" ^ Linearity.to_string l ^ "," ^ + Restriction.to_string r ^ ")" in fun (policy, _vars) -> if policy.kinds = "full" then @@ -1896,34 +1896,34 @@ struct function | (Linearity.Unl, Restriction.Any) -> "" | (Linearity.Any, Restriction.Any) -> "Any" - | (Linearity.Unl, Restriction.Base) -> Restriction.string_of resBase - | (Linearity.Any, Restriction.Session) -> Restriction.string_of resSession - | (Linearity.Unl, Restriction.Effect) -> Restriction.string_of resEffect + | (Linearity.Unl, Restriction.Base) -> Restriction.to_string res_base + | (Linearity.Any, Restriction.Session) -> Restriction.to_string res_session + | (Linearity.Unl, Restriction.Effect) -> Restriction.to_string res_effect | (l, r) -> full (l, r) let kind : (policy * names) -> kind -> string = let full (policy, _vars) (k, sk) = - PrimaryKind.string_of k ^ subkind (policy, _vars) sk in + PrimaryKind.to_string k ^ subkind (policy, _vars) sk in fun (policy, _vars) (k, sk) -> if policy.kinds = "full" then full (policy, _vars) (k, sk) else if policy.kinds = "hide" then - PrimaryKind.string_of k + PrimaryKind.to_string k else match (k, sk) with | PrimaryKind.Type, (Linearity.Unl, Restriction.Any) -> "" | PrimaryKind.Type, (Linearity.Unl, Restriction.Base) -> - Restriction.string_of resBase + Restriction.to_string res_base | PrimaryKind.Type, (Linearity.Any, Restriction.Session) -> - Restriction.string_of resSession + Restriction.to_string res_session | PrimaryKind.Type, sk -> subkind ({policy with kinds="full"}, _vars) sk | PrimaryKind.Row, (Linearity.Unl, Restriction.Any) -> - PrimaryKind.string_of pkRow + PrimaryKind.to_string pk_row | PrimaryKind.Row, (Linearity.Unl, Restriction.Effect) -> - PrimaryKind.string_of pkRow + PrimaryKind.to_string pk_row | PrimaryKind.Presence, (Linearity.Unl, Restriction.Any) -> - PrimaryKind.string_of pkPresence + PrimaryKind.to_string pk_presence | PrimaryKind.Row, _ | PrimaryKind.Presence, _ -> full ({policy with kinds="full"}, _vars) (k, sk) @@ -2502,15 +2502,15 @@ 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 (linAny, resAny)) tenv, - IntMap.map (fun _ -> (StringMap.empty, fresh_rigid_row_variable (linAny, resAny), false)) renv, - IntMap.map (fun _ -> fresh_rigid_presence_variable (linAny, resAny)) penv) + (IntMap.map (fun _ -> fresh_rigid_type_variable (lin_any, res_any)) tenv, + IntMap.map (fun _ -> (StringMap.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 (linAny, resAny)) tenv, - IntMap.map (fun _ -> (StringMap.empty, fresh_row_variable (linAny, resAny), false)) renv, - IntMap.map (fun _ -> fresh_presence_variable (linAny, resAny)) penv) + (IntMap.map (fun _ -> fresh_type_variable (lin_any, res_any)) tenv, + IntMap.map (fun _ -> (StringMap.empty, fresh_row_variable (lin_any, res_any), false)) renv, + IntMap.map (fun _ -> fresh_presence_variable (lin_any, res_any)) penv) (* subtyping *) diff --git a/core/unify.ml b/core/unify.ml index d1630b568..2e0aa65f3 100644 --- a/core/unify.ml +++ b/core/unify.ml @@ -362,7 +362,7 @@ let rec unify' : unify_env -> (datatype * datatype) -> unit = | Some t2 -> unify' rec_env (t1, t2); false | None -> Debug.if_set (show_recursion) (fun () -> "rec intro1 (" ^ (string_of_int var) ^ ")"); - if Restriction.isBase rest then + if Restriction.is_base rest then raise (Failure (`Msg ("Cannot infer a recursive type for the base type variable "^ string_of_int var ^ " with the body "^ string_of_datatype t2))); rec_intro rpoint (var, Types.concrete_type t2); @@ -373,19 +373,19 @@ let rec unify' : unify_env -> (datatype * datatype) -> unit = (* FIXME: does this really still need to happen if we've just introduced a recursive type? *) if tidy then begin - if Restriction.isBase rest then + if Restriction.is_base rest then if Types.is_baseable_type t2 then Types.basify_type t2 else raise (Failure (`Msg ("Cannot unify the base type variable "^ string_of_int var ^ " with the non-base type "^ string_of_datatype t2))); - if Linearity.isUnl lin then + if Linearity.is_nonlinear lin then if Types.type_can_be_unl t2 then Types.make_type_unl t2 else raise (Failure (`Msg ("Cannot unify the unlimited type variable " ^ string_of_int var ^ " with the linear type " ^ string_of_datatype t2))); - if Restriction.isSession rest then + if Restriction.is_session rest then if Types.is_sessionable_type t2 then Types.sessionify_type t2 else @@ -402,7 +402,7 @@ let rec unify' : unify_env -> (datatype * datatype) -> unit = | Some t1 -> unify' rec_env (t1, t2); false | None -> Debug.if_set (show_recursion) (fun () -> "rec intro2 (" ^ (string_of_int var) ^ ")"); - if Restriction.isBase rest then + if Restriction.is_base rest then raise (Failure (`Msg ("Cannot infer a recursive type for the base type variable "^ string_of_int var ^ " with the body "^ string_of_datatype t1))); rec_intro lpoint (var, Types.concrete_type t1); @@ -413,19 +413,19 @@ let rec unify' : unify_env -> (datatype * datatype) -> unit = (* FIXME: does this really still need to happen if we've just introduced a recursive type? *) if tidy then begin - if Restriction.isBase rest then + if Restriction.is_base rest then if Types.is_baseable_type t1 then Types.basify_type t1 else raise (Failure (`Msg ("Cannot unify the base type variable "^ string_of_int var ^ " with the non-base type "^ string_of_datatype t1))); - if Linearity.isUnl lin then + if Linearity.is_nonlinear lin then if Types.type_can_be_unl t1 then Types.make_type_unl t1 else raise (Failure (`Msg ("Cannot unify the unlimited type variable " ^ string_of_int var ^ " with the linear type " ^ string_of_datatype t1))); - if Restriction.isSession rest then + if Restriction.is_session rest then if Types.is_sessionable_type t1 then Types.sessionify_type t1 else @@ -518,7 +518,7 @@ let rec unify' : unify_env -> (datatype * datatype) -> unit = Debug.if_set (show_recursion) (fun () -> "rec intro3 ("^string_of_int var^","^string_of_datatype t^")"); - if Restriction.isBase rest then + if Restriction.is_base rest then raise (Failure (`Msg ("Cannot infer a recursive type for the type variable "^ string_of_int var ^ " with the body "^ string_of_datatype t))); let point' = Unionfind.fresh (`Body t) in @@ -527,19 +527,19 @@ let rec unify' : unify_env -> (datatype * datatype) -> unit = end else (Debug.if_set (show_recursion) (fun () -> "non-rec intro (" ^ string_of_int var ^ ")"); - if Restriction.isBase rest then + if Restriction.is_base rest then if Types.is_baseable_type t then Types.basify_type t else raise (Failure (`Msg ("Cannot unify the base type variable "^ string_of_int var ^ " with the non-base type "^ string_of_datatype t))); - if Linearity.isUnl lin then + if Linearity.is_nonlinear lin then if Types.type_can_be_unl t then Types.make_type_unl t else raise (Failure (`Msg ("Cannot unify the unlimited type variable " ^ string_of_int var ^ " with the linear type "^ string_of_datatype t))); - if Restriction.isSession rest then + if Restriction.is_session rest then if Types.is_sessionable_type t then Types.sessionify_type t else @@ -979,7 +979,7 @@ and unify_rows' : unify_env -> ((row * row) -> unit) = | `Closed -> raise (Failure (`Msg ("Rigid row var cannot be unified with empty closed row\n"))) | `Var (_, (_, rest'), `Flexible) -> - if Restriction.isAny rest && Restriction.isBase rest' then + if Restriction.is_any rest && Restriction.is_base rest' then raise (Failure (`Msg ("Rigid non-base row var cannot be unified with empty base row\n"))); Unionfind.change point' (`Var (var, (lin, rest), `Rigid)) | `Var (var', _, `Rigid) when var=var' -> () @@ -1008,27 +1008,27 @@ and unify_rows' : unify_env -> ((row * row) -> unit) = if not (StringMap.is_empty extension_field_env) && TypeVarSet.mem var (free_row_type_vars extension_row) then begin - if Restriction.isBase rest then + if Restriction.is_base rest then raise (Failure (`Msg ("Cannot infer a recursive type for the base row variable "^ string_of_int var ^ " with the body "^ string_of_row extension_row))); rec_row_intro point (var, extension_row) end else begin - if Restriction.isBase rest then + if Restriction.is_base rest then if Types.is_baseable_row extension_row then Types.basify_row extension_row else raise (Failure (`Msg ("Cannot unify the base row variable "^ string_of_int var ^ " with the non-base row "^ string_of_row extension_row))); - if Restriction.isSession rest then + if Restriction.is_session rest then if Types.is_sessionable_row extension_row then Types.sessionify_row extension_row else raise (Failure (`Msg ("Cannot unify the session row variable "^ string_of_int var ^ " with the non-session row "^ string_of_row extension_row))); - if Linearity.isUnl lin then + if Linearity.is_nonlinear lin then if Types.row_can_be_unl extension_row then Types.make_row_unl extension_row else @@ -1209,7 +1209,7 @@ and unify_rows' : unify_env -> ((row * row) -> unit) = unify_field_envs ~closed:false ~rigid:false rec_env (lfield_env', rfield_env'); (* a fresh row variable common to the left and the right *) - let fresh_row_var = fresh_row_variable (linAny, resAny) in + let fresh_row_var = fresh_row_variable (lin_any, res_any) 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