(* 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
let body = <:expr<
(* Define a goal name which the body may use. *)
let goalname = $str:name$ in
+
+ _enter_goal goalname;
+
+ (* 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
$body$ ;
_call_onruns ();
_call_onsuccesses ();
+ _leave_goal goalname;
(* 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
* ordinary function exit.
*)
| Goal_result Goal_OK ->
+ _leave_goal goalname;
_call_onsuccesses ();
()
| exn ->
+ _leave_goal goalname;
_call_onfails exn;
raise exn
>> in
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$);
* 'expr' is a function call.
*)
let generate_require _loc expr =
- (* Note that 'f a b c' is parsed as '((f a) b) c' so the actually
+ (* Note that 'f a b c' is parsed as '((f a) b) c' so the actual
* function name is buried deeply in the tree. Rewrite the name.
*)
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$) >>
;;