From 5dda93a3b5debe8f10da6cb7868876728d99fe9e Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Wed, 18 Sep 2013 16:21:26 +0100
Subject: [PATCH] Pass a suspension to 'require'.
---
goaljobs.ml | 2 +-
goaljobs.mli | 2 +-
pa_goal.ml | 6 +++---
3 files changed, 5 insertions(+), 5 deletions(-)
diff --git a/goaljobs.ml b/goaljobs.ml
index 2dc0541..3be5b51 100644
--- a/goaljobs.ml
+++ b/goaljobs.ml
@@ -35,7 +35,7 @@ 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 () = ()
+let require f = f ()
type period_t = Seconds | Days | Months | Years
let seconds = (1, Seconds)
diff --git a/goaljobs.mli b/goaljobs.mli
index 0437826..daaf0b2 100644
--- a/goaljobs.mli
+++ b/goaljobs.mli
@@ -100,7 +100,7 @@ val target_exists : bool list -> unit
(** [target_exists [t1; t2; ...]] is the same as writing
[target (t1 || t2 || ...)] *)
-val require : unit -> unit
+val require : (unit -> unit) -> unit
(** [require] {!goal} defines the requirements of this rule, that
is, other goals that have to be met before this rule is able to run.
diff --git a/pa_goal.ml b/pa_goal.ml
index 723df1b..86f67db 100644
--- a/pa_goal.ml
+++ b/pa_goal.ml
@@ -111,7 +111,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 +120,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 +137,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$) >>
;;
--
GitLab