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