blob: 47e5a991a4eccddd2f7cd04968ab47ac42333384 (
plain) (
blame)
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
|
(** 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]. *)
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
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)))))
let sexp_of_dispatch_error (NoMatch sexp) = sexp
end
module Memory = Make (Management.Physical.Memory)
|
