Added a functor for creating a lazy version of an Expression module

1 files changed, 48 insertions, 15 deletions

diff --git a/lib/syntax/compose.ml b/lib/syntax/compose.ml
index 670249a..8c92ed0 100644
--- a/lib/syntax/compose.ml
+++ b/lib/syntax/compose.ml
@@ -2,6 +2,42 @@
 
 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. *)
@@ -35,23 +71,25 @@ module Expression (E : S.Expression) = struct
     (** 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 Lazy.t * M.t
+    type t = E.t * M.t
     type t' = M.t'
 
-    let v' : E.t Lazy.t -> E.t' Lazy.t = Lazy.map E.v
-    let fst' : 'a Lazy.t * _ -> 'a = fun v -> Lazy.force (fst v)
+    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' = lazy (E.ident { pos; name; index = Option.map fst' index }) in
+      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' = lazy (E.integer pos i) in
+      let t' = E.integer pos i in
       (t', M.integer pos i (v' t'))
 
     let literal : S.pos -> t T.literal list -> t =
@@ -61,9 +99,8 @@ module Expression (E : S.Expression) = struct
       in
 
       let t' =
-        lazy
-          (let e_litts = List.map litts ~f:(T.map_litteral ~f:fst') in
-           E.literal pos e_litts)
+        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'))
 
@@ -72,21 +109,17 @@ module Expression (E : S.Expression) = struct
       let e = List.map ~f:fst expressions
       and expressions' = List.map ~f:(fun (e, m) -> (v' e, m)) expressions in
 
-      let t' =
-        lazy
-          (let e' = List.map ~f:Lazy.force e in
-           E.function_ pos f e')
-      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' = lazy (E.uoperator pos op (Lazy.force t)) in
+      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' = lazy (E.boperator pos op (Lazy.force t1) (Lazy.force t2)) in
+      let t' = E.boperator pos op t1 t2 in
       (t', M.boperator pos op (v' t1, expr1) (v' t2, expr2) (v' t'))
   end
 end