blob: 8d61aa38b926bae65ed9d7a50fc34184c0882a0f (
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
38
39
|
(** 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)
|
