diff options
Diffstat (limited to 'lib/icl')
| -rw-r--r-- | lib/icl/executor.ml | 48 | ||||
| -rw-r--r-- | lib/icl/sublanguage.ml | 13 |
2 files changed, 36 insertions, 25 deletions
diff --git a/lib/icl/executor.ml b/lib/icl/executor.ml index 8de60e0..0a77dff 100644 --- a/lib/icl/executor.ml +++ b/lib/icl/executor.ml @@ -1,19 +1,31 @@ -module Make (Storage : Management.Physical.S) = struct - module Ops = Manipulation.Make (Storage) - +module Make (NT : Nt.S) = struct type error = | ParseError of string - | ManipulationError of Error.t + | NtError of Nt.error | ConversionError of string + | MultigroupNotFound of string + | UnqualifiedName of string let sexp_of_error e = let open Sexplib.Sexp in match e with | ParseError s -> List [ Atom "parse-error"; Atom s ] - | ManipulationError e -> Error.sexp_of_error e + | NtError e -> List [ Atom "nt-error"; Atom (Nt.string_of_error e) ] | ConversionError s -> List [ Atom "conversion-error"; Atom s ] + | MultigroupNotFound s -> List [ Atom "multigroup-not-found"; Atom s ] + | UnqualifiedName s -> List [ Atom "unqualified-name"; Atom s ] + + let ( let* ) = Result.bind + let wrap_nt = Result.map_error (fun e -> NtError e) + + let parse_fqn (s : string) : (Qualified_name.t, error) result = + Qualified_name.try_parse s |> Result.map_error (fun s -> UnqualifiedName s) - let wrap_manip = Result.map_error (fun e -> ManipulationError e) + let lookup_mg (ctx : Sublanguage_context.t) (mg_name : string) : + (Management.Multigroup.multigroup, error) result = + match ctx.branch#mg_of mg_name with + | Some mg -> Ok mg + | None -> Error (MultigroupNotFound mg_name) let convert_binding_expr : Ast.binding_expr -> Constraint.binding_expr = function @@ -39,18 +51,20 @@ module Make (Storage : Management.Physical.S) = struct | Ast.Forall { variable; quantifier; body } -> Constraint.forall ~variable ~quantifier (convert_body body) - let execute (storage : Storage.t) (db : Management.Multigroup.multigroup) - (stmt : Ast.statement) : (Management.Multigroup.multigroup * string, error) result = + let execute (ctx : Sublanguage_context.t) (stmt : Ast.statement) : + (Sublanguage_types.transition_delta * string, error) result = match stmt with - | Ast.RegisterConstraint { constraint_name; relation_name; body } -> ( + | Ast.RegisterConstraint { constraint_name; relation_name; body } -> + let* fqn = parse_fqn relation_name in + let* mg = lookup_mg ctx fqn.mg in let runtime_body = convert_body body in - match - Ops.register_constraint storage db ~constraint_name ~relation_name - ~body:runtime_body - |> wrap_manip - with - | Ok new_db -> Ok (new_db, "Constraint registered: " ^ constraint_name) - | Error e -> Error e) + let* _bh, new_mg = + NT.register_constraint ctx.write_handle mg + ~constraint_name ~relation_name:fqn.name ~body:runtime_body + |> wrap_nt + in + ctx.branch#set_mg ~name:fqn.mg new_mg; + Ok ([ (fqn.mg, new_mg) ], "Constraint registered: " ^ constraint_name) end -module Memory = Make (Management.Physical.Memory) +module Memory = Make (Nt.Memory) diff --git a/lib/icl/sublanguage.ml b/lib/icl/sublanguage.ml index c415d96..ae2c359 100644 --- a/lib/icl/sublanguage.ml +++ b/lib/icl/sublanguage.ml @@ -1,8 +1,7 @@ -module Make (Storage : Management.Physical.S) = struct - module Exec = Executor.Make (Storage) +module Make (NT : Nt.S) = struct + module Exec = Executor.Make (NT) type configuration = unit - type storage = Storage.t type ast = Ast.statement type error = Exec.error @@ -14,12 +13,10 @@ module Make (Storage : Management.Physical.S) = struct | Ok r -> Ok r | Error (Parser.ParseError s) -> Error (Exec.ParseError s) - let execute storage db ast = - match Exec.execute storage db ast with - | Ok (db, _) -> Ok (Sublanguage_types.Transition db) + let execute ctx ast = + match Exec.execute ctx ast with + | Ok (delta, _msg) -> Ok (Sublanguage_types.Transition delta) | Error e -> Error e let sexp_of_error = Exec.sexp_of_error end - -module Memory = Make (Management.Physical.Memory) |
