From 1964e58daa24d8966cfa052689eb0a4791d2b278 Mon Sep 17 00:00:00 2001 From: Jan Stolarek Date: Tue, 19 Feb 2019 10:24:20 +0000 Subject: [PATCH] Redefine Sugartypes as ordinary variants This patch changes AST definitions in Sugartypes from polymorphic variants to ordinary variants. Some constructors are renamed to avoid name clashes. Others are placed inside modules. Common datatypes used throughout the compiler are placed in a new CommonTypes module. Operators are placed in a separate module to avoid import cycles with lens code. Closes #487 --- bin/repl.ml | 7 +- core/chaser.ml | 9 +- core/checkXmlQuasiquotes.ml | 18 +- core/closures.ml | 7 +- core/commonTypes.ml | 125 +++ core/compilePatterns.ml | 64 +- core/desugarAlienBlocks.ml | 12 +- core/desugarCP.ml | 35 +- core/desugarDatatypes.ml | 231 +++--- core/desugarDbs.ml | 8 +- core/desugarFormlets.ml | 49 +- core/desugarFors.ml | 32 +- core/desugarFuns.ml | 33 +- core/desugarHandlers.ml | 145 ++-- core/desugarInners.ml | 25 +- core/desugarLAttributes.ml | 40 +- core/desugarModules.ml | 116 +-- core/desugarPages.ml | 35 +- core/desugarProcesses.ml | 21 +- core/desugarRegexes.ml | 11 +- core/desugarSessionExceptions.ml | 40 +- core/dumpTypes.ml | 2 +- core/evalir.ml | 7 +- core/experimentalExtensions.ml | 24 +- core/instantiate.ml | 10 +- core/ir.ml | 2 +- core/ir.mli | 2 +- core/irCheck.ml | 7 +- core/irtojs.ml | 19 +- core/json.ml | 9 +- core/lens/lensTypes.ml | 6 +- core/lens/lens_operators.ml | 25 +- core/lens/lens_phrase.ml | 19 +- core/lexer.mll | 13 +- core/lib.ml | 9 +- core/lib.mli | 2 +- core/moduleUtils.ml | 35 +- core/operators.ml | 67 ++ core/parse.ml | 2 +- core/parse.mli | 2 +- core/parser.mly | 461 ++++++----- core/query/query.ml | 9 +- core/refineBindings.ml | 121 +-- core/sugarConstructors.ml | 98 +-- core/sugarConstructorsIntf.ml | 60 +- core/sugarTraversals.ml | 1330 +++++++++++++++--------------- core/sugarTraversals.mli | 89 +- core/sugartoir.ml | 277 ++++--- core/sugartypes.ml | 740 ++++++++--------- core/transformSugar.ml | 440 +++++----- core/transformSugar.mli | 26 +- core/typeSugar.ml | 1167 +++++++++++++------------- core/typeUtils.ml | 3 +- core/types.ml | 190 ++--- core/types.mli | 22 +- core/unify.ml | 51 +- 56 files changed, 3306 insertions(+), 3103 deletions(-) create mode 100644 core/commonTypes.ml create mode 100644 core/operators.ml 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/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/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/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 new file mode 100644 index 000000000..3e1d6ac30 --- /dev/null +++ b/core/commonTypes.ml @@ -0,0 +1,125 @@ +module Linearity = struct + type t = Any | Unl + [@@deriving eq,show] + + let is_any = function + | Any -> true + | _ -> false + + let is_nonlinear = function + | Unl -> true + | _ -> false + + let to_string = function + | Any -> "Any" + | Unl -> "Unl" +end + +(* Convenient aliases for constructing values *) +let lin_any = Linearity.Any +let lin_unl = Linearity.Unl + +module DeclaredLinearity = struct + type t = Lin | Unl + [@@deriving show] + + let is_linear = function + | Lin -> true + | _ -> false + + let is_nonlinear = function + | Unl -> true + | _ -> false +end + +(* Convenient aliases for constructing values *) +let dl_lin = DeclaredLinearity.Lin +let dl_unl = DeclaredLinearity.Unl + +module Restriction = struct + type t = + | Any + | Base + | Session + | Effect + [@@deriving eq,show] + + let is_any = function + | Any -> true + | _ -> false + + let is_base = function + | Base -> true + | _ -> false + + let is_session = function + | Session -> true + | _ -> false + + let is_effect = function + | Effect -> true + | _ -> false + + let to_string = function + | Any -> "Any" + | Base -> "Base" + | Session -> "Session" + | Effect -> "Eff" +end + +(* Convenient aliases for constructing values *) +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 = + | Type + | Row + | Presence + [@@deriving show,eq] + + let to_string = function + | Type -> "Type" + | Row -> "Row" + | Presence -> "Presence" +end + +(* Convenient aliases for constructing values *) +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 is_client = function + | Client -> true + | _ -> false + + let is_server = function + | Server -> true + | _ -> false + + let is_native = function + | Native -> true + | _ -> false + + let is_unknown = function + | Unknown -> true + | _ -> false + + let to_string = function + | Client -> "client" + | Server -> "server" + | Native -> "native" + | Unknown -> "unknown" +end + +(* Convenient aliases for constructing values *) +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 b152ad105..e891f9758 100644 --- a/core/compilePatterns.ml +++ b/core/compilePatterns.ml @@ -8,6 +8,7 @@ to adjust our intermediate language. *) +open CommonTypes open Utility open Ir @@ -74,10 +75,10 @@ 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.with_pos -> pattern * raw_env = fun scope {Sugartypes.node=p; Sugartypes.pos} -> - let pp = desugar_pattern scope in - let empty = (NEnv.empty, TEnv.empty, Types.make_empty_open_row (`Any, `Any)) in + let desugar_pat = desugar_pattern scope 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); @@ -86,38 +87,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 +127,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/desugarAlienBlocks.ml b/core/desugarAlienBlocks.ml index 5f67b87ff..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 () -> @@ -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/desugarCP.ml b/core/desugarCP.ml index 3d60b262b..cfc04b36b 100644 --- a/core/desugarCP.ml +++ b/core/desugarCP.ml @@ -19,21 +19,21 @@ 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 - | 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 @@ -41,16 +41,17 @@ 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) -> + | 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 @@ -60,35 +61,35 @@ 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; _}) -> - o, `Var c, t - | Select ({node=c, Some s; _}, label, p) -> + | CPGiveNothing ({node=c, Some 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 let (o, p, t) = desugar_cp o p in 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 - | 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 let (o, p, t) = desugar_cp o p in - let pat : pattern = with_dummy_pos (`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 (match List.split cases with | (_, []) -> 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 _; _}) -> + 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], 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/desugarDatatypes.ml b/core/desugarDatatypes.ml index f48405e33..5343b0c63 100644 --- a/core/desugarDatatypes.ml +++ b/core/desugarDatatypes.ml @@ -1,3 +1,4 @@ +open CommonTypes open Types open Sugartypes open Utility @@ -19,7 +20,7 @@ object (self) | _ -> self method! phrasenode = function - | `TableLit (_, (_, None), _, _, _) -> {< all_desugared = false >} + | TableLit (_, (_, None), _, _, _) -> {< all_desugared = false >} | p -> super#phrasenode p end @@ -73,32 +74,27 @@ object (self) method! bindingnode = function (* type declarations bind variables; exclude those from the analysis. *) - | `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! 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! fieldspec = function - | `Absent -> self - | `Present t -> self#datatype t - | `Var (x, k, freedom) -> self#add (x, (`Presence, k), freedom) + | Type _ -> self + | b -> super#bindingnode b + + method! datatypenode = let open Datatype in + function + | 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 + | dt -> super#datatypenode dt + + method! row_var = let open Datatype in function + | Closed -> self + | 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, (pk_presence, k), freedom) end type var_env = { tenv : Types.meta_type_var StringMap.t; @@ -117,44 +113,45 @@ 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 - | `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 @@ -167,35 +164,36 @@ 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 - | `Type _ -> `Type - | `Row _ -> `Row - | `Presence _ -> `Presence + let primary_kind_of_type_arg : Datatype.type_arg -> PrimaryKind.t = + function + | 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 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 @@ -204,7 +202,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 @@ -219,38 +217,27 @@ 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 - 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) @@ -258,14 +245,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 @@ -284,15 +272,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}) + | 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) @@ -311,26 +299,15 @@ 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 (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) = @@ -343,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), _ -> @@ -375,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, @@ -445,14 +422,14 @@ 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 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,25 +438,25 @@ 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 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 +466,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 +489,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/desugarDbs.ml b/core/desugarDbs.ml index f76f0ba88..9b1681355 100644 --- a/core/desugarDbs.ml +++ b/core/desugarDbs.ml @@ -1,3 +1,5 @@ +open CommonTypes +open Sugartypes open SugarConstructors.Make (* @@ -46,7 +48,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 @@ -62,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 (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 @@ -87,6 +89,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 c4da2d60c..d0ff83b75 100644 --- a/core/desugarFormlets.ml +++ b/core/desugarFormlets.ml @@ -1,16 +1,17 @@ +open CommonTypes open Utility open Sugartypes 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 @@ -33,23 +34,23 @@ 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.with_pos list * Sugartypes.phrase list * Types.datatype list) = fun ph -> 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 t = Types.fresh_type_variable (lin_any, res_any) in let () = Unify.datatypes (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] - | `Xml (_, _, _, [node]) -> + [with_dummy_pos (Pattern.As (xb, p))], [x], [t] + | Xml (_, _, _, [node]) -> o#formlet_patterns node - | `Xml (_, _, _, contents) -> + | Xml (_, _, _, contents) -> let ps, vs, ts = List.fold_left (fun (ps, vs, ts) e -> @@ -67,22 +68,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 +111,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) @@ -119,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) dl_unl (List.rev pss) (tuple vs)] in let p, et = List.fold_right @@ -134,14 +135,14 @@ 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 let context : phrase = let name = Utility.gensym ~prefix:"_formlet_" () in fun_lit ~args:[Types.make_tuple_type [Types.xml_type], eff] - `Unl + 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 @@ -154,7 +155,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 @@ -176,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] dl_unl pss yields]] in (o, e, Instantiate.alias "Formlet" [`Type yields_type] tycon_env) | e -> super#phrasenode e @@ -192,6 +193,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 0d016a7e3..957fa9e85 100644 --- a/core/desugarFors.ml +++ b/core/desugarFors.ml @@ -1,4 +1,5 @@ open Utility +open CommonTypes open Sugartypes open SugarConstructors.Make @@ -61,7 +62,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.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 @@ -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] 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] `Unl [[qb]] - (fn_appl "map" [a; `Row eff; b] [inner; r]) in + fun_lit ~args:[Types.make_tuple_type [t], eff] + 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 fn_appl "concatMap" [a; `Row eff; b] [outer; e] @@ -100,14 +102,14 @@ 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.with_pos list * Sugartypes.name list * Types.datatype list) = fun qs -> let o, (es, ps, xs, ts) = 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 @@ -115,8 +117,9 @@ 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) - | `Table (p, e) -> + 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 +133,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 @@ -139,7 +143,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 @@ -151,7 +155,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 @@ -164,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 + dl_unl [arg] body in let results = results eff (es, xs, ts) in let results = @@ -176,7 +180,7 @@ object (o : 'self_type) let g : phrase = fun_lit ~args:[Types.make_tuple_type [arg_type], eff] - `Unl [arg] sort + dl_unl [arg] sort in fn_appl sort_by [`Type arg_type; `Row eff; sort_type_arg] [g; results] @@ -200,6 +204,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 7f2dd145f..75dc42e7a 100644 --- a/core/desugarFuns.ml +++ b/core/desugarFuns.ml @@ -1,3 +1,4 @@ +open CommonTypes open Utility open Sugartypes open SugarConstructors.Make @@ -65,7 +66,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 = @@ -77,15 +78,15 @@ 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) - | `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 + | Section (Section.Project name) -> + 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 @@ -95,7 +96,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)], @@ -104,18 +105,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 @@ -131,14 +132,14 @@ 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 - | `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 acadeb3c3..2937db9bd 100644 --- a/core/desugarHandlers.ml +++ b/core/desugarHandlers.ml @@ -1,4 +1,6 @@ open Utility +open CommonTypes +open Operators open Sugartypes open SugarConstructors.Make @@ -20,47 +22,49 @@ open SugarConstructors.Make (* Computes the set of names in a given pattern *) -let rec names : pattern -> string list +let rec names : Pattern.with_pos -> 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.with_pos -> stringset -> Pattern.with_pos = fun pat conflicts -> - let rec hide_names : pattern -> pattern + let rec hide_names : Pattern.with_pos -> Pattern.with_pos = 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 +86,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.with_pos * phrase) list -> Pattern.with_pos list list option -> (Pattern.with_pos * phrase) list = fun cases params -> match params with None @@ -95,65 +99,70 @@ let parameterize : (pattern * phrase) list -> pattern list list option -> (patte 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 dl_unl params body) ) cases (* This function assigns fresh names to `Any (_) *) -let rec deanonymize : pattern -> pattern +let rec deanonymize : Pattern.with_pos -> Pattern.with_pos = 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.with_pos -> 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) 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) + | 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. *) 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 * phrase) list -> (pattern * phrase) list * (pattern * 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 (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 @@ -167,10 +176,10 @@ let split_handler_cases : (pattern * phrase) list -> (pattern * phrase) list * ( 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 @@ -179,7 +188,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.with_pos list list = [[]] in let fnparams = match params with Some params -> params @ ([m] :: fnparams) @@ -191,22 +200,22 @@ 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 + let funlit : Sugartypes.phrasenode = (fun_lit dl_unl fnparams body).node in super#phrasenode funlit | e -> super#phrasenode e 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} 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..d28a55d9a 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 @@ -34,26 +35,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, 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)) - | `UnaryAppl ((tyargs, `Name name), e) when StringMap.mem name extra_env -> + 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 - 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 -> + | 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 @@ -65,7 +66,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 +110,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 +130,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/desugarLAttributes.ml b/core/desugarLAttributes.ml index 3e5f517bd..7e69eb398 100644 --- a/core/desugarLAttributes.ml +++ b/core/desugarLAttributes.ml @@ -1,4 +1,5 @@ open Utility +open CommonTypes open Sugartypes open List open SugarConstructors.Make @@ -11,7 +12,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,24 +29,23 @@ 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 | [_,[target]], rest -> ("href", [constant_str "?_k="; - apply "pickleCont" [fun_lit ~location:`Server `Unl [[]] 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 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 -> @@ -54,10 +54,10 @@ 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:loc_server dl_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. *) @@ -69,24 +69,24 @@ 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:loc_client dl_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,18 +94,18 @@ 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 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, loc_unknown)], body) let bind_lname_vars lnames = function | "l:action" as attr, es -> @@ -121,7 +121,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 +129,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 +146,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 +159,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 1b4ff2990..ec074072e 100644 --- a/core/desugarModules.ml +++ b/core/desugarModules.ml @@ -24,6 +24,7 @@ * *) open Utility +open Operators open Sugartypes open Printf open ModuleUtils @@ -38,13 +39,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 @@ -62,9 +63,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 +94,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 +133,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 +167,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 @@ -192,10 +193,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 @@ -208,40 +209,40 @@ 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 - | `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 - | `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 - | `Block (bs, phr) -> + | Block (bs, phr) -> (* Process bindings, then process the phrase using * updated shadow table. *) let (term_ht, type_ht, bs') = @@ -250,47 +251,48 @@ 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 - | `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 +301,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/desugarPages.ml b/core/desugarPages.ml index 1d6347fd4..316b5f1b8 100644 --- a/core/desugarPages.ml +++ b/core/desugarPages.ml @@ -1,16 +1,17 @@ +open CommonTypes open Sugartypes 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,22 +34,22 @@ 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 - let b = Types.fresh_type_variable (`Any, `Any) 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] - | `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] - `Unl [[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] | _ -> @@ -59,7 +60,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 +76,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..8ef4f3e07 100644 --- a/core/desugarProcesses.ml +++ b/core/desugarProcesses.ml @@ -1,4 +1,5 @@ open Utility +open CommonTypes open Sugartypes open SugarConstructors.Make @@ -18,7 +19,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 *) @@ -30,10 +31,10 @@ 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)] dl_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 @@ -62,20 +63,20 @@ 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)] dl_unl [[]] body; 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 +92,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..1d2dd1abc 100644 --- a/core/desugarRegexes.ml +++ b/core/desugarRegexes.ml @@ -1,3 +1,4 @@ +open Operators open Sugartypes open SugarConstructors.Make @@ -55,9 +56,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, @@ -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/desugarSessionExceptions.ml b/core/desugarSessionExceptions.ml index afae3ae83..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 @@ -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.with_pos = + with_dummy_pos (Pattern.Effect (failure_op_name, [], cont_pat)) in let otherwise_clause = (otherwise_pat, otherwise_phr) 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,20 +160,20 @@ 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", 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/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/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/experimentalExtensions.ml b/core/experimentalExtensions.ml index a69544ca4..928537739 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 @@ -17,22 +19,22 @@ 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 - | `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/instantiate.ml b/core/instantiate.ml index c3172b695..1fafe2283 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', (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' @@ -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', (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) @@ -419,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.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/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/irCheck.ml b/core/irCheck.ml index c401ecffd..33fb8c232 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 pk_type 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 pk_presence 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 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 d108d092d..2c9d14363 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.is_server (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.is_server (Lib.primitive_location name) then (name, var)::funcs else funcs) @@ -811,7 +812,7 @@ end = functor (K : CONTINUATION) -> struct ((name, args @ [__kappa], body, - `Server), + loc_server), 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.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 @@ -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/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_operators.ml b/core/lens/lens_operators.ml index 1cf7df17e..9cca86c4f 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 @@ -59,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/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/lexer.mll b/core/lexer.mll index 68fd28eb8..ab2deabf9 100644 --- a/core/lexer.mll +++ b/core/lexer.mll @@ -36,6 +36,7 @@ open Lexing open Utility open Parser +open Operators (* Constructors are not first class in OCaml *) let infix0 x = INFIX0 x @@ -131,13 +132,13 @@ object try List.assoc name optable name with NotFound _ -> default_precedence name - method setprec (assoc : [`None|`Left|`Right|`Pre|`Post]) level name = + method setprec (assoc : Associativity.t) level name = let value = match List.nth precs level, assoc with - | (a,_,_), `None -> a - | (_,a,_), `Left -> a - | (_,_,a), `Right -> a - | _, `Pre -> prefix - | _, `Post -> postfix + | (a,_,_), Associativity.None -> a + | (_,a,_), Associativity.Left -> a + | (_,_,a), Associativity.Right -> a + | _, Associativity.Pre -> prefix + | _, Associativity.Post -> postfix in optable <- (name, value) :: optable diff --git a/core/lib.ml b/core/lib.ml index c2431dd97..9d79d3c9e 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 (lin_any, res_any) in (`ForAll (Types.box_quantifiers [q], `Function (make_tuple_type [from], r, into)) : Types.datatype)), pure) @@ -1655,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/moduleUtils.ml b/core/moduleUtils.ml index 6388c2ecc..b338de80f 100644 --- a/core/moduleUtils.ml +++ b/core/moduleUtils.ml @@ -55,16 +55,16 @@ 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 - | `QualifiedTypeApplication _ -> {< has_no_modules = false >} + | Datatype.QualifiedTypeApplication _ -> {< has_no_modules = false >} | dt -> super#datatypenode dt method! phrasenode = function - | `QualifiedVar _ -> {< has_no_modules = false >} + | QualifiedVar _ -> {< has_no_modules = false >} | pn -> super#phrasenode pn end @@ -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 = { @@ -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 @@ -120,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 @@ -141,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 @@ -158,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; @@ -169,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/operators.ml b/core/operators.ml new file mode 100644 index 000000000..cf1ad9122 --- /dev/null +++ b/core/operators.ml @@ -0,0 +1,67 @@ +(* 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 + + Operators were extracted from Sugartypes to their own module to avoid import + cycle with lens code. If, at any point in the future, the import cycle no + longer exists this module can be merged back into Sugartypes. +*) + +type name = string [@@deriving show] + +type regexflag = RegexList | RegexNative | RegexGlobal | RegexReplace + [@@deriving show] + +module Associativity = struct + type t = Left | Right | None | Pre | Post + [@@deriving show] +end + +module UnaryOp = struct + type t = + | Minus + | FloatMinus + | 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/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 23bd8be1e..52f1d2aa2 100644 --- a/core/parser.mly +++ b/core/parser.mly @@ -37,15 +37,19 @@ or Menhir it is no longer necessary. %{ +open CommonTypes open Utility +open Operators open Sugartypes 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 *) @@ -70,24 +74,24 @@ let default_fixity = 9 let primary_kind_of_string p = function - | "Type" -> `Type - | "Row" -> `Row - | "Presence" -> `Presence + | "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" -> `Any - | "Unl" -> `Unl + | "Any" -> lin_any + | "Unl" -> lin_unl | lin -> raise (ConcreteSyntaxError ("Invalid kind linearity: " ^ lin, pos p)) let restriction_of_string p = function - | "Any" -> `Any - | "Base" -> `Base - | "Session" -> `Session + | "Any" -> res_any + | "Base" -> res_base + | "Session" -> res_session | rest -> raise (ConcreteSyntaxError ("Invalid kind restriction: " ^ rest, pos p)) @@ -104,33 +108,33 @@ 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. *) let kind_of p = function (* primary kind abbreviation *) - | "Type" -> (`Type, None) - | "Row" -> (`Row, None) - | "Presence" -> (`Presence, None) + | "Type" -> (pk_type, None) + | "Row" -> (pk_row, None) + | "Presence" -> (pk_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" -> (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 (`Any, `Any) - | "Base" -> Some (`Unl, `Base) - | "Session" -> Some (`Any, `Session) - | "Eff" -> Some (`Unl, `Effect) + | "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) @@ -140,14 +144,14 @@ 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 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 @@ -213,7 +217,7 @@ let parseRegexFlags f = %token QUOTEDMETA %token SLASHFLAGS %token UNDERSCORE AS -%token <[`Left|`Right|`None|`Pre|`Post] -> int -> string -> unit> INFIX INFIXL INFIXR PREFIX POSTFIX +%token int -> string -> unit> INFIX INFIXL INFIXR PREFIX POSTFIX %token TYPENAME %token TYPE ROW PRESENCE %token TRY OTHERWISE RAISE @@ -234,15 +238,15 @@ 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 %type regex_pattern_sequence -%type pattern -%type pattern +%type tlfunbinding %type postfix_expression %type primary_expression @@ -301,11 +305,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 +320,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 } @@ -338,31 +342,31 @@ 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: | UINTEGER? { $1 } linearity: -| FUN { `Unl } -| LINFUN { `Lin } +| 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 { (`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 { (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 { (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) } | 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 */ { [] } @@ -378,24 +382,24 @@ 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: | separated_nonempty_list(COMMA, typearg) { $1 } fixity: -| INFIX { (`None , $1) } -| INFIXL { (`Left , $1) } -| INFIXR { (`Right, $1) } -| PREFIX { (`Pre , $1) } -| POSTFIX { (`Post , $1) } +| INFIX { (Associativity.None , $1) } +| INFIXL { (Associativity.Left , $1) } +| INFIXR { (Associativity.Right, $1) } +| PREFIX { (Associativity.Pre , $1) } +| POSTFIX { (Associativity.Post , $1) } perhaps_location: -| SERVER { `Server } -| CLIENT { `Client } -| NATIVE { `Native } -| /* empty */ { `Unknown } +| SERVER { loc_server } +| CLIENT { loc_client } +| NATIVE { loc_native } +| /* empty */ { loc_unknown } constant: | UINTEGER { `Int $1 } @@ -416,13 +420,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 } @@ -443,25 +447,25 @@ 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 } | 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,17 +483,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 @@ -513,13 +517,13 @@ 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 } +| 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: @@ -532,11 +536,11 @@ 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)) } +| DOOP CONSTRUCTOR loption(arg_spec) { with_pos $loc (DoOperation ($2, $3, None)) } infixr_9: @@ -551,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 } @@ -574,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 } @@ -594,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 } @@ -638,19 +642,19 @@ 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 } -| 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 +682,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 +715,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,14 +733,14 @@ 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 } generator: -| list_generator { `List $1 } -| table_generator { `Table $1 } +| list_generator { List $1 } +| table_generator { Table $1 } list_generator: | pattern LARROW exp { ($1, $3) } @@ -753,18 +757,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 +810,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,31 +822,31 @@ 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: | 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) } -| 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) } +| exp SEMICOLON { with_pos $loc (Exp $1) } +| 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 } @@ -857,13 +861,13 @@ 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 [])) } +| SEMICOLON | /* empty */ { ([], with_pos $loc (TupleLit [])) } labeled_exps: | separated_nonempty_list(COMMA, @@ -879,7 +883,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,33 +895,33 @@ 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 - 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 +941,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 +958,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 () } @@ -994,27 +999,27 @@ 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 } 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 ) } @@ -1045,10 +1050,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) } @@ -1066,18 +1071,18 @@ 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 () } 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 () } @@ -1087,7 +1092,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) } @@ -1099,10 +1104,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: @@ -1110,9 +1115,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 } @@ -1139,40 +1144,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/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/refineBindings.ml b/core/refineBindings.ml index f4680c11c..20013082f 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 @@ -119,16 +119,16 @@ 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 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 @@ -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,37 +166,39 @@ 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 + | 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 -> + 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 - method! row_var : row_var -> 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 @@ -209,10 +212,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, @@ -263,19 +266,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 ([], []) @@ -302,11 +305,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)) @@ -315,7 +318,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) @@ -352,7 +355,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 @@ -390,11 +393,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 +407,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; @@ -429,13 +432,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 fd9657df3..53088e1bf 100644 --- a/core/sugarConstructors.ml +++ b/core/sugarConstructors.ml @@ -1,3 +1,5 @@ +open CommonTypes +open Operators open Sugartypes open Utility.OptionUtils @@ -21,29 +23,29 @@ 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) + Datatype.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) + Datatype.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) + Datatype.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) + Datatype.Var ("_" ^ string_of_int (!type_variable_counter), None, `Rigid) (** Helper data types and functions for passing arguments to smart @@ -51,7 +53,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 = 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 @@ -75,37 +77,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 (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)) + 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 **) @@ -117,19 +119,19 @@ 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 *) - let present = `Present (Sugartypes.with_dummy_pos `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 *) @@ -144,8 +146,8 @@ module SugarConstructors (Position : Pos) (** Various phrases *) (* Create a FunLit. *) - let fun_lit ?(ppos=dp) ?args ?(location=`Unknown) linearity pats blk = - with_pos ppos (`FunLit (args, linearity, (pats, blk), location)) + 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. *) let hnlit_arg depth computation_param handler_param = @@ -153,14 +155,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) @@ -173,36 +175,36 @@ 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)) + 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)) (* 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 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) | 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 = - val_binding' ~ppos NoSig (Pat pat, phrase, `Unknown) + val_binding' ~ppos NoSig (Pat pat, phrase, loc_unknown) (** Database queries *) @@ -213,7 +215,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,26 +226,26 @@ 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 = - 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 = - 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 +258,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/sugarConstructorsIntf.ml b/core/sugarConstructorsIntf.ml index 86cfc783e..f9f81fed5 100644 --- a/core/sugarConstructorsIntf.ml +++ b/core/sugarConstructorsIntf.ml @@ -1,6 +1,8 @@ (* This module contains module signatures used by SugarConstructors module. Putting them here allows to avoid repetition. *) +open CommonTypes +open Operators open Sugartypes (* An abstract type of positions and operations on them. The core type of @@ -37,17 +39,17 @@ 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. *) - type name_or_pat = Name of name - | Pat of pattern + type name_or_pat = PatName of name + | Pat of Pattern.with_pos type signature = Sig of (name with_pos * datatype') with_pos | NoSig @@ -58,7 +60,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 @@ -76,25 +78,27 @@ 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.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 + 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 : ?ppos:t -> ?args:((Types.datatype * Types.row) list) - -> ?location:location -> declared_linearity -> pattern list list -> phrase + -> ?location:Location.t -> DeclaredLinearity.t + -> Pattern.with_pos list list -> phrase -> phrase val hnlit_arg - : handler_depth -> pattern -> clause list * pattern 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,20 +116,21 @@ module type SugarConstructorsSig = sig (* Bindings *) val fun_binding : ?ppos:t -> signature - -> (declared_linearity * name * pattern list list * location * phrase) + -> (DeclaredLinearity.t * name * Pattern.with_pos list list * Location.t * + phrase) -> binding val fun_binding' - : ?ppos:t -> ?linearity:declared_linearity -> ?tyvars:tyvar list - -> ?location:location -> ?annotation:datatype' -> binder -> funlit + : ?ppos:t -> ?linearity:DeclaredLinearity.t -> ?tyvars:tyvar list + -> ?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 -> phrase + : ?ppos:t -> Pattern.with_pos -> phrase -> binding (* Database queries *) @@ -138,9 +143,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 -> 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 @@ -150,7 +155,8 @@ module type SugarConstructorsSig = sig (* Handlers *) val untyped_handler - : ?val_cases:(clause list) -> ?parameters:((phrase * pattern) 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 1d090b438..08024d416 100644 --- a/core/sugarTraversals.ml +++ b/core/sugarTraversals.ml @@ -8,6 +8,8 @@ generate all this automatically instead of maintaining this file. *) +open Operators +open CommonTypes open Sugartypes class map = @@ -36,13 +38,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 = @@ -59,12 +61,12 @@ 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 = - 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 @@ -84,16 +86,17 @@ 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 = + 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 : row -> row = + method row : Datatype.row -> Datatype.row = fun (_x, _x_i1) -> let _x = o#list @@ -105,8 +108,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 @@ -153,68 +156,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#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 - 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 +225,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 +237,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 +274,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 +284,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 +293,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 +310,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 +335,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 +397,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 +408,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 = @@ -437,39 +440,40 @@ 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) - method patternnode : patternnode -> patternnode = + method patternnode : Pattern.t -> Pattern.t = + 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,37 +481,34 @@ 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.with_pos -> Pattern.with_pos = fun {node; pos} -> let node = o#patternnode node in let pos = o#position pos in {node; pos} 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 location : Location.t -> Location.t = o#unknown 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) -> @@ -545,11 +546,11 @@ class map = in { params with shp_bindings = bindings } - method fieldspec : fieldspec -> 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 + method fieldspec : Datatype.fieldspec -> Datatype.fieldspec = + 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 @@ -559,73 +560,73 @@ 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_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 = - 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 type_arg : Datatype.type_arg -> Datatype.type_arg = + 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 @@ -635,34 +636,35 @@ 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 - | (#logical_binop as x) -> (o#logical_binop x :> binop) - | `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 = 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) -> @@ -673,23 +675,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 @@ -698,21 +700,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} -> @@ -752,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 = @@ -773,12 +775,12 @@ 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 = - 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 @@ -798,15 +800,15 @@ 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 = - function - | `Closed -> o - | `Open _x -> + method row_var : Datatype.row_var -> 'self_type = + 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 : row -> 'self_type = + method row : Datatype.row -> 'self_type = fun (_x, _x_i1) -> let o = o#list @@ -817,8 +819,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 @@ -860,18 +862,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) -> @@ -879,48 +881,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#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 - | `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 @@ -928,19 +930,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 @@ -961,7 +963,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 @@ -970,7 +972,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) -> @@ -978,15 +980,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 @@ -995,8 +997,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) -> @@ -1004,7 +1006,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 @@ -1020,55 +1022,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 @@ -1078,7 +1080,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 @@ -1088,23 +1090,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} -> @@ -1112,51 +1114,52 @@ 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 - method patternnode : patternnode -> 'self_type = + method patternnode : Pattern.t -> '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.with_pos -> 'self_type = fun {node; pos} -> let o = o#patternnode node in let o = o#position pos in @@ -1164,16 +1167,13 @@ 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 location : Location.t -> 'self_type = o#unknown 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 = @@ -1208,11 +1208,11 @@ class fold = o#pattern pat) params.shp_bindings - method fieldspec : 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 + method fieldspec : Datatype.fieldspec -> 'self_type = + 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 @@ -1223,66 +1223,67 @@ 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 = - 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 type_arg : Datatype.type_arg -> 'self_type = + 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 @@ -1292,33 +1293,34 @@ 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 - | (#logical_binop as x) -> o#logical_binop x - | `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 = 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) -> @@ -1330,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 @@ -1353,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)-> @@ -1421,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)) @@ -1439,12 +1441,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 sec : sec -> ('self_type * sec) = - 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) @@ -1464,16 +1466,16 @@ 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) = - function - | `Closed -> (o, `Closed) - | `Open _x -> - let (o, _x) = o#known_type_variable _x in (o, (`Open _x)) - | `Recursive ((_x, _x_i1)) -> + method row_var : Datatype.row_var -> ('self_type * Datatype.row_var) = + 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 : row -> ('self_type * row) = + method row : Datatype.row -> ('self_type * Datatype.row) = fun (_x, _x_i1) -> let (o, _x) = o#list @@ -1485,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) @@ -1535,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#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 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) -> @@ -1609,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 @@ -1621,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 @@ -1660,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 @@ -1670,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) -> @@ -1679,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 @@ -1696,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) -> @@ -1708,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) -> @@ -1730,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 @@ -1793,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 @@ -1805,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} -> @@ -1838,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} -> @@ -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.t -> ('self_type * Pattern.t) = + 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.with_pos -> ('self_type * Pattern.with_pos) = fun {node; pos} -> let (o, node) = o#patternnode node in let (o, pos ) = o#position pos in @@ -1921,19 +1924,16 @@ 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 location : Location.t -> ('self_type * Location.t) = o#unknown 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) -> @@ -1971,11 +1971,11 @@ class fold_map = in (o, { params with shp_bindings = bindings }) - method fieldspec : fieldspec -> ('self_type * 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) + method fieldspec : Datatype.fieldspec -> ('self_type * Datatype.fieldspec) = + 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) @@ -1991,77 +1991,78 @@ 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) = - 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 type_arg : Datatype.type_arg -> ('self_type * Datatype.type_arg) = + 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 @@ -2071,36 +2072,37 @@ 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)) - | (#logical_binop as x) -> (o#logical_binop x :> 'self_type * binop) - | `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)) 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) -> @@ -2111,23 +2113,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 @@ -2137,14 +2139,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) -> @@ -2152,7 +2154,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/sugarTraversals.mli b/core/sugarTraversals.mli index 5b8f12ba1..89c35c259 100644 --- a/core/sugarTraversals.mli +++ b/core/sugarTraversals.mli @@ -1,3 +1,5 @@ +open Operators +open CommonTypes open Sugartypes (* Make a copy of a value. You can override any method(s) to get a @@ -22,18 +24,18 @@ 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 sec : sec -> sec + method section : Section.t -> Section.t method subkind : subkind -> subkind method kind : kind -> kind 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 @@ -43,25 +45,24 @@ 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.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 location : Location.t -> Location.t method iterpatt : iterpatt -> iterpatt 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 + 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 @@ -92,18 +93,18 @@ 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 sec : sec -> 'self + method section : Section.t -> 'self method subkind : subkind -> 'self method kind : kind -> 'self 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 @@ -113,27 +114,26 @@ 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.t -> 'self + method pattern : Pattern.with_pos -> 'self method name : name -> 'self - method logical_binop : logical_binop -> 'self - method location : location -> 'self + method location : Location.t -> 'self method iterpatt : iterpatt -> 'self method funlit : funlit -> 'self 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 + method binop : BinaryOp.t -> 'self + method tybinop : tyarg list * BinaryOp.t -> 'self method bindingnode : bindingnode -> 'self method binding : binding -> 'self method program : program -> 'self @@ -156,17 +156,17 @@ 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 - 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 @@ -174,12 +174,11 @@ 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 logical_binop : logical_binop -> 'self * logical_binop + 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 : patternnode -> 'self * patternnode - method pattern : pattern -> 'self * pattern + 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 @@ -191,9 +190,9 @@ 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 sec : sec -> 'self * sec + method row : Datatype.row -> 'self * Datatype.row + method row_var : Datatype.row_var -> 'self * Datatype.row_var + method section : Section.t -> 'self * Section.t method sentence : sentence -> 'self * sentence method string : name -> 'self * name method subkind : subkind -> 'self * subkind @@ -201,8 +200,8 @@ 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 tyunary_op : tyarg list * unary_op -> 'self * (tyarg list * unary_op) - method unary_op : unary_op -> 'self * unary_op + method type_arg : Datatype.type_arg -> 'self * Datatype.type_arg + 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 a04f472d6..b24cb84c9 100644 --- a/core/sugartoir.ml +++ b/core/sugartoir.ml @@ -1,3 +1,5 @@ +open CommonTypes +open Operators open Utility open Ir @@ -596,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), loc_unknown)) rest let letfun env ((ft, _, _) as f_info, (tyvars, (ps, body)), location) rest = let xsb : binder list = @@ -724,7 +726,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 +745,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 +758,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 (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) -> + | 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, `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 ({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 +830,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 + 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 { 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 +899,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 +908,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 +982,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 +998,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 +1011,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 +1024,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 (Section.Project _) + | FunLit _ + | Iteration _ + | InfixAppl ((_, BinaryOp.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 = @@ -1065,27 +1068,28 @@ struct | [] -> ec e | { Sugartypes.node = b; _ }::bs -> begin + let open Sugartypes in match b with - | `Val ({Sugartypes.node=`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 +1102,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 +1119,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 +1135,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 = @@ -1203,7 +1208,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 219f2ea53..78f034487 100644 --- a/core/sugartypes.ml +++ b/core/sugartypes.ml @@ -1,60 +1,16 @@ +open CommonTypes +open Operators 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 unary_op = [ -| `Minus -| `FloatMinus -| `Name of name -] -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 ] - [@@deriving show] - -let string_of_unary_op = - function - | `Minus -> "-" - | `FloatMinus -> ".-" - | `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 -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 } @@ -63,6 +19,13 @@ type 'a with_pos = { node : 'a let with_pos pos node = { node; pos } let with_dummy_pos node = { node; pos = dummy_position } +(* 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 + type binder = (name * Types.datatype option) with_pos [@@deriving show] @@ -70,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); _ } = Utility.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 @@ -88,32 +51,15 @@ 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 restriction = [ `Any | `Base | `Session | `Effect ] - [@@deriving eq,show] -type linearity = [ `Any | `Unl ] - [@@deriving eq,show] - -type subkind = linearity * restriction +type subkind = Linearity.t * Restriction.t [@@deriving eq,show] -let default_subkind = (`Unl, `Any) +let default_subkind : subkind = (lin_unl, res_any) 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 @@ -131,98 +77,112 @@ 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 = - [ `Closed - | `Open of known_type_variable - | `Recursive of name * row ] -and fieldspec = - [ `Present of datatype - | `Absent - | `Var of known_type_variable ] -and type_arg = - [ `Type of datatype - | `Row of row - | `Presence of fieldspec ] +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 with_pos + | Absent + | Var of known_type_variable + 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 [@@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 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' + and with_pos = t WithPos.t + [@@deriving show] +end type spawn_kind = Angel | Demon | Wait [@@deriving show] -type replace_rhs = [ -| `Literal of string -| `Splice of phrase -] +module Section = struct + type t = Minus | FloatMinus | Project of name | Name of name + [@@deriving show] +end + +type fn_dep = string * string + [@@deriving show] + +type handler_depth = Deep | Shallow + [@@deriving show] + +type replace_rhs = + | 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) -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 *) + | 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 *) and handler = { sh_expr: phrase; sh_effect_cases: clause list; @@ -236,114 +196,132 @@ and handler_descriptor = { shd_params: handler_parameterisation option } and handler_parameterisation = { - shp_bindings: (phrase * pattern) list; + shp_bindings: (phrase * Pattern.with_pos) list; shp_types: Types.datatype list } -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 -| `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 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 * phrase) list * Types.datatype option -| `Receive of (pattern * 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 -| `DBInsert of phrase * name list * phrase * phrase option -| `DBUpdate of pattern * 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 -(* choose *) -| `Select of name * phrase -(* choice *) -| `Offer of phrase * (pattern * phrase) list * Types.datatype option -(* | `Fork of binder * phrase *) -| `CP of cp_phrase -| `TryInOtherwise of (phrase * pattern * phrase * phrase * Types.datatype option) -| `Raise -] +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 * + DeclaredLinearity.t * funlit * Location.t + | 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 * BinaryOp.t) * phrase * phrase + | Regex of regex + | UnaryAppl of (tyarg list * UnaryOp.t) * 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 and phrase = phrasenode with_pos -and bindingnode = [ -| `Val of pattern * (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.t * + datatype' option) + | 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.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 *) + | 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 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 -| 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] + +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 @@ -361,13 +339,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 @@ -377,118 +354,116 @@ 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.with_pos) : 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 - | `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 (Section.Name n) -> singleton n + + | Constant _ + | TextNode _ + | Section (Section.Minus|Section.FloatMinus|Section.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 ((_, 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] + | 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 + | 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 } -> + | 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) @@ -497,35 +472,39 @@ 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] - | `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) -> + 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) -> 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 - and binding ({node = binding; _}: binding) : StringSet.t (* vars bound in the pattern *) - * StringSet.t (* free vars in the rhs *) = + | 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 - | `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) -> @@ -533,23 +512,24 @@ 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 = - 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 -> @@ -568,21 +548,25 @@ 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 - | 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) -> - union (singleton (name_of_binder bndr)) (union_map (fun (_label, p) -> cp_phrase p) cases) - | Link (bndr1, bndr2) -> - union (singleton (name_of_binder bndr1)) (singleton (name_of_binder bndr2)) - | Comp (bndr, left, right) -> - diff (union (cp_phrase left) (cp_phrase right)) (singleton (name_of_binder bndr)) + | CPOffer (bndr, 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)) + | 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 e908fd70a..75704037b 100644 --- a/core/transformSugar.ml +++ b/core/transformSugar.ml @@ -1,33 +1,36 @@ -open Utility +open CommonTypes +open Operators open Sugartypes +open Utility 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 (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], + `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 - | `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 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 @@ -37,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 "<>" -> - let ab, a = Types.fresh_type_quantifier (`Any, `Any) in - let eb, e = Types.fresh_row_quantifier (`Any, `Any) in + | 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 (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" - | `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 = @@ -151,7 +154,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) = @@ -170,17 +173,17 @@ 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) - 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) - method sec : sec -> ('self_type * sec * Types.datatype) = - fun sec -> - (o, sec, type_section var_env sec) + method section : Section.t -> ('self_type * Section.t * Types.datatype) = + fun section -> + (o, section, type_section var_env section) method sentence : sentence -> ('self_type * sentence) = function @@ -204,13 +207,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) -> @@ -228,9 +231,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 +245,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 +256,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 +267,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 +280,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 +294,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 +402,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 +419,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 +482,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 +500,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 +509,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 +559,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 +578,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 +588,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 +598,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 +617,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) = @@ -622,55 +625,56 @@ 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.t -> ('self_type * Pattern.t) = + 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.with_pos -> ('self_type * Pattern.with_pos) = fun {node; pos} -> let (o, node) = o#patternnode node in (o, {node; pos}) 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) -> @@ -713,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.t * 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.t * datatype' option * position) list) = let outer_tyvars = o#backup_quantifiers in let rec list o = function @@ -733,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.t * 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.t * datatype' option * position) list) = let rec list o = function | [] -> o, [] @@ -748,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.t * datatype' option * position) list -> 'self_type = let rec list o = function @@ -762,15 +766,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 @@ -778,9 +782,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 @@ -789,20 +793,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} -> @@ -821,44 +825,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 @@ -867,16 +871,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/transformSugar.mli b/core/transformSugar.mli index 942bc9050..3a781a0be 100644 --- a/core/transformSugar.mli +++ b/core/transformSugar.mli @@ -1,3 +1,5 @@ +open Operators +open CommonTypes open Sugartypes (* @@ -49,7 +51,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 @@ -60,25 +62,25 @@ 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.t * 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.t * 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.t * 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.t * 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.t * 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 method row : Types.row -> 'self * Types.row - method patternnode : patternnode -> 'self * patternnode - method pattern : pattern -> 'self * pattern + 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 @@ -86,13 +88,13 @@ 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.t -> 'self * Section.t * Types.datatype method sentence : sentence -> 'self * sentence (* 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 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 b8dee8b7f..5cd03382f 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -1,5 +1,6 @@ +open CommonTypes open Utility -open Types +open Operators open Sugartypes (* let constrain_absence_types = Basicsettings.Typing.contrain_absence_types *) @@ -36,106 +37,106 @@ 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 _ - | `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; _} = 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 @@ -151,8 +152,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 @@ -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 (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)) @@ -1378,25 +1379,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 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 type_section context = function + | Section s as s' -> + let env = context.var_env in + let ((tyargs, t), usages) = + 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 (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 - 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) @@ -1405,15 +1408,16 @@ 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 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 @@ -1424,45 +1428,46 @@ 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 "<>" -> - let a = Types.fresh_type_variable (`Any, `Any) in - let eff = (StringMap.empty, Types.fresh_row_variable (`Any, `Any), false) in + | 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 (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) - | `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 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.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 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-> 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 +1484,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 +1497,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 +1522,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.with_pos -> Pattern.with_pos 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.with_pos 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 +1574,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.with_pos -> Pattern.with_pos list = fun name p -> + let open Pattern in match p.node with - | `Effect (name', ps, _) when name=name' -> ps - | `Effect _ -> [] - | `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 +1599,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.with_pos list list = let non_empty ps = ps <> [] in let rows = map_filter @@ -1632,14 +1641,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.with_pos 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 +1713,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.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 @@ -1711,34 +1721,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,11 +1759,11 @@ 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.with_pos -> Pattern.with_pos * Types.environment * Types.datatype = 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 (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 @@ -1764,7 +1775,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.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) @@ -1775,31 +1786,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.t * 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 -> - let t = Types.make_list_type (Types.fresh_type_variable (`Any, `Any)) in - `Nil, Env.empty, (t, t) - | `Constant c as c' -> + | Nil -> + 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 (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 (`Any, `Any) in - (`Variable (set_binder_type bndr xtype), + | Variable bndr -> + 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)) - | `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 = @@ -1808,41 +1820,42 @@ let type_pattern closed : pattern -> pattern * Types.environment * Types.datatyp 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 (lin_any, res_any) in t, t | 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.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 (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 + 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,22 +1889,22 @@ 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 -> - let row_var = Types.fresh_row_variable (`Any, `Any) in + Effect (name, List.map erase ps, erase k), env, (eff ot, eff it) + | Negative names -> + 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 (`Any, `Any) 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 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 = @@ -1905,7 +1918,7 @@ let type_pattern closed : pattern -> pattern * Types.environment * Types.datatyp 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 (lin_any, res_any)) in let () = unify ~handle:Gripers.record_pattern (("", `Record row), (pos r, typ r)) in @@ -1919,23 +1932,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,51 +1956,53 @@ 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.with_pos -> 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.t -> Pattern.t = 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 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)) @@ -2008,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 declared_linearity=`Lin 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 (`Any, `Any), 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 @@ -2021,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 declared_linearity=`Lin 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 (`Any, `Any) in + let q, eff = Types.fresh_row_quantifier (lin_any, res_any) in q::qs, ftcon (args p, eff, t) | [] -> assert false in @@ -2109,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 (`Any, `Any) in - let bt = Types.fresh_type_variable (`Any, `Any) 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) -> @@ -2148,29 +2163,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 @@ -2192,7 +2207,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 @@ -2214,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 (`Any, `Any), 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); @@ -2240,26 +2255,26 @@ 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 + 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; - `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 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 (lin_any, res_any), false) in let body = type_check ({context with var_env = env'; effect_row = effects}) body in @@ -2275,7 +2290,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = pat_env in let () = - if lin=`Unl 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 @@ -2312,7 +2327,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 @@ -2320,59 +2335,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 + (lin_any, res_any)) in + 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 + (lin_any, res_any)) in + 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 @@ -2382,12 +2397,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 @@ -2398,25 +2413,25 @@ 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 - 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 (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 @@ -2436,20 +2451,20 @@ 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) (lin_any, res_any) in 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 - 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 (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 @@ -2459,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 (`Any, `Base))) 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 *) @@ -2470,16 +2485,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 (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 (`Any, `Base), 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 (`Any, `Base), 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 @@ -2492,7 +2507,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 @@ -2501,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 (`Any, `Base), 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 @@ -2509,19 +2524,19 @@ 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) (lin_any, res_any) in 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 - 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 (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 @@ -2554,43 +2569,43 @@ 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 (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 (`Any, `Base), 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 (`Any, `Base), 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 (`Any, `Base), 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) (`Any, `Any) + 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)) 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 + | 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) (`Any, `Any) + 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 @@ -2598,26 +2613,26 @@ 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 (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] + 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 + 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) (`Any, `Any) + 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 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 -> @@ -2627,23 +2642,23 @@ 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 (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) (`Any, `Any) + 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 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, _) -> - let mb_type = Types.fresh_type_variable (`Any, `Any) in + Spawn (k, given_loc, erase p, Some inner_effects), pid_type, usages p + | Receive (binders, _) -> + 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) (`Any, `Any)) 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 @@ -2652,69 +2667,59 @@ 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) -> *) - (* 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) -> + | 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 (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) - (`Any, `Session)))); - `Select (l, erase e), selected_session, usages e - | `Offer (e, branches, _) -> + (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 (`Any, `Session) 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] + 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 + 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))); - `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 - and rettyp = Types.fresh_type_variable (`Any, `Any) 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], 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 @@ -2789,7 +2794,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, @@ -2800,7 +2805,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, @@ -2811,7 +2816,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 (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), @@ -2819,18 +2824,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 @@ -2847,31 +2852,31 @@ 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) -> - let t = Types.fresh_type_variable (`Any, `Any) in + Page (erase e), Instantiate.alias "Page" [] context.tycon_env, usages e + | FormletPlacement (f, h, attributes) -> + let t = Types.fresh_type_variable (lin_any, res_any) in let f = tc f and h = tc h @@ -2884,27 +2889,27 @@ 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 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)); - `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 - | `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 ()} @@ -2914,25 +2919,25 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * usagemap = List.fold_left (fun (generators, generator_usages, environments) -> function - | `List (pattern, e) -> - let a = Types.fresh_type_variable (`Any, `Any) in + | List (pattern, e) -> + 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 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) -> - 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 + | Table (pattern, e) -> + 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 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 @@ -2944,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 (`Any, `Any)))) 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 @@ -2953,21 +2958,21 @@ 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 (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 (`Any, `Base))))) in - let e = `Iteration (generators, erase body, opt_map erase where, opt_map erase orderby) 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 (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 @@ -2991,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 (`Any, `Any) in - let t = Types.fresh_type_variable (`Any, `Any) 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) (`Any, `Any) 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 @@ -3003,14 +3008,14 @@ 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) (lin_any, res_any) in unify ~handle:Gripers.escape_outer (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 @@ -3018,16 +3023,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: @@ -3091,33 +3096,33 @@ 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 (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 + 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 (lin_any, res_any) in unify ~handle:Gripers.projection ((exp_pos r, rt), no_pos (`Record (Types.make_singleton_open_row (l, `Present fieldtype) - (`Unl, `Any)))); + (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 + 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 (lin_any, res_any) in unify ~handle:Gripers.projection (pos_and_typ r, no_pos (`Record (Types.make_singleton_open_row (l, `Present fieldtype) - (`Unl, `Any)))); - `Projection (erase r, l), fieldtype, usages r + (lin_unl, res_any)))); + 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 @@ -3125,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 (`Unl, `Any))) row) - fields (Types.make_empty_open_row (`Any, `Any))) 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); @@ -3138,23 +3143,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, [] @@ -3171,15 +3176,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.with_pos * phrase) list -> (Pattern.with_pos * phrase) list * (Pattern.with_pos * 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 @@ -3214,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 (`Unl, `Any) 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 (`Unl, `Any) in - let bt = Types.fresh_type_variable (`Unl, `Any) 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 *) @@ -3239,19 +3246,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 +3274,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,19 +3290,20 @@ 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 + (Types.fresh_type_variable (lin_unl, res_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 (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) - | `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 +3324,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,12 +3336,12 @@ 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)] - (Types.make_empty_open_row (`Unl, `Any)) - (Types.fresh_type_variable (`Unl, `Any)) + [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 @@ -3358,7 +3367,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.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) @@ -3397,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 (`Unl, `Any)) (* 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 (`Unl, `Any) } 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'. *) @@ -3440,11 +3449,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 @@ -3457,25 +3466,25 @@ 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 (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) (`Unl, `Effect) 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 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 type variable *) + (* Pattern.with_posype variable *) let pat = tpc pat in (* Check whether pattern corresponds to try_phrase *) @@ -3538,11 +3547,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 (lin_any, res_any), StringMap.empty) in with_pos pos e, t, usages (** [type_binding] takes XXX YYY (FIXME) @@ -3578,7 +3587,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 @@ -3607,17 +3616,17 @@ 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 - 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 (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 = @@ -3665,7 +3674,7 @@ and type_binding : context -> binding -> binding * context * usagemap = (List.flatten pats) in let () = - if lin = `Unl 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 @@ -3680,14 +3689,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 @@ -3701,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)) (`Any, `Any) 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 @@ -3723,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 (`Any, `Any)) + 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 (`Any, `Any)) 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 *) @@ -3770,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.is_nonlinear lin then StringMap.iter (fun v _ -> if not (StringSet.mem v vs) then let t = Env.lookup context'.var_env v in @@ -3837,29 +3846,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 = @@ -3881,8 +3890,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 @@ -3921,23 +3930,23 @@ 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) -> - let (_, t, _) = type_check context (with_pos pos (`Var c)) in + CPUnquote (bindings, e), t, usage_builder u + | CPGrab ((c, _), None, p) -> + 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 - 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 - let s = Types.fresh_session_variable `Any in + let (_, t, _) = type_check context (with_pos pos (Sugartypes.Var c)) 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); @@ -3948,7 +3957,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) -> @@ -3962,23 +3971,23 @@ 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) -> - let (_, t, _) = type_check context (with_pos pos (`Var c)) 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 (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 - Give ((c, Some (ctype, [])), None, p), t, use c u - | Give ((c, _), Some e, p) -> - let (_, t, _) = type_check context (with_pos pos (`Var c)) in + CPGive ((c, Some (ctype, [])), None, p), t, use c u + | 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 lin_any in let ctype = `Output (t', s) in unify ~pos:pos ~handle:(Gripers.cp_give c) (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) -> @@ -3992,61 +4001,61 @@ 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 + 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); - 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 - let r = Types.make_singleton_open_row (label, `Present s) (`Any, `Session) in + let (_, t, _) = type_check context (with_pos pos (Sugartypes.Var c)) 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); 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 + 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 (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 (`Any, `Session) in - let r = Types.make_singleton_open_row (label, `Present s) (`Any, `Session) 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 (`Any, `Any) 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 - 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 - 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)); + (tc, Types.fresh_type_variable (lin_any, res_session)); unify ~pos:pos ~handle:Gripers.cp_link_session - (td, Types.fresh_type_variable (`Any, `Session)); + (td, Types.fresh_type_variable (lin_any, res_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 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); - 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 diff --git a/core/typeUtils.ml b/core/typeUtils.ml index d3345655c..fa6e44b19 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) (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 baf896634..ec9646d92 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,21 +19,13 @@ 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.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 = @@ -74,7 +67,7 @@ end let process = { Abstype.id = "Process" ; name = "Process" ; - arity = [`Row, (`Any, `Any)] ; + arity = [pk_row, (lin_any, res_any)] ; } (* Lists are currently unlimited because the only deconstructors are @@ -83,7 +76,7 @@ let process = { let list = { Abstype.id = "List" ; name = "List" ; - arity = [`Type, (`Unl, `Any)] ; + arity = [pk_type, (lin_unl, res_any)] ; } let event = { @@ -100,7 +93,7 @@ let dom_node = { let access_point = { Abstype.id = "AP" ; name = "AP" ; - arity = [`Type, (`Any, `Session)] ; + arity = [pk_type, (lin_any, res_session)] ; } let socket = { @@ -266,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', (`Any, `Any), `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 @@ -286,7 +279,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', (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 @@ -439,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, (`Any, `Any), `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 @@ -452,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, (`Any, `Any), `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 @@ -494,7 +487,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 @@ -505,7 +498,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 @@ -527,7 +520,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 @@ -539,7 +532,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 @@ -562,9 +555,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, res_base), `Flexible)) | `Var (_, _, `Flexible) -> assert false | `Body t -> basify_type t | `Recursive _ -> assert false @@ -575,8 +568,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, res_base), `Flexible)) | `Var _ -> assert false | `Body row -> basify_row row | `Recursive _ -> assert false @@ -609,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 _ -> pk_type, sk + | _, sk, `Row _ -> pk_row, sk + | _, sk, `Presence _ -> pk_presence, sk let type_arg_of_quantifier : quantifier -> type_arg = function @@ -619,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 _ -> pk_type + | _, _, `Row _ -> pk_row + | _, _, `Presence _ -> pk_presence 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 _ -> 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 @@ -645,7 +638,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 || 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) @@ -694,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 || lin=`Unl + | `Var (v, (lin, _), `Rigid) -> IntSet.mem v quant_vars || Linearity.is_nonlinear lin | `Var (_, _, `Flexible) -> true | `Body t -> f vars t | `Recursive (var, t) -> @@ -748,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 || 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 || 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) @@ -783,7 +776,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) -> @@ -818,13 +811,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) @@ -858,8 +851,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) @@ -958,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, `Session) + 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 @@ -1403,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, (`Any, `Any), `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')); @@ -1670,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 @@ -1706,12 +1700,12 @@ struct begin match Unionfind.find point with | `Var (var, _, freedom) -> - [var, ((freedom :> flavour), `Type, `Free)] + [var, ((freedom :> flavour), pk_type, `Free)] | `Recursive (var, body) -> if TypeVarSet.mem var bound_vars then - [var, (`Recursive, `Type, `Bound)] + [var, (`Recursive, pk_type, `Bound)] else - (var, (`Recursive, `Type, `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) -> @@ -1753,7 +1747,7 @@ struct begin match Unionfind.find point with | `Var (var, _, freedom) -> - [var, ((freedom :> flavour), `Presence, `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, _) = @@ -1768,12 +1762,12 @@ struct match Unionfind.find row_var with | `Closed -> [] | `Var (var, _, freedom) -> - [var, ((freedom :> flavour), `Row, `Free)] + [var, ((freedom :> flavour), pk_row, `Free)] | `Recursive (var, row) -> if TypeVarSet.mem var bound_vars then - [var, (`Recursive, `Row, `Bound)] + [var, (`Recursive, pk_row, `Bound)] else - (var, (`Recursive, `Row, `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 @@ -1890,16 +1884,8 @@ 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) = "(" ^ Linearity.to_string l ^ "," ^ + Restriction.to_string r ^ ")" in fun (policy, _vars) -> if policy.kinds = "full" then @@ -1908,43 +1894,38 @@ struct function (_, _) -> "" else function - | (`Unl, `Any) -> "" - | (`Any, `Any) -> "Any" - | (`Unl, `Base) -> restriction `Base - | (`Any, `Session) -> restriction `Session - | (`Unl, `Effect) -> restriction `Effect + | (Linearity.Unl, Restriction.Any) -> "" + | (Linearity.Any, Restriction.Any) -> "Any" + | (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 primary_kind : primary_kind -> string = function - | `Type -> "Type" - | `Row -> "Row" - | `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 + 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 - primary_kind k + PrimaryKind.to_string k else match (k, sk) with - | `Type, (`Unl, `Any) -> "" - | `Type, (`Unl, `Base) -> restriction `Base - | `Type, (`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, _ - | `Presence, _ -> full ({policy with kinds="full"}, _vars) (k, sk) + | PrimaryKind.Type, (Linearity.Unl, Restriction.Any) -> "" + | PrimaryKind.Type, (Linearity.Unl, Restriction.Base) -> + Restriction.to_string res_base + | PrimaryKind.Type, (Linearity.Any, Restriction.Session) -> + Restriction.to_string res_session + | PrimaryKind.Type, sk -> + subkind ({policy with kinds="full"}, _vars) sk + | PrimaryKind.Row, (Linearity.Unl, Restriction.Any) -> + PrimaryKind.to_string pk_row + | PrimaryKind.Row, (Linearity.Unl, Restriction.Effect) -> + PrimaryKind.to_string pk_row + | PrimaryKind.Presence, (Linearity.Unl, Restriction.Any) -> + PrimaryKind.to_string pk_presence + | PrimaryKind.Row, _ | PrimaryKind.Presence, _ -> + full ({policy with kinds="full"}, _vars) (k, sk) let quantifier : (policy * names) -> quantifier -> string = fun (policy, vars) q -> @@ -2400,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]; @@ -2524,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 (`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 (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 (`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 (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/types.mli b/core/types.mli index 90cc1b9bb..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,21 +15,13 @@ 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 linearity = [ `Any | `Unl ] - [@@deriving eq,show] - -type subkind = linearity * restriction +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 = @@ -57,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 @@ -233,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 @@ -263,7 +256,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 @@ -382,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 diff --git a/core/unify.ml b/core/unify.ml index b13356845..2e0aa65f3 100644 --- a/core/unify.ml +++ b/core/unify.ml @@ -1,3 +1,4 @@ +open CommonTypes open Utility open Types open Typevarcheck @@ -312,19 +313,17 @@ 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 = + 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 *) @@ -363,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 rest = `Base 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); @@ -374,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 rest = `Base 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 lin = `Unl 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 rest = `Session then + if Restriction.is_session rest then if Types.is_sessionable_type t2 then Types.sessionify_type t2 else @@ -403,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 rest = `Base 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); @@ -414,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 rest = `Base 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 lin = `Unl 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 rest = `Session then + if Restriction.is_session rest then if Types.is_sessionable_type t1 then Types.sessionify_type t1 else @@ -519,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 rest = `Base 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 @@ -528,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 rest = `Base 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 lin = `Unl 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 rest = `Session then + if Restriction.is_session rest then if Types.is_sessionable_type t then Types.sessionify_type t else @@ -980,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 rest = `Any && rest' = `Base 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' -> () @@ -1009,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 rest = `Base 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 rest = `Base 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 rest = `Session 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 lin = `Unl then + if Linearity.is_nonlinear lin then if Types.row_can_be_unl extension_row then Types.make_row_unl extension_row else @@ -1210,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 (`Any, `Any) 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