aboutsummaryrefslogtreecommitdiffstats
path: root/lib/dml/executor.ml
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lib/dml/executor.ml172
1 files changed, 75 insertions, 97 deletions
diff --git a/lib/dml/executor.ml b/lib/dml/executor.ml
index d5c55f8..f034f4a 100644
--- a/lib/dml/executor.ml
+++ b/lib/dml/executor.ml
@@ -3,16 +3,19 @@ module Make (NT : Nt.S) = struct
module Error = struct
open Condition
+
(* TODO: more structure *)
let parse_error msg = condition "parse-error" msg empty
- let relation_not_found name = condition "relation-not-found" "Relation not found" ("name" |=| (of_string name))
- let multigroup_not_found name = condition "multigroup-not-found" "Multigroup not found" ("name" |=| (of_string name))
+
+ let relation_not_found name =
+ condition "relation-not-found" "Relation not found" ("name" |=| of_string name)
+
+ let multigroup_not_found name =
+ condition "multigroup-not-found" "Multigroup not found" ("name" |=| of_string name)
end
let ( let* ) = Result.bind
-
- let parse_fqn (s : string) : (Qualified_name.t, Condition.t) result =
- Qualified_name.try_parse s
+ let parse_fqn (s : string) : (Qualified_name.t, Condition.t) result = Qualified_name.try_parse s
let lookup_mg (ctx : Sublanguage_context.t) (mg_name : string) :
(Management.Multigroup.multigroup, Condition.t) result =
@@ -26,27 +29,22 @@ module Make (NT : Nt.S) = struct
| Some r -> Ok r
| None -> Error (Error.relation_not_found (Qualified_name.to_string fqn))
- let retarget target (t : Tuple.materialized) =
- { t with Tuple.relation = target }
+ let retarget target (t : Tuple.materialized) = {t with Tuple.relation= target}
let build_tuple ~relation (attributes : Ast.attr_value list) : Tuple.materialized =
let attr_map =
List.fold_left
(fun acc (name, value) ->
- Tuple.AttributeMap.add name
- { Attribute.value = Drl.Ast.value_to_abstract value }
- acc)
+ Tuple.AttributeMap.add name {Attribute.value= Drl.Ast.value_to_abstract value} acc )
Tuple.AttributeMap.empty attributes
in
- { Tuple.relation; attributes = attr_map }
+ {Tuple.relation; attributes= attr_map}
(* Drain all tuples from a DRL query using ctx.resolve for path resolution.
Cross-multigroup reads work transparently here. *)
let drain_query (ctx : Sublanguage_context.t) query =
let* plan = DrlExec.compile ctx query in
- let* stream =
- NT.execute_query plan ~rel_name:"dml_drain"
- in
+ let* stream = NT.execute_query plan ~rel_name:"dml_drain" in
let rec drain acc =
match NT.stream_next stream with
| Error _ -> List.rev acc
@@ -60,38 +58,36 @@ module Make (NT : Nt.S) = struct
(* Stored-relation paths referenced by a query, for ephemeral dependency
pinning. A qualified leaf resolves through ctx; an unqualified one is a
previously Defined session ephemeral (views compose). *)
- let rec base_dep_paths (ctx : Sublanguage_context.t) (q : Drl.Ast.query) :
- string list =
+ let rec base_dep_paths (ctx : Sublanguage_context.t) (q : Drl.Ast.query) : string list =
match q with
- | Drl.Ast.Base name ->
- (match Qualified_name.try_parse name with
- | Ok fqn -> [ ctx.resolve fqn ]
- | Error _ -> [ Sublanguage_context.ephemeral_path ctx name ])
+ | Drl.Ast.Base name -> (
+ match Qualified_name.try_parse name with
+ | Ok fqn -> [ctx.resolve fqn]
+ | Error _ -> [Sublanguage_context.ephemeral_path ctx name] )
| Drl.Ast.Const _ -> []
| Drl.Ast.Select (a, b)
- | Drl.Ast.Join (_, a, b)
- | Drl.Ast.Cartesian (a, b)
- | Drl.Ast.Union (a, b)
- | Drl.Ast.Diff (a, b) -> base_dep_paths ctx a @ base_dep_paths ctx b
- | Drl.Ast.Project (_, s)
- | Drl.Ast.Rename (_, s)
- | Drl.Ast.Take (_, s) -> base_dep_paths ctx s
+ |Drl.Ast.Join (_, a, b)
+ |Drl.Ast.Cartesian (a, b)
+ |Drl.Ast.Union (a, b)
+ |Drl.Ast.Diff (a, b) ->
+ base_dep_paths ctx a @ base_dep_paths ctx b
+ | Drl.Ast.Project (_, s) | Drl.Ast.Rename (_, s) | Drl.Ast.Take (_, s) -> base_dep_paths ctx s
(* Schema of a query result, walked structurally from the base relations'
schemas. Mirrors the operator semantics in docs/relational-algebra.org. *)
let rec infer_schema (ctx : Sublanguage_context.t) (q : Drl.Ast.query) :
(Schema.t, Condition.t) result =
match q with
- | Drl.Ast.Base name ->
- (match Qualified_name.try_parse name with
- | Error _ ->
- (* Session ephemeral: RNT owns its schema; nothing to derive
+ | Drl.Ast.Base name -> (
+ match Qualified_name.try_parse name with
+ | Error _ ->
+ (* Session ephemeral: RNT owns its schema; nothing to derive
on the OCaml-side, so treated as contributing no attributes. *)
- Ok []
- | Ok fqn ->
- let* rel = get_rel ctx fqn in
- Ok rel#schema)
- | Drl.Ast.Const attrs -> Ok (List.map (fun (n, _) -> (n, "abstract")) attrs)
+ Ok []
+ | Ok fqn ->
+ let* rel = get_rel ctx fqn in
+ Ok rel#schema )
+ | Drl.Ast.Const attrs -> Ok (List.map (fun (n, _) -> n, "abstract") attrs)
| Drl.Ast.Select (_, src) -> infer_schema ctx src
| Drl.Ast.Join (_, l, r) | Drl.Ast.Cartesian (l, r) ->
let* ls = infer_schema ctx l in
@@ -102,31 +98,28 @@ module Make (NT : Nt.S) = struct
Ok (List.filter (fun (n, _) -> List.mem n attrs) s)
| Drl.Ast.Rename (renames, src) ->
let* s = infer_schema ctx src in
- Ok (List.map (fun (n, d) ->
- match List.assoc_opt n renames with
- | Some n' -> (n', d)
- | None -> (n, d)) s)
+ Ok
+ (List.map
+ (fun (n, d) -> match List.assoc_opt n renames with Some n' -> n', d | None -> n, d)
+ s )
| Drl.Ast.Union (l, _) | Drl.Ast.Diff (l, _) -> infer_schema ctx l
| Drl.Ast.Take (_, src) -> infer_schema ctx src
- let attr_val_eq a b =
- Stdlib.( = ) a.Attribute.value b.Attribute.value
-
- let tuple_matches_pred common (target_t : Tuple.materialized)
- (pred_t : Tuple.materialized) =
- List.for_all (fun attr ->
- match
- ( Tuple.AttributeMap.find_opt attr target_t.Tuple.attributes,
- Tuple.AttributeMap.find_opt attr pred_t.Tuple.attributes )
- with
- | Some a, Some b -> attr_val_eq a b
- | _ -> false)
+ let attr_val_eq a b = Stdlib.( = ) a.Attribute.value b.Attribute.value
+
+ let tuple_matches_pred common (target_t : Tuple.materialized) (pred_t : Tuple.materialized) =
+ List.for_all
+ (fun attr ->
+ match
+ ( Tuple.AttributeMap.find_opt attr target_t.Tuple.attributes,
+ Tuple.AttributeMap.find_opt attr pred_t.Tuple.attributes )
+ with
+ | Some a, Some b -> attr_val_eq a b
+ | _ -> false )
common
let semijoin common target_tuples pred_tuples =
- List.filter
- (fun t -> List.exists (tuple_matches_pred common t) pred_tuples)
- target_tuples
+ List.filter (fun t -> List.exists (tuple_matches_pred common t) pred_tuples) target_tuples
(* DML mutates tuples in a single mg per statement. Returns a
single-element transition delta keyed by that mg's name. *)
@@ -134,52 +127,44 @@ module Make (NT : Nt.S) = struct
(Sublanguage_types.transition_delta, Condition.t) result =
let bh = ctx.write_handle in
let branch_name = ctx.branch#name in
- let after fqn = Result.bind (lookup_mg ctx fqn.Qualified_name.mg)
- (fun mg -> Ok [ (fqn.Qualified_name.mg, mg) ])
+ let after fqn =
+ Result.bind (lookup_mg ctx fqn.Qualified_name.mg) (fun mg -> Ok [fqn.Qualified_name.mg, mg])
in
match stmt with
- | Ast.InsertTuple { relation; attributes } ->
+ | Ast.InsertTuple {relation; attributes} ->
let* fqn = parse_fqn relation in
let* rel = get_rel ctx fqn in
let tuple = build_tuple ~relation:rel#name attributes in
- let* _ =
- NT.create_tuple ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name tuple
- in
+ let* _ = NT.create_tuple ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name tuple in
after fqn
- | Ast.InsertTuples { relation; tuples } ->
+ | Ast.InsertTuples {relation; tuples} ->
let* fqn = parse_fqn relation in
let* rel = get_rel ctx fqn in
let tuple_list = List.map (build_tuple ~relation:rel#name) tuples in
- let* _ =
- NT.create_tuples ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name
- tuple_list
- in
+ let* _ = NT.create_tuples ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name tuple_list in
after fqn
- | Ast.DeleteTuple { relation; attributes } ->
+ | Ast.DeleteTuple {relation; attributes} ->
let* fqn = parse_fqn relation in
let* rel = get_rel ctx fqn in
let tuple = build_tuple ~relation:rel#name attributes in
let hash = Hashing.hash_tuple tuple in
- let* () =
- NT.retract_tuple ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name hash
- in
+ let* () = NT.retract_tuple ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name hash in
after fqn
- | Ast.Assign { target; body } ->
+ | Ast.Assign {target; body} ->
let* fqn = parse_fqn target in
- let* mg = lookup_mg ctx fqn.mg in
+ let* mg = lookup_mg ctx fqn.mg in
let* rel = get_rel ctx fqn in
let* tuples = drain_query ctx body in
let* _bh, new_mg =
- NT.clear_relation bh mg ~branch_name ~mg_name:fqn.mg
- (rel :> Relation.relation)
+ NT.clear_relation bh mg ~branch_name ~mg_name:fqn.mg (rel :> Relation.relation)
in
ctx.branch#set_mg ~name:fqn.mg new_mg;
let* _ =
NT.create_tuples ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name
(List.map (retarget rel#name) tuples)
in
- Ok [ (fqn.mg, new_mg) ]
- | Ast.InsertFrom { target; source } ->
+ Ok [fqn.mg, new_mg]
+ | Ast.InsertFrom {target; source} ->
let* fqn = parse_fqn target in
let* rel = get_rel ctx fqn in
let* tuples = drain_query ctx source in
@@ -188,11 +173,11 @@ module Make (NT : Nt.S) = struct
(List.map (retarget rel#name) tuples)
in
after fqn
- | Ast.Define { target; body } ->
+ | Ast.Define {target; body} ->
let* () =
if String.contains target ':' then
- Error (Error.parse_error
- ("Define target must be unqualified (session-scoped): " ^ target))
+ Error
+ (Error.parse_error ("Define target must be unqualified (session-scoped): " ^ target))
else Ok ()
in
(* TODO: redefining an existing name isn't guarded. Right now we lean on
@@ -204,35 +189,29 @@ module Make (NT : Nt.S) = struct
time. Push the offset/limit down or cache the result. *)
let generator ~offset ~limit =
match drain_query ctx body with
- | Error _ -> []
- | Ok tuples ->
- List.filteri (fun i _ -> i >= offset && i < offset + limit) tuples
+ | Error _ -> []
+ | Ok tuples -> List.filteri (fun i _ -> i >= offset && i < offset + limit) tuples
in
let* _path =
- NT.register_ephemeral ~session:ctx.session_hash ~named:true
- ~name:target ~generator
+ NT.register_ephemeral ~session:ctx.session_hash ~named:true ~name:target ~generator
~cardinality:Conventions.Cardinality.ConstrainedFinite
- ~identity:(Drl.Parser.to_string body) ~schema
- ~deps:(base_dep_paths ctx body)
+ ~identity:(Drl.Parser.to_string body) ~schema ~deps:(base_dep_paths ctx body)
in
Ok []
- | Ast.DropDefine { target } ->
- let* () =
- NT.drop_ephemeral ~session:ctx.session_hash ~name:target
- in
+ | Ast.DropDefine {target} ->
+ let* () = NT.drop_ephemeral ~session:ctx.session_hash ~name:target in
Ok []
- | Ast.DeleteWhere { target; predicate } ->
+ | Ast.DeleteWhere {target; predicate} ->
let* fqn = parse_fqn target in
let* rel = get_rel ctx fqn in
let* target_tuples = drain_query ctx (Drl.Ast.Base target) in
- let* pred_tuples = drain_query ctx predicate in
+ let* pred_tuples = drain_query ctx predicate in
let attr_names_of = function
| [] -> []
- | t :: _ ->
- List.map fst (Tuple.AttributeMap.bindings t.Tuple.attributes)
+ | t :: _ -> List.map fst (Tuple.AttributeMap.bindings t.Tuple.attributes)
in
let target_attrs = attr_names_of target_tuples in
- let pred_attrs = attr_names_of pred_tuples in
+ let pred_attrs = attr_names_of pred_tuples in
let common = List.filter (fun n -> List.mem n pred_attrs) target_attrs in
let to_delete = semijoin common target_tuples pred_tuples in
let* () =
@@ -240,8 +219,7 @@ module Make (NT : Nt.S) = struct
(fun acc t ->
let* () = acc in
let hash = Hashing.hash_tuple (retarget rel#name t) in
- NT.retract_tuple ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name
- hash)
+ NT.retract_tuple ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name hash )
(Ok ()) to_delete
in
after fqn
generated by cgit v1.2.3 (git 2.25.1) at 2026-11-04 09:04:09 +0000