Implement: onfail, onsuccess, onrun, log_program_output, mailto.

[goaljobs.git] / pa_goal.ml

diff --git a/pa_goal.ml b/pa_goal.ml
index 723df1b..e795233 100644 (file)
--- a/pa_goal.ml
+++ b/pa_goal.ml
@@ -84,7 +84,44 @@ let generate_let_goal _loc (r : rec_flag) (lets : binding) =
       );
 
       (* Put a try-clause around the body. *)
-      let body = <:expr< try $body$ with Goal_result Goal_OK -> () >> in
+      let body = <:expr<
+        (* Define a goal name which the body may use. *)
+        let goalname = $str:name$ in
+        (* Define onsuccess, onrun, onfail functions that the body may call. *)
+        let _on, _call_on =
+          let _on fns f = fns := f :: !fns in
+          let _call_on fns a = List.iter (fun f -> f a) !fns in
+          _on, _call_on
+        in
+        let onfail, _call_onfails =
+          let fns = ref [] in (_on fns), (_call_on fns)
+        in
+        let onrun, _call_onruns =
+          let fns = ref [] in (_on fns), (_call_on fns)
+        in
+        let onsuccess, _call_onsuccesses =
+          let fns = ref [] in (_on fns), (_call_on fns)
+        in
+
+        try
+          $body$ ;
+          _call_onruns ();
+          _call_onsuccesses ();
+
+          (* Avoid a compiler warning: *)
+          ignore (goalname)
+        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 ->
+          _call_onsuccesses ();
+          ()
+        | exn ->
+          _call_onfails exn;
+          raise exn
+      >> in
 
       (* Recreate the function with parameters. *)
       let expr =
@@ -111,7 +148,7 @@ let generate_let_goal _loc (r : rec_flag) (lets : binding) =
           let () = publish $str:name$ (
             function
             | [] ->
-              Goaljobs.require ($lid:gname$ ())
+              Goaljobs.require $lid:gname$
             | _ ->
               failwith (Printf.sprintf "goal '%s' does not take any arguments"
                           $str:name$);
@@ -120,7 +157,7 @@ let generate_let_goal _loc (r : rec_flag) (lets : binding) =
       StSem (_loc, stmt, publish_name)
   ) stmts !autopublish
 
-(* Rewrite 'require (name args...)' as 'require (goal_name args)'.
+(* Rewrite 'require (name args...)' as 'require (fun () -> goal_name args)'.
  * 'expr' is a function call.
  *)
 let generate_require _loc expr =
@@ -137,7 +174,7 @@ let generate_require _loc expr =
       locfail _loc "require (...) expression must contain a call to a goal"
   in
   let expr = rewrite expr in
-  <:expr< Goaljobs.require ($expr$) >>
+  <:expr< Goaljobs.require (fun () -> $expr$) >>
 
 ;;