From 087ea609510e7c85e1048219f4aa96348d1eaeda Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Thu, 26 Sep 2013 14:40:33 +0100
Subject: [PATCH] Implement goalloc.

---
 goaljobs-reference.pod | 15 +++++++++++++++
 pa_goal.ml             |  9 ++++++++-
 2 files changed, 23 insertions(+), 1 deletion(-)

diff --git a/goaljobs-reference.pod b/goaljobs-reference.pod
index 393e4b5..2ca27c7 100644
--- a/goaljobs-reference.pod
+++ b/goaljobs-reference.pod
@@ -193,6 +193,21 @@ would print:
 
  my name is foo
 
+=head2 goalloc
+
+Inside goals, you can use C<goalloc> to get a printable source
+location of the goal, ie:
+
+ let goal foo () =
+   printf "%s\n" goalloc
+
+would print:
+
+ File "source.ml", line 2, characters 13-71 (end at line 3, character 23)
+
+Note that the actual string format depends on the internal OCaml
+function C<Loc.to_string> so it might change in future.
+
 =head2 onfail, onsuccess, onrun
 
 Inside goals you can register function(s) which run if the goal
diff --git a/pa_goal.ml b/pa_goal.ml
index e795233..13ea23c 100644
--- a/pa_goal.ml
+++ b/pa_goal.ml
@@ -68,6 +68,9 @@ let generate_let_goal _loc (r : rec_flag) (lets : binding) =
       (* Rename the function to goal_<name>. *)
       let gname = "goal_" ^ name in
 
+      (* Convert loc to string for goalloc. *)
+      let goalloc = Loc.to_string _loc in
+
       (* Split the function into parameters and body. *)
       let params, body = function_parameters expr in
 
@@ -87,6 +90,10 @@ let generate_let_goal _loc (r : rec_flag) (lets : binding) =
       let body = <:expr<
         (* Define a goal name which the body may use. *)
         let goalname = $str:name$ in
+
+        (* Source location. *)
+        let goalloc = $str:goalloc$ in
+
         (* Define onsuccess, onrun, onfail functions that the body may call. *)
         let _on, _call_on =
           let _on fns f = fns := f :: !fns in
@@ -109,7 +116,7 @@ let generate_let_goal _loc (r : rec_flag) (lets : binding) =
           _call_onsuccesses ();
 
           (* Avoid a compiler warning: *)
-          ignore (goalname)
+          ignore (goalname); ignore (goalloc)
         with
         (* target() within the body may raise Goal_OK meaning that the
          * goal should be short-circuited.  We return as if it's an
-- 
1.8.3.1