Commits

Moritz Heidkamp committed b6fdd00

Make realize-plan's plan-realization a parameter

Comments (0)

Files changed (3)

                 (loop (append step-deps (cdr to-realize))
                       (cons (cons name step-deps) deps))))))))
 
-(define (make-realization-promise step-name realize force-result* result-ref results dependencies body)
+(define (make-realization-promise step-name step-result result-ref results dependencies body)
   (delay
     (handle-exceptions exn
       (abort (make-composite-condition
                'step step-name
                'results (map (lambda (result)
                                (cons (car result)
-                                     (force-result* (cdr result))))
+                                     (step-result (cdr result))))
                              results)
                'cause exn)))
       (body step-name
                    (result-ref x results))
                  dependencies)))))
 
-(define (realize-steps to-realize realize force-result* result-ref)
+(define (realize-steps to-realize realize-step step-result result-ref)
   (let loop ((to-realize to-realize)
              (results '()))
     (if (null? to-realize)
         results
         (match-let (((name dependencies . body) (car to-realize)))
           (let ((value (if dependencies
-                           (realize (make-realization-promise
-                                     name
-                                     realize
-                                     force-result*
-                                     result-ref
-                                     results
-                                     dependencies
-                                     body))
+                           (realize-step
+                            (make-realization-promise
+                             name
+                             step-result
+                             result-ref
+                             results
+                             dependencies
+                             body))
                            body)))
             (loop (cdr to-realize)
                   (cons (cons* name dependencies value) results)))))))
                            (fold append '() (map alist->steps alists)))
                    (or (not to-realize) return-all-realized-results?))))))))
 
-(define (plan-realization realize-step force-step)
-  (lambda (plan . args)
-    (receive (to-realize inputs return-all-realized-results?)
-        (destructure-realization-args args)
-      (let* ((steps (append inputs (plan-steps plan)))
-             (to-realize* (cond ((not to-realize)
-                                 (map car steps))
-                                ((list? to-realize)
-                                 to-realize)
-                                (else
-                                 (list to-realize))))
-             (dependencies (step-dependencies to-realize* steps))
-             (to-realize* (let loop ((deps (topological-sort dependencies equal?))
-                                     (to-realize* '()))
-                            (if (null? deps)
-                                to-realize*
-                                (loop (cdr deps)
-                                      (cons (assoc (car deps) steps)
-                                            to-realize*)))))
-             (force-step* (lambda (step)
+(define-record plan-realization
+  realize-step step-result)
+
+(define plan-realization
+  (make-parameter
+   (make-plan-realization force force)))
+
+(define (realize-plan plan . args)
+  @("Realizes the given plan sequentially.")
+  (receive (to-realize inputs return-all-realized-results?)
+      (destructure-realization-args args)
+    (let* ((steps (append inputs (plan-steps plan)))
+           (to-realize* (cond ((not to-realize)
+                               (map car steps))
+                              ((list? to-realize)
+                               to-realize)
+                              (else
+                               (list to-realize))))
+           (dependencies (step-dependencies to-realize* steps))
+           (to-realize* (let loop ((deps (topological-sort dependencies equal?))
+                                   (to-realize* '()))
+                          (if (null? deps)
+                              to-realize*
+                              (loop (cdr deps)
+                                    (cons (assoc (car deps) steps)
+                                          to-realize*)))))
+           (step-result  (plan-realization-step-result (plan-realization)))
+           (realize-step (plan-realization-realize-step (plan-realization)))
+           (step-result*  (lambda (step)
                             (if (car step)
-                                (force-step (cdr step))
+                                (step-result (cdr step))
                                 (cdr step))))
-             (result-ref (lambda (x results)
-                           (force-step* (alist-ref x results equal?))))
-             (results (realize-steps to-realize* realize-step force-step* result-ref)))
-        (cond (return-all-realized-results?
-               (map (lambda (result)
-                      (cons (car result)
-                            (force-step* (cdr result))))
-                    results))
-              ((list? to-realize)
-               (map (lambda (c)
-                      (result-ref c results))
-                    to-realize))
-              (else
-               (result-ref to-realize results)))))))
-
-(define realize-plan
-  @("Realizes the given plan sequentially.")
-  (plan-realization identity force))
+           (result-ref (lambda (x results)
+                         (step-result* (alist-ref x results equal?))))
+           (results (realize-steps to-realize* realize-step step-result* result-ref)))
+      (cond (return-all-realized-results?
+             (map (lambda (result)
+                    (cons (car result)
+                          (step-result* (cdr result))))
+                  results))
+            ((list? to-realize)
+             (map (lambda (c)
+                    (result-ref c results))
+                  to-realize))
+            (else
+             (result-ref to-realize results))))))
 
 (define (merge-plans . plans)
   (make-plan (append-map plan-steps (reverse plans))))
 (module plan-parallel
 
-(realize-plan-parallel)
+(realize-plan-parallel
+ plan-realization-parallel)
 
 (import chicken scheme)
 (use srfi-18 plan)
         (abort (cdr result))
         result)))
 
-(define realize-plan-parallel
-  (plan-realization future-force future-result))
+(define plan-realization-parallel
+  (make-plan-realization future-force future-result))
+
+(define (realize-plan-parallel . args)
+  (parameterize ((plan-realization plan-realization-parallel))
+    (apply realize-plan args)))
 
 )
  plan?
  plan-steps
  plan-realization
+ make-plan-realization
  realize-plan
  merge-plans
  write-plan-dot