Commits

Moritz Heidkamp  committed 8caab67

Add beginnings of documentation

  • Participants
  • Parent commits 05dde70

Comments (0)

Files changed (5)

File plan-impl.scm

+@(egg "plan")
+@(description "A data structure for representing process plans.")
+@(author "Moritz Heidkamp")
+@(email "moritz@twoticketsplease.de")
+@(username "syn")
+
+@(heading "Overview")
+
+@(text "''A plan is typically any diagram or list of steps with timing
+and resources, used to achieve an objective.'' ― [[http://en.wikipedia.org/wiki/Plan]]
+
+This extension provides a {{plan}} data structure which is inspired by
+[[http://blog.getprismatic.com/blog/2012/10/1/prismatics-graph-at-strange-loop.html|Prismatic's
+\"Graph\"]]. It represents processes and their
+interdependencies. Plans can be inspected, augmented, or realized. The
+source code can be found on
+[[https://bitbucket.org/DerGuteMoritz/plan|Bitbucket]].")
+
+@(heading "API")
+
+(import chicken scheme)
+(use srfi-1 data-structures extras matchable)
+
+(define (make-plan steps)
+  @("Constructs a plan record with the given list of {{steps}} of the following form:
+
+  steps          = (<step> ...)
+  step           = <constant-step> | <dependent-step>
+  constant-step  = (<name> #f . <value>)
+  dependent-step = (<name> (<dependency> ...) . proc)
+  dependency     = <name>
+  value          = datum
+  name           = datum
+
+Semantically, a step is a description of how to realize a (sub-)result
+of a plan. It consist of the following components:
+
+* A {{name}}, which may be any kind of datum comparable with
+  {{equal?}}, usually a symbol or a string.
+
+* Zero or more dependencies which are specified as a list of step
+  names. Upon realization (see [[#realize-plan|{{realize-plan}}]]),
+  dependencies will be realized before a dependent step is
+  realized. Alternatively, {{#f}} can be used to signify that this step
+  has a constant result without any dependencies.
+
+* A realization result which can either be a constant {{value}} or
+  procedure {{proc}} which produces a result from the given
+  dependencies. In the latter case, dependencies are realized
+  before their results are passed as arguments to {{proc}} in the
+  order they are specified."
+    (@to "plan"))
+  (void))
+
+(define (plan-steps plan)
+  @("Returns a {{plan}}'s list of steps as passed to [[#make-plan|{{make-plan}}]]."
+    (@to "(<step> ...)"))
+  (void))
+
+(define (plan? datum)
+  @("Checks whether {{datum}} is a plan."
+    (@to "boolean"))
+  (void))
+
+(define-record plan steps)
+
+(define-record-printer (plan p out)
+  (display "#<plan " out)
+  (for-each (match-lambda
+             ((? string? x)
+              (newline out)
+              (display x out))
+             ((name deps . value)
+              (write (cons name
+                           (if deps
+                               (list deps '...)
+                               (list value)))
+                     out)))
+            (intersperse (plan-steps p) "       "))
+  (display ">" out))
+
+(define (kvlist->steps kvlist)
+  (let loop ((kvlist kvlist))
+    (if (null? kvlist)
+        '()
+        (cons (cons (string->symbol (keyword->string (car kvlist)))
+                    (cons #f (cadr kvlist)))
+              (loop (cddr kvlist))))))
+
+(define (alist->steps alist)
+  (map (match-lambda ((k . v) (cons* k #f v))) alist))
+
+(define-syntax plan*
+  (syntax-rules ()
+    ((_ (step value) more-steps ...)
+     (alist-cons 'step (cons #f value) (plan* more-steps ...)))
+    ((_ (step (dependency ...) body ...) more-steps ...)
+     (alist-cons 'step
+                 (cons '(dependency ...)
+                       (match-lambda*
+                        ((_ (dependency ...))
+                         body ...)))
+                 (plan* more-steps ...)))
+    ((_) '())))
+
+
+
+(define-syntax plan
+  @("Convenience syntax for constructing plans. Its
+body has the following structure:
+
+  step           = <constant-step> | <dependent-step>
+  constant-step  = (<name> value)
+  dependent-step = (<name> (<dependency> ...) expression ...)
+  dependency     = <name>
+  name           = symbol
+
+See [[#make-plan|{{make-plan}}]] for explanation of steps and
+dependencies. Note that with this form, step names must be
+symbols. For dependent steps, those names are then lexically bound
+when {{expression ...}} is evaluated upon realization."
+    (step "A step")
+    (... "More steps"))
+  (syntax-rules ()
+    ((_ step ...)
+     (make-plan (plan* step ...)))))
+
+(define (step-ref steps name)
+  (or (alist-ref name steps equal?)
+      (abort
+       (make-composite-condition
+        (make-property-condition
+         'exn
+         'message "Missing plan step"
+         'arguments (list name (map car steps)))
+        (make-property-condition 'plan)
+        (make-property-condition 'missing-step 'step name)))))
+
+(define (step-dependencies to-realize steps)
+  (let loop ((to-realize to-realize)
+             (deps '()))
+    (if (null? to-realize)
+        deps
+        (let ((name (car to-realize)))
+          (if (find (lambda (dep) (equal? name (car dep))) deps)
+              (loop (cdr to-realize) deps)
+              (let ((step-deps (or (car (step-ref steps name)) '())))
+                (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)
+  (delay
+    (handle-exceptions exn
+      (abort (make-composite-condition
+              exn
+              (make-property-condition 'plan)
+              (make-property-condition
+               'step-failed
+               'step step-name
+               'results (map (lambda (result)
+                               (cons (car result)
+                                     (force-result* (cdr result))))
+                             results)
+               'cause exn)))
+      (body step-name
+            (map (lambda (x)
+                   (result-ref x results))
+                 dependencies)))))
+
+(define (realize-steps to-realize realize force-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))
+                           body)))
+            (loop (cdr to-realize)
+                  (cons (cons* name dependencies value) results)))))))
+
+(define (to-realize-arg? to-realize)
+  (or (atom? to-realize)
+      (and (pair? to-realize) (atom? (car to-realize)))))
+
+(define (destructure-realization-args args)
+  (receive (rest kwargs) (break keyword? args)
+    (let* ((inputs (kvlist->steps kwargs)))
+      (match rest
+        (()
+         (values #f inputs #t))
+        ((to-realize)
+         (receive (to-realize inputs)
+             (if (to-realize-arg? to-realize)
+                 (values to-realize inputs)
+                 (values #f (fold append (alist->steps to-realize) inputs)))
+           (values to-realize inputs (not to-realize))))
+        ((to-realize rest ...)
+         (let*-values (((return-all-realized-results? alists)
+                        (if (and (pair? rest) (boolean? (car rest)))
+                            (values (car rest) (cdr rest))
+                            (values #f rest)))
+                       ((to-realize alists)
+                        (if (to-realize-arg? to-realize)
+                            (values to-realize alists)
+                            (values #f (cons to-realize alists)))))
+           (values to-realize
+                   (append inputs
+                           (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)
+                            (if (car step)
+                                (force-step (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))
+
+(define (merge-plans . plans)
+  (make-plan (append-map plan-steps (reverse plans))))
+
+(define-syntax plan-let
+  (syntax-rules ()
+    ((_ (realize (step value ...) ...) body ...)
+     (match-let (((step ...)
+                  (realize (plan (step value ...) ...)
+                           '(step ...))))
+       body ...))))
+
+(define (write-plan-dot plan #!optional (out (current-output-port)) (name "plan"))
+  (fprintf out "digraph ~S {~%" name)
+  (for-each (lambda (step)
+              (let ((name (symbol->string (car step))))
+                (for-each (lambda (dep)
+                            (fprintf out " ~S -> ~S;~%" (symbol->string dep) name))
+                          (or (cadr step) '()))))
+            (plan-steps plan))
+  (fprintf out "}~%"))
  (author "Moritz Heidkamp")
  (category lang-exts)
  (license "BSD")
- (depends matchable)
+ (depends matchable cock)
  (test-depends test))
 (module plan
 
-(plan
- make-plan
+(make-plan
+ plan
  plan?
  plan-steps
  plan-realization
  write-plan-dot
  plan-let)
 
-(import chicken scheme)
-(use srfi-1 data-structures extras matchable)
-
-(define-record plan steps)
-
-(define-record-printer (plan p out)
-  (display "#<plan " out)
-  (for-each (match-lambda
-             ((? string? x)
-              (newline out)
-              (display x out))
-             ((name deps . value)
-              (write (cons name
-                           (if deps
-                               (list deps '...)
-                               (list value)))
-                     out)))
-            (intersperse (plan-steps p) "       "))
-  (display ">" out))
-
-(define (kvlist->steps kvlist)
-  (let loop ((kvlist kvlist))
-    (if (null? kvlist)
-        '()
-        (cons (cons (string->symbol (keyword->string (car kvlist)))
-                    (cons #f (cadr kvlist)))
-              (loop (cddr kvlist))))))
-
-(define (alist->steps alist)
-  (map (match-lambda ((k . v) (cons* k #f v))) alist))
-
-(define-syntax plan*
-  (syntax-rules ()
-    ((_ (step value) more-steps ...)
-     (alist-cons 'step (cons #f value) (plan* more-steps ...)))
-    ((_ (step (dependency ...) body ...) more-steps ...)
-     (alist-cons 'step
-                 (cons '(dependency ...)
-                       (match-lambda*
-                        ((_ (dependency ...))
-                         body ...)))
-                 (plan* more-steps ...)))
-    ((_) '())))
-
-(define-syntax plan
-  (syntax-rules ()
-    ((_ step ...)
-     (make-plan (plan* step ...)))))
-
-(define (step-ref steps name)
-  (or (alist-ref name steps equal?)
-      (abort
-       (make-composite-condition
-        (make-property-condition
-         'exn
-         'message "Missing plan step"
-         'arguments (list name (map car steps)))
-        (make-property-condition 'plan)
-        (make-property-condition 'missing-step 'step name)))))
-
-(define (step-dependencies to-realize steps)
-  (let loop ((to-realize to-realize)
-             (deps '()))
-    (if (null? to-realize)
-        deps
-        (let ((name (car to-realize)))
-          (if (find (lambda (dep) (equal? name (car dep))) deps)
-              (loop (cdr to-realize) deps)
-              (let ((step-deps (or (car (step-ref steps name)) '())))
-                (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)
-  (delay
-    (handle-exceptions exn
-      (abort (make-composite-condition
-              exn
-              (make-property-condition 'plan)
-              (make-property-condition
-               'step-failed
-               'step step-name
-               'results (map (lambda (result)
-                               (cons (car result)
-                                     (force-result* (cdr result))))
-                             results)
-               'cause exn)))
-      (body step-name
-            (map (lambda (x)
-                   (result-ref x results))
-                 dependencies)))))
-
-(define (realize-steps to-realize realize force-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))
-                           body)))
-            (loop (cdr to-realize)
-                  (cons (cons* name dependencies value) results)))))))
-
-(define (to-realize-arg? to-realize)
-  (or (atom? to-realize)
-      (and (pair? to-realize) (atom? (car to-realize)))))
-
-(define (destructure-realization-args args)
-  (receive (rest kwargs) (break keyword? args)
-    (let* ((inputs (kvlist->steps kwargs)))
-      (match rest
-        (()
-         (values #f inputs #t))
-        ((to-realize)
-         (receive (to-realize inputs)
-             (if (to-realize-arg? to-realize)
-                 (values to-realize inputs)
-                 (values #f (fold append (alist->steps to-realize) inputs)))
-           (values to-realize inputs (not to-realize))))
-        ((to-realize rest ...)
-         (let*-values (((return-all-realized-results? alists)
-                        (if (and (pair? rest) (boolean? (car rest)))
-                            (values (car rest) (cdr rest))
-                            (values #f rest)))
-                       ((to-realize alists)
-                        (if (to-realize-arg? to-realize)
-                            (values to-realize alists)
-                            (values #f (cons to-realize alists)))))
-           (values to-realize
-                   (append inputs
-                           (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)
-                            (if (car step)
-                                (force-step (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
-  (plan-realization identity force))
-
-(define (merge-plans . plans)
-  (make-plan (append-map plan-steps (reverse plans))))
-
-(define-syntax plan-let
-  (syntax-rules ()
-    ((_ (realize (step value ...) ...) body ...)
-     (match-let (((step ...)
-                  (realize (plan (step value ...) ...)
-                           '(step ...))))
-       body ...))))
-
-(define (write-plan-dot plan #!optional (out (current-output-port)) (name "plan"))
-  (fprintf out "digraph ~S {~%" name)
-  (for-each (lambda (step)
-              (let ((name (symbol->string (car step))))
-                (for-each (lambda (dep)
-                            (fprintf out " ~S -> ~S;~%" (symbol->string dep) name))
-                          (or (cadr step) '()))))
-            (plan-steps plan))
-  (fprintf out "}~%"))
-
-)
+"plan-impl.scm")
-(compile -d0 -O3 -J -s plan.scm)
+(compile -X cock -d0 -O3 -J -s plan.scm)
 (compile -d0 -O3 -s plan.import.scm)
 (compile -d0 -O3 -J -s plan-parallel.scm)
 (compile -d0 -O3 -s plan-parallel.import.scm)

File tests/run.scm

-(use test)
-(load-relative "../plan.scm")
-(load-relative "../plan-parallel.scm")
-
-(import plan plan-parallel)
-(use srfi-18)
+(use test plan plan-parallel srfi-18)
 
 (define foo-count 0)
 (define bar-count 0)