diff options
| -rw-r--r-- | ccwl/ccwl.scm | 190 | ||||
| -rw-r--r-- | doc/capture-output-file-with-parameter-reference.scm | 2 | ||||
| -rw-r--r-- | doc/capture-output-file.scm | 2 | ||||
| -rw-r--r-- | doc/capture-stdout.scm | 2 | ||||
| -rw-r--r-- | doc/checksum.scm | 6 | ||||
| -rw-r--r-- | doc/decompress-compile-run.scm | 4 | ||||
| -rw-r--r-- | doc/hello-world.scm | 2 | ||||
| -rw-r--r-- | doc/pass-stdin.scm | 2 |
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)) |