From 38d2881dcd1917a93b202c16a55d57d51006ee88 Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Fri, 25 Apr 2014 14:36:19 +0200
Subject: Adding a debug printer for futures.

---
 lib/future.ml  | 14 ++++++++++++++
 lib/future.mli |  5 +++--
 2 files changed, 17 insertions(+), 2 deletions(-)

(limited to 'lib')

diff --git a/lib/future.ml b/lib/future.ml
index 1e878ac32c..1f68061efe 100644
--- a/lib/future.ml
+++ b/lib/future.ml
@@ -191,3 +191,17 @@ let map2 ?greedy f x l =
         with Failure _ | Invalid_argument _ ->
           Errors.anomaly (Pp.str "Future.map2 length mismatch")) in
     f xi y) 0 l
+
+let print f kx =
+  let open Pp in
+  let (uid, _, x) = get kx in
+  let uid =
+    if UUID.equal uid UUID.invalid then str "[#]"
+    else str "[" ++ int uid ++ str "]"
+  in
+  match !x with
+  | Delegated _ -> str "Delegated" ++ uid
+  | Closure _ -> str "Closure" ++ uid
+  | Val (x, None) -> str "PureVal" ++ uid ++ spc () ++ hov 0 (f x)
+  | Val (x, Some _) -> str "StateVal" ++ uid ++ spc () ++ hov 0 (f x)
+  | Exn e -> str "Exn"  ++ uid ++ spc () ++ hov 0 (str (Printexc.to_string e))
diff --git a/lib/future.mli b/lib/future.mli
index 785b2df531..09d18ff269 100644
--- a/lib/future.mli
+++ b/lib/future.mli
@@ -143,9 +143,10 @@ val purify : ('a -> 'b) -> 'a -> 'b
 (* And also let a function alter the state but backtrack if it raises exn *)
 val transactify : ('a -> 'b) -> 'a -> 'b
 
+(** Debug: print a computation given an inner printing function. *)
+val print : ('a -> Pp.std_ppcmds) -> 'a computation -> Pp.std_ppcmds
+
 (* These functions are needed to get rid of side effects.
    Thy are set for the outermos layer of the system, since they have to
    deal with the whole system state. *)
 val set_freeze : (unit -> Dyn.t) -> (Dyn.t -> unit) -> unit
-
-
-- 
cgit v1.2.3