aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--ccwl/ccwl.scm190
-rw-r--r--doc/capture-output-file-with-parameter-reference.scm2
-rw-r--r--doc/capture-output-file.scm2
-rw-r--r--doc/capture-stdout.scm2
-rw-r--r--doc/checksum.scm6
-rw-r--r--doc/decompress-compile-run.scm4
-rw-r--r--doc/hello-world.scm2
-rw-r--r--doc/pass-stdin.scm2
8 files changed, 112 insertions, 98 deletions
diff --git a/ccwl/ccwl.scm b/ccwl/ccwl.scm
index 09c590c..48c2d50 100644
--- a/ccwl/ccwl.scm
+++ b/ccwl/ccwl.scm
@@ -45,17 +45,29 @@
(type input-type)
(label input-label)
(default input-default)
- (position input-position)
- (prefix input-prefix)
+ (position input-position set-input-position)
+ (prefix input-prefix set-input-prefix)
(other input-other))
(define-immutable-record-type <unspecified-default>
(make-unspecified-default)
unspecified-default?)
-(define* (input id #:key (type 'File) label (default (make-unspecified-default)) position prefix (other '()))
- "Build and return an <input> object."
- (make-input id type label default position prefix other))
+(define (input input-spec)
+ "Return syntax to build an <input> object from INPUT-SPEC."
+ (syntax-case input-spec ()
+ ((id args ...) (identifier? #'id)
+ (apply (syntax-lambda** (id #:key (type #'File) label (default (make-unspecified-default)) #:key* other)
+ (let ((position #f)
+ (prefix #f))
+ #`(make-input '#,id '#,type #,label
+ #,(if (unspecified-default? default)
+ #'(make-unspecified-default)
+ default)
+ #,position #,prefix '#,other)))
+ #'(id args ...)))
+ (id (identifier? #'id) (input #'(id)))
+ (_ (error "Invalid input:" (syntax->datum input-spec)))))
(define-immutable-record-type <output>
(make-output id type binding source other)
@@ -98,77 +110,84 @@ association list."
(stdin command-stdin)
(other command-other))
+(define (input-spec-id input-spec)
+ "Return the identifier symbol of INPUT-SPEC."
+ (syntax->datum
+ (syntax-case input-spec ()
+ ((id _ ...) (identifier? #'id) #'id)
+ (id (identifier? #'id) #'id)
+ (_ (error "Invalid input:" (syntax->datum input-spec))))))
+
+(define (run-arg-position input-id run-args)
+ "Return the position of input identified by symbol INPUT-ID in
+RUN-ARGS. If such an input is not present in RUN-ARGS, return #f."
+ (list-index (lambda (run-arg)
+ (let ((run-arg-input
+ (syntax-case run-arg ()
+ (input (identifier? #'input)
+ (syntax->datum #'input))
+ ((_ input) (identifier? #'input)
+ (syntax->datum #'input))
+ (_ #f))))
+ (and run-arg-input
+ (eq? run-arg-input input-id))))
+ run-args))
+
+(define (run-arg-prefix input-id run-args)
+ "Return the prefix of input identified by symbol INPUT-ID in
+RUN-ARGS. If such an input is not present in RUN-ARGS, return #f."
+ (any (lambda (x)
+ (syntax-case x ()
+ ((prefix input) (identifier? #'input)
+ (and (eq? (syntax->datum #'input)
+ input-id)
+ #'prefix))
+ (_ #f)))
+ run-args))
+
;; TODO: Add fine-grained syntax checking.
(define-syntax command
(lambda (x)
(syntax-case x ()
((_ args ...)
(apply (syntax-lambda** (#:key stdin #:key* inputs outputs run other)
- (let ((inputs
- ;; Canonicalize inputs.
- (map (lambda (x)
- (syntax-case x ()
- ((id args ...) (identifier? #'id)
- #'(id args ...))
- (id (identifier? #'id) #'(id))
- (_ (error "Invalid input:" (syntax->datum x)))))
- inputs)))
- (unless run
- (error "#:run key required in command definition" (syntax->datum x)))
- #`(make-command
- (list #,@(map (lambda (x)
- (syntax-case x ()
- ((id args ...)
- ;; Instantiate <input> object with
- ;; position and prefix.
- #`(input 'id
- #:position #,(list-index (lambda (x)
- (syntax-case x ()
- (input (identifier? #'input)
- (eq? (syntax->datum #'id)
- (syntax->datum #'input)))
- ((_ input)
- (eq? (syntax->datum #'id)
- (syntax->datum #'input)))
- (_ #f)))
- run)
- #:prefix #,(any (lambda (x)
- (syntax-case x ()
- ((prefix input)
- (and (eq? (syntax->datum #'id)
- (syntax->datum #'input))
- #'prefix))
- (_ #f)))
- run)
- args ...))))
- inputs))
- (list #,@(map (lambda (x)
- ;; Instantiate <output> object.
- (syntax-case x ()
- ((id args ...) (identifier? #'id)
- #'(output 'id args ...))
- (id (identifier? #'id) #'(output 'id))
- (_ (error "Invalid output:"
- (syntax->datum x)))))
- outputs))
- (list #,@(map (lambda (x)
- (syntax-case x ()
- ;; Replace input symbol with quoted symbol.
- (input (identifier? #'input)
- #''input)
- ;; Leave string as is.
- (string-arg (string? (syntax->datum #'string-arg))
- #'string-arg)
- ;; Replace prefixed input symbol with
- ;; quoted symbol.
- ((prefix input) (and (string? (syntax->datum #'prefix))
- (identifier? #'input))
- #''input)
- (_ (error "Invalid command element:"
- (syntax->datum x)))))
- run))
- #,(and stdin #`'#,stdin)
- (list #,@other))))
+ (unless run
+ (error "#:run key required in command definition" (syntax->datum x)))
+ #`(make-command
+ (list #,@(map (lambda (input-spec)
+ (let ((id (input-spec-id input-spec)))
+ #`(set-input-prefix
+ (set-input-position #,(input input-spec)
+ #,(run-arg-position id run))
+ #,(run-arg-prefix id run))))
+ inputs))
+ (list #,@(map (lambda (x)
+ ;; Instantiate <output> object.
+ (syntax-case x ()
+ ((id args ...) (identifier? #'id)
+ #'(output 'id args ...))
+ (id (identifier? #'id) #'(output 'id))
+ (_ (error "Invalid output:"
+ (syntax->datum x)))))
+ outputs))
+ (list #,@(map (lambda (x)
+ (syntax-case x ()
+ ;; Replace input symbol with quoted symbol.
+ (input (identifier? #'input)
+ #''input)
+ ;; Leave string as is.
+ (string-arg (string? (syntax->datum #'string-arg))
+ #'string-arg)
+ ;; Replace prefixed input symbol with
+ ;; quoted symbol.
+ ((prefix input) (and (string? (syntax->datum #'prefix))
+ (identifier? #'input))
+ #''input)
+ (_ (error "Invalid command element:"
+ (syntax->datum x)))))
+ run))
+ #,(and stdin #`'#,stdin)
+ (list #,@other)))
#'(args ...))))))
(define (input=? input1 input2)
@@ -414,23 +433,18 @@ return #f."
(define-syntax workflow
(lambda (x)
(syntax-case x ()
- ((_ inputs tree)
- (let* ((inputs (map (match-lambda
- ((id args ...)
- (apply input id args))
- (id (input id)))
- (syntax->datum #'inputs)))
- (output-keys steps (workflow-steps #'tree
- (map (compose key input-id) inputs))))
- ;; TODO: Error out on duplicated step IDs.
- #`'#,(datum->syntax
- x
- (make-workflow steps
- inputs
- ;; Find the output object for each
- ;; output key. Filter out global
- ;; workflow inputs.
- (filter-map (cut key->output <> steps)
- output-keys)))))
+ ((_ (inputs ...) tree)
+ #`(let ((input-objects (list #,@(map input #'(inputs ...))))
+ (output-keys steps (workflow-steps #'tree
+ (map (compose key input-spec-id)
+ #'(inputs ...)))))
+ ;; TODO: Error out on duplicated step IDs.
+ (make-workflow steps
+ input-objects
+ ;; Find the output object for each
+ ;; output key. Filter out global
+ ;; workflow inputs.
+ (filter-map (cut key->output <> steps)
+ output-keys))))
(x (error "Unrecognized workflow syntax [expected (workflow (input ...) tree)]:"
(syntax->datum #'x))))))
diff --git a/doc/capture-output-file-with-parameter-reference.scm b/doc/capture-output-file-with-parameter-reference.scm
index bb5476b..88d17ad 100644
--- a/doc/capture-output-file-with-parameter-reference.scm
+++ b/doc/capture-output-file-with-parameter-reference.scm
@@ -1,5 +1,5 @@
(define extract-specific-file
- (command #:inputs (archive #:type 'File) (extractfile #:type 'string)
+ (command #:inputs (archive #:type File) (extractfile #:type string)
#:run "tar" "--extract" "--file" archive extractfile
#:outputs (extracted-file
#:type 'File
diff --git a/doc/capture-output-file.scm b/doc/capture-output-file.scm
index 6c5dbbd..ddeb218 100644
--- a/doc/capture-output-file.scm
+++ b/doc/capture-output-file.scm
@@ -1,5 +1,5 @@
(define extract
- (command #:inputs (archive #:type 'File)
+ (command #:inputs (archive #:type File)
#:run "tar" "--extract" "--file" archive
#:outputs (extracted-file
#:type 'File
diff --git a/doc/capture-stdout.scm b/doc/capture-stdout.scm
index 6913809..1aed277 100644
--- a/doc/capture-stdout.scm
+++ b/doc/capture-stdout.scm
@@ -1,5 +1,5 @@
(define print
- (command #:inputs (message #:type 'string)
+ (command #:inputs (message #:type string)
#:run "echo" message
#:outputs (printed-message #:type 'stdout)))
diff --git a/doc/checksum.scm b/doc/checksum.scm
index 4d8bfaf..e746779 100644
--- a/doc/checksum.scm
+++ b/doc/checksum.scm
@@ -1,15 +1,15 @@
(define md5sum
- (command #:inputs (file #:type 'File)
+ (command #:inputs (file #:type File)
#:run "md5sum" file
#:outputs (md5 #:type 'stdout)))
(define sha1sum
- (command #:inputs (file #:type 'File)
+ (command #:inputs (file #:type File)
#:run "sha1sum" file
#:outputs (sha1 #:type 'stdout)))
(define sha256sum
- (command #:inputs (file #:type 'File)
+ (command #:inputs (file #:type File)
#:run "sha256sum" file
#:outputs (sha256 #:type 'stdout)))
diff --git a/doc/decompress-compile-run.scm b/doc/decompress-compile-run.scm
index a2c58bb..4e916b2 100644
--- a/doc/decompress-compile-run.scm
+++ b/doc/decompress-compile-run.scm
@@ -1,10 +1,10 @@
(define decompress
- (command #:inputs (compressed #:type 'File)
+ (command #:inputs (compressed #:type File)
#:run "gzip" "--stdout" "--decompress" compressed
#:outputs (decompressed #:type 'stdout)))
(define compile
- (command #:inputs (source #:type 'File)
+ (command #:inputs (source #:type File)
#:run "gcc" "-x" "c" source
#:outputs (executable
#:type 'File
diff --git a/doc/hello-world.scm b/doc/hello-world.scm
index 1624053..3b44dbb 100644
--- a/doc/hello-world.scm
+++ b/doc/hello-world.scm
@@ -1,5 +1,5 @@
(define print
- (command #:inputs (message #:type 'string)
+ (command #:inputs (message #:type string)
#:run "echo" message))
(workflow ((message #:type string))
diff --git a/doc/pass-stdin.scm b/doc/pass-stdin.scm
index 3bdc70b..af125ba 100644
--- a/doc/pass-stdin.scm
+++ b/doc/pass-stdin.scm
@@ -1,5 +1,5 @@
(define count-bytes
- (command #:inputs (file #:type 'File)
+ (command #:inputs (file #:type File)
#:run "wc" "-c"
#:stdin file))