Ignore warnings about immutable strings.

[goaljobs.git] / pa_goal.ml

diff --git a/pa_goal.ml b/pa_goal.ml
index 06b2ec8..c95095c 100644 (file)
--- a/pa_goal.ml
+++ b/pa_goal.ml
@@ -51,6 +51,8 @@ let rec function_parameters = function
  * of let statements.
  *)
 let generate_let_goal _loc (r : rec_flag) (lets : binding) =
+  let autopublish = ref [] in
+
   (* lets might be a single binding, or multiple bindings using BiAnd
    * ('let .. and').  Rewrite each individual goal in the list.
    *)
@@ -66,14 +68,72 @@ 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
 
       if params = [] then
         locfail _loc "goal must have some parameters; you probably want to put '()' here";
 
+      (* Is it a "zero-parameters" automatically published goal?  What
+       * this really means is it has exactly one unit parameter.
+       *)
+      (match params with
+      | [ _, PaId (_, IdUid (_, "()")) ] ->
+        autopublish := name :: !autopublish
+      | _ -> ()
+      );
+
       (* 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
+
+        _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
+          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 ();
+          _leave_goal goalname;
+
+          (* Avoid a compiler warning: *)
+          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
 
       (* Recreate the function with parameters. *)
       let expr =
@@ -89,26 +149,47 @@ let generate_let_goal _loc (r : rec_flag) (lets : binding) =
   let lets = rewrite lets in
 
   (* let [rec] ... and ... in () *)
-  Ast.StVal (_loc, r, lets)
-
-(* Rewrite 'require (name args...)' as 'require (goal_name args)'.
+  let stmts = Ast.StVal (_loc, r, lets) in
+
+  (* Auto-published goals. *)
+  List.fold_left (
+    fun stmt name ->
+      let publish_name =
+        let gname = "goal_" ^ name in
+        <:str_item<
+          let () = publish $str:name$ (
+            function
+            | [] ->
+              Goaljobs.require $str:name$ $lid:gname$
+            | _ ->
+              failwith (Printf.sprintf "goal '%s' does not take any arguments"
+                          $str:name$);
+          )
+        >> in
+      StSem (_loc, stmt, publish_name)
+  ) stmts !autopublish
+
+(* Rewrite 'require (name args...)' as 'require (fun () -> goal_name args)'.
  * '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 ($expr$) >>
+  let expr, name = rewrite expr in
+  <:expr< Goaljobs.require $str:name$ (fun () -> $expr$) >>
 
 ;;