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)