diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/dbms_language.ml | 42 |
1 files changed, 20 insertions, 22 deletions
diff --git a/lib/dbms_language.ml b/lib/dbms_language.ml index 8d61aa3..47e5a99 100644 --- a/lib/dbms_language.ml +++ b/lib/dbms_language.ml @@ -1,39 +1,37 @@ (** Composable dispatch over sublanguages. - All commands must use the tagged envelope format: (tag payload) - where [tag] is the sublanguage name (drl, dml, ddl, icl, dcl, ...). - Adding a new sublanguage is just extending the list passed to [create]. *) + All commands must use the tagged envelope format: (tag payload) where [tag] + is the sublanguage name (drl, dml, ddl, icl, dcl, ...). Adding a new + sublanguage is just extending the list passed to [create]. *) module Make (Storage : Management.Physical.S with type error = string) = struct module type SubS = Sublanguage.S with type storage = Storage.t type dispatch_error = NoMatch of Sexplib.Sexp.t - type dispatch = (module SubS) list let create (langs : (module SubS) list) : dispatch = langs - let execute - (langs : dispatch) - (storage : Storage.t) - (db : Management.Database.t) - (input : string) - : (Sublanguage.result, dispatch_error) Result.t = - let no_match s = Error (NoMatch Sexplib.Sexp.(List [Atom "parse-error"; Atom s])) in + let execute (langs : dispatch) (storage : Storage.t) + (db : Management.Database.t) (input : string) : + (Sublanguage.result, dispatch_error) Result.t = + let no_match s = + Error (NoMatch Sexplib.Sexp.(List [ Atom "parse-error"; Atom s ])) + in match Envelope.parse input with | Error msg -> no_match msg - | Ok { tag; payload } -> - match List.find_opt (fun (module L : SubS) -> L.name = tag) langs with - | None -> no_match ("unknown sublanguage: " ^ tag) - | Some (module L) -> - match L.parse_sexp payload with - | Error e -> Error (NoMatch (L.sexp_of_error e)) - | Ok ast -> - match L.execute storage db ast with - | Ok result -> Ok result - | Error e -> Error (NoMatch (L.sexp_of_error e)) + | Ok { tag; payload } -> ( + match List.find_opt (fun (module L : SubS) -> L.name = tag) langs with + | None -> no_match ("unknown sublanguage: " ^ tag) + | Some (module L) -> ( + match L.parse_sexp payload with + | Error e -> Error (NoMatch (L.sexp_of_error e)) + | Ok ast -> ( + match L.execute storage db ast with + | Ok result -> Ok result + | Error e -> Error (NoMatch (L.sexp_of_error e))))) let sexp_of_dispatch_error (NoMatch sexp) = sexp end -module Memory = Make(Management.Physical.Memory) +module Memory = Make (Management.Physical.Memory) |
