From 36ebdebb6bc0064c904f069b77e66fce98d704c5 Mon Sep 17 00:00:00 2001
From: Arun Isaac
Date: Tue, 3 Aug 2021 16:31:46 +0530
Subject: ccwl: Define input objects using a macro instead of a function.

This allows us to do sophisticated syntax checking at an early stage,
very close to the user interface. That way error messages from ccwl
will make a lot more sense.

* ccwl/ccwl.scm (input): Re-implement as macro.
(<input>): Add new functional setters set-input-position and
set-input-prefix.
(input-spec-id, run-arg-position, run-arg-prefix): New functions.
(command, workflow): Use the new macro interface.
* doc/capture-output-file-with-parameter-reference.scm,
doc/capture-output-file.scm, doc/capture-stdout.scm, doc/checksum.scm,
doc/decompress-compile-run.scm, doc/hello-world.scm,
doc/pass-stdin.scm: Use new quoting syntax for input types.
---
 ccwl/ccwl.scm                                      | 190 +++++++++++----------
 ...apture-output-file-with-parameter-reference.scm |   2 +-
 doc/capture-output-file.scm                        |   2 +-
 doc/capture-stdout.scm                             |   2 +-
 doc/checksum.scm                                   |   6 +-
 doc/decompress-compile-run.scm                     |   4 +-
 doc/hello-world.scm                                |   2 +-
 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))
 
-- 
cgit v1.2.3