From 0d5bcaea3370697822675d9f8d25bca34c02505e Mon Sep 17 00:00:00 2001
From: Chimrod <>
Date: Thu, 9 Nov 2023 16:04:09 +0100
Subject: Made the compose evaluation lazy

---
 lib/syntax/compose.ml | 71 ++++++++++++++++++++++++++++++++-------------------
 1 file changed, 45 insertions(+), 26 deletions(-)

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

diff --git a/lib/syntax/compose.ml b/lib/syntax/compose.ml
index dcc1a86..670249a 100644
--- a/lib/syntax/compose.ml
+++ b/lib/syntax/compose.ml
@@ -14,60 +14,79 @@ module Expression (E : S.Expression) = struct
        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'
+    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
 
   module Make (M : SIG) : S.Expression with type t' = M.t' = struct
-    type t = E.t * M.t
+    type t = E.t Lazy.t * M.t
     type t' = M.t'
 
-    let v : t -> t' = fun (type_of, v) -> M.v (E.v type_of, v)
+    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 : 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) -> (E.v e, m)) index in
-      (t', M.ident { pos; name; index = index' } (E.v @@ t'))
+      let t' = lazy (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 (E.v t'))
+      let t' = lazy (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 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)))
+        List.map litts ~f:(T.map_litteral ~f:(fun (e, m) -> (v' e, m)))
       in
 
-      let t' = E.literal pos e_litts in
-      (t', M.literal pos litts' (E.v t'))
+      let t' =
+        lazy
+          (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) -> (E.v e, m)) expressions in
+      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' (E.v t'))
+      let t' =
+        lazy
+          (let e' = List.map ~f:Lazy.force e in
+           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 (E.v t, expr) (E.v t'))
+      let t' = lazy (E.uoperator pos op (Lazy.force 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 (E.v t1, expr1) (E.v t2, expr2) (E.v t'))
+      let t' = lazy (E.boperator pos op (Lazy.force t1) (Lazy.force t2)) in
+      (t', M.boperator pos op (v' t1, expr1) (v' t2, expr2) (v' t'))
   end
 end
-- 
cgit v1.2.3