From edab879d0a98b849adbabf39b0d452163f815419 Mon Sep 17 00:00:00 2001 From: rajdakin Date: Mon, 24 Mar 2025 15:41:09 +0000 Subject: [PATCH] Sorting record members first on the length of the key --- core/buildTables.ml | 2 +- core/channelVarUtils.ml | 5 +- core/closures.ml | 12 +-- core/compilePatterns.ml | 42 +++++------ core/desugarCP.ml | 5 +- core/desugarDatatypes.ml | 6 +- core/desugarEffects.ml | 2 +- core/desugarFuns.ml | 2 +- core/desugarProcesses.ml | 2 +- core/evalir.ml | 10 +-- core/generalise.ml | 6 +- core/instantiate.ml | 24 +++--- core/ir.ml | 6 +- core/ir.mli | 24 +++--- core/irCheck.ml | 18 ++--- core/irTraversals.ml | 19 ++++- core/irTraversals.mli | 4 + core/irtojs.ml | 6 +- core/lens_ir_conv.ml | 2 +- core/lens_type_conv.ml | 6 +- core/lib.ml | 2 +- core/page.ml | 2 +- core/query/delateralize.ml | 12 +-- core/query/evalMixingQuery.ml | 30 ++++---- core/query/evalNestedQuery.ml | 122 +++++++++++++++---------------- core/query/evalQuery.ml | 4 +- core/query/mixingQuery.ml | 88 +++++++++++----------- core/query/mixingQuery.mli | 6 +- core/query/query.ml | 58 +++++++-------- core/query/query.mli | 5 +- core/query/queryLang.ml | 103 +++++++++++++------------- core/query/queryLang.mli | 14 ++-- core/query/temporalQuery.ml | 94 ++++++++++++------------ core/sugartoir.ml | 8 +- core/transformSugar.ml | 8 +- core/typeSugar.ml | 96 ++++++++++++------------ core/typeUtils.ml | 24 +++--- core/typeUtils.mli | 2 +- core/types.ml | 46 +++++++----- core/types.mli | 5 +- core/typevarcheck.ml | 4 +- core/unify.ml | 38 +++++----- core/utility.ml | 5 +- tests/handlers.tests | 2 +- tests/handlers_with_cfl_on.tests | 2 +- tests/patterns.tests | 4 +- tests/records.tests | 2 +- 47 files changed, 510 insertions(+), 479 deletions(-) diff --git a/core/buildTables.ml b/core/buildTables.ml index 5ac05cb13..56fbaf7ae 100644 --- a/core/buildTables.ml +++ b/core/buildTables.ml @@ -255,7 +255,7 @@ struct let bindings tyenv bound_vars cont_vars bs = let o = new visitor tyenv bound_vars cont_vars in - let _ = o#computation (bs, Return (Extend (StringMap.empty, None))) in () + let _ = o#computation (bs, Return (Extend (Types.FieldEnv.empty, None))) in () let program tyenv bound_vars cont_vars e = let _ = (new visitor tyenv bound_vars cont_vars)#computation e in () diff --git a/core/channelVarUtils.ml b/core/channelVarUtils.ml index 369296a7a..a008d609d 100644 --- a/core/channelVarUtils.ml +++ b/core/channelVarUtils.ml @@ -14,6 +14,9 @@ let variables_in_computation comp = let rec traverse_stringmap : 'a . ('a -> unit) -> 'a stringmap -> unit = fun proj_fn smap -> (* (proj_fn: 'a . 'a -> 'b) (smap: 'a stringmap) : unit = *) StringMap.fold (fun _ v _ -> proj_fn v) smap () + and traverse_ststringmap : 'a . ('a -> unit) -> 'a st_name_map -> unit = + fun proj_fn smap -> (* (proj_fn: 'a . 'a -> 'b) (smap: 'a st_name_map) : unit = *) + Types.FieldEnv.fold (fun _ v _ -> proj_fn v) smap () and traverse_value = function | Variable v -> add_variable v | Closure (_, _, value) @@ -30,7 +33,7 @@ let variables_in_computation comp = traverse_value v; List.iter traverse_value vs | Extend (v_map, v_opt) -> - traverse_stringmap (traverse_value) v_map; + traverse_ststringmap (traverse_value) v_map; begin match v_opt with | Some v -> traverse_value v | None -> () end | Constant _ -> () and traverse_tail_computation = function diff --git a/core/closures.ml b/core/closures.ml index 7c7d2145f..398fa73ee 100644 --- a/core/closures.ml +++ b/core/closures.ml @@ -428,9 +428,9 @@ struct let close f zs tyargs = Closure (f, tyargs, Extend (List.fold_right (fun (zname, zv) fields -> - StringMap.add zname zv fields) + Types.FieldEnv.add zname zv fields) zs - StringMap.empty, None)) + Types.FieldEnv.empty, None)) class visitor tenv fenv = object (o : 'self) inherit IrTraversals.Transform.visitor(tenv) as super @@ -539,8 +539,8 @@ struct (fun fields b -> let x = Var.var_of_binder b in let xt = Var.type_of_binder b in - StringMap.add (string_of_int x) xt fields) - StringMap.empty + Types.FieldEnv.add (string_of_int x) xt fields) + Types.FieldEnv.empty zs) in (* fresh variable for the closure environment *) @@ -615,8 +615,8 @@ struct (fun fields b -> let x = Var.var_of_binder b in let xt = Var.type_of_binder b in - StringMap.add (string_of_int x) xt fields) - StringMap.empty + Types.FieldEnv.add (string_of_int x) xt fields) + Types.FieldEnv.empty zs) in (* fresh variable for the closure environment *) diff --git a/core/compilePatterns.ml b/core/compilePatterns.ml index 4922eecf2..8c999f9dd 100644 --- a/core/compilePatterns.ml +++ b/core/compilePatterns.ml @@ -33,7 +33,7 @@ struct | Variant of Name.t * t | Operation of Name.t * t list * t | Negative of StringSet.t - | Record of t StringMap.t * t option + | Record of t Types.FieldEnv.t * t option | Constant of Constant.t | Variable of binder | As of binder * t @@ -144,9 +144,9 @@ let rec desugar_pattern : Types.row -> Sugartypes.Pattern.with_pos -> Pattern.t List.fold_right (fun (name, p) (bs, env) -> let p, env' = desugar_pattern p in - StringMap.add name p bs, env ++ env') + Types.FieldEnv.add name p bs, env ++ env') bs - (StringMap.empty, empty) in + (Types.FieldEnv.empty, empty) in let p, env = match p with | None -> None, env @@ -297,7 +297,7 @@ let let_pattern : raw_env -> Pattern.t -> value * Types.datatype -> computation | None -> body | Some p -> let names = - StringMap.fold + Types.FieldEnv.fold (fun name _ names -> StringSet.add name names) fields @@ -306,7 +306,7 @@ let let_pattern : raw_env -> Pattern.t -> value * Types.datatype -> computation lp rt p (Erase (names, value)) body (* lp rt p (`Coerce (value, rt)) body *) in - StringMap.fold + Types.FieldEnv.fold (fun name p body -> let t' = (TypeUtils.project_type name t) in (lp t' p (Project (name, value)) body)) @@ -444,7 +444,7 @@ let arrange_constant_clauses This function flattens all the record clauses. *) let arrange_record_clauses - : clause list -> (annotated_pattern StringMap.t * annotated_pattern option * annotated_clause) list = + : clause list -> (annotated_pattern Types.FieldEnv.t * annotated_pattern option * annotated_clause) list = fun clauses -> let rec flatten = function @@ -452,16 +452,16 @@ let arrange_record_clauses bs, None | Pattern.Record (bs, Some p) -> let bs', p' = flatten p in - StringMap.union_disjoint bs bs', p' + Types.FieldEnv.union_disjoint bs bs', p' | p -> - StringMap.empty, Some p + Types.FieldEnv.empty, Some p in List.fold_right (fun (ps, body) xs -> match ps with | (annotation, p)::ps -> let bs, p = flatten p in - let bs = StringMap.map reduce_pattern bs in + let bs = Types.FieldEnv.map reduce_pattern bs in let p = opt_map reduce_pattern p in (bs, p, (annotation, (ps, body)))::xs | _ -> assert false @@ -810,7 +810,7 @@ and match_constant | _ -> assert false and match_record - : var list -> (annotated_pattern StringMap.t * annotated_pattern option * annotated_clause) list -> + : var list -> (annotated_pattern Types.FieldEnv.t * annotated_pattern option * annotated_clause) list -> bound_computation -> var -> bound_computation = fun vars xs def var env -> let t = lookup_type var env in @@ -818,7 +818,7 @@ and match_record let names = List.fold_right (fun (bs, _, _) names -> - StringMap.fold (fun name _ names -> StringSet.add name names) bs names) xs StringSet.empty in + Types.FieldEnv.fold (fun name _ names -> StringSet.add name names) bs names) xs StringSet.empty in let all_closed = List.for_all (function | (_, None, _) -> true | (_, Some _, _) -> false) xs in @@ -838,17 +838,17 @@ and match_record let rps, fields = StringSet.fold (fun name (ps, fields) -> - if StringMap.mem name bs then - StringMap.find name bs :: ps, fields + if Types.FieldEnv.mem name bs then + Types.FieldEnv.find name bs :: ps, fields else if closed then ([], Pattern.Any)::ps, fields else let xt = TypeUtils.project_type name t in let xb, x = Var.fresh_var_of_type xt in - ([], Pattern.Variable xb)::ps, StringMap.add name (Variable x) fields) + ([], Pattern.Variable xb)::ps, Types.FieldEnv.add name (Variable x) fields) names - ([], StringMap.empty) in + ([], Types.FieldEnv.empty) in let rps, body = if all_closed then rps, body @@ -856,7 +856,7 @@ and match_record ([], Pattern.Any)::List.rev rps, body else let original_names = - StringMap.fold + Types.FieldEnv.fold (fun name _ names -> StringSet.add name names) bs @@ -988,7 +988,7 @@ let compile_handle_cases let variant_type = let (fields,_,_) = comp_eff |> TypeUtils.extract_row_parts in let fields' = - StringMap.filter + Types.FieldEnv.filter (fun _ -> function | Types.Present _ -> true @@ -998,9 +998,9 @@ let compile_handle_cases let rec extract t = match TypeUtils.concrete_type t with | Types.Operation (domain, _, _) -> let (fields, _, _) = TypeUtils.extract_row domain |> TypeUtils.extract_row_parts in - let arity = StringMap.size fields in + let arity = Types.FieldEnv.size fields in if arity = 1 then - match StringMap.find "1" fields with + match Types.FieldEnv.find "1" fields with | Types.Present t -> t | _ -> assert false else @@ -1009,7 +1009,7 @@ let compile_handle_cases | _ -> Types.unit_type (* nullary operation *) in let fields'' = - StringMap.map + Types.FieldEnv.map (function | Types.Present t -> extract t @@ -1033,7 +1033,7 @@ let compile_handle_cases let fields = List.mapi (fun i p -> (string_of_int (i+1), p)) ps in - Pattern.Record (StringMap.from_alist fields, None) + Pattern.Record (Types.FieldEnv.from_alist fields, None) in Pattern.Variant (name, packaged_args) | _ -> assert false diff --git a/core/desugarCP.ml b/core/desugarCP.ml index dda621626..9d7178927 100644 --- a/core/desugarCP.ml +++ b/core/desugarCP.ml @@ -115,10 +115,10 @@ object (o : 'self_type) let (eff_fields, eff_row, eff_closed) = Types.flatten_row o#lookup_effects |> TypeUtils.extract_row_parts in - let eff_fields = StringMap.remove wild_str eff_fields in + let eff_fields = Types.FieldEnv.remove wild_str eff_fields in let eff_fields = if Settings.get Basicsettings.Sessions.exceptions_enabled then - StringMap.remove Value.session_exception_operation eff_fields + Types.FieldEnv.remove Value.session_exception_operation eff_fields else eff_fields in @@ -149,4 +149,3 @@ module Typeable let name = "cp" let obj env = (desugar_cp env : TransformSugar.transform :> Transform.Typeable.sugar_transformer) end) - diff --git a/core/desugarDatatypes.ml b/core/desugarDatatypes.ml index ed28f7011..d56e941d7 100644 --- a/core/desugarDatatypes.ml +++ b/core/desugarDatatypes.ml @@ -282,7 +282,7 @@ module Desugar = struct | Closed -> Types.make_empty_closed_row () | Open srv -> let rv = SugarTypeVar.get_resolved_row_exn srv in - Types.Row (StringMap.empty, rv, false) + Types.Row (Types.FieldEnv.empty, rv, false) | Recursive (stv, r) -> let mrv = SugarTypeVar.get_resolved_row_exn stv in @@ -291,7 +291,7 @@ module Desugar = struct (* Turn mrv into a proper recursive row *) Unionfind.change mrv (Types.Recursive (var, sk, r)); - Types.Row (StringMap.empty, mrv, false) + Types.Row (Types.FieldEnv.empty, mrv, false) in let fields = List.map (fun (k, p) -> (k, fieldspec alias_env p node)) fields in @@ -335,7 +335,7 @@ module Desugar = struct let write_row, needed_row = match TypeUtils.concrete_type read_type with | Record (Row (fields, _, _)) -> - StringMap.fold + Types.FieldEnv.fold (fun label t (write, needed) -> match lookup label constraints with | Some cs -> diff --git a/core/desugarEffects.ml b/core/desugarEffects.ml index 704479058..ba4c4b44b 100644 --- a/core/desugarEffects.ml +++ b/core/desugarEffects.ml @@ -479,7 +479,7 @@ let gather_mutual_info (tycon_env : simple_tycon_env) = let gather_operation_of_type tp = let open Types in - let module FieldEnv = Utility.StringMap in + let module FieldEnv = Types.FieldEnv in let is_effect_row_kind : Kind.t -> bool = fun (primary, (_, restriction)) -> primary = PrimaryKind.Row && restriction = Restriction.Effect diff --git a/core/desugarFuns.ml b/core/desugarFuns.ml index e87db890e..9c8510cb2 100644 --- a/core/desugarFuns.ml +++ b/core/desugarFuns.ml @@ -132,7 +132,7 @@ object (o : 'self_type) let (fields, rho, _) = TypeUtils.extract_row_parts row in let effb, row = fresh_row_quantifier default_effect_subkind in - let r = Record (Row (StringMap.add name (Present a) fields, rho, false)) in + let r = Record (Row (FieldEnv.add name (Present a) fields, rho, false)) in let f = gensym ~prefix:"_fun_" () in let x = gensym ~prefix:"_fun_" () in diff --git a/core/desugarProcesses.ml b/core/desugarProcesses.ml index ae073231d..fbdca59c2 100644 --- a/core/desugarProcesses.ml +++ b/core/desugarProcesses.ml @@ -81,7 +81,7 @@ object (o : 'self_type) Types.(remove_field hear (remove_field wild (Row (fieldenv, rho, false)))) in begin - match StringMap.find Types.hear fieldenv with + match Types.FieldEnv.find Types.hear fieldenv with | (Types.Present mbt) -> o#phrasenode (Switch (fn_appl "recv" [(Type, mbt); (Row, other_effects)] [], diff --git a/core/evalir.ml b/core/evalir.ml index 4fec8d4b0..b471695d9 100644 --- a/core/evalir.ml +++ b/core/evalir.ml @@ -167,7 +167,7 @@ struct opt_app (value env) (Lwt.return (`Record [])) r >>= fun res -> match res with | `Record fs -> - let fields = StringMap.bindings fields in + let fields = Types.FieldEnv.bindings fields in LwtHelpers.foldr_lwt (fun (label, v) (fs: (string * Value.t) list) -> if List.mem_assoc label fs then @@ -598,7 +598,7 @@ struct let get_fields t = match t with | `Record fields -> - StringMap.to_list (fun name p -> (name, Types.Primitive p)) fields + Types.FieldEnv.to_list (fun name p -> (name, Types.Primitive p)) fields | _ -> assert false in let execute_shredded_raw (q, t) = @@ -783,7 +783,7 @@ struct let r, _ = Types.unwrap_row (TypeUtils.extract_row t) in TypeUtils.extract_row_parts r in let fields = - StringMap.fold + Types.FieldEnv.fold (fun name t fields -> let open Types in match t with @@ -881,7 +881,7 @@ struct | `Table { Value.Table.database = (db, _); name = table; row = (fields, _, _); temporal_fields; _ } -> let field_types = - StringMap.map + Types.FieldEnv.map (function | Types.Present t -> t | _ -> assert false) fields @@ -919,7 +919,7 @@ struct match source with | `Table { database = (db, _); name = table; row = (fields, _, _); temporal_fields; _ } -> let field_types = - StringMap.map + Types.FieldEnv.map (function | Types.Present t -> t | _ -> assert false) fields diff --git a/core/generalise.ml b/core/generalise.ml index 009732a6d..b20825a8c 100644 --- a/core/generalise.ml +++ b/core/generalise.ml @@ -78,7 +78,7 @@ let rec get_type_args : gen_kind -> TypeVarSet.t -> datatype -> type_arg list = (* Row *) | Row (field_env, row_var, _) -> let field_vars = - StringMap.fold + FieldEnv.fold (fun _ field_spec vars -> vars @ get_presence_type_args kind bound_vars field_spec ) field_env [] in @@ -149,7 +149,7 @@ let rigidify_type_arg : type_arg -> unit = | Type, Meta point -> rigidify_point point | Presence, Meta point -> rigidify_point point | Row, Row (fields, point, _dual) -> - assert (StringMap.is_empty fields); + assert (FieldEnv.is_empty fields); rigidify_point point (* HACK: probably shouldn't happen *) | Row, Meta point -> rigidify_point point @@ -169,7 +169,7 @@ let mono_type_args : type_arg -> unit = | Type, Meta point -> check_sk point | Presence, Meta point -> check_sk point | Row, Row (fields, point, _dual) -> - assert (StringMap.is_empty fields); + assert (FieldEnv.is_empty fields); check_sk point (* HACK: probably shouldn't happen *) | Row, Meta point -> check_sk point diff --git a/core/instantiate.ml b/core/instantiate.ml index 76226ae94..664fdd1a1 100644 --- a/core/instantiate.ml +++ b/core/instantiate.ml @@ -128,14 +128,14 @@ let instantiates : instantiation_maps -> (datatype -> datatype) * (row -> row) * | Closed -> true | _ -> false in - let field_env' = StringMap.fold + let field_env' = FieldEnv.fold (fun label f field_env' -> let rec add = function - | Present t -> StringMap.add label (Present (inst t)) field_env' + | Present t -> FieldEnv.add label (Present (inst t)) field_env' | Absent -> if is_closed then field_env' - else StringMap.add label Absent field_env' + else FieldEnv.add label Absent field_env' | Meta point -> begin match Unionfind.find point with @@ -146,7 +146,7 @@ let instantiates : instantiation_maps -> (datatype -> datatype) * (row -> row) * else Meta point in - StringMap.add label f field_env' + FieldEnv.add label f field_env' | f -> add f end @@ -157,9 +157,9 @@ let instantiates : instantiation_maps -> (datatype -> datatype) * (row -> row) * in add f) field_env - StringMap.empty in + FieldEnv.empty in let field_env'', row_var', dual' = inst_row_var inst_map rec_env row_var dual |> TypeUtils.extract_row_parts in - Row (StringMap.fold StringMap.add field_env' field_env'', row_var', dual') + Row (FieldEnv.fold FieldEnv.add field_env' field_env'', row_var', dual') (* precondition: row_var has been flattened *) and inst_row_var : instantiation_maps -> inst_env -> row_var -> bool -> row = fun inst_map rec_env row_var dual -> (* HACK: fix the ill-formed rows that are introduced in the @@ -169,28 +169,28 @@ let instantiates : instantiation_maps -> (datatype -> datatype) * (row -> row) * let rowify t = match t with | Row _ -> t - | Meta row_var -> Row (StringMap.empty, row_var, false) + | Meta row_var -> Row (FieldEnv.empty, row_var, false) | Alias (PrimaryKind.Row, _,row) -> row | _ -> assert false in let instr = inst_row inst_map rec_env in let dual_if = if dual then dual_row else fun x -> x in match Unionfind.find row_var with - | Closed -> Row (StringMap.empty, row_var, dual) + | Closed -> Row (FieldEnv.empty, row_var, dual) | Var (var, _, _) -> if IntMap.mem var inst_map then dual_if (rowify (snd (IntMap.find var inst_map))) else - Row (StringMap.empty, row_var, dual) + Row (FieldEnv.empty, row_var, dual) | Recursive (var, kind, rec_row) -> if IntMap.mem var rec_env then - Row (StringMap.empty, IntMap.find var rec_env, dual) + Row (FieldEnv.empty, IntMap.find var rec_env, dual) else begin let var' = Types.fresh_raw_variable () in let point' = Unionfind.fresh (Var (var', kind, `Flexible)) in let rec_row' = inst_row inst_map (IntMap.add var point' rec_env) rec_row in let _ = Unionfind.change point' (Recursive (var', kind, rec_row')) in - Row (StringMap.empty, point', dual) + Row (FieldEnv.empty, point', dual) end | row -> dual_if (instr row) @@ -234,7 +234,7 @@ let instantiate_typ : bool -> datatype -> (type_arg list * datatype) = fun rigid let open PrimaryKind in match Kind.primary_kind kind with | (Type | Presence) as pk -> pk, Meta point - | Row -> Row, Row (StringMap.empty, point, false) in + | Row -> Row, Row (FieldEnv.empty, point, false) in IntMap.add var ty inst_env, ty :: tys in let inst_map, tys = diff --git a/core/ir.ml b/core/ir.ml index 1a7b660bb..4279315ae 100644 --- a/core/ir.ml +++ b/core/ir.ml @@ -22,6 +22,8 @@ type name_set = Utility.stringset [@@deriving show] type 'a name_map = 'a Utility.stringmap [@@deriving show] +type 'a st_name_map = 'a Types.field_env + [@@deriving show] type 'a var_map = 'a Utility.intmap [@@deriving show] @@ -35,7 +37,7 @@ type location = CommonTypes.Location.t type value = | Constant of Constant.t | Variable of var - | Extend of value name_map * value option + | Extend of value st_name_map * value option | Project of Name.t * value | Erase of name_set * value | Inject of Name.t * value * Types.t @@ -174,7 +176,7 @@ let rec is_atom = let with_bindings bs' (bs, tc) = (bs' @ bs, tc) -let unit = Extend (Utility.StringMap.empty, None) +let unit = Extend (Types.FieldEnv.empty, None) let unit_comp = ([], Return unit) type program = computation diff --git a/core/ir.mli b/core/ir.mli index 060918cb8..837eb8341 100644 --- a/core/ir.mli +++ b/core/ir.mli @@ -22,6 +22,8 @@ type name_set = Utility.stringset [@@deriving show] type 'a name_map = 'a Utility.stringmap [@@deriving show] +type 'a st_name_map = 'a Types.field_env + [@@deriving show] type 'a var_map = 'a Utility.intmap [@@deriving show] @@ -35,23 +37,23 @@ type location = CommonTypes.Location.t (* INVARIANT: all IR binders have unique names *) type value = - | Constant of Constant.t (* constant: c *) - | Variable of var (* variable use: x *) - | Extend of value name_map * value option (* record extension: (l1=v1, ..., lk=vk|r) or (l1=v1, ..., lk=vk) *) + | Constant of Constant.t (* constant: c *) + | Variable of var (* variable use: x *) + | Extend of value st_name_map * value option (* record extension: (l1=v1, ..., lk=vk|r) or (l1=v1, ..., lk=vk) *) | Project of Name.t * value (* record projection: r.l *) - | Erase of name_set * value (* erase fields from a record: r\{ls} *) - | Inject of Name.t * value * Types.t (* variant injection: L(v) *) + | Erase of name_set * value (* erase fields from a record: r\{ls} *) + | Inject of Name.t * value * Types.t (* variant injection: L(v) *) - | TAbs of tyvar list * value (* type abstraction: /\xs.v *) - | TApp of value * tyarg list (* type application: v ts *) + | TAbs of tyvar list * value (* type abstraction: /\xs.v *) + | TApp of value * tyarg list (* type application: v ts *) | XmlNode of Name.t * value name_map * value list - (* XML node construction: body *) - | ApplyPure of value * value list (* non-side-effecting application: v ws *) + (* XML node construction: body *) + | ApplyPure of value * value list (* non-side-effecting application: v ws *) - | Closure of var * tyarg list * value (* closure creation: f env *) + | Closure of var * tyarg list * value (* closure creation: f env *) - | Coerce of value * Types.t (* type coercion: v:A *) + | Coerce of value * Types.t (* type coercion: v:A *) and tail_computation = | Return of value diff --git a/core/irCheck.ml b/core/irCheck.ml index f3f6df4de..1355b762c 100644 --- a/core/irCheck.ml +++ b/core/irCheck.ml @@ -222,7 +222,7 @@ let eq_types occurrence : type_eq_context -> (Types.datatype * Types.datatype) - row |> TypeUtils.extract_row_parts in if Types.is_closed_row row then let field_env' = - Utility.StringMap.filter + Types.FieldEnv.filter ( fun _ v -> match v with | T.Absent -> false | _ -> true ) @@ -434,12 +434,12 @@ let eq_types occurrence : type_eq_context -> (Types.datatype * Types.datatype) - | _, _ -> false and eq_field_envs (context, lfield_env, rfield_env) = let lfields_in_rfields = - StringMap.for_all (fun field lp -> - match StringMap.find_opt field rfield_env with + Types.FieldEnv.for_all (fun field lp -> + match Types.FieldEnv.find_opt field rfield_env with | Some rp -> eq_presence (context, lp, rp) | None -> false ) lfield_env in - lfields_in_rfields && StringMap.cardinal lfield_env = StringMap.cardinal rfield_env + lfields_in_rfields && Types.FieldEnv.cardinal lfield_env = Types.FieldEnv.cardinal rfield_env and eq_row_vars (context, lpoint, rpoint) = match Unionfind.find lpoint, Unionfind.find rpoint with | Closed, Closed -> true @@ -477,7 +477,7 @@ let check_eq_type_lists = fun (ctx : type_eq_context) exptl actl occurrence -> let ensure_effect_present_in_row ctx allowed_effects required_effect_name required_effect_type occurrence = let (map, _, _) = fst (Types.unwrap_row allowed_effects) |> TypeUtils.extract_row_parts in - match StringMap.find_opt required_effect_name map with + match Types.FieldEnv.find_opt required_effect_name map with | Some (T.Present et) -> check_eq_types ctx et required_effect_type occurrence | _ -> raise_ir_type_error ("Required effect " ^ required_effect_name ^ " not present in effect row " ^ Types.string_of_row allowed_effects) occurrence @@ -572,7 +572,7 @@ struct | Ir.Constant c -> let (o, c, t) = o#constant c in o, Ir.Constant c, t | Variable x -> let (o, x, t) = o#var x in o, Variable x, t | Extend (fields, base) as orig -> - let (o, fields, field_types) = o#name_map (fun o -> o#value) fields in + let (o, fields, field_types) = o#st_name_map (fun o -> o#value) fields in let (o, base, base_type) = o#option (fun o -> o#value) base in let handle_extended_record = function @@ -735,7 +735,7 @@ struct | Variant row as variant -> let unwrapped_row = fst (unwrap_row row) |> TypeUtils.extract_row_parts in let present_fields, has_bad_presence_polymorphism = - StringMap.fold (fun field field_spec (fields, poly) -> match field_spec with + Types.FieldEnv.fold (fun field field_spec (fields, poly) -> match field_spec with | Present _ -> (StringSet.add field fields), poly | Meta _ -> fields, StringMap.mem field cases | Absent -> fields, poly @@ -1057,12 +1057,12 @@ struct if StringMap.mem effect inner_effects_map_from_branches then map else - StringMap.add effect outer_presence_spec map + Types.FieldEnv.add effect outer_presence_spec map ) inner_effects_map_from_branches outer_effects_map in let inner_effects = Row (inner_effects_map, outer_effects_var, outer_effects_dualized) in (if not (Types.is_closed_row outer_effects) then - let outer_effects_contain e = StringMap.mem e outer_effects_map in + let outer_effects_contain e = Types.FieldEnv.mem e outer_effects_map in ensure (StringMap.for_all (fun e _ -> outer_effects_contain e) cases) "Outer effects are open but do not mention an effect handled by handler" (SSpec special)); (* comp_t is A_c in the IR formalization *) diff --git a/core/irTraversals.ml b/core/irTraversals.ml index 64d4b731b..ae4fc0536 100644 --- a/core/irTraversals.ml +++ b/core/irTraversals.ml @@ -37,6 +37,10 @@ module type IR_VISITOR = sig 'a. ('self_type -> 'a -> ('self_type * 'a * Types.datatype)) -> 'a name_map -> 'self_type * 'a name_map * Types.datatype name_map + method st_name_map : + 'a. + ('self_type -> 'a -> ('self_type * 'a * Types.datatype)) -> + 'a st_name_map -> 'self_type * 'a st_name_map * Types.datatype st_name_map method var_map : 'a. ('self_type -> 'a -> ('self_type * 'a * Types.datatype)) -> @@ -138,6 +142,19 @@ struct vmap (o, StringMap.empty, StringMap.empty) + method st_name_map : + 'a. + ('self_type -> 'a -> ('self_type * 'a * datatype)) -> + 'a st_name_map -> 'self_type * 'a st_name_map * datatype st_name_map = + fun f vmap -> + Types.FieldEnv.fold + (fun name v (o, vmap, tmap) -> + let (o, v, t) = f o v in + (o, Types.FieldEnv.add name v vmap, + Types.FieldEnv.add name t tmap)) + vmap + (o, Types.FieldEnv.empty, Types.FieldEnv.empty) + method var_map : 'a. ('self_type -> 'a -> ('self_type * 'a * datatype)) -> @@ -179,7 +196,7 @@ struct | Ir.Constant c -> let (o, c, t) = o#constant c in o, Ir.Constant c, t | Variable x -> let (o, x, t) = o#var x in o, Ir.Variable x, t | Extend (fields, base) -> - let (o, fields, field_types) = o#name_map (fun o -> o#value) fields in + let (o, fields, field_types) = o#st_name_map (fun o -> o#value) fields in let (o, base, base_type) = o#option (fun o -> o#value) base in let t = diff --git a/core/irTraversals.mli b/core/irTraversals.mli index e84ccc733..e1f3a6db3 100644 --- a/core/irTraversals.mli +++ b/core/irTraversals.mli @@ -28,6 +28,10 @@ sig 'a. ('self_type -> 'a -> ('self_type * 'a * Types.datatype)) -> 'a name_map -> 'self_type * 'a name_map * Types.datatype name_map + method st_name_map : + 'a. + ('self_type -> 'a -> ('self_type * 'a * Types.datatype)) -> + 'a st_name_map -> 'self_type * 'a st_name_map * Types.datatype st_name_map method var_map : 'a. ('self_type -> 'a -> ('self_type * 'a * Types.datatype)) -> diff --git a/core/irtojs.ml b/core/irtojs.ml index 8ef409e8b..56eddaff5 100644 --- a/core/irtojs.ml +++ b/core/irtojs.ml @@ -861,7 +861,7 @@ end = functor (K : CONTINUATION) -> struct | Ir.Extend (field_map, rest) -> let dict = Dict - (StringMap.fold + (Types.FieldEnv.fold (fun name v dict -> (name, gv v) :: dict) field_map []) @@ -1242,8 +1242,8 @@ end = functor (K : CONTINUATION) -> struct let name_map = List.fold_left (fun box (i, _, initial_value) -> - StringMap.add (string_of_int i) initial_value box) - StringMap.empty params + Types.FieldEnv.add (string_of_int i) initial_value box) + Types.FieldEnv.empty params in (Ir.Let (param_ptr_binder, ([], Ir.Return (Ir.Extend (name_map, None)))) :: bs, tc) in diff --git a/core/lens_ir_conv.ml b/core/lens_ir_conv.ml index 5f1b0fead..af73a15f7 100644 --- a/core/lens_ir_conv.ml +++ b/core/lens_ir_conv.ml @@ -348,7 +348,7 @@ let lens_sugar_phrase_of_ir p env = | I.Extend (ext_fields, r) -> let r = Option.map ~f:(links_value env) r in Option.value r ~default:(`Record [] |> Result.return) >>= fun r -> - let fields = StringMap.to_alist ext_fields in + let fields = Types.FieldEnv.to_alist ext_fields in List.map_result ~f:(fun (k, v) -> links_value env v >>| fun v -> (k, v)) fields diff --git a/core/lens_type_conv.ml b/core/lens_type_conv.ml index d971c0fe9..854fcc494 100644 --- a/core/lens_type_conv.ml +++ b/core/lens_type_conv.ml @@ -8,8 +8,8 @@ type 'a die = string -> 'a let to_links_map m = String.Map.fold - (fun k v m -> Utility.StringMap.add k v m) - m Utility.StringMap.empty + (fun k v m -> Types.FieldEnv.add k v m) + m Types.FieldEnv.empty let lookup_alias context ~alias = match Env.String.find_opt alias context with @@ -50,7 +50,7 @@ let rec lens_phrase_type_of_type t = | T.Record r -> lens_phrase_type_of_type r | T.Row (fields, _, _) -> let fields = - Utility.StringMap.to_alist fields + Types.FieldEnv.to_alist fields |> String.Map.from_alist |> String.Map.map (fun v -> match v with diff --git a/core/lib.ml b/core/lib.ml index f5b6e2e44..41f2a677b 100644 --- a/core/lib.ml +++ b/core/lib.ml @@ -1813,7 +1813,7 @@ let rec function_arity = function | Function (Record row, _, _) -> let (l, _, _) = TypeUtils.extract_row_parts row in - (Some (StringMap.size l)) + (Some (FieldEnv.size l)) | ForAll (_, t) -> function_arity t | _ -> None diff --git a/core/page.ml b/core/page.ml index 33c74c6da..9f9485dfc 100644 --- a/core/page.ml +++ b/core/page.ml @@ -120,7 +120,7 @@ module Make_RealPage (C : JS_PAGE_COMPILER) (G : JS_CODEGEN) = struct let escaped_state_string = `String state_string |> Json.json_to_string in let printed_code = - let _venv, code = C.generate_program venv ([], Ir.Return (Ir.Extend (StringMap.empty, None))) in + let _venv, code = C.generate_program venv ([], Ir.Return (Ir.Extend (Types.FieldEnv.empty, None))) in let code = f code in let code = code |> (C.generate_stubs valenv defs) |> C.wrap_with_server_lib_stubs diff --git a/core/query/delateralize.ml b/core/query/delateralize.ml index 789b3eaae..21202e65f 100644 --- a/core/query/delateralize.ml +++ b/core/query/delateralize.ml @@ -46,7 +46,7 @@ let rew_delateralize genkind gs q1 x (q2,ty2) y (q3,ty3) = to a conjunction of equalities over their fields; however, here we are using a flattened version of the record p, so extracting p.1 really amounts to building a new record; maybe it wouldn't be much smarter, after all *) let eq_query = - StringMap.fold + Types.FieldEnv.fold (fun f _ acc -> and_query acc (eq_test (QL.Project (vx, f)) (QL.Project (vp, Q.flatfield "1" f)))) (QL.recdty_field_types ty2) (QL.Constant (Constant.Bool true)) @@ -54,10 +54,10 @@ let rew_delateralize genkind gs q1 x (q2,ty2) y (q3,ty3) = (* eta-expanded p.2, with record flattening *) let rp = QL.Record - (StringMap.fold - (fun f _ acc -> StringMap.add f (QL.Project (vp, Q.flatfield "2" f)) acc) + (Types.FieldEnv.fold + (fun f _ acc -> Types.FieldEnv.add f (QL.Project (vp, Q.flatfield "2" f)) acc) (QL.recdty_field_types ty3) - StringMap.empty) + Types.FieldEnv.empty) in let q1_rp = QL.subst q1 y rp in @@ -119,8 +119,8 @@ let rec delateralize_step q = | QL.Dedup t -> ds t >>=? fun t' -> Some (QL.Dedup t') | QL.Prom t -> ds t >>=? fun t' -> Some (QL.Prom t') | QL.Record fl -> - let ofl = StringMap.to_alist fl >>==? fun (z,qz) -> ds qz >>=? fun qz' -> Some (z,qz') in - ofl >>=? fun fl' -> Some (QL.Record (StringMap.from_alist fl')) + let ofl = Types.FieldEnv.to_alist fl >>==? fun (z,qz) -> ds qz >>=? fun qz' -> Some (z,qz') in + ofl >>=? fun fl' -> Some (QL.Record (Types.FieldEnv.from_alist fl')) | QL.Project (t,f) -> ds t >>=? fun t' -> Some (QL.Project (t',f)) (* XXX: assumes no Closures are left *) diff --git a/core/query/evalMixingQuery.ml b/core/query/evalMixingQuery.ml index 4a3f710a7..7720eecad 100644 --- a/core/query/evalMixingQuery.ml +++ b/core/query/evalMixingQuery.ml @@ -57,8 +57,8 @@ and aggregator ar q = let z = Var.fresh_raw_var () in let tyk, _tyv = q |> QL.type_of_expression |> Types.unwrap_map_type in let fsk, _, _ = tyk |> Types.extract_row |> Types.extract_row_parts in - let fields_k = fsk |> StringMap.to_alist |> List.map (fun (f,_) -> S.Project (z, "1@" ^ f), "1@" ^ f) in - let fields_v = ar |> StringMap.to_alist |> List.map (fun (f_out, (aggfun, f_in)) -> + let fields_k = fsk |> Types.FieldEnv.to_alist |> List.map (fun (f,_) -> S.Project (z, "1@" ^ f), "1@" ^ f) in + let fields_v = ar |> Types.FieldEnv.to_alist |> List.map (fun (f_out, (aggfun, f_in)) -> S.Apply (aggr aggfun, [S.Project (z, "2@" ^ f_in)]), "2@" ^ f_out) in let fields = fields_k @ fields_v in @@ -72,7 +72,7 @@ and generator locvars = function S.Subquery (S.Standard, S.Select (S.Distinct, S.Star, [S.TableRef (name, v)], S.Constant (Constant.Bool true), [], []), v) | (QL.Keys, v, QL.GroupBy ((x, QL.Record gc), QL.Table Value.Table.{ name; _})) | (QL.Keys, v, QL.GroupBy ((x, QL.Record gc), QL.Dedup (QL.Table Value.Table.{ name; _}))) -> - let fields = List.map (fun (f,e) -> (base_exp e, f)) (StringMap.to_alist gc) in + let fields = List.map (fun (f,e) -> (base_exp e, f)) (Types.FieldEnv.to_alist gc) in S.Subquery (dependency_of_contains_free (E.contains_free locvars (QL.Record gc)), S.Select (S.Distinct, S.Fields fields, [S.TableRef (name, x)], S.Constant (Constant.Bool true), [], []), v) | (QL.Keys, v, q) -> @@ -81,7 +81,7 @@ and generator locvars = function let fsk, _, _ = tyk |> Types.extract_row |> Types.extract_row_parts in let fields = fsk - |> StringMap.to_alist + |> Types.FieldEnv.to_alist |> List.map (fun (f,_) -> S.Project (z, "1@" ^ f), f) in S.Subquery (dependency_of_contains_free (E.contains_free locvars q), @@ -107,21 +107,21 @@ and body is_set gs os j = | QL.Concat [] -> dummy_sql_empty_query | QL.Singleton (QL.Record fields) -> selquery - <| List.map (fun (f,x) -> (base_exp x, f)) (StringMap.to_alist fields) + <| List.map (fun (f,x) -> (base_exp x, f)) (Types.FieldEnv.to_alist fields) <| Sql.Constant (Constant.Bool true) | QL.Singleton (QL.MapEntry (QL.Record keys, QL.Record values)) -> selquery - <| List.map (fun (f,x) -> (base_exp x, "1@" ^ f)) (StringMap.to_alist keys) - @ List.map (fun (f,x) -> (base_exp x, "2@" ^ f)) (StringMap.to_alist values) + <| List.map (fun (f,x) -> (base_exp x, "1@" ^ f)) (Types.FieldEnv.to_alist keys) + @ List.map (fun (f,x) -> (base_exp x, "2@" ^ f)) (Types.FieldEnv.to_alist values) <| Sql.Constant (Constant.Bool true) | QL.If (c, QL.Singleton (QL.Record fields), QL.Concat []) -> selquery - <| List.map (fun (f,x) -> (base_exp x, f)) (StringMap.to_alist fields) + <| List.map (fun (f,x) -> (base_exp x, f)) (Types.FieldEnv.to_alist fields) <| base_exp c | QL.If (c, QL.Singleton (QL.MapEntry (QL.Record keys, QL.Record values)), QL.Concat []) -> selquery - <| List.map (fun (f,x) -> (base_exp x, "1@" ^ f)) (StringMap.to_alist keys) - @ List.map (fun (f,x) -> (base_exp x, "2@" ^ f)) (StringMap.to_alist values) + <| List.map (fun (f,x) -> (base_exp x, "1@" ^ f)) (Types.FieldEnv.to_alist keys) + @ List.map (fun (f,x) -> (base_exp x, "2@" ^ f)) (Types.FieldEnv.to_alist values) <| base_exp c | _ -> Debug.print ("error in EvalMixingQuery.body: unexpected j = " ^ QL.show j); failwith "body" @@ -196,13 +196,13 @@ let compile_mixing : delateralize:QueryPolicy.t -> Value.env -> (int * int) opti let tyk, tyv = Types.unwrap_mapentry_type t_flat in let rowk, _, _ = tyk |> Types.extract_row |> Types.extract_row_parts in let rowv, _, _ = tyv |> Types.extract_row |> Types.extract_row_parts in - let row = StringMap.fold - <| (fun k v acc -> StringMap.add ("1@" ^ k) (strip_presence v) acc) + let row = Types.FieldEnv.fold + <| (fun k v acc -> Types.FieldEnv.add ("1@" ^ k) (strip_presence v) acc) <| rowk - <| StringMap.empty + <| Types.FieldEnv.empty in - let row = StringMap.fold - <| (fun k v acc -> StringMap.add ("2@" ^ k) (strip_presence v) acc) + let row = Types.FieldEnv.fold + <| (fun k v acc -> Types.FieldEnv.add ("2@" ^ k) (strip_presence v) acc) <| rowv <| row in diff --git a/core/query/evalNestedQuery.ml b/core/query/evalNestedQuery.ml index bf3817b8d..3a57a293f 100644 --- a/core/query/evalNestedQuery.ml +++ b/core/query/evalNestedQuery.ml @@ -28,7 +28,7 @@ let tag_query : QL.t -> QL.t = Concat (List.map tag es) | Dedup t -> Dedup (tag t) | Prom t -> Prom (tag t) - | Record fields -> Record (StringMap.map tag fields) + | Record fields -> Record (Types.FieldEnv.map tag fields) | Project (e, l) -> Project (tag e, l) | Erase (e, fields) -> Erase (tag e, fields) | Variant (l, e) -> Variant (l, tag e) @@ -42,7 +42,7 @@ let tag_query : QL.t -> QL.t = | Database db -> Database db | GroupBy ((x,k), q) -> GroupBy ((x,tag k), tag q) (* XXX: defensive programming: recursion on ar not needed now, but might be in the future *) - | AggBy (ar, q) -> AggBy (StringMap.map (fun (x,y) -> tag x, y) ar, tag q) + | AggBy (ar, q) -> AggBy (Types.FieldEnv.map (fun (x,y) -> tag x, y) ar, tag q) | Lookup (q,k) -> Lookup (tag q, tag k) in tag e @@ -50,8 +50,8 @@ let tag_query : QL.t -> QL.t = let tuple xs = QL.Record (snd (List.fold_left (fun (i, fields) x -> - (i+1, StringMap.add (string_of_int i) x fields)) - (1, StringMap.empty) + (i+1, Types.FieldEnv.add (string_of_int i) x fields)) + (1, Types.FieldEnv.empty) xs)) let pair x y = tuple [x; y] @@ -59,11 +59,11 @@ module Shred = struct type nested_type = [ `Primitive of Primitive.t - | `Record of nested_type StringMap.t + | `Record of nested_type Types.FieldEnv.t | `List of nested_type ] [@@deriving show] - type 'a shredded = [`Primitive of 'a | `Record of ('a shredded) StringMap.t] + type 'a shredded = [`Primitive of 'a | `Record of ('a shredded) Types.FieldEnv.t] [@@deriving show] type shredded_type = Primitive.t shredded [@@deriving show] @@ -72,12 +72,12 @@ struct type flat_type = [ `Primitive of Primitive.t - | `Record of Primitive.t StringMap.t ] + | `Record of Primitive.t Types.FieldEnv.t ] [@@deriving show] type 'a package = [ `Primitive of Primitive.t - | `Record of 'a package StringMap.t + | `Record of 'a package Types.FieldEnv.t | `List of 'a package * 'a ] [@@deriving show] @@ -96,7 +96,7 @@ struct | Types.Primitive t -> `Primitive t | Types.Record row -> let (fields, _, _) = TypeUtils.extract_row_parts row in - `Record (StringMap.map + `Record (Types.FieldEnv.map (function | Present t -> nested_type_of_type t | _ -> assert false) fields) @@ -111,7 +111,7 @@ struct let rec erase : 'a package -> nested_type = function | `Primitive t -> `Primitive t - | `Record fields -> `Record (StringMap.map erase fields) + | `Record fields -> `Record (Types.FieldEnv.map erase fields) | `List (t, _) -> `List (erase t) (* map over a package *) @@ -119,7 +119,7 @@ struct fun f -> function | `Primitive t -> `Primitive t - | `Record fields -> `Record (StringMap.map (pmap f) fields) + | `Record fields -> `Record (Types.FieldEnv.map (pmap f) fields) | `List (t, a) -> `List (pmap f t, f a) (* construct a package using a shredding function f *) @@ -127,11 +127,11 @@ struct let rec package f p = function | `Primitive t -> `Primitive t - | `Record fields -> `Record (StringMap.fold + | `Record fields -> `Record (Types.FieldEnv.fold (fun name t fields -> - StringMap.add name (package f (p @ [`Record name]) t) fields) + Types.FieldEnv.add name (package f (p @ [`Record name]) t) fields) fields - StringMap.empty) + Types.FieldEnv.empty) | `List t -> `List (package f (p @ [`List]) t, f p) in package f [] @@ -142,12 +142,12 @@ struct | `Primitive t1, `Primitive _ -> `Primitive t1 | `Record fields1, `Record fields2 -> `Record - (StringMap.fold + (Types.FieldEnv.fold (fun name t1 fields -> - let t2 = StringMap.find name fields2 in - StringMap.add name (pzip t1 t2) fields) + let t2 = Types.FieldEnv.find name fields2 in + Types.FieldEnv.add name (pzip t1 t2) fields) fields1 - StringMap.empty) + Types.FieldEnv.empty) | `List (t1, a1), `List (t2, a2) -> `List (pzip t1 t2, (a1, a2)) @@ -179,7 +179,7 @@ struct | Apply (Primitive "length", [e]) -> Apply (Primitive "length", [shred_outer e []]) | Apply (f, vs) -> Apply (f, List.map (shinner a) vs) | Record fields -> - Record (StringMap.map (shinner a) fields) + Record (Types.FieldEnv.map (shinner a) fields) | e when QL.is_list e -> in_index a | e -> e @@ -194,7 +194,7 @@ struct begin match p with | (`Record l :: p) -> - shouter a p (StringMap.find l fields) + shouter a p (Types.FieldEnv.find l fields) | _ -> assert false end | For (Some b, gs, os, body) -> @@ -222,28 +222,28 @@ struct let rec shred_inner_type : nested_type -> shredded_type = function | `Primitive p -> `Primitive p - | `Record fields -> `Record (StringMap.map shred_inner_type fields) + | `Record fields -> `Record (Types.FieldEnv.map shred_inner_type fields) | `List _ -> `Record - (StringMap.add "1" (`Primitive Primitive.Int) - (StringMap.add "2" (`Primitive Primitive.Int) StringMap.empty)) + (Types.FieldEnv.add "1" (`Primitive Primitive.Int) + (Types.FieldEnv.add "2" (`Primitive Primitive.Int) Types.FieldEnv.empty)) let rec shred_outer_type : nested_type -> path -> shredded_type = fun t p -> match t, p with | `List t, [] -> `Record - (StringMap.add "1" + (Types.FieldEnv.add "1" (`Record - (StringMap.add "1" (`Primitive Primitive.Int) - (StringMap.add "2" (`Primitive Primitive.Int) - StringMap.empty))) - (StringMap.add "2" (shred_inner_type t) - StringMap.empty)) + (Types.FieldEnv.add "1" (`Primitive Primitive.Int) + (Types.FieldEnv.add "2" (`Primitive Primitive.Int) + Types.FieldEnv.empty))) + (Types.FieldEnv.add "2" (shred_inner_type t) + Types.FieldEnv.empty)) | `List t, `List :: p -> shred_outer_type t p | `Record fields, `Record l :: p -> - shred_outer_type (StringMap.find l fields) p + shred_outer_type (Types.FieldEnv.find l fields) p | _ -> assert false let shred_query_type : nested_type -> shredded_type package = @@ -286,7 +286,7 @@ struct function | If (c, t, e) -> If (inner c, inner t, inner e) - | Record fields -> Record (StringMap.map inner fields) + | Record fields -> Record (Types.FieldEnv.map inner fields) | Project (e, l) -> Project (inner e, l) | Apply (f, es) -> Apply (f, List.map inner es) | Primitive p -> Primitive p @@ -404,7 +404,7 @@ struct | Apply (Primitive f, es) -> Apply (Primitive f, List.map li es) | Record fields -> - Record (StringMap.map li fields) + Record (Types.FieldEnv.map li fields) | Primitive "out" -> (* z.2 *) Project (Var (z, z_fields), "2") @@ -443,7 +443,7 @@ struct For Empty and length we don't care about what the body returns. *) - | Singleton _ -> Singleton (Record StringMap.empty) + | Singleton _ -> Singleton (Record Types.FieldEnv.empty) | e -> Debug.print ("Can't apply lins_inner_query to: " ^ QL.show e); assert false @@ -536,19 +536,19 @@ struct | Record fields -> (* concatenate labels of nested records *) Record - (StringMap.fold + (Types.FieldEnv.fold (fun name body fields -> match flatten_inner body with | Record inner_fields -> - StringMap.fold + Types.FieldEnv.fold (fun name' body fields -> - StringMap.add (name ^ "@" ^ name') body fields) + Types.FieldEnv.add (name ^ "@" ^ name') body fields) inner_fields fields | body -> - StringMap.add name body fields) + Types.FieldEnv.add name body fields) fields - StringMap.empty) + Types.FieldEnv.empty) | Variant ("Simply", x) -> Variant ("Simply", flatten_inner x) | Variant ("Seq", Singleton r) -> @@ -580,7 +580,7 @@ struct (* lift base expressions to records *) match flatten_inner e with | Record fields -> Record fields - | p -> Record (StringMap.add "@" p StringMap.empty) + | p -> Record (Types.FieldEnv.add "@" p Types.FieldEnv.empty) in Singleton e' (* HACK: not sure if Concat is supposed to appear here... @@ -608,39 +608,39 @@ struct | `Primitive p -> `Primitive p | `Record fields -> `Record - (StringMap.fold + (Types.FieldEnv.fold (fun name t fields -> match flatten_type t with | `Record inner_fields -> - StringMap.fold + Types.FieldEnv.fold (fun name' t fields -> - StringMap.add (name ^ "@" ^ name') t fields) + Types.FieldEnv.add (name ^ "@" ^ name') t fields) inner_fields fields | `Primitive p -> - StringMap.add name p fields) + Types.FieldEnv.add name p fields) fields - StringMap.empty) + Types.FieldEnv.empty) let flatten_query_type : shredded_type -> flat_type = flatten_type (* add a flattened field to an unflattened record (type or value) *) - let rec unflatten_field : string list -> 'a -> ('a shredded) StringMap.t -> ('a shredded) StringMap.t = + let rec unflatten_field : string list -> 'a -> ('a shredded) Types.FieldEnv.t -> ('a shredded) Types.FieldEnv.t = fun names v fields -> match names with - | [name] -> StringMap.add name (`Primitive v) fields + | [name] -> Types.FieldEnv.add name (`Primitive v) fields | name::name'::names -> let fields' = - if StringMap.mem name fields then - let w = StringMap.find name fields in + if Types.FieldEnv.mem name fields then + let w = Types.FieldEnv.find name fields in match w with | `Record fields' -> fields' | _ -> assert false else - StringMap.empty in + Types.FieldEnv.empty in let fields' = unflatten_field (name'::names) v fields' in - StringMap.add name (`Record fields') fields + Types.FieldEnv.add name (`Record fields') fields | [] -> assert false (* fill in any unit fields that are apparent from the type but not @@ -651,17 +651,17 @@ struct | `Primitive _, `Primitive v -> `Primitive v | `Record fts, `Record fs -> `Record - (StringMap.fold + (Types.FieldEnv.fold (fun name t fields -> let v = - if StringMap.mem name fs then - StringMap.find name fs + if Types.FieldEnv.mem name fs then + Types.FieldEnv.find name fs else - `Record (StringMap.empty) + `Record (Types.FieldEnv.empty) in - StringMap.add name (fill t v) fields) + Types.FieldEnv.add name (fill t v) fields) fts - StringMap.empty) + Types.FieldEnv.empty) | _ -> assert false let unflatten_type : flat_type -> shredded_type = @@ -669,12 +669,12 @@ struct | `Primitive p -> `Primitive p | `Record fields -> `Record - (StringMap.fold + (Types.FieldEnv.fold (fun name p fields -> let names = split_string name '@' in unflatten_field names p fields) fields - StringMap.empty) + Types.FieldEnv.empty) (* Fast unflattening. @@ -702,13 +702,13 @@ Fast unflattening. | `Record rcd -> `Record (List.map (fun (nm,t') -> (nm,make_tmpl_inner (name ^"@"^nm) t')) - (StringMap.to_alist rcd)) + (Types.FieldEnv.to_alist rcd)) and make_tmpl_outer t = match t with `Primitive _ -> `Primitive "" | `Record rcd -> `Record (List.map (fun (nm,t') -> (nm,make_tmpl_inner nm t')) - (StringMap.to_alist rcd)) + (Types.FieldEnv.to_alist rcd)) in make_tmpl_outer ty let build_unflattened_record : string template -> Value.t -> Value.t = @@ -760,7 +760,7 @@ struct | c, `Primitive _ -> c | `Record fs, `Record fts -> `Record - (List.map (fun (l, v) -> (l, stitch v (StringMap.find l fts))) fs) + (List.map (fun (l, v) -> (l, stitch v (Types.FieldEnv.find l fts))) fs) | `Record [("1", `Int a); ("2", `Int d)], `List (t, m) -> (*`List (List.map (fun w -> stitch w t) (lookup (a, d) m))*) diff --git a/core/query/evalQuery.ml b/core/query/evalQuery.ml index b0a3a609d..c8ebb783c 100644 --- a/core/query/evalQuery.ml +++ b/core/query/evalQuery.ml @@ -106,7 +106,7 @@ struct let field_types = QL.table_field_types t in let tyx = Types.make_record_type field_types in List.rev - (StringMap.fold + (Types.FieldEnv.fold (fun name _t es -> QL.Project (QL.Var (x, tyx), name) :: es ) field_types []) @@ -262,7 +262,7 @@ struct | [] -> fields | o :: os -> add_indexes - (StringMap.add ("order_" ^ string_of_int i) o fields) + (Types.FieldEnv.add ("order_" ^ string_of_int i) o fields) (i+1) os in let rec order = diff --git a/core/query/mixingQuery.ml b/core/query/mixingQuery.ml index 8ba326716..6da3f6fa6 100644 --- a/core/query/mixingQuery.ml +++ b/core/query/mixingQuery.ml @@ -59,7 +59,7 @@ let rec freshen_for_bindings : Var.var Env.Int.t -> Q.t -> Q.t = | Q.Concat vs -> Q.Concat (List.map ffb vs) | Q.Dedup q -> Q.Dedup (ffb q) | Q.Prom q -> Q.Prom (ffb q) - | Q.Record fields -> Q.Record (StringMap.map ffb fields) + | Q.Record fields -> Q.Record (Types.FieldEnv.map ffb fields) | Q.Variant (name, v) -> Q.Variant (name, ffb v) | Q.XML xmlitem -> Q.XML xmlitem | Q.Project (v, name) -> Q.Project (ffb v, name) @@ -83,7 +83,7 @@ let rec freshen_for_bindings : Var.var Env.Int.t -> Q.t -> Q.t = let env' = Env.Int.bind v y env in Q.GroupBy ((y, freshen_for_bindings env' i), ffb q) (* XXX: defensive programming; recursion on ar not needed now, but may be in the future *) - | Q.AggBy (ar, q) -> Q.AggBy (StringMap.map (fun (x,y) -> ffb x, y) ar, ffb q) + | Q.AggBy (ar, q) -> Q.AggBy (Types.FieldEnv.map (fun (x,y) -> ffb x, y) ar, ffb q) | Q.Lookup (q,k) -> Q.Lookup (ffb q, ffb k) let flatfield f1 f2 = f1 ^ "@" ^ f2 @@ -91,23 +91,23 @@ let flatfield f1 f2 = f1 ^ "@" ^ f2 let rec flattened_pair x y = match x, y with | Q.Var (_nx, Types.Record row), _ -> - let x' = Q.Record (StringMap.fold (fun f _ acc -> StringMap.add f (Q.Project (x,f)) acc) (Q.field_types_of_row row) StringMap.empty) + let x' = Q.Record (Types.FieldEnv.fold (fun f _ acc -> Types.FieldEnv.add f (Q.Project (x,f)) acc) (Q.field_types_of_row row) Types.FieldEnv.empty) in flattened_pair x' y | _, Q.Var (_ny, Types.Record row) -> - let y' = Q.Record (StringMap.fold (fun f _ acc -> StringMap.add f (Q.Project (y,f)) acc) (Q.field_types_of_row row) StringMap.empty) + let y' = Q.Record (Types.FieldEnv.fold (fun f _ acc -> Types.FieldEnv.add f (Q.Project (y,f)) acc) (Q.field_types_of_row row) Types.FieldEnv.empty) in flattened_pair x y' (* We use a field with an empty name to deal with variables of non-record type *) | Q.Var (_nx, _), _ -> - let x' = Q.Record (StringMap.from_alist ["",x]) + let x' = Q.Record (Types.FieldEnv.from_alist ["",x]) in flattened_pair x' y | _, Q.Var (_ny, _) -> - let y' = Q.Record (StringMap.from_alist ["",y]) + let y' = Q.Record (Types.FieldEnv.from_alist ["",y]) in flattened_pair x y' | Q.Record fty1, Q.Record fty2 -> let out1 = - StringMap.fold (fun f v acc -> StringMap.add (flatfield "1" f) v acc) fty1 StringMap.empty + Types.FieldEnv.fold (fun f v acc -> Types.FieldEnv.add (flatfield "1" f) v acc) fty1 Types.FieldEnv.empty in - let out2 = StringMap.fold (fun f v acc -> StringMap.add (flatfield "2" f) v acc) fty2 out1 + let out2 = Types.FieldEnv.fold (fun f v acc -> Types.FieldEnv.add (flatfield "2" f) v acc) fty2 out1 in Q.Record out2 | _ -> assert false @@ -115,12 +115,12 @@ let rec flattened_pair_ft x y = match x, y with | Q.Var (_nx, Types.Record rowx), Q.Var (_ny, Types.Record rowy) -> let out1 = - StringMap.fold (fun f t acc -> StringMap.add (flatfield "1" f) t acc) (Q.field_types_of_row rowx) StringMap.empty + Types.FieldEnv.fold (fun f t acc -> Types.FieldEnv.add (flatfield "1" f) t acc) (Q.field_types_of_row rowx) Types.FieldEnv.empty in - StringMap.fold (fun f t acc -> StringMap.add (flatfield "2" f) t acc) (Q.field_types_of_row rowy) out1 + Types.FieldEnv.fold (fun f t acc -> Types.FieldEnv.add (flatfield "2" f) t acc) (Q.field_types_of_row rowy) out1 (* XXX: same as above, using a field with an empty name to deal with variables of non-record type *) - | Q.Var (nx, tyx), _ -> flattened_pair_ft (Q.Var (nx, Types.make_record_type (StringMap.from_alist ["", tyx]))) y - | _, Q.Var (ny, tyy) -> flattened_pair_ft x (Q.Var (ny, Types.make_record_type (StringMap.from_alist ["", tyy]))) + | Q.Var (nx, tyx), _ -> flattened_pair_ft (Q.Var (nx, Types.make_record_type (Types.FieldEnv.from_alist ["", tyx]))) y + | _, Q.Var (ny, tyy) -> flattened_pair_ft x (Q.Var (ny, Types.make_record_type (Types.FieldEnv.from_alist ["", tyy]))) | _ -> assert false (* gs must ALWAYS be non-empty, both input and output!*) @@ -181,8 +181,8 @@ let rec reduce_eq (a, b) = List.fold_right2 (fun (_, v1) (_, v2) e -> reduce_and (reduce_eq (v1, v2), e)) - (StringMap.to_alist lfields) - (StringMap.to_alist rfields) + (Types.FieldEnv.to_alist lfields) + (Types.FieldEnv.to_alist rfields) (Q.Constant (Constant.Bool true)) | (a, b) -> Q.Apply (Q.Primitive "==", [a; b]) @@ -221,14 +221,14 @@ let rec reduce_if_body (c, t, e) = | Q.Record then_fields -> begin match e with | Q.Record else_fields -> - assert (StringMap.equal (fun _ _ -> true) then_fields else_fields); + assert (Types.FieldEnv.equal (fun _ _ -> true) then_fields else_fields); Q.Record - (StringMap.fold + (Types.FieldEnv.fold (fun name t fields -> - let e = StringMap.find name else_fields in - StringMap.add name (reduce_if_body (c, t, e)) fields) + let e = Types.FieldEnv.find name else_fields in + Types.FieldEnv.add name (reduce_if_body (c, t, e)) fields) then_fields - StringMap.empty) + Types.FieldEnv.empty) (* NOTE: this relies on any record variables having been eta-expanded by this point *) | _ -> Q.query_error "Mismatched fields" @@ -273,13 +273,13 @@ struct let rec reduce_project (r, label) = match r with | Q.Record fields -> - assert (StringMap.mem label fields); - StringMap.find label fields + assert (Types.FieldEnv.mem label fields); + Types.FieldEnv.find label fields | Q.If (c, t, e) -> Q.If (c, reduce_project (t, label), reduce_project (e, label)) | Q.Var (_x, Types.Record row) -> let field_types = Q.field_types_of_row row in - assert (StringMap.mem label field_types); + assert (Types.FieldEnv.mem label field_types); Q.Project (r, label) | _ -> Q.query_error ("Error projecting label %s from record: %s") label (Q.string_of_t r) @@ -332,7 +332,7 @@ struct in let of_record _x = function | Q.Record fields -> - StringMap.fold (fun label v acc -> + Types.FieldEnv.fold (fun label v acc -> (* f is the aggregate function for this label *) let f, arg = of_apply v in let c, _q = of_map_project arg in @@ -340,11 +340,11 @@ struct let y, cbody = of_closure c in match of_project (of_singleton cbody) with | l, Q.Var (var, _) when var = y -> - StringMap.add label (f, l) acc + Types.FieldEnv.add label (f, l) acc | l, q -> aggError ("of_record label " ^ l ^ ": " ^ (Q.show q)) ) fields - StringMap.empty + Types.FieldEnv.empty | q -> aggError ("of_record " ^ (Q.show q)) in Debug.print ("Aggregating with: " ^ Q.show aggs); @@ -394,16 +394,16 @@ struct end | Extend (ext_fields, r) -> begin - match opt_app (xlate env) (Q.Record StringMap.empty) r with + match opt_app (xlate env) (Q.Record Types.FieldEnv.empty) r with | Q.Record fields -> - Q.Record (StringMap.fold + Q.Record (Types.FieldEnv.fold (fun label v fields -> - if StringMap.mem label fields then + if Types.FieldEnv.mem label fields then Q.query_error "Error adding fields: label %s already present" label else - StringMap.add label (xlate env v) fields) + Types.FieldEnv.add label (xlate env v) fields) ext_fields fields) | _ -> Q.query_error "Error adding fields: non-record" @@ -536,7 +536,7 @@ struct | Q.For (_, gs, os, b) -> let bvs'', res = List.fold_left (fun (bvs',acc) (_genkind,w,q) -> w::bvs', acc || cfree bvs' q) (bvs, false) gs in res || cfree bvs'' b || List.exists (cfree bvs) os - | Q.Record fl -> StringMap.exists (fun _ t -> cfree bvs t) fl + | Q.Record fl -> Types.FieldEnv.exists (fun _ t -> cfree bvs t) fl | _ -> false in cfree [] @@ -558,10 +558,10 @@ struct let (from_field, to_field) = OptionUtils.val_of temporal_fields in (* Transaction / Valid-time tables: Need to wrap as metadata *) (* First, generate a fresh variable for the table *) - let make_spec_map = StringMap.map (fun x -> Types.Present x) in + let make_spec_map = Types.FieldEnv.map (fun x -> Types.Present x) in let field_types = Q.table_field_types table in let base_field_types = - StringMap.filter + Types.FieldEnv.filter (fun x _ -> x <> from_field && x <> to_field) field_types in let (_, row_var, dual) = row in @@ -572,7 +572,7 @@ struct (* Second, generate a fresh variable for the metadata *) let metadata_record = - StringMap.from_alist [ + Types.FieldEnv.from_alist [ (TemporalField.data_field, Q.eta_expand_var (z, base_ty_elem)); (TemporalField.from_field, @@ -672,7 +672,7 @@ struct with | InternalError _ -> retn in_dedup orig end - | Q.Record fl -> Q.Record (StringMap.map (norm false env) fl) + | Q.Record fl -> Q.Record (Types.FieldEnv.map (norm false env) fl) | Q.Singleton v -> Q.Singleton (norm false env v) | Q.MapEntry (k,v) -> Q.MapEntry (norm false env k, norm false env v) | Q.Concat xs -> reduce_concat (List.map (norm in_dedup env) xs) @@ -683,16 +683,16 @@ struct match r with | Q.Record fields -> assert (StringSet.for_all - (fun label -> StringMap.mem label fields) labels); + (fun label -> Types.FieldEnv.mem label fields) labels); Q.Record - (StringMap.fold + (Types.FieldEnv.fold (fun label v fields -> if StringSet.mem label labels then fields else - StringMap.add label v fields) + Types.FieldEnv.add label v fields) fields - StringMap.empty) + Types.FieldEnv.empty) | Q.If (c, t, e) -> Q.If (c, erase (t, labels), erase (e, labels)) | Q.Var (_x, Types.Record row) -> @@ -771,8 +771,8 @@ struct let rcd_combine = function | Q.Record rx, Q.Record ry -> begin - try Q.Record (StringMap.union_disjoint rx ry) - with StringMap.Not_disjoint _ -> Q.query_error "rcd_combine: unnable to merge overlapping grouping criteria (buggy typechecker?)" + try Q.Record (Types.FieldEnv.union_disjoint rx ry) + with Types.FieldEnv.Not_disjoint _ -> Q.query_error "rcd_combine: unnable to merge overlapping grouping criteria (buggy typechecker?)" end | Q.Record _, z | z, _ -> Q.query_error "rcd_combine: unexpected non-record argument (buggy normaliser?): %s" (Q.show z) in @@ -792,7 +792,7 @@ struct in let ql' = List.map (fun (b, c, gs, os) -> (reduce_groupby b, c, gs, os)) ql in pack_ncoll ql' - | Q.AggBy (ar, q) -> Q.AggBy (StringMap.map (fun (x,y) -> norm false env x, y) ar, norm in_dedup env q) + | Q.AggBy (ar, q) -> Q.AggBy (Types.FieldEnv.map (fun (x,y) -> norm false env x, y) ar, norm in_dedup env q) | Q.Lookup (q, k) -> let ql = unpack_ncoll (norm in_dedup env q) in let k' = norm false env k in @@ -869,7 +869,7 @@ struct let o = norm_comp false cenv os in match o with | Q.Record fields -> - List.rev (StringMap.fold (fun _ o os -> o::os) fields []) + List.rev (Types.FieldEnv.fold (fun _ o os -> o::os) fields []) | _ -> assert false in (* this is unsmart: everything is normalized here, but we have to potentially @@ -921,7 +921,7 @@ struct end let compile_update : Value.database -> Value.env -> - ((Ir.var * string * Types.datatype StringMap.t) * Ir.computation option * Ir.computation) -> Sql.query = + ((Ir.var * string * Types.datatype Types.FieldEnv.t) * Ir.computation option * Ir.computation) -> Sql.query = fun db env ((x, table, field_types), where, body) -> let tyx = Types.make_record_type field_types in let env = Q.bind (Q.env_of_value_env QueryPolicy.Mixing env) (x, Q.Var (x, tyx)) in @@ -934,7 +934,7 @@ let compile_update : Value.database -> Value.env -> q let compile_delete : Value.database -> Value.env -> - ((Ir.var * string * Types.datatype StringMap.t) * Ir.computation option) -> Sql.query = + ((Ir.var * string * Types.datatype Types.FieldEnv.t) * Ir.computation option) -> Sql.query = fun db env ((x, table, field_types), where) -> let tyx = Types.make_record_type field_types in let env = Q.bind (Q.env_of_value_env QueryPolicy.Mixing env) (x, Q.Var (x, tyx)) in diff --git a/core/query/mixingQuery.mli b/core/query/mixingQuery.mli index 69f07ea24..f6938dddf 100644 --- a/core/query/mixingQuery.mli +++ b/core/query/mixingQuery.mli @@ -13,7 +13,7 @@ open CommonTypes val flatfield : string -> string -> string val flattened_pair : QueryLang.t -> QueryLang.t -> QueryLang.t -val flattened_pair_ft : QueryLang.t -> QueryLang.t -> Types.datatype stringmap +val flattened_pair_ft : QueryLang.t -> QueryLang.t -> Types.datatype Types.field_env val type_of_for_var : QueryLang.genkind -> QueryLang.t -> Types.datatype val reduce_where_then : QueryLang.t * QueryLang.t -> QueryLang.t @@ -29,7 +29,7 @@ sig end val compile_update : Value.database -> Value.env -> - ((Ir.var * string * Types.datatype StringMap.t) * Ir.computation option * Ir.computation) -> Sql.query + ((Ir.var * string * Types.datatype Types.FieldEnv.t) * Ir.computation option * Ir.computation) -> Sql.query val compile_delete : Value.database -> Value.env -> - ((Ir.var * string * Types.datatype StringMap.t) * Ir.computation option) -> Sql.query \ No newline at end of file + ((Ir.var * string * Types.datatype Types.FieldEnv.t) * Ir.computation option) -> Sql.query diff --git a/core/query/query.ml b/core/query/query.ml index 45eaffe84..81b5cca8d 100644 --- a/core/query/query.ml +++ b/core/query/query.ml @@ -37,7 +37,7 @@ let rec freshen_for_bindings : Var.var Env.Int.t -> Q.t -> Q.t = | Q.Concat vs -> Q.Concat (List.map ffb vs) | Q.Dedup t -> Q.Dedup (ffb t) | Q.Prom t -> Q.Prom (ffb t) - | Q.Record fields -> Q.Record (StringMap.map ffb fields) + | Q.Record fields -> Q.Record (Types.FieldEnv.map ffb fields) | Q.Variant (name, v) -> Q.Variant (name, ffb v) | Q.XML xmlitem -> Q.XML xmlitem | Q.Project (v, name) -> Q.Project (ffb v, name) @@ -106,8 +106,8 @@ let rec reduce_eq (a, b) = List.fold_right2 (fun (_, v1) (_, v2) e -> reduce_and (reduce_eq (v1, v2), e)) - (StringMap.to_alist lfields) - (StringMap.to_alist rfields) + (Types.FieldEnv.to_alist lfields) + (Types.FieldEnv.to_alist rfields) (Q.Constant (Constant.Bool true)) | (a, b) -> Q.Apply (Q.Primitive "==", [a; b]) @@ -180,10 +180,10 @@ let rec reduce_for_source : Q.t * (Q.t -> Q.t) -> Q.t = let (from_field, to_field) = OptionUtils.val_of temporal_fields in (* Transaction / Valid-time tables: Need to wrap as metadata *) (* First, generate a fresh variable for the table *) - let make_spec_map = StringMap.map (fun x -> Types.Present x) in + let make_spec_map = Types.FieldEnv.map (fun x -> Types.Present x) in let field_types = Q.table_field_types table in let base_field_types = - StringMap.filter + Types.FieldEnv.filter (fun x _ -> x <> from_field && x <> to_field) field_types in @@ -195,7 +195,7 @@ let rec reduce_for_source : Q.t * (Q.t -> Q.t) -> Q.t = (* Second, generate a fresh variable for the metadata *) let metadata_record = - StringMap.from_alist [ + Types.FieldEnv.from_alist [ (TemporalField.data_field, Q.eta_expand_var (table_raw_var, base_ty_elem)); (TemporalField.from_field, @@ -213,14 +213,14 @@ let rec reduce_if_body (c, t, e) = | Q.Record then_fields -> begin match e with | Q.Record else_fields -> - assert (StringMap.equal (fun _ _ -> true) then_fields else_fields); + assert (Types.FieldEnv.equal (fun _ _ -> true) then_fields else_fields); Q.Record - (StringMap.fold + (Types.FieldEnv.fold (fun name t fields -> - let e = StringMap.find name else_fields in - StringMap.add name (reduce_if_body (c, t, e)) fields) + let e = Types.FieldEnv.find name else_fields in + Types.FieldEnv.add name (reduce_if_body (c, t, e)) fields) then_fields - StringMap.empty) + Types.FieldEnv.empty) (* NOTE: this relies on any record variables having been eta-expanded by this point *) | _ -> Q.query_error "Mismatched fields" @@ -271,7 +271,7 @@ struct begin match x with | Q.Record r -> - StringMap.find TemporalField.data_field r + Types.FieldEnv.find TemporalField.data_field r | _ -> Q.Project (x, TemporalField.data_field) end @@ -280,7 +280,7 @@ struct begin match x with | Q.Record r -> - StringMap.find TemporalField.from_field r + Types.FieldEnv.find TemporalField.from_field r | _ -> Q.Project (x, TemporalField.from_field) end @@ -289,7 +289,7 @@ struct begin match x with | Q.Record r -> - StringMap.find TemporalField.to_field r + Types.FieldEnv.find TemporalField.to_field r | _ -> Q.Project (x, TemporalField.to_field) end @@ -338,16 +338,16 @@ struct end | Extend (ext_fields, r) -> begin - match opt_app (xlate env) (Q.Record StringMap.empty) r with + match opt_app (xlate env) (Q.Record Types.FieldEnv.empty) r with | Q.Record fields -> - Q.Record (StringMap.fold + Q.Record (Types.FieldEnv.fold (fun label v fields -> - if StringMap.mem label fields then + if Types.FieldEnv.mem label fields then Q.query_error "Error adding fields: label %s already present" label else - StringMap.add label (xlate env v) fields) + Types.FieldEnv.add label (xlate env v) fields) ext_fields fields) | _ -> Q.query_error "Error adding fields: non-record" @@ -462,19 +462,19 @@ struct let rec norm env : Q.t -> Q.t = function - | Q.Record fl -> Q.Record (StringMap.map (norm env) fl) + | Q.Record fl -> Q.Record (Types.FieldEnv.map (norm env) fl) | Q.Concat xs -> reduce_concat (List.map (norm env) xs) | Q.Project (r, label) -> let rec project (r, label) = match r with | Q.Record fields -> - assert (StringMap.mem label fields); - StringMap.find label fields + assert (Types.FieldEnv.mem label fields); + Types.FieldEnv.find label fields | Q.If (c, t, e) -> Q.If (c, project (t, label), project (e, label)) | Q.Var (_x, Types.Record row) -> let field_types = Q.field_types_of_row row in - assert (StringMap.mem label field_types); + assert (Types.FieldEnv.mem label field_types); Q.Project (r, label) | _ -> Q.query_error ("Error projecting from record: %s") (Q.string_of_t r) in @@ -484,16 +484,16 @@ struct match r with | Q.Record fields -> assert (StringSet.for_all - (fun label -> StringMap.mem label fields) labels); + (fun label -> Types.FieldEnv.mem label fields) labels); Q.Record - (StringMap.fold + (Types.FieldEnv.fold (fun label v fields -> if StringSet.mem label labels then fields else - StringMap.add label v fields) + Types.FieldEnv.add label v fields) fields - StringMap.empty) + Types.FieldEnv.empty) | Q.If (c, t, e) -> Q.If (c, erase (t, labels), erase (e, labels)) | Q.Var (_x, Types.Record row) -> @@ -589,7 +589,7 @@ struct let o = norm_comp env os in match o with | Q.Record fields -> - List.rev (StringMap.fold (fun _ o os -> o::os) fields []) + List.rev (Types.FieldEnv.fold (fun _ o os -> o::os) fields []) | _ -> assert false in Q.For (None, gs, os @ os', body) @@ -621,7 +621,7 @@ struct end let compile_update : Value.database -> Value.env -> - ((Ir.var * string * Types.datatype StringMap.t) * Ir.computation option * Ir.computation) -> Sql.query = + ((Ir.var * string * Types.datatype Types.FieldEnv.t) * Ir.computation option * Ir.computation) -> Sql.query = fun db env ((x, table, field_types), where, body) -> let tyx = Types.make_record_type field_types in let env = Q.bind (Q.env_of_value_env QueryPolicy.Flat env) (x, Q.Var (x, tyx)) in @@ -634,7 +634,7 @@ let compile_update : Value.database -> Value.env -> q let compile_delete : Value.database -> Value.env -> - ((Ir.var * string * Types.datatype StringMap.t) * Ir.computation option) -> Sql.query = + ((Ir.var * string * Types.datatype Types.FieldEnv.t) * Ir.computation option) -> Sql.query = fun db env ((x, table, field_types), where) -> let tyx = Types.make_record_type field_types in let env = Q.bind (Q.env_of_value_env QueryPolicy.Flat env) (x, Q.Var (x, tyx)) in diff --git a/core/query/query.mli b/core/query/query.mli index 8ac6519d9..d18f66286 100644 --- a/core/query/query.mli +++ b/core/query/query.mli @@ -1,4 +1,3 @@ -open Utility open CommonTypes val reduce_and : QueryLang.t * QueryLang.t -> QueryLang.t @@ -17,7 +16,7 @@ sig end val compile_update : Value.database -> Value.env -> - ((Ir.var * string * Types.datatype StringMap.t) * Ir.computation option * Ir.computation) -> Sql.query + ((Ir.var * string * Types.datatype Types.FieldEnv.t) * Ir.computation option * Ir.computation) -> Sql.query val compile_delete : Value.database -> Value.env -> - ((Ir.var * string * Types.datatype StringMap.t) * Ir.computation option) -> Sql.query + ((Ir.var * string * Types.datatype Types.FieldEnv.t) * Ir.computation option) -> Sql.query diff --git a/core/query/queryLang.ml b/core/query/queryLang.ml index f49327c9b..e2d2d2dc2 100644 --- a/core/query/queryLang.ml +++ b/core/query/queryLang.ml @@ -47,9 +47,9 @@ type t = | Dedup of t | Prom of t | GroupBy of (Var.var * t) * t - | AggBy of (t * string) StringMap.t * t + | AggBy of (t * string) Types.FieldEnv.t * t | Lookup of t * t - | Record of t StringMap.t + | Record of t Types.FieldEnv.t | Project of t * string | Erase of t * StringSet.t | Variant of string * t @@ -78,9 +78,9 @@ struct | Dedup of pt | Prom of pt | GroupBy of (Var.var * pt) * pt - | AggBy of (pt * string) StringMap.t * pt + | AggBy of (pt * string) Types.FieldEnv.t * pt | Lookup of pt * pt - | Record of pt StringMap.t + | Record of pt Types.FieldEnv.t | Project of pt * string | Erase of pt * StringSet.t | Variant of string * pt @@ -108,7 +108,7 @@ let rec pt_of_t : 't -> S.pt = fun v -> | Concat vs -> S.Concat (List.map bt vs) | Dedup q -> S.Dedup (bt q) | Prom q -> S.Prom (bt q) - | Record fields -> S.Record (StringMap.map bt fields) + | Record fields -> S.Record (Types.FieldEnv.map bt fields) | Variant (name, v) -> S.Variant (name, bt v) | XML xmlitem -> S.XML xmlitem | Project (v, name) -> S.Project (bt v, name) @@ -120,7 +120,7 @@ let rec pt_of_t : 't -> S.pt = fun v -> | Var (v, t) -> S.Var (v, t) | Constant c -> S.Constant c | GroupBy ((x,k), q) -> S.GroupBy ((x, bt k), bt q) - | AggBy (ar, q) -> S.AggBy (StringMap.map (fun (x,y) -> bt x, y) ar, bt q) + | AggBy (ar, q) -> S.AggBy (Types.FieldEnv.map (fun (x,y) -> bt x, y) ar, bt q) | Lookup (q,k) -> S.Lookup (bt q, bt k) | Database _ -> assert false @@ -160,7 +160,7 @@ let rec value_of_expression = fun v -> | Variant (name, v) -> `Variant (name, ve v) | XML xmlitem -> `XML xmlitem | Record fields -> - `Record (List.rev (StringMap.fold (fun name v fields -> + `Record (List.rev (Types.FieldEnv.fold (fun name v fields -> (name, ve v)::fields) fields [])) | _ -> assert false @@ -175,7 +175,7 @@ let rec expression_of_base_value : Value.t -> t = function let fields = fields |> List.map (fun (k, v) -> (k, expression_of_base_value v)) - |> StringMap.from_alist in + |> Types.FieldEnv.from_alist in Record fields | `DateTime dt -> Constant (Constant.DateTime dt) | other -> @@ -183,7 +183,7 @@ let rec expression_of_base_value : Value.t -> t = function Value.string_of_value other)) let field_types_of_spec_map = - StringMap.map (function + Types.FieldEnv.map (function | Types.Present t -> t | _ -> assert false) @@ -200,7 +200,7 @@ let table_field_types Value.Table.{ row = (fields, _, _); temporal_fields; _ } = in let declared_fields = field_types_of_spec_map fields in (* Add metadata fields *) - StringMap.superimpose (StringMap.from_alist metadata_fields) declared_fields + Types.FieldEnv.superimpose (Types.FieldEnv.from_alist metadata_fields) declared_fields let unbox_xml = function @@ -210,8 +210,8 @@ let unbox_xml = let unbox_pair = function | Record fields -> - let x = StringMap.find "1" fields in - let y = StringMap.find "2" fields in + let x = Types.FieldEnv.find "1" fields in + let y = Types.FieldEnv.find "2" fields in x, y | _ -> raise (runtime_type_error "failed to unbox pair") @@ -240,14 +240,14 @@ let unbox_string = (unbox_list v)) | _ -> raise (runtime_type_error "failed to unbox string") -let recdty_field_types (t : Types.datatype) : Types.datatype StringMap.t = +let recdty_field_types (t : Types.datatype) : Types.datatype Types.FieldEnv.t = field_types_of_row (TypeUtils.extract_row t) let rec subst t x u = let srec t = subst t x u in match t with | Var (var, _) when var = x -> u - | Record fl -> Record (StringMap.map srec fl) + | Record fl -> Record (Types.FieldEnv.map srec fl) | Singleton v -> Singleton (srec v) | MapEntry (k, v) -> MapEntry (srec k, srec v) | Concat xs -> Concat (List.map srec xs) @@ -273,7 +273,7 @@ let rec subst t x u = | Closure (c, closure_env) -> let cenv = bind closure_env (x,u) in Closure (c, cenv) - | AggBy (ar, q) -> AggBy (StringMap.map (fun (t0,l) -> srec t0, l) ar, srec q) + | AggBy (ar, q) -> AggBy (Types.FieldEnv.map (fun (t0,l) -> srec t0, l) ar, srec q) | GroupBy ((v,i), q) -> let i' = if v = x then i else srec i in let q' = srec q in @@ -307,9 +307,9 @@ let occurs_free (v : Var.var) = (* FIXME: do we need to check os as well? *) let bvs'', res = List.fold_left (fun (bvs',acc) (_genkind,w,q) -> w::bvs', acc ||=? occf bvs' q) (bvs, None) gs in res ||=? occf bvs'' b - | Record fl -> map_tryPick (fun _ t -> occf bvs t) fl + | Record fl -> unk_map_tryPick Types.FieldEnv.fold (fun _ t -> occf bvs t) fl | GroupBy ((v,i), q) -> occf (v::bvs) i ||=? occf bvs q - | AggBy (ar, q) -> map_tryPick (fun _ (t, _) -> occf bvs t) ar ||=? occf bvs q + | AggBy (ar, q) -> unk_map_tryPick Types.FieldEnv.fold (fun _ (t, _) -> occf bvs t) ar ||=? occf bvs q | _ -> None in occf [] @@ -328,7 +328,7 @@ let rec occurs_free_gens (gs : (genkind * Var.var * t) list) q = let rec type_of_expression : t -> Types.datatype = fun v -> let te = type_of_expression in let record fields : Types.datatype = - Types.make_record_type (StringMap.map te fields) + Types.make_record_type (Types.FieldEnv.map te fields) in match v with | Var (_,ty) -> ty @@ -342,7 +342,7 @@ let rec type_of_expression : t -> Types.datatype = fun v -> |> Types.make_list_type | AggBy (aggs,q) -> let tyk = te q |> Types.unwrap_map_type |> fst in - let ty = StringMap.map (function (Primitive f,_) -> TypeUtils.return_type (Env.String.find f Lib.type_env) | _ -> assert false) aggs + let ty = Types.FieldEnv.map (function (Primitive f,_) -> TypeUtils.return_type (Env.String.find f Lib.type_env) | _ -> assert false) aggs |> Types.make_record_type in Types.make_mapentry_type tyk ty |> Types.make_list_type @@ -368,7 +368,7 @@ let rec type_of_expression : t -> Types.datatype = fun v -> | Project (w, name) -> begin match te w with - | Types.Record _ as rty -> StringMap.find name (recdty_field_types rty) + | Types.Record _ as rty -> Types.FieldEnv.find name (recdty_field_types rty) | ty -> failwith (Format.asprintf ("term:\n" ^^ @@ -398,11 +398,11 @@ let eta_expand_var (x, ty) = | Types.Record row -> let field_types = field_types_of_row row in Record - (StringMap.fold + (Types.FieldEnv.fold (fun name _t fields -> - StringMap.add name (Project (Var (x, ty), name)) fields) + Types.FieldEnv.add name (Project (Var (x, ty), name)) fields) field_types - StringMap.empty) + Types.FieldEnv.empty) | _ -> Var (x, ty) let eta_expand_list xs = @@ -446,7 +446,7 @@ let used_database : t -> Value.database option = | Singleton v -> used_item v | MapEntry (k,v) -> used_item v ||=? used_item k | Record v -> - StringMap.to_alist v + Types.FieldEnv.to_alist v |> List.map snd |> traverse | Apply (_, args) -> @@ -460,7 +460,7 @@ let used_database : t -> Value.database option = | Erase (x, _) -> used x | Variant (_, x) -> used x | AggBy (aggs, q) -> - let aggs' = StringMap.to_alist aggs |> List.map (fun (_,(x,_)) -> x) in + let aggs' = Types.FieldEnv.to_alist aggs |> List.map (fun (_,(x,_)) -> x) in traverse (q::aggs') | GroupBy ((_,i), q) -> traverse [q;i] | _ -> None @@ -473,13 +473,13 @@ let used_database : t -> Value.database option = let string_of_t = string_of_t let labels_of_field_types field_types = - StringMap.fold + Types.FieldEnv.fold (fun name _ labels' -> StringSet.add name labels') field_types StringSet.empty -let recdty_field_types (t : Types.datatype) : Types.datatype StringMap.t = +let recdty_field_types (t : Types.datatype) : Types.datatype Types.FieldEnv.t = field_types_of_row (TypeUtils.extract_row t) let env_of_value_env policy value_env = @@ -577,8 +577,8 @@ let rec expression_of_value : env -> Value.t -> t = fun env v -> | `Record fields -> Record (List.fold_left - (fun fields (name, v) -> StringMap.add name (expression_of_value env v) fields) - StringMap.empty + (fun fields (name, v) -> Types.FieldEnv.add name (expression_of_value env v) fields) + Types.FieldEnv.empty fields) | `Variant (name, v) -> Variant (name, expression_of_value env v) | `XML xmlitem -> XML xmlitem @@ -724,7 +724,7 @@ let rec select_clause : Sql.index -> bool -> t -> Sql.select_clause = let fields = Sql.Fields (List.rev - (StringMap.fold + (Types.FieldEnv.fold (fun name _ fields -> (Sql.Project (var, name), name)::fields) fields @@ -742,7 +742,7 @@ let rec select_clause : Sql.index -> bool -> t -> Sql.select_clause = let fields = Sql.Fields (List.rev - (StringMap.fold + (Types.FieldEnv.fold (fun name v fields -> (base index v, name)::fields) fields @@ -866,8 +866,8 @@ let update : ((Ir.var * string) * t option * t) -> Sql.query = OptionUtils.opt_map (base []) where in let upd_fields = unbox_record body - |> StringMap.map (base []) - |> StringMap.to_alist in + |> Types.FieldEnv.map (base []) + |> Types.FieldEnv.to_alist in Update { upd_table = table; upd_fields; upd_where } let delete : ((Ir.var * string) * t option) -> Sql.query = @@ -969,9 +969,9 @@ struct (o, Prom q) | Record fields -> let (o, fields) = - StringMap.fold (fun k v (o, acc)-> + Types.FieldEnv.fold (fun k v (o, acc)-> let (o, v) = o#query v in - (o, StringMap.add k v acc)) fields (o, StringMap.empty) in + (o, Types.FieldEnv.add k v acc)) fields (o, Types.FieldEnv.empty) in (o, Record fields) | Project (x, field) -> let (o, x) = o#query x in (o, Project (x, field)) | Erase (x, fields) -> @@ -1007,9 +1007,9 @@ struct let (o,q) = o#query q in (o, GroupBy ((v,i),q)) | AggBy (ar,q) -> - let (o,ar) = StringMap.fold (fun l_in (v, l_out) (o, acc) -> + let (o,ar) = Types.FieldEnv.fold (fun l_in (v, l_out) (o, acc) -> let (o, v) = o#query v in - (o, StringMap.add l_in (v, l_out) acc)) ar (o, StringMap.empty) + (o, Types.FieldEnv.add l_in (v, l_out) acc)) ar (o, Types.FieldEnv.empty) in let (o,q) = o#query q in (o, AggBy (ar, q)) @@ -1029,20 +1029,20 @@ struct | Types.Primitive _ as t -> t | Types.Record fields -> Types.make_record_type - (StringMap.fold + (Types.FieldEnv.fold (fun name t fields -> match flatten_base_type t with | Types.Record inner_fields -> - StringMap.fold + Types.FieldEnv.fold (fun name' t fields -> - StringMap.add (name ^ "@" ^ name') t fields) + Types.FieldEnv.add (name ^ "@" ^ name') t fields) (field_types_of_row inner_fields) fields | Types.Primitive _ as t -> - StringMap.add name t fields + Types.FieldEnv.add name t fields | _ -> assert false) (field_types_of_row fields) - StringMap.empty) + Types.FieldEnv.empty) | t (* MapEntry *) -> let kty, vty = Types.unwrap_mapentry_type t in let kty' = flatten_base_type kty in @@ -1053,7 +1053,7 @@ struct let t' = Types.unwrap_list_type t |> flatten_base_type in match t' with | Types.Record _ -> Types.make_list_type t' - | _ -> StringMap.add "@" t' StringMap.empty |> Types.make_record_type |> Types.make_list_type + | _ -> Types.FieldEnv.add "@" t' Types.FieldEnv.empty |> Types.make_record_type |> Types.make_list_type let rec flatten_inner : t -> t = let is_aggr_primitive = function @@ -1087,19 +1087,19 @@ struct let extend name name' = name ^ "@" ^ name' in (* concatenate labels of nested records *) Record - (StringMap.fold + (Types.FieldEnv.fold (fun name body fields -> match flatten_inner body with | Record inner_fields -> - StringMap.fold + Types.FieldEnv.fold (fun name' body fields -> - StringMap.add (extend name name') body fields) + Types.FieldEnv.add (extend name name') body fields) inner_fields fields | body -> - StringMap.add name body fields) + Types.FieldEnv.add name body fields) fields - StringMap.empty) + Types.FieldEnv.empty) | Variant ("Simply", x) -> Variant ("Simply", flatten_inner x) | Variant ("Seq", Singleton r) -> @@ -1139,7 +1139,7 @@ struct | MapEntry (Record _, Record _) | Record _ as p -> p | MapEntry (_, _) -> assert false (* we don't want to handle the case of MapEntries not containing records *) - | p -> Record (StringMap.add "@" p StringMap.empty) + | p -> Record (Types.FieldEnv.add "@" p Types.FieldEnv.empty) in Singleton e' (* HACK: not sure if Concat is supposed to appear here... @@ -1164,7 +1164,7 @@ struct | Types.Primitive _ -> List.assoc base_label frow | Types.Record nrow -> let nfields = - StringMap.fold + Types.FieldEnv.fold <| (fun k v acc -> (k, ur ~prefix:(extend_label k) v frow)::acc) <| field_types_of_row nrow <| [] @@ -1202,8 +1202,7 @@ struct * and need to be inferred from the nested type when unflattening -- we're not doing that here * * or maybe we are? we proceed by case analysis on the nested type and, from the looks of it, - * the code, not finding any matching attribute in the DB result, should conjure a `Record StringMap.empty + * the code, not finding any matching attribute in the DB result, should conjure a `Record Types.FieldEnv.empty * i.e. the unit value! *) end - diff --git a/core/query/queryLang.mli b/core/query/queryLang.mli index 4f4c0ea8f..0ae13dd93 100644 --- a/core/query/queryLang.mli +++ b/core/query/queryLang.mli @@ -31,9 +31,9 @@ type t = | Dedup of t | Prom of t | GroupBy of (Var.var * t) * t - | AggBy of (t * string) StringMap.t * t + | AggBy of (t * string) Types.FieldEnv.t * t | Lookup of t * t - | Record of t StringMap.t + | Record of t Types.FieldEnv.t | Project of t * string | Erase of t * StringSet.t | Variant of string * t @@ -59,7 +59,7 @@ val expression_of_base_value : Value.t -> t val check_policies_compatible : CommonTypes.QueryPolicy.t -> CommonTypes.QueryPolicy.t -> unit -val field_types_of_row : Types.datatype -> Types.datatype StringMap.t +val field_types_of_row : Types.datatype -> Types.datatype Types.FieldEnv.t val unbox_xml : t -> Value.xmlitem @@ -69,13 +69,13 @@ val unbox_list : t -> t list val unbox_pair : t -> t * t -val unbox_record : t -> t StringMap.t +val unbox_record : t -> t Types.FieldEnv.t val used_database : t -> Value.database option val string_of_t : t -> string -val recdty_field_types : Types.datatype -> Types.datatype StringMap.t +val recdty_field_types : Types.datatype -> Types.datatype Types.FieldEnv.t val env_of_value_env : CommonTypes.QueryPolicy.t -> Value.env -> env @@ -97,8 +97,8 @@ val default_of_base_type : Primitive.t -> t val value_of_expression : t -> Value.t -val labels_of_field_types : 'a Utility.StringMap.t -> Utility.StringSet.t -val table_field_types : Value.table -> Types.typ Utility.StringMap.t +val labels_of_field_types : 'a Types.FieldEnv.t -> Utility.StringSet.t +val table_field_types : Value.table -> Types.typ Types.FieldEnv.t val is_list : t -> bool val likeify : t -> t option diff --git a/core/query/temporalQuery.ml b/core/query/temporalQuery.ml index c52ccaef3..6fa0163b9 100644 --- a/core/query/temporalQuery.ml +++ b/core/query/temporalQuery.ml @@ -61,7 +61,7 @@ module TransactionTime = struct let insert = current_insertion let update : - Types.datatype StringMap.t -> + datatype FieldEnv.t -> ((Ir.var * string) * Q.t option * Q.t) -> string -> string -> @@ -77,10 +77,10 @@ module TransactionTime = struct (* We need to augment table_types with the period-stamping columns. *) let table_types = table_types - |> StringMap.add tt_from (Primitive Primitive.DateTime) - |> StringMap.add tt_to (Primitive Primitive.DateTime) in + |> FieldEnv.add tt_from (Primitive Primitive.DateTime) + |> FieldEnv.add tt_to (Primitive Primitive.DateTime) in let field_names = - StringMap.to_alist table_types |> List.map fst in + FieldEnv.to_alist table_types |> List.map fst in (* The select query should either select the updated field if specified, * otherwise it should select a the field projection. *) @@ -90,18 +90,18 @@ module TransactionTime = struct match body with | Q.Record fields -> fields - |> StringMap.add tt_from (Q.Constant now_const) - |> StringMap.add tt_to (Q.Constant forever_const) + |> FieldEnv.add tt_from (Q.Constant now_const) + |> FieldEnv.add tt_to (Q.Constant forever_const) | _ -> assert false in - let record_fields_list = StringMap.to_alist record_fields in + let record_fields_list = FieldEnv.to_alist record_fields in (* Select either the field name if unspecified, or the updated value * if it is. *) let select_fields = - StringMap.mapi (fun k _ -> - OptionUtils.opt_map (base []) (StringMap.lookup k record_fields) + FieldEnv.mapi (fun k _ -> + OptionUtils.opt_map (base []) (FieldEnv.lookup k record_fields) |> OptionUtils.from_option (Project (tbl_var, k))) table_types - |> StringMap.to_alist + |> FieldEnv.to_alist (* Need to swap (col, val) pairs to (val, col) to fit select_clause AST, * which mirrors "SELECT V as K" form in SQL *) |> List.map (fun (k, v) -> (v, k)) in @@ -183,7 +183,7 @@ module TransactionTime = struct let compile_update : Value.env -> - ((Ir.var * string * Types.datatype StringMap.t) * Ir.computation option * Ir.computation) -> + ((Ir.var * string * Types.datatype FieldEnv.t) * Ir.computation option * Ir.computation) -> string -> (* transaction time from field *) string -> (* transaction time to field *) Sql.query = @@ -200,7 +200,7 @@ module TransactionTime = struct let compile_delete : Value.database -> Value.env -> - ((Ir.var * string * Types.datatype StringMap.t) * Ir.computation option) -> + ((Ir.var * string * Types.datatype FieldEnv.t) * Ir.computation option) -> string (* Transaction time 'to' field *) -> Sql.query = fun db env ((x, table, field_types), where) to_field -> @@ -221,11 +221,11 @@ module ValidTime = struct let metadata x field_types from_field to_field = let extended_field_types = field_types - |> StringMap.add from_field Types.datetime_type - |> StringMap.add to_field Types.datetime_type in + |> Types.FieldEnv.add from_field Types.datetime_type + |> Types.FieldEnv.add to_field Types.datetime_type in let table_var = Q.Var (x, Types.make_record_type extended_field_types) in let metadata_record = - StringMap.from_alist [ + Types.FieldEnv.from_alist [ (TemporalField.data_field, Q.eta_expand_var (x, Types.make_record_type field_types)); (TemporalField.from_field, @@ -283,7 +283,7 @@ module ValidTime = struct module Update = struct let current : - Types.datatype StringMap.t -> + Types.datatype Types.FieldEnv.t -> ((Ir.var * string) * Q.t option * Q.t) -> string -> string -> @@ -306,24 +306,24 @@ module ValidTime = struct * abstract it (in some nice way) *) let table_types = table_types - |> StringMap.add from_field (Primitive Primitive.DateTime) - |> StringMap.add to_field (Primitive Primitive.DateTime) in + |> Types.FieldEnv.add from_field (Primitive Primitive.DateTime) + |> Types.FieldEnv.add to_field (Primitive Primitive.DateTime) in let field_names = - StringMap.to_alist table_types |> List.map fst in + Types.FieldEnv.to_alist table_types |> List.map fst in let record_fields = match body with | Q.Record fields -> fields | _ -> assert false in let fields_with_time = - StringMap.add from_field (Q.Constant now_const) record_fields in + Types.FieldEnv.add from_field (Q.Constant now_const) record_fields in (* Select either the field name if unspecified, or the updated value * if it is. *) let select_fields = - StringMap.mapi (fun k _ -> - OptionUtils.opt_map (base []) (StringMap.lookup k fields_with_time) + Types.FieldEnv.mapi (fun k _ -> + OptionUtils.opt_map (base []) (Types.FieldEnv.lookup k fields_with_time) |> OptionUtils.from_option (Project (tbl_var, k))) table_types - |> StringMap.to_alist + |> Types.FieldEnv.to_alist (* Need to swap (col, val) pairs to (val, col) to fit select_clause AST, * which mirrors "SELECT V as K" form in SQL *) |> List.map (fun (k, v) -> (v, k)) in @@ -371,7 +371,7 @@ module ValidTime = struct Update { upd_table = table; upd_fields = - StringMap.to_alist record_fields + Types.FieldEnv.to_alist record_fields |> List.map (fun (x, y) -> (x, base [] y)); upd_where = Some pred } in @@ -399,13 +399,13 @@ module ValidTime = struct let upd_fields = Q.unbox_record body - |> StringMap.map (base []) - |> StringMap.to_alist in + |> Types.FieldEnv.map (base []) + |> Types.FieldEnv.to_alist in let upd_fields = upd_fields @ upd_from @ upd_to in Update { upd_table = table; upd_fields; upd_where } let sequenced : - Types.datatype StringMap.t -> + Types.datatype Types.FieldEnv.t -> ((Ir.var * string) * Q.t option * Q.t * Q.t * Q.t) -> string (* valid from field *) -> string (* valid to field *) -> @@ -420,11 +420,11 @@ module ValidTime = struct (* - Add the period-stamping fields to the table types *) let table_types = table_types - |> StringMap.add from_field (Primitive Primitive.DateTime) - |> StringMap.add to_field (Primitive Primitive.DateTime) in + |> Types.FieldEnv.add from_field (Primitive Primitive.DateTime) + |> Types.FieldEnv.add to_field (Primitive Primitive.DateTime) in let field_names = - StringMap.to_alist table_types |> List.map fst in + Types.FieldEnv.to_alist table_types |> List.map fst in let and_where pred = let open OpHelpers in @@ -438,12 +438,12 @@ module ValidTime = struct (* - Select either the field name if unspecified, or the updated value * if it is. *) let make_select values where = - let values = StringMap.from_alist values in + let values = Types.FieldEnv.from_alist values in let fields = - StringMap.mapi (fun k _ -> - StringMap.lookup k values + Types.FieldEnv.mapi (fun k _ -> + Types.FieldEnv.lookup k values |> OptionUtils.from_option (Project (tbl_var, k))) table_types - |> StringMap.to_alist + |> Types.FieldEnv.to_alist (* Need to swap (col, val) pairs to (val, col) to fit select_clause AST, * which mirrors "SELECT V as K" form in SQL *) |> List.map (fun (k, v) -> (v, k)) in @@ -484,7 +484,7 @@ module ValidTime = struct let upd1 = let upd_fields = Q.unbox_record set - |> StringMap.to_alist + |> Types.FieldEnv.to_alist |> List.map (fun (k, v) -> (k, base [] v)) in let where = @@ -583,7 +583,7 @@ module ValidTime = struct let sequenced : - Types.datatype StringMap.t -> + Types.datatype Types.FieldEnv.t -> ((Ir.var * string) * Q.t option * Q.t * Q.t) -> string (* valid from field *) -> string (* valid to field *) -> @@ -602,14 +602,14 @@ module ValidTime = struct (* Add the period-stamping fields to the table types *) let table_types = table_types - |> StringMap.add from_field (Primitive Primitive.DateTime) - |> StringMap.add to_field (Primitive Primitive.DateTime) in + |> Types.FieldEnv.add from_field (Primitive Primitive.DateTime) + |> Types.FieldEnv.add to_field (Primitive Primitive.DateTime) in (* Select all fields, 'start' date is end of PA *) let select_fields = - StringMap.mapi (fun k _ -> + Types.FieldEnv.mapi (fun k _ -> if k = from_field then app_to else proj k) table_types - |> StringMap.to_alist + |> Types.FieldEnv.to_alist (* Need to swap (col, val) pairs to (val, col) to fit select_clause AST, * which mirrors "SELECT V as K" form in SQL *) |> List.map (fun (k, v) -> (v, k)) in @@ -673,7 +673,7 @@ module ValidTime = struct Ir.valid_time_update -> Value.database -> Value.env -> - ((Ir.var * string * Types.datatype StringMap.t) * + ((Ir.var * string * Types.datatype Types.FieldEnv.t) * Ir.computation option * Ir.computation) -> string (* valid from field *) -> string (* valid to field *) -> @@ -722,7 +722,7 @@ module ValidTime = struct Ir.valid_time_deletion -> Value.database -> Value.env -> - ((Ir.var * string * Types.datatype StringMap.t) * Ir.computation option) -> + ((Ir.var * string * Types.datatype Types.FieldEnv.t) * Ir.computation option) -> string (* from field *) -> string (* to field *) -> Sql.query = @@ -786,7 +786,7 @@ module TemporalJoin = struct method private project tbl field = match tbl with - | Q.Record x -> StringMap.find field x + | Q.Record x -> Types.FieldEnv.find field x | _ -> Q.Project (tbl, field) (* Start time: maximum of all start times *) @@ -842,10 +842,10 @@ module TemporalJoin = struct List.fold_left (fun acc (k, x) -> match x with - | Present t -> StringMap.add k t acc + | Present t -> Types.FieldEnv.add k t acc | _ -> assert false) - (StringMap.empty) - (fst3 x.row |> StringMap.to_alist) in + (Types.FieldEnv.empty) + (fst3 x.row |> Types.FieldEnv.to_alist) in (Q.Var (v, Types.make_record_type ty), from_field, to_field) ) tables in @@ -867,7 +867,7 @@ module TemporalJoin = struct (TemporalField.from_field, o#start_time); (TemporalField.to_field, o#end_time)] in - (o, Singleton (Record (StringMap.from_alist record_fields))) + (o, Singleton (Record (Types.FieldEnv.from_alist record_fields))) | q -> super#query q end diff --git a/core/sugartoir.ml b/core/sugartoir.ml index c0cad95f3..addbf2048 100644 --- a/core/sugartoir.ml +++ b/core/sugartoir.ml @@ -429,8 +429,8 @@ struct let record (fields, r) = let field_types = List.fold_left - (fun field_types (name, s) -> StringMap.add name (sem_type s) field_types) - StringMap.empty + (fun field_types (name, s) -> Types.FieldEnv.add name (sem_type s) field_types) + Types.FieldEnv.empty fields in let s' = lift_alist fields in match r with @@ -438,13 +438,13 @@ struct let t = Types.make_record_type field_types in M.bind s' (fun fields -> - lift (Extend (StringMap.from_alist fields, None), t)) + lift (Extend (Types.FieldEnv.from_alist fields, None), t)) | Some s -> let t = Types.Record (Types.extend_row field_types (TypeUtils.extract_row (sem_type s))) in bind s (fun r -> M.bind s' - (fun fields -> lift (Extend (StringMap.from_alist fields, Some r), t))) + (fun fields -> lift (Extend (Types.FieldEnv.from_alist fields, Some r), t))) let project (s, name) = let t = TypeUtils.project_type name (sem_type s) in diff --git a/core/transformSugar.ml b/core/transformSugar.ml index b0af370a4..ac76d7c1e 100644 --- a/core/transformSugar.ml +++ b/core/transformSugar.ml @@ -24,7 +24,7 @@ let type_section env = let (fields, rho, _) = TypeUtils.extract_row_parts row in let eb, e = Types.fresh_row_quantifier default_effect_subkind in - let r = Record (Row (StringMap.add label (Present a) fields, rho, false)) in + let r = Record (Row (FieldEnv.add label (Present a) fields, rho, false)) in ForAll ([ab; rhob; eb], Function (Types.make_tuple_type [r], e, a)) | Name var -> TyEnv.find var env @@ -432,13 +432,13 @@ class transform (env : Types.typing_environment) = let (o, fields, field_types) = let rec list o = function - | [] -> (o, [], StringMap.empty) + | [] -> (o, [], FieldEnv.empty) | (name, e)::fields -> let (o, e, t) = o#phrase e in let (o, fields, field_types) = list o fields in (o, (name, e)::fields, - StringMap.add name t field_types) + FieldEnv.add name t field_types) in list o fields in let (o, base, base_type) = option o (fun o -> o#phrase) base in @@ -471,7 +471,7 @@ class transform (env : Types.typing_environment) = let ( fs, rv, closed ) = Types.flatten_row row |> TypeUtils.extract_row_parts in - let fs = List.fold_left2 (fun fs (name, _) t -> StringMap.add name (Present t) fs) fs fields ts in + let fs = List.fold_left2 (fun fs (name, _) t -> FieldEnv.add name (Present t) fs) fs fields ts in Record (Row (fs, rv, closed)) | _ -> t in diff --git a/core/typeSugar.ml b/core/typeSugar.ml index f9f5225b7..fb68e1849 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -1689,7 +1689,7 @@ let bind_effects context r = {context with effect_row = Types.flatten_r let lookup_effect context name = match context.effect_row with | Types.Row (fields, _, _) -> - begin match Utility.StringMap.find_opt name fields with + begin match Types.FieldEnv.find_opt name fields with | Some (Types.Present t) -> Some t | _ -> None end @@ -1938,8 +1938,8 @@ let type_section pos context s = let a = Types.fresh_type_variable (lin_unl, res_any) in let rho = Types.fresh_row_variable (lin_unl, res_any) in let effects = Types.make_empty_open_row default_effect_subkind in (* projection is pure! *) - let r = Record (Row (StringMap.add label (Present a) StringMap.empty, rho, false)) in - ([(PrimaryKind.Type, a); (PrimaryKind.Row, Row (StringMap.empty, rho, false)); (PrimaryKind.Row, effects)], + let r = Record (Row (FieldEnv.add label (Present a) FieldEnv.empty, rho, false)) in + ([(PrimaryKind.Type, a); (PrimaryKind.Row, Row (FieldEnv.empty, rho, false)); (PrimaryKind.Row, effects)], Function (Types.make_tuple_type [r], effects, a)), Usage.empty | Name var -> @@ -1960,11 +1960,11 @@ let type_frozen_section context s = | Project label -> let a = Types.fresh_rigid_type_variable (lin_unl, res_any) in let rho = Types.fresh_rigid_row_variable (lin_unl, res_any) in - let effects = StringMap.empty, Types.fresh_rigid_row_variable default_effect_subkind, false in - let r = Record (Row (StringMap.add label (Present a) StringMap.empty, rho, false)) in + let effects = FieldEnv.empty, Types.fresh_rigid_row_variable default_effect_subkind, false in + let r = Record (Row (FieldEnv.add label (Present a) FieldEnv.empty, rho, false)) in Types.for_all (Types.quantifiers_of_type_args [(PrimaryKind.Type, a); - (PrimaryKind.Row, Row (StringMap.empty, rho, false)); + (PrimaryKind.Row, Row (FieldEnv.empty, rho, false)); (PrimaryKind.Row, Row effects)], Function (Types.make_tuple_type [r], Row effects, a)), Usage.empty @@ -2052,15 +2052,15 @@ let close_pattern_type : Pattern.with_pos list -> Types.datatype -> Types.dataty List.nth ps i | Nil | Cons _ | List _ | Record _ | Variant _ | Negative _ | Operation _ -> assert false in let fields = - StringMap.fold(* true if the row variable is dualised *) + FieldEnv.fold(* true if the row variable is dualised *) (fun name -> function | Present t -> let pats = List.map (unwrap_at ((int_of_string name) - 1)) pats in - StringMap.add name (Present (cpt pats t)) + FieldEnv.add name (Present (cpt pats t)) | (Absent | Meta _) -> assert false - | _ -> raise Types.tag_expectation_mismatch) fields StringMap.empty in + | _ -> raise Types.tag_expectation_mismatch) fields FieldEnv.empty in Record (Row (fields, row_var, dual)) | Record row -> let fields, row_var, lr = (Types.unwrap_row row |> fst |> TypeUtils.extract_row_parts) in @@ -2081,14 +2081,14 @@ let close_pattern_type : Pattern.with_pos list -> Types.datatype -> Types.dataty end | Nil | Cons _ | List _ | Tuple _ | Variant _ | Negative _ | Operation _ -> assert false in let fields = - StringMap.fold + FieldEnv.fold (fun name -> function | Present t -> let pats = List.map (unwrap_at name) pats in - StringMap.add name (Present (cpt pats t)) + FieldEnv.add name (Present (cpt pats t)) | (Absent | Meta _) -> assert false - | _ -> raise Types.tag_expectation_mismatch) fields StringMap.empty in + | _ -> raise Types.tag_expectation_mismatch) fields FieldEnv.empty in Record (Row (fields, row_var, false)) | Variant row -> let fields, row_var, lr = (Types.unwrap_row row |> fst |> TypeUtils.extract_row_parts) in @@ -2115,15 +2115,15 @@ let close_pattern_type : Pattern.with_pos list -> Types.datatype -> Types.dataty | {node = (Variant _); _} :: ps -> are_open ps | {node = (Nil | Cons _ | List _ | Tuple _ | Record _ | Constant _ | Operation _); _} :: _ -> assert false in let fields = - StringMap.fold + FieldEnv.fold (fun name field_spec env -> match field_spec with | Present t -> let pats = concat_map (unwrap_at name) pats in let t = cpt pats t in - (StringMap.add name (Present t)) env + (FieldEnv.add name (Present t)) env | (Absent | Meta _) -> assert false - | _ -> raise Types.tag_expectation_mismatch) fields StringMap.empty + | _ -> raise Types.tag_expectation_mismatch) fields FieldEnv.empty in if are_open pats then begin @@ -2153,7 +2153,7 @@ let close_pattern_type : Pattern.with_pos list -> Types.datatype -> Types.dataty | Variable _ | Any | As _ | HasType _ | Negative _ | Nil | Cons _ | List _ | Tuple _ | Record _ | Variant _ | Constant _ -> assert false in let fields = - StringMap.fold + FieldEnv.fold (fun name field_spec env -> match field_spec with | Present t -> @@ -2200,11 +2200,11 @@ let close_pattern_type : Pattern.with_pos list -> Types.datatype -> Types.dataty Types.make_function_type domain effs codomain in (* Bind name |-> Pre(t) *) - StringMap.add name (Present t) env + FieldEnv.add name (Present t) env | _ -> - StringMap.add name (Present t) env + FieldEnv.add name (Present t) env end - | t -> StringMap.add name t env) fields StringMap.empty + | t -> FieldEnv.add name t env) fields FieldEnv.empty in let row = Row (fields, row_var, false) in (* NOTE: type annotations can lead to a closed type even though @@ -2516,9 +2516,9 @@ let type_pattern ?(linear_vars=true) closed List.fold_right (fun name (positive, negative) -> let a = fresh_var () in - (StringMap.add name (Present a) positive, - StringMap.add name Absent negative)) - names (StringMap.empty, StringMap.empty) in + (Types.FieldEnv.add name (Present a) positive, + Types.FieldEnv.add name Absent negative)) + names (Types.FieldEnv.empty, Types.FieldEnv.empty) in let outer_type = Types.Variant (Row (positive, row_var, false)) in let inner_type = Types.Variant (Row (negative, row_var, false)) in @@ -2901,10 +2901,10 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = let e = tc e in let t = typ e in ((label, e)::fields, - StringMap.add label (T.Present t) field_env, - StringMap.add label T.Absent absent_field_env, + Types.FieldEnv.add label (T.Present t) field_env, + Types.FieldEnv.add label T.Absent absent_field_env, Usage.combine field_usages (usages e))) - fields ([], StringMap.empty, StringMap.empty, Usage.empty) in + fields ([], Types.FieldEnv.empty, Types.FieldEnv.empty, Usage.empty) in begin match rest with | None -> let r = T.Row (field_env, Unionfind.fresh T.Closed, false) in @@ -2939,22 +2939,22 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = i.e. all the labels belonging to the record r *) let field_env' = - StringMap.fold (fun label f field_env' -> + Types.FieldEnv.fold (fun label f field_env' -> match f with | T.Absent -> - if StringMap.mem label field_env then + if Types.FieldEnv.mem label field_env then field_env' else - StringMap.add label T.Absent field_env' + Types.FieldEnv.add label T.Absent field_env' | T.Present t -> - if StringMap.mem label field_env then + if Types.FieldEnv.mem label field_env then failwith ("Could not extend record "^ expr_string (erase r)^" (of type "^ Types.string_of_datatype rtype^") with the label "^ label^ " (of type"^Types.string_of_datatype (T.Record (T.Row (field_env, Unionfind.fresh T.Closed, false)))^ ") because the labels overlap") else - StringMap.add label (T.Present t) field_env' + Types.FieldEnv.add label (T.Present t) field_env' | T.Meta _ -> assert false | _ -> raise Types.tag_expectation_mismatch) rfield_env field_env in @@ -3290,11 +3290,11 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = let field_env = List.fold_right (fun name field_env -> - if StringMap.mem name field_env then + if Types.FieldEnv.mem name field_env then Gripers.die pos "Duplicate labels in insert expression." else - StringMap.add name (T.Present (Types.fresh_type_variable (lin_any, res_base))) field_env) - labels StringMap.empty + Types.FieldEnv.add name (T.Present (Types.fresh_type_variable (lin_any, res_base))) field_env) + labels Types.FieldEnv.empty in (* Check that the fields in the type of values match the declared labels *) @@ -3314,7 +3314,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = in let needed_env = - StringMap.map + Types.FieldEnv.map (fun _f -> Types.fresh_presence_variable (lin_any, res_base)) field_env in @@ -3347,7 +3347,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = the table. *) let row = - T.Row (StringMap.singleton id (T.Present Types.int_type), + T.Row (Types.FieldEnv.singleton id (T.Present Types.int_type), Types.fresh_row_variable (lin_any, res_base), false) in unify ~handle:Gripers.insert_id @@ -3414,14 +3414,14 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = List.fold_right (fun (name, exp) (set, field_env) -> let exp = type_check context' exp in - if StringMap.mem name field_env then + if Types.FieldEnv.mem name field_env then Gripers.die pos "Duplicate fields in update expression." else - (name, exp)::set, StringMap.add name (T.Present (typ exp)) field_env) - set ([], StringMap.empty) in + (name, exp)::set, Types.FieldEnv.add name (T.Present (typ exp)) field_env) + set ([], Types.FieldEnv.empty) in let needed_env = - StringMap.map + Types.FieldEnv.map (fun _f -> Types.fresh_presence_variable (lin_any, res_base)) field_env in @@ -3555,7 +3555,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = | Flat -> let shape = Types.make_list_type - (T.Record (T.Row (StringMap.empty, + (T.Record (T.Row (Types.FieldEnv.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 @@ -4092,7 +4092,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = in assert (not lr); begin - match StringMap.lookup l field_env with + match Types.FieldEnv.lookup l field_env with | Some (T.Present t) -> (* the free type variables in the projected type *) let vars = Types.free_type_vars t in @@ -4150,7 +4150,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = let rfields, row_var, lr = (TypeUtils.extract_row (typ r)) |> Types.unwrap_row |> fst |> TypeUtils.extract_row_parts in assert (not lr); let rfields = - StringMap.mapi + Types.FieldEnv.mapi (fun name t -> if List.mem_assoc name fields then T.Present (snd3 (List.assoc name fields)) @@ -4308,7 +4308,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = let kname = Binder.to_name bndr in let kt = let (fields,_,_) = TypeUtils.extract_row_parts (TypeUtils.extract_row effrow) in - let kt = find_effect_type effname (StringMap.to_alist fields) in + let kt = find_effect_type effname (Types.FieldEnv.to_alist fields) in let op_param = TypeUtils.return_type kt in let typ = Env.find kname env in let domain = @@ -4448,7 +4448,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = = fun row -> let (operations, rho, dual) = TypeUtils.extract_row_parts row in let operations' = - StringMap.mapi + Types.FieldEnv.mapi (fun name p -> if TypeUtils.is_builtin_effect name then p @@ -4625,17 +4625,17 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = if Settings.get Basicsettings.Sessions.expose_session_fail then Types.row_with (Value.session_exception_operation, Types.fresh_presence_variable default_subkind) - (T.Row (StringMap.empty, rho, false)) + (T.Row (Types.FieldEnv.empty, rho, false)) else - T.Row (StringMap.empty, rho, false) + T.Row (Types.FieldEnv.empty, rho, false) in let try_effects = if Settings.get Basicsettings.Sessions.expose_session_fail then Types.row_with (Value.session_exception_operation, T.Present (LinCont.make_operation_type [] Types.empty_type)) - (T.Row (StringMap.empty, rho, false)) + (T.Row (Types.FieldEnv.empty, rho, false)) else - T.Row (StringMap.empty, rho, false) + T.Row (Types.FieldEnv.empty, rho, false) in unify ~handle:Gripers.try_effect diff --git a/core/typeUtils.ml b/core/typeUtils.ml index a7c8d69e5..b5c27b47d 100644 --- a/core/typeUtils.ml +++ b/core/typeUtils.ml @@ -15,8 +15,8 @@ let extract_row_parts = Types.extract_row_parts let split_row name row = let (field_env, row_var, dual) = fst (unwrap_row row) |> extract_row_parts in let t = - if StringMap.mem name field_env then - match (StringMap.find name field_env) with + if FieldEnv.mem name field_env then + match (FieldEnv.find name field_env) with | Present t -> t | Absent -> error ("Attempt to split row "^string_of_row row ^" on absent field " ^ name) @@ -28,9 +28,9 @@ let split_row name row = in let new_field_env = if is_closed_row row then - StringMap.remove name field_env + FieldEnv.remove name field_env else - StringMap.add name Absent field_env + FieldEnv.add name Absent field_env in t, Row (new_field_env, row_var, dual) @@ -102,12 +102,12 @@ let rec erase_type ?(overstep_quantifiers=true) names t = let field_env = StringSet.fold (fun name field_env -> - match StringMap.lookup name field_env with + match FieldEnv.lookup name field_env with | Some (Present _) -> if closed then - StringMap.remove name field_env + FieldEnv.remove name field_env else - StringMap.add name Absent field_env + FieldEnv.add name Absent field_env | Some Absent -> error ("Attempt to remove absent field "^name^" from row "^string_of_row row) | Some (Meta _) -> @@ -154,7 +154,7 @@ let rec effect_row ?(overstep_quantifiers=true) t = match (concrete_type t, over let iter_row (iter_func : string -> field_spec -> unit) row = let (field_spec_map, _, _) = fst (unwrap_row row) |> extract_row_parts in - Utility.StringMap.iter iter_func field_spec_map + FieldEnv.iter iter_func field_spec_map let is_function_type t = match concrete_type t with | Lolli (_, _, _) @@ -212,11 +212,11 @@ let record_without t names = match concrete_type t with | Record (Row (fields, row_var, dual) as row) -> if is_closed_row row then - let fieldm = StringSet.fold (fun name fields -> StringMap.remove name fields) names fields in + let fieldm = StringSet.fold (fun name fields -> FieldEnv.remove name fields) names fields in Record (Row (fieldm, row_var, dual)) else let fieldm = - StringMap.mapi + FieldEnv.mapi (fun name f -> if StringSet.mem name names then Absent @@ -370,7 +370,7 @@ let check_type_wellformedness primary_kind t : unit = (* Row *) | Row (field_spec_map, row_var, _dual) -> let handle_fs _label f = ifield_spec f in - StringMap.iter handle_fs field_spec_map; + FieldEnv.iter handle_fs field_spec_map; meta rec_env row_var (* Session *) | Input (t, s) @@ -394,7 +394,7 @@ let row_present_types t = extract_row t |> extract_row_parts |> fst3 - |> StringMap.filter_map + |> FieldEnv.filter_map (fun _ v -> match v with | Present t -> Some t diff --git a/core/typeUtils.mli b/core/typeUtils.mli index 1191b0220..b542dcb86 100644 --- a/core/typeUtils.mli +++ b/core/typeUtils.mli @@ -44,7 +44,7 @@ val choice_at : string -> Types.datatype -> Types.datatype val primary_kind_of_type : Types.datatype -> PrimaryKind.t val check_type_wellformedness : PrimaryKind.t option -> Types.datatype -> unit -val row_present_types : Types.datatype -> Types.datatype Utility.StringMap.t +val row_present_types : Types.datatype -> Types.datatype Types.FieldEnv.t val pack_types : Types.datatype list -> Types.datatype diff --git a/core/types.ml b/core/types.ml index 6a8690b24..8557b108a 100644 --- a/core/types.ml +++ b/core/types.ml @@ -12,9 +12,15 @@ let tag_expectation_mismatch = let lincont_enabled = Settings.get Basicsettings.CTLinearity.enabled -module FieldEnv = Utility.StringMap +module FieldEnv = Utility.Map.Make(struct + type t = string + let pp = String.pp + let show = String.show + (* Ensure tuples are ordered correctly *) + let compare s1 s2 = let c = Int.compare (String.length s1) (String.length s2) in if c <> 0 then c else String.compare s1 s2 +end) type 'a stringmap = 'a Utility.stringmap [@@deriving show] -type 'a field_env = 'a stringmap [@@deriving show] +type 'a field_env = 'a FieldEnv.t [@@deriving show] (* type var sets *) module TypeVarSet = struct @@ -192,7 +198,7 @@ and session_type = typ and datatype = typ and type_arg = PrimaryKind.t * typ and field_spec = typ -and field_spec_map = field_spec Utility.StringMap.t +and field_spec_map = field_spec field_env and meta_type_var = typ point and meta_row_var = row point and meta_presence_var = typ point @@ -312,11 +318,11 @@ struct method field_spec_map : field_spec_map -> ('self_type * field_spec_map) = fun fsmap -> - StringMap.fold + FieldEnv.fold (fun lbl fs (o, fsmap') -> let (o, fs) = o#field_spec fs in - (o, StringMap.add lbl fs fsmap')) - fsmap (o, StringMap.empty) + (o, FieldEnv.add lbl fs fsmap')) + fsmap (o, FieldEnv.empty) method quantifier : Quantifier.t -> ('self_type * Quantifier.t) = fun q -> (o, q) @@ -1034,7 +1040,7 @@ module Env = Env.String let open PrimaryKind in match pk with | Type -> (Type, make_rigid_type_variable var sk) - | Row -> (Row, Row (StringMap.empty, make_rigid_row_variable var sk, false)) + | Row -> (Row, Row (FieldEnv.empty, make_rigid_row_variable var sk, false)) | Presence -> (Presence, make_rigid_presence_variable var sk) let is_closed_row : row -> bool = @@ -1370,7 +1376,7 @@ and dual_row : var_map -> row -> row = match fst (unwrap_row row) with | Row (fields, row_var, dual) -> let fields' = - StringMap.map + FieldEnv.map (function | Absent -> Absent | Present t -> @@ -1445,7 +1451,7 @@ and subst_dual_row : var_map -> row -> row = match fst (unwrap_row row) with | Row (fields, row_var, dual) -> let fields' = - StringMap.map + FieldEnv.map (subst_dual_field_spec rec_points) fields in @@ -1471,7 +1477,7 @@ and flatten_row : row -> row = fun row -> match row with | Row _ -> row (* HACK: this probably shouldn't happen! *) - | Meta row_var -> Row (StringMap.empty, row_var, false) + | Meta row_var -> Row (FieldEnv.empty, row_var, false) | _ -> raise (internal_error "attempt to flatten, row expected") in let dual_if = @@ -1695,7 +1701,7 @@ let quantifier_of_type_arg = function | Type, Meta point -> quantifier_of_point point | Row, Row (fields, point, _dual) -> - assert (StringMap.is_empty fields); + assert (FieldEnv.is_empty fields); quantifier_of_point point | Presence, Meta point -> quantifier_of_point point (* HACK: this probably shouldn't happen *) @@ -1740,7 +1746,7 @@ let is_tuple ?(allow_onetuples=false) row = in match Unionfind.find row_var with | Closed -> - let n = StringMap.size field_env in + let n = FieldEnv.size field_env in let b = n = 0 || (List.for_all @@ -2567,7 +2573,7 @@ struct | Row (fields, _, _) -> fields | _ -> raise tag_expectation_mismatch in - if StringMap.is_empty fields then + if FieldEnv.is_empty fields then ts else let r = row ~name:(fun _ _ -> name_of_eff_var ~allows_shared:true) "," context p r' in @@ -2735,7 +2741,7 @@ struct (* FIXME: this shouldn't happen *) | Meta rv -> Debug.print ("Row variable where row expected:"^show_datatype (Meta rv)); - row sep context ~name:name ~strip_wild:strip_wild p (Row (StringMap.empty, rv, false)) + row sep context ~name:name ~strip_wild:strip_wild p (Row (FieldEnv.empty, rv, false)) | t -> failwith ("Illformed row:"^show_datatype t) (* raise tag_expectation_mismatch *) @@ -4498,10 +4504,10 @@ let make_fresh_envs : datatype -> datatype IntMap.t * row IntMap.t * field_spec | Closed -> empties | Var (var, kind, `Flexible) -> let tenv, renv, penv = empties in - (tenv, M.add var (Row (StringMap.empty, fresh_row_variable (Kind.subkind kind), false)) renv, penv) + (tenv, M.add var (Row (FieldEnv.empty, fresh_row_variable (Kind.subkind kind), false)) renv, penv) | Var (var, kind, `Rigid) -> let tenv, renv, penv = empties in - (tenv, M.add var (Row (StringMap.empty, fresh_rigid_row_variable (Kind.subkind kind), false)) renv, penv) + (tenv, M.add var (Row (FieldEnv.empty, fresh_rigid_row_variable (Kind.subkind kind), false)) renv, penv) | Recursive (l, _, _) when S.mem l boundvars -> empties | Recursive (l, _, row) -> make_env (S.add l boundvars) row | row -> make_env boundvars row @@ -4526,13 +4532,13 @@ let make_fresh_envs : datatype -> datatype IntMap.t * row IntMap.t * field_spec let make_rigid_envs datatype : datatype IntMap.t * row IntMap.t * field_spec Utility.IntMap.t = let tenv, renv, penv = make_fresh_envs datatype in (IntMap.map (fun _ -> fresh_rigid_type_variable (lin_any, res_any)) tenv, - IntMap.map (fun _ -> Row (StringMap.empty, fresh_rigid_row_variable (lin_any, res_any), false)) renv, + IntMap.map (fun _ -> Row (FieldEnv.empty, fresh_rigid_row_variable (lin_any, res_any), false)) renv, IntMap.map (fun _ -> fresh_rigid_presence_variable (lin_any, res_any)) penv) let make_wobbly_envs datatype : datatype IntMap.t * row IntMap.t * field_spec Utility.IntMap.t = let tenv, renv, penv = make_fresh_envs datatype in (IntMap.map (fun _ -> fresh_type_variable (lin_any, res_any)) tenv, - IntMap.map (fun _ -> Row (StringMap.empty, fresh_row_variable (lin_any, res_any), false)) renv, + IntMap.map (fun _ -> Row (FieldEnv.empty, fresh_row_variable (lin_any, res_any), false)) renv, IntMap.map (fun _ -> fresh_presence_variable (lin_any, res_any)) penv) let combine_per_kind_envs : datatype IntMap.t * row IntMap.t * field_spec IntMap.t -> type_arg IntMap.t = @@ -4742,8 +4748,8 @@ let remove_field : ?idempotent:bool -> Label.t -> row -> row = fun ?(idempotent=true) lbl row -> match row with | Row (fieldenv, var, dual) -> - if idempotent || StringMap.mem lbl fieldenv - then Row (StringMap.remove lbl fieldenv, var, dual) + if idempotent || FieldEnv.mem lbl fieldenv + then Row (FieldEnv.remove lbl fieldenv, var, dual) else raise (internal_error "attempt to remove non-existent field") | _ -> raise tag_expectation_mismatch diff --git a/core/types.mli b/core/types.mli index 5ef8b3f0a..cc1e3c3da 100644 --- a/core/types.mli +++ b/core/types.mli @@ -2,8 +2,9 @@ open CommonTypes (* field environments *) +module FieldEnv : Utility.Map.S with type key = string type 'a stringmap = 'a Utility.StringMap.t [@@deriving show] -type 'a field_env = 'a stringmap [@@deriving show] +type 'a field_env = 'a FieldEnv.t [@@deriving show] (* type var sets *) module TypeVarSet : sig @@ -164,7 +165,7 @@ and session_type = typ and datatype = typ and type_arg = PrimaryKind.t * typ and field_spec = typ -and field_spec_map = field_spec Utility.StringMap.t +and field_spec_map = field_spec field_env and meta_type_var = typ point and meta_row_var = row point and meta_presence_var = typ point diff --git a/core/typevarcheck.ml b/core/typevarcheck.ml index ef4aec4d2..e8178aacc 100644 --- a/core/typevarcheck.ml +++ b/core/typevarcheck.ml @@ -1,8 +1,6 @@ open Utility open Types -module FieldEnv = Utility.StringMap - (* TODO - Actually make use of the bool argument to is_guarded_row. We @@ -93,7 +91,7 @@ let rec is_guarded : TypeVarSet.t -> StringSet.t -> int -> datatype -> bool = | Row (fields, row_var, _dual) -> let check_fields = false in (if check_fields then - (StringMap.fold + (FieldEnv.fold (fun _ f b -> b && isg f) fields true) diff --git a/core/unify.ml b/core/unify.ml index 4f234f6ff..c61e220fe 100644 --- a/core/unify.ml +++ b/core/unify.ml @@ -224,7 +224,7 @@ and eq_presence = fun (l, r) -> eq_types (l, r) and eq_field_envs (lfield_env, rfield_env) = let eq_specs lf rf = eq_presence (lf, rf) in - StringMap.equal eq_specs lfield_env rfield_env + FieldEnv.equal eq_specs lfield_env rfield_env and eq_row_vars (lpoint, rpoint) = (* QUESTION: Do we need to deal with closed rows specially? @@ -803,7 +803,7 @@ and unify_rows' : ?var_sk:Subkind.t -> unify_env -> ((row' * row') -> unit) = let is_unguarded_recursive row = let rec is_unguarded rec_rows (field_env, row_var, _) = - StringMap.is_empty field_env && + FieldEnv.is_empty field_env && (match Unionfind.find row_var with | Closed | Var _ -> false @@ -814,7 +814,7 @@ and unify_rows' : ?var_sk:Subkind.t -> unify_env -> ((row' * row') -> unit) = is_unguarded IntSet.empty row in let domain_of_env : field_spec_map -> StringSet.t = - fun env -> StringMap.fold (fun label _ labels -> StringSet.add label labels) env StringSet.empty in + fun env -> FieldEnv.fold (fun label _ labels -> StringSet.add label labels) env StringSet.empty in (* unify_field_envs closed rec_env (lenv, renv) @@ -848,7 +848,7 @@ and unify_rows' : ?var_sk:Subkind.t -> unify_env -> ((row' * row') -> unit) = let kill_extras extras env = StringSet.iter (fun label -> - match StringMap.find label env with + match FieldEnv.find label env with | (Absent | Meta _) as f -> unify_presence' rec_env (f, Absent) | _ -> @@ -873,8 +873,8 @@ and unify_rows' : ?var_sk:Subkind.t -> unify_env -> ((row' * row') -> unit) = (* unify fields in shared domain *) StringSet.iter (fun label -> - let lf = StringMap.find label lenv in - let rf = StringMap.find label renv in + let lf = FieldEnv.find label lenv in + let rf = FieldEnv.find label renv in unify_presence' rec_env (lf, rf)) shared_dom in @@ -946,7 +946,7 @@ and unify_rows' : ?var_sk:Subkind.t -> unify_env -> ((row' * row') -> unit) = raise (Failure (`Msg ("Rigid row variable cannot be unified with non-empty row\n" ^string_of_row (Row extension_row)))) | Var (var, ((_, (lin, rest)) as kind), `Flexible) -> - if not (StringMap.is_empty extension_field_env) && + if not (FieldEnv.is_empty extension_field_env) && TypeVarSet.mem var (free_row_type_vars (Row extension_row)) then begin if Restriction.is_base rest then @@ -975,9 +975,9 @@ and unify_rows' : ?var_sk:Subkind.t -> unify_env -> ((row' * row') -> unit) = in raise (Failure (`Msg message)) end; - if StringMap.is_empty extension_field_env then + if FieldEnv.is_empty extension_field_env then if dual then - Unionfind.change point (Row (StringMap.empty, extension_row_var, true)) + Unionfind.change point (Row (FieldEnv.empty, extension_row_var, true)) else Unionfind.union point extension_row_var else @@ -987,7 +987,7 @@ and unify_rows' : ?var_sk:Subkind.t -> unify_env -> ((row' * row') -> unit) = Unionfind.change point (Row extension_row) end | Recursive _ -> - unify_rows' rec_env ((StringMap.empty, point, dual), extension_row) + unify_rows' rec_env ((FieldEnv.empty, point, dual), extension_row) | row -> unify_rows' rec_env (TypeUtils.extract_row_parts (if dual then dual_row row else row), extension_row) in extend row_var in @@ -1000,8 +1000,8 @@ and unify_rows' : ?var_sk:Subkind.t -> unify_env -> ((row' * row') -> unit) = *) let matching_labels : field_spec_map * field_spec_map -> StringSet.t = fun (big_field_env, small_field_env) -> - StringMap.fold (fun label _ labels -> - if StringMap.mem label small_field_env then + FieldEnv.fold (fun label _ labels -> + if FieldEnv.mem label small_field_env then StringSet.add label labels else labels) big_field_env StringSet.empty in @@ -1010,7 +1010,7 @@ and unify_rows' : ?var_sk:Subkind.t -> unify_env -> ((row' * row') -> unit) = fun labels (field_env, row_var, dual) -> let restricted_field_env = StringSet.fold (fun label field_env -> - StringMap.remove label field_env) labels field_env in + FieldEnv.remove label field_env) labels field_env in (restricted_field_env, row_var, dual) in (* @@ -1033,7 +1033,7 @@ and unify_rows' : ?var_sk:Subkind.t -> unify_env -> ((row' * row') -> unit) = if IntMap.mem var rec_rows then IntMap.find var rec_rows else - [Row (StringMap.empty, row_var, false)] in + [Row (FieldEnv.empty, row_var, false)] in if List.exists (fun r -> eq_rows (r, Row restricted_row)) rs then None else @@ -1111,9 +1111,9 @@ and unify_rows' : ?var_sk:Subkind.t -> unify_env -> ((row' * row') -> unit) = let (flexible_field_env', flexible_row_var', flexible_dual) as flexible_row' = TypeUtils.extract_row_parts flexible_row' in (* let (flexible_field_env', flexible_row_var', flexible_dual) as flexible_row', flexible_rec_row = unwrap_row flexible_row in *) (* check that the flexible row contains no extra fields *) - StringMap.iter + FieldEnv.iter (fun label f -> - if (StringMap.mem label rigid_field_env') then + if (FieldEnv.mem label rigid_field_env') then () else match f with @@ -1139,7 +1139,7 @@ and unify_rows' : ?var_sk:Subkind.t -> unify_env -> ((row' * row') -> unit) = | None -> () | Some rec_env -> unify_field_envs ~closed:false ~rigid:false rec_env (rigid_field_env', flexible_field_env'); - let flexible_extension = StringMap.filter (fun label _ -> not (StringMap.mem label flexible_field_env')) rigid_field_env' in + let flexible_extension = FieldEnv.filter (fun label _ -> not (FieldEnv.mem label flexible_field_env')) rigid_field_env' in unify_row_var_with_row rec_env (flexible_row_var', flexible_dual, (flexible_extension, rigid_row_var', rigid_dual')) in let unify_both_flexible ((lfield_env, _, ldual as lrow), (rfield_env, _, rdual as rrow)) = @@ -1171,11 +1171,11 @@ and unify_rows' : ?var_sk:Subkind.t -> unify_env -> ((row' * row') -> unit) = let fresh_row_var = fresh_row_variable var_sk in (* each row can contain fields missing from the other *) - let rextension = StringMap.filter (fun label _ -> not (StringMap.mem label rfield_env')) lfield_env' in + let rextension = FieldEnv.filter (fun label _ -> not (FieldEnv.mem label rfield_env')) lfield_env' in (* Debug.print ("rext: "^string_of_row (Row (rextension, fresh_row_var, false))); *) unify_row_var_with_row rec_env (rrow_var', rdual', (rextension, fresh_row_var, false)); - let lextension = StringMap.filter (fun label _ -> not (StringMap.mem label lfield_env')) rfield_env' in + let lextension = FieldEnv.filter (fun label _ -> not (FieldEnv.mem label lfield_env')) rfield_env' in unify_row_var_with_row rec_env (lrow_var', ldual', (lextension, fresh_row_var, false)) end in diff --git a/core/utility.ml b/core/utility.ml index 2ef7870ef..1d2d46b80 100644 --- a/core/utility.ml +++ b/core/utility.ml @@ -962,14 +962,15 @@ struct | fa, fal -> Some (from_option a fa::from_option al fal) - let map_tryPick f m = - StringMap.fold + let unk_map_tryPick fold f m = + fold (fun k v acc -> lazy (match f k v with | None -> Lazy.force acc | y -> y)) m (lazy None) |> Lazy.force + let map_tryPick f m = unk_map_tryPick StringMap.fold f m let rec list_tryPick f = function | [] -> None diff --git a/tests/handlers.tests b/tests/handlers.tests index 11335f7f2..369a0f4f7 100644 --- a/tests/handlers.tests +++ b/tests/handlers.tests @@ -231,7 +231,7 @@ args : --enable-handlers Operation parameter pattern-matching (7) fun(m) { handle(m()) { case -> 'A' case -> 'B' case -> 'U' case x -> x } } -stdout : fun : (() {Move:([|Alice|Bob|_|]) => _::Any|c}~> Char) {Move{_}|c}~> Char +stdout : fun : (() {Move:([|Bob|Alice|_|]) => _::Any|c}~> Char) {Move{_}|c}~> Char args : --enable-handlers Operation parameter pattern-matching (8) diff --git a/tests/handlers_with_cfl_on.tests b/tests/handlers_with_cfl_on.tests index 998aab9e9..e74a2ea74 100644 --- a/tests/handlers_with_cfl_on.tests +++ b/tests/handlers_with_cfl_on.tests @@ -235,7 +235,7 @@ args : --enable-handlers Operation parameter pattern-matching (7) fun(m) { handle(m()) { case -> 'A' case -> 'B' case -> 'U' case x -> x } } -stdout : fun : (() {Move:([|Alice|Bob|_|]) => _::Any|c}~> Char) {Move{_}|c}~> Char +stdout : fun : (() {Move:([|Bob|Alice|_|]) => _::Any|c}~> Char) {Move{_}|c}~> Char args : --enable-handlers Operation parameter pattern-matching (8) diff --git a/tests/patterns.tests b/tests/patterns.tests index 18f9733f3..9cbc0bbc2 100644 --- a/tests/patterns.tests +++ b/tests/patterns.tests @@ -148,7 +148,7 @@ stdout : Quux : [|Bar-|Baz-|Foo-|Quux|_|] Negative pattern [12] (fun(x) { switch(x) { case (-(Foo, Bar, Baz) as x) -> x case _ -> Quux }})(FooBar) -stdout : FooBar : [|Bar-|Baz-|Foo-|FooBar|Quux|_|] +stdout : FooBar : [|Bar-|Baz-|Foo-|Quux|FooBar|_|] Presence polymorphism 1 [13] (fun (x : [|Foo| Bar{p}|]) { switch(x) {case Foo -> 1 case _ -> 2 }} ) @@ -157,4 +157,4 @@ stdout : fun : ([|Bar{_}|Foo|]) -> Int Presence polymorphism 2 [14] (fun (x : [|Foo| Bar{p}|]) { switch(x) {case Bar -> 1 case _ -> 2 }} ) stderr : @.*Type error.* -exit : 1 \ No newline at end of file +exit : 1 diff --git a/tests/records.tests b/tests/records.tests index 685ccbef4..5e0800c6f 100644 --- a/tests/records.tests +++ b/tests/records.tests @@ -4,7 +4,7 @@ stdout : (x = 1, y = "two") : (x:Int,y:String) Quote record labels that are also keywords ("client"=5, "fun"=7) -stdout : ("client" = 5, "fun" = 7) : (client:Int,fun:Int) +stdout : ("client" = 5, "fun" = 7) : (fun:Int,client:Int) Record comparisons (x=1, y="two") == (y="two", x=1)