diff options
| author | Marcos Magueta <maguetamarcos@gmail.com> | 2026-04-03 16:17:38 -0300 |
|---|---|---|
| committer | Marcos Magueta <maguetamarcos@gmail.com> | 2026-04-03 16:17:38 -0300 |
| commit | 63ae3c930de89af6f85229a467caa3f53cb844a2 (patch) | |
| tree | cda4d513672f9fefa09c3a1dff69d8443890e224 /lib/dbms_language.ml | |
| parent | c5bc3a4992b4968780c286a084ad7c02b2b58f1e (diff) | |
| download | Sakura-63ae3c930de89af6f85229a467caa3f53cb844a2.tar.gz Sakura-63ae3c930de89af6f85229a467caa3f53cb844a2.zip | |
format
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) |
