1 files changed, 73 insertions, 0 deletions
diff --git a/lib/syntax/compose.ml b/lib/syntax/compose.ml
new file mode 100644
index 0000000..dcc1a86
--- /dev/null
+++ b/lib/syntax/compose.ml
@@ -0,0 +1,73 @@
+(** Build a module with the result from another one module *)
+
+open StdLabels
+
+(** Build an expression module with the result from another expression. The
+    signature of the fuctions is a bit different, as they all receive the
+    result from the previous evaluated element in argument. *)
+module Expression (E : S.Expression) = struct
+  module type SIG = sig
+    type t
+    type t'
+
+    (* Override the type [t] in the definition of all the functions. The
+       signatures differs a bit from the standard signature as they get the
+       result from E.t in last argument *)
+
+    val ident : (S.pos, E.t' * t) S.variable -> E.t' -> t
+    val integer : S.pos -> string -> E.t' -> t
+    val literal : S.pos -> (E.t' * t) T.literal list -> E.t' -> t
+    val function_ : S.pos -> T.function_ -> (E.t' * t) list -> E.t' -> t
+    val uoperator : S.pos -> T.uoperator -> E.t' * t -> E.t' -> t
+    val boperator : S.pos -> T.boperator -> E.t' * t -> E.t' * t -> E.t' -> t
+
+    val v : E.t' * t -> t'
+    (** Convert from the internal representation to the external one. *)
+  end
+
+  module Make (M : SIG) : S.Expression with type t' = M.t' = struct
+    type t = E.t * M.t
+    type t' = M.t'
+
+    let v : t -> t' = fun (type_of, v) -> M.v (E.v type_of, v)
+
+    let ident : (S.pos, t) S.variable -> t =
+     fun { pos; name : string; index : t option } ->
+      let t' = E.ident { pos; name; index = Option.map fst index } in
+      let index' = Option.map (fun (e, m) -> (E.v e, m)) index in
+      (t', M.ident { pos; name; index = index' } (E.v @@ t'))
+
+    let integer : S.pos -> string -> t =
+     fun pos i ->
+      let t' = E.integer pos i in
+      (t', M.integer pos i (E.v t'))
+
+    let literal : S.pos -> t T.literal list -> t =
+     fun pos litts ->
+      let e_litts = List.map litts ~f:(T.map_litteral ~f:fst) in
+      let litts' =
+        List.map litts ~f:(T.map_litteral ~f:(fun (e, m) -> (E.v e, m)))
+      in
+
+      let t' = E.literal pos e_litts in
+      (t', M.literal pos litts' (E.v t'))
+
+    let function_ : S.pos -> T.function_ -> t list -> t =
+     fun pos f expressions ->
+      let e = List.map ~f:fst expressions
+      and expressions' = List.map ~f:(fun (e, m) -> (E.v e, m)) expressions in
+
+      let t' = E.function_ pos f e in
+      (t', M.function_ pos f expressions' (E.v t'))
+
+    let uoperator : S.pos -> T.uoperator -> t -> t =
+     fun pos op (t, expr) ->
+      let t' = E.uoperator pos op t in
+      (t', M.uoperator pos op (E.v t, expr) (E.v t'))
+
+    let boperator : S.pos -> T.boperator -> t -> t -> t =
+     fun pos op (t1, expr1) (t2, expr2) ->
+      let t' = E.boperator pos op t1 t2 in
+      (t', M.boperator pos op (E.v t1, expr1) (E.v t2, expr2) (E.v t'))
+  end
+end