From: Richard W.M. Jones <rjones@redhat.com>
Date: Tue, 8 Oct 2013 18:03:33 +0000 (+0100)
Subject: debug: Print the name of goals that run, and goals required.
X-Git-Tag: 0.2~5
X-Git-Url: http://git.annexia.org/?a=commitdiff_plain;h=c233ce39dd4be632238faba62e93ff4b9a48766e;p=goaljobs.git

debug: Print the name of goals that run, and goals required.
---

diff --git a/goaljobs.ml b/goaljobs.ml
index 4e3c07b..fcbcf23 100644
--- a/goaljobs.ml
+++ b/goaljobs.ml
@@ -33,11 +33,31 @@ exception Goal_result of goal_result_t
 
 let goal_failed msg = raise (Goal_result (Goal_failed msg))
 
+let depth = ref 0
+let indent fs =
+  let do_indent str =
+    prerr_string "| ";
+    for i = 0 to !depth-1 do prerr_string "  " done;
+    prerr_string str;
+    Pervasives.flush Pervasives.stderr
+  in
+  ksprintf do_indent fs
+
 let target v =
   if v then raise (Goal_result Goal_OK)
 let target_all vs = target (List.fold_left (&&) true vs)
 let target_exists vs = target (List.fold_left (||) false vs)
-let require f = f ()
+let require name f =
+  indent "require: %s\n" name;
+  incr depth;
+  let r = (try Either (f ()) with exn -> Or exn) in
+  decr depth;
+  match r with
+  | Either x -> x
+  | Or exn -> raise exn
+
+let _enter_goal name = indent "enter goal: %s\n" name
+let _leave_goal name = indent "leave goal: %s\n" name
 
 type period_t = Seconds | Days | Months | Years
 let seconds = (1, Seconds)
diff --git a/goaljobs.mli b/goaljobs.mli
index a6361c5..43432f1 100644
--- a/goaljobs.mli
+++ b/goaljobs.mli
@@ -70,7 +70,7 @@ val target_exists : bool list -> unit
   (** [target_exists [t1; t2; ...]] is the same as writing
       [target (t1 || t2 || ...)] *)
 
-val require : (unit -> unit) -> unit
+val require : string -> (unit -> unit) -> unit
   (** [require] {i goal} defines the requirements of this goal, that
       is, other goals that have to be met before the rest of the
       goal is able to run.
@@ -343,3 +343,7 @@ val init : unit -> unit
 (* Export this so the macros can catch these exceptions. *)
 type goal_result_t = Goal_OK | Goal_failed of string
 exception Goal_result of goal_result_t
+
+(* Called to print debug message when we enter or leave a goal. *)
+val _enter_goal : string -> unit
+val _leave_goal : string -> unit
diff --git a/pa_goal.ml b/pa_goal.ml
index 20df4fa..c95095c 100644
--- a/pa_goal.ml
+++ b/pa_goal.ml
@@ -91,6 +91,8 @@ let generate_let_goal _loc (r : rec_flag) (lets : binding) =
         (* Define a goal name which the body may use. *)
         let goalname = $str:name$ in
 
+        _enter_goal goalname;
+
         (* Source location. *)
         let goalloc = $str:goalloc$ in
 
@@ -114,6 +116,7 @@ let generate_let_goal _loc (r : rec_flag) (lets : binding) =
           $body$ ;
           _call_onruns ();
           _call_onsuccesses ();
+          _leave_goal goalname;
 
           (* Avoid a compiler warning: *)
           ignore (goalname); ignore (goalloc)
@@ -123,9 +126,11 @@ let generate_let_goal _loc (r : rec_flag) (lets : binding) =
          * ordinary function exit.
          *)
         | Goal_result Goal_OK ->
+          _leave_goal goalname;
           _call_onsuccesses ();
           ()
         | exn ->
+          _leave_goal goalname;
           _call_onfails exn;
           raise exn
       >> in
@@ -155,7 +160,7 @@ let generate_let_goal _loc (r : rec_flag) (lets : binding) =
           let () = publish $str:name$ (
             function
             | [] ->
-              Goaljobs.require $lid:gname$
+              Goaljobs.require $str:name$ $lid:gname$
             | _ ->
               failwith (Printf.sprintf "goal '%s' does not take any arguments"
                           $str:name$);
@@ -174,14 +179,17 @@ let generate_require _loc expr =
   let rec rewrite = function
     | ExApp (_loc, ExId (_loc1, IdLid (_loc2, name)), right) ->
       let gname = "goal_" ^ name in
-      ExApp (_loc, ExId (_loc1, IdLid (_loc2, gname)), right)
+      ExApp (_loc, ExId (_loc1, IdLid (_loc2, gname)), right), name
+
     | ExApp (_loc, (ExApp _ as expr), right) ->
-      ExApp (_loc, rewrite expr, right)
+      let expr, name = rewrite expr in
+      ExApp (_loc, expr, right), name
+
     | _ ->
       locfail _loc "require (...) expression must contain a call to a goal"
   in
-  let expr = rewrite expr in
-  <:expr< Goaljobs.require (fun () -> $expr$) >>
+  let expr, name = rewrite expr in
+  <:expr< Goaljobs.require $str:name$ (fun () -> $expr$) >>
 
 ;;