qsp_parser/lib/syntax/compose.ml

(** Build a module with the result from another one module *)

open StdLabels

(** Make a module lazy *)
module Lazier (E : S.Expression) :
  S.Expression with type t' = E.t' Lazy.t and type t = E.t Lazy.t = struct
  type t = E.t Lazy.t
  type t' = E.t' Lazy.t

  let v : E.t Lazy.t -> E.t' Lazy.t = Lazy.map E.v
  let integer : S.pos -> string -> t = fun pos i -> lazy (E.integer pos i)

  let ident : (S.pos, t) S.variable -> t =
   fun { pos; name : string; index : t option } ->
    lazy (E.ident { pos; name; index = Option.map Lazy.force index })

  let literal : S.pos -> t T.literal list -> t =
   fun pos litts ->
    lazy
      (let e_litts = List.map litts ~f:(T.map_litteral ~f:Lazy.force) in
       E.literal pos e_litts)

  let function_ : S.pos -> T.function_ -> t list -> t =
   fun pos f e ->
    lazy
      (let e' = List.map ~f:Lazy.force e in
       E.function_ pos f e')

  let uoperator : S.pos -> T.uoperator -> t -> t =
   fun pos op t ->
    let t' = lazy (E.uoperator pos op (Lazy.force t)) in
    t'

  let boperator : S.pos -> T.boperator -> t -> t -> t =
   fun pos op t1 t2 ->
    let t' = lazy (E.boperator pos op (Lazy.force t1) (Lazy.force t2)) in
    t'
end

(** 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' Lazy.t * t) S.variable -> E.t' Lazy.t -> t
    val integer : S.pos -> string -> E.t' Lazy.t -> t
    val literal : S.pos -> (E.t' Lazy.t * t) T.literal list -> E.t' Lazy.t -> t

    val function_ :
      S.pos -> T.function_ -> (E.t' Lazy.t * t) list -> E.t' Lazy.t -> t

    val uoperator : S.pos -> T.uoperator -> E.t' Lazy.t * t -> E.t' Lazy.t -> t

    val boperator :
      S.pos ->
      T.boperator ->
      E.t' Lazy.t * t ->
      E.t' Lazy.t * t ->
      E.t' Lazy.t ->
      t

    val v : E.t' Lazy.t * t -> t'
    (** Convert from the internal representation to the external one. *)
  end

  (* Create a lazy version of the module *)
  module E = Lazier (E)

  module Make (M : SIG) : S.Expression with type t' = M.t' = struct
    type t = E.t * M.t
    type t' = M.t'

    let v' : E.t -> E.t' = E.v
    let v : t -> t' = fun (type_of, v) -> M.v (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) -> (v' e, m)) index in
      (t', M.ident { pos; name; index = index' } (v' t'))

    let integer : S.pos -> string -> t =
     fun pos i ->
      let t' = E.integer pos i in
      (t', M.integer pos i (v' t'))

    let literal : S.pos -> t T.literal list -> t =
     fun pos litts ->
      let litts' =
        List.map litts ~f:(T.map_litteral ~f:(fun (e, m) -> (v' e, m)))
      in

      let t' =
        let e_litts = List.map litts ~f:(T.map_litteral ~f:fst) in
        E.literal pos e_litts
      in
      (t', M.literal pos litts' (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) -> (v' e, m)) expressions in

      let t' = E.function_ pos f e in
      (t', M.function_ pos f expressions' (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 (v' t, expr) (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 (v' t1, expr1) (v' t2, expr2) (v' t'))
  end
end