1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
|
module Make (NT : Nt.S) = struct
module Error = struct
open Condition
(* TODO: more structure *)
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 lookup_mg (ctx : Sublanguage_context.t) (mg_name : string) :
(Management.Multigroup.multigroup, Condition.t) result =
match ctx.branch#mg_of mg_name with
| Some mg -> Ok mg
| None -> Error (Error.multigroup_not_found mg_name)
let convert_cardinality : Ast.cardinality_spec -> Conventions.Cardinality.t =
function
| Ast.Finite n -> Conventions.Cardinality.Finite n
| Ast.AlephZero -> Conventions.Cardinality.AlephZero
| Ast.Continuum -> Conventions.Cardinality.Continuum
| Ast.ConstrainedFinite -> Conventions.Cardinality.ConstrainedFinite
(* Every relation-touching statement names exactly one mg via its FQN
prefix. The executor parses the FQN, resolves the mg in the branch
cache, advances it through NT, and returns a single-element delta. *)
let execute (ctx : Sublanguage_context.t) (stmt : Ast.statement) :
(Sublanguage_types.transition_delta * string, Condition.t) result =
let bh = ctx.write_handle in
let branch_name = ctx.branch#name in
match stmt with
| Ast.CreateMultigroup name ->
ctx.branch#add_multigroup ~name;
(match ctx.branch#mg_of name with
| Some mg -> Ok ([ (name, mg) ], "Multigroup created: " ^ name)
| None -> Error (Error.multigroup_not_found name))
| Ast.CreateRelation { name; schema = schema_pairs } ->
let* fqn = parse_fqn name in
let* mg = lookup_mg ctx fqn.mg in
let schema =
List.fold_left
(fun s (attr, dom) -> Schema.add attr dom s)
Schema.empty schema_pairs
in
let* _bh, new_mg =
NT.create_relation bh mg ~branch_name ~name:fqn.name ~schema
in
ctx.branch#set_mg ~name:fqn.mg new_mg;
Ok ([ (fqn.mg, new_mg) ], "Relation created: " ^ name)
| Ast.RetractRelation name ->
let* fqn = parse_fqn name in
let* mg = lookup_mg ctx fqn.mg in
let* _bh, new_mg =
NT.retract_relation bh mg ~name:fqn.name
in
ctx.branch#set_mg ~name:fqn.mg new_mg;
Ok ([ (fqn.mg, new_mg) ], "Relation retracted: " ^ name)
| Ast.ClearRelation name ->
let* fqn = parse_fqn name in
let* mg = lookup_mg ctx fqn.mg in
(match mg#get_relation fqn.name with
| None -> Error (Error.relation_not_found name)
| Some rel ->
let* _bh, new_mg =
NT.clear_relation bh mg
~branch_name ~mg_name:fqn.mg
(rel :> Relation.relation)
in
ctx.branch#set_mg ~name:fqn.mg new_mg;
Ok ([ (fqn.mg, new_mg) ], "Relation cleared: " ^ name))
| Ast.RegisterDomain { name; cardinality } ->
let* fqn = parse_fqn name in
let* mg = lookup_mg ctx fqn.mg in
let domain : Relation.domain =
new Relation.domain ~name:fqn.name
~generator:(fun _ -> Generator.Error "not enumerable via DDL")
~membership_criteria:(fun _ -> true)
~cardinality:(convert_cardinality cardinality)
~schema:Schema.empty ~provenance:None ~lineage:None
~constraints:None
in
let* _bh, new_mg = NT.register_domain bh mg domain in
ctx.branch#set_mg ~name:fqn.mg new_mg;
Ok ([ (fqn.mg, new_mg) ], "Domain registered: " ^ name)
end
|
