From 6b377719c10d5ab3343fd5221f99a4a21008e25a Mon Sep 17 00:00:00 2001
From: Sébastien Dailly <sebastien@dailly.me>
Date: Thu, 14 Mar 2024 08:26:58 +0100
Subject: Initial commit

---
 lib/expression/compose.ml | 150 ++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 150 insertions(+)
 create mode 100644 lib/expression/compose.ml

(limited to 'lib/expression/compose.ml')

diff --git a/lib/expression/compose.ml b/lib/expression/compose.ml
new file mode 100644
index 0000000..028602b
--- /dev/null
+++ b/lib/expression/compose.ml
@@ -0,0 +1,150 @@
+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 : Sym.SYM_EXPR)
+    (R : sig
+      val v : 'a E.path_repr
+    end) =
+struct
+  module type SIG = sig
+    type 'a repr
+    type 'a obs
+    type 'a path_repr
+
+    val empty : 'a E.obs -> 'a repr
+    val expr : 'a E.obs * 'a repr -> 'a E.obs -> 'a repr
+    val literal : string -> 'a E.obs -> 'a repr
+    val integer : string -> 'a E.obs -> 'a repr
+    val path : 'a path_repr -> 'a -> 'a E.obs -> 'a repr
+    val concat : ('a E.obs * 'a repr) list -> 'a E.obs -> 'a repr
+
+    val window :
+      ('a E.obs * 'a repr) T.window ->
+      ('a E.obs * 'a repr) list ->
+      ('a E.obs * 'a repr) list ->
+      'a E.obs ->
+      'a repr
+
+    val nvl : ('a E.obs * 'a repr) list -> 'a E.obs -> 'a repr
+    val join : string -> ('a E.obs * 'a repr) list -> 'a E.obs -> 'a repr
+
+    val boperator :
+      T.binary_operator ->
+      'a E.obs * 'a repr ->
+      'a E.obs * 'a repr ->
+      'a E.obs ->
+      'a repr
+
+    val gequality :
+      T.binary_operator ->
+      'a E.obs * 'a repr ->
+      ('a E.obs * 'a repr) list ->
+      'a E.obs ->
+      'a repr
+
+    val funct : string -> ('a E.obs * 'a repr) list -> 'a E.obs -> 'a repr
+    val function' : T.funct -> ('a E.obs * 'a repr) list -> 'a E.obs -> 'a repr
+    val observe : 'a E.obs * 'a repr -> 'a obs
+  end
+
+  module Make (M : SIG) = struct
+    type 'a repr = 'a E.repr * 'a M.repr
+    type 'a obs = 'a M.obs
+    type 'a path_repr = 'a M.path_repr
+
+    let map' : 'a repr list -> 'a E.repr list * ('a E.obs * 'a M.repr) list =
+     fun ll ->
+      let e = List.map ~f:fst ll in
+      (e, List.map ll ~f:(fun (e, m) -> (E.observe e, m)))
+
+    let observe : 'a repr -> 'a obs = fun (t, v) -> M.observe (E.observe t, v)
+
+    let empty : unit -> 'a repr =
+     fun () ->
+      let e = E.empty () in
+      (e, M.empty (E.observe e))
+
+    let expr : 'a repr -> 'a repr =
+     fun (e, m) ->
+      let e' = E.expr e in
+      (e', M.expr (E.observe e, m) (E.observe e'))
+
+    let literal : string -> 'a repr =
+     fun litt ->
+      let e = E.literal litt in
+      (e, M.literal litt (E.observe e))
+
+    let integer : string -> 'a repr =
+     fun i ->
+      let e' = E.integer i in
+      (e', M.integer i (E.observe e'))
+
+    let path : 'b path_repr -> 'b -> 'a repr =
+     fun path_repr path ->
+      let e = E.path R.v path in
+      let m = M.path path_repr path (E.observe e) in
+      (e, m)
+
+    let concat : 'a repr list -> 'a repr =
+     fun reprs ->
+      let e, m = map' reprs in
+      let e' = E.concat e in
+      (e', M.concat m (E.observe e'))
+
+    let window : 'a repr T.window -> 'a repr list -> 'a repr list -> 'a repr =
+     fun window expressions order ->
+      let e_expressions, m_expressions = map' expressions
+      and e_order, m_order = map' order
+      and e_window = T.map_window window ~f:fst
+      and m_window = T.map_window window ~f:(fun (e, m) -> (E.observe e, m)) in
+
+      let e = E.window e_window e_expressions e_order in
+      (e, M.window m_window m_expressions m_order (E.observe e))
+
+    let nvl : 'a repr list -> 'a repr =
+     fun reprs ->
+      let e, m = List.split reprs in
+
+      let e' = E.nvl e in
+      let e = List.map ~f:E.observe e in
+      (e', M.nvl (List.combine e m) (E.observe e'))
+
+    let join : string -> 'a repr list -> 'a repr =
+     fun sep reprs ->
+      let e_reprs, m = map' reprs in
+
+      let e = E.join sep e_reprs in
+      (e, M.join sep m (E.observe e))
+
+    let boperator : T.binary_operator -> 'a repr -> 'a repr -> 'a repr =
+     fun op (e1, m1) (e2, m2) ->
+      let e1' = E.observe e1
+      and e2' = E.observe e2
+      and e = E.boperator op e1 e2 in
+      let m' = M.boperator op (e1', m1) (e2', m2) (E.observe e) in
+      (e, m')
+
+    let gequality : T.binary_operator -> 'a repr -> 'a repr list -> 'a repr =
+     fun op (e1, m1) exprs ->
+      let e_reprs, m_reprs = map' exprs in
+      let e' = E.gequality op e1 e_reprs in
+      let m' = M.gequality op (E.observe e1, m1) m_reprs (E.observe e') in
+      (e', m')
+
+    let funct : string -> 'a repr list -> 'a repr =
+     fun sep reprs ->
+      let e_reprs, m = map' reprs in
+
+      let e = E.funct sep e_reprs in
+      (e, M.funct sep m (E.observe e))
+
+    let function' : T.funct -> 'a repr list -> 'a repr =
+     fun f reprs ->
+      let e_reprs, m = map' reprs in
+      let e = E.function' f e_reprs in
+      (e, M.function' f m (E.observe e))
+  end
+end
-- 
cgit v1.2.3