From 676322e6756c9a3b52d8cd1d0e6fd39f7ccc7983 Mon Sep 17 00:00:00 2001
From: Arun Isaac
Date: Tue, 1 Jun 2021 14:53:34 +0530
Subject: Introduce new command definition syntax.

* ccwl/ccwl.scm: Do not export input and output.
(<input>): Delete source field. Add position field.
(input): Accept position and prefix fields in constructor. Do not
initialize non-existent source field.
(<command>): Delete additional-inputs field. Add inputs field. Delete
set-command-outputs and set-command-stdin setters.
(command): Rewrite as macro that accepts new command definition
syntax.
(<cli-element>): Delete type.
(command->cwl): Generate CWL from new <command> type.
(command-input-keys): Simplify to support new <command> type.
---
 ccwl/ccwl.scm | 204 ++++++++++++++++++++++++++++++++--------------------------
 1 file changed, 111 insertions(+), 93 deletions(-)

diff --git a/ccwl/ccwl.scm b/ccwl/ccwl.scm
index 81f9a13..55db7a0 100644
--- a/ccwl/ccwl.scm
+++ b/ccwl/ccwl.scm
@@ -33,8 +33,6 @@
   #:use-module (ccwl yaml)
   #:export (command
             workflow
-            input
-            output
             step
             pipeline
             write-cwl))
@@ -42,13 +40,13 @@
 (define %cwl-version "v1.2")
 
 (define-immutable-record-type <input>
-  (make-input id type label default source prefix other)
+  (make-input id type label default position prefix other)
   input?
   (id input-id)
   (type input-type)
   (label input-label)
   (default input-default)
-  (source input-source set-input-source)
+  (position input-position)
   (prefix input-prefix)
   (other input-other))
 
@@ -56,14 +54,10 @@
   (make-unspecified-default)
   unspecified-default?)
 
-(define* (input id #:key (type 'File) label (default (make-unspecified-default)) (other '()))
+(define* (input id #:key (type 'File) label (default (make-unspecified-default)) position prefix (other '()))
   "Build and return an <input> object."
-  ;; The user should never set source, and should not set prefix
-  ;; directly during construction of the <input> object. Hence, do not
-  ;; expose it as a parameter of this constructor.
-  (let ((source #f)
-        (prefix #f))
-    (make-input id type label default source prefix other)))
+  (make-input id type label default position prefix other))
+
 
 (define-immutable-record-type <output>
   (make-output id type binding source other)
@@ -94,17 +88,85 @@
   (out step-out))
 
 (define-immutable-record-type <command>
-  (make-command additional-inputs outputs args stdin other)
+  (make-command inputs outputs args stdin other)
   command?
-  (additional-inputs command-additional-inputs)
-  (outputs command-outputs set-command-outputs)
+  (inputs command-inputs)
+  (outputs command-outputs)
   (args command-args)
-  (stdin command-stdin set-command-stdin)
+  (stdin command-stdin)
   (other command-other))
 
-(define command
-  (lambda** (#:key stdin #:key* run (additional-inputs '()) (outputs '()) (other '()))
-    (make-command additional-inputs outputs run stdin other)))
+;; TODO: Add fine-grained syntax checking.
+(define-syntax command
+  (lambda (x)
+    ((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))))
+     x)))
+
 
 (define (input=? input1 input2)
   (eq? (input-id input1)
@@ -165,78 +227,38 @@
                          (cons 'outputBinding (output-binding output)))))
     ,@(output-other output)))
 
-(define-immutable-record-type <cli-element>
-  (make-cli-element argument position)
-  cli-element?
-  (argument cli-element-argument)
-  (position cli-element-position))
 
 (define (command->cwl command)
-  (let ((elements
-         ;; Add a position to all arguments, converting them to
-         ;; <cli-element> objects.
-         (map (lambda (arg position)
-                (make-cli-element
-                 ;; If duplicate input, convert it to an expression
-                 ;; referring to the input.
-                 (if (and (input? arg)
-                          (not (= (list-index (lambda (x)
-                                                (and (input? x)
-                                                     (input=? arg x)))
-                                              (command-args command))
-                                  position)))
-                     (string-append "$(inputs." (symbol->string (input-id arg)) ")")
-                     arg)
-                 position))
-              (command-args command)
-              (iota (length (command-args command))))))
-    `((cwlVersion . ,%cwl-version)
-      (class . CommandLineTool)
-      ,@(command-other command)
-      (arguments . ,(list->vector
-                     ;; Put string arguments into the arguments array.
-                     (filter-map (lambda (element)
-                                   (and (string? (cli-element-argument element))
-                                        `((position . ,(cli-element-position element))
-                                          (valueFrom . ,(cli-element-argument element)))))
-                                 elements)))
-      (inputs . ,(append
-                  ;; Put <input> arguments into the inputs array.
-                  (filter-map (lambda (element)
-                                (let ((input (cli-element-argument element)))
-                                  (and (input? input)
-                                       `(,(input-id input)
-                                         ,@(filter-alist
-                                            `((type . ,(input-type input))
-                                              (label . ,(input-label input))
-                                              (default . ,(and (not (unspecified-default? (input-default input)))
-                                                               (input-default input)))
-                                              (inputBinding . ,(filter-alist
-                                                                `((position . ,(cli-element-position element))
-                                                                  (prefix . ,(input-prefix input)))))))
-                                         ,@(input-other input)))))
-                              elements)
-                  (map (lambda (input)
-                         `(,(input-id input)
-                           ,@(filter-alist
-                              `((type . ,(input-type input))
-                                (label . ,(input-label input))
-                                (default . ,(and (not (unspecified-default? (input-default input)))
-                                                 (input-default input)))))
-                           ,@(input-other input)))
-                       (command-additional-inputs command))
-                  (let ((stdin (command-stdin command)))
-                    (if stdin
-                        (list `(,(input-id stdin)
-                                (type . ,(input-type stdin))))
-                        (list)))))
-      (outputs . ,(map output->cwl (command-outputs command)))
-      ,@(if (command-stdin command)
-            `((stdin . ,(string-append "$(inputs."
-                                       (symbol->string
-                                        (input-id (command-stdin command)))
-                                       ".path)")))
-            '()))))
+  `((cwlVersion . ,%cwl-version)
+    (class . CommandLineTool)
+    ,@(command-other command)
+    (arguments . ,(list->vector
+                   ;; Put string arguments into the arguments array.
+                   (filter-mapi (lambda (arg index)
+                                  (and (string? arg)
+                                       `((position . ,index)
+                                         (valueFrom . ,arg))))
+                                (command-args command))))
+    (inputs . ,(map (lambda (input)
+                      `(,(input-id input)
+                        ,@(filter-alist
+                           `((type . ,(input-type input))
+                             (label . ,(input-label input))
+                             (default . ,(and (not (unspecified-default? (input-default input)))
+                                              (input-default input)))
+                             ;; FIXME: inputBinding can be an empty dictionary.
+                             (inputBinding . ,(filter-alist
+                                               `((position . ,(input-position input))
+                                                 (prefix . ,(input-prefix input)))))))
+                        ,@(input-other input)))
+                    (command-inputs command)))
+    (outputs . ,(map output->cwl (command-outputs command)))
+    ,@(if (command-stdin command)
+          `((stdin . ,(string-append "$(inputs."
+                                     (symbol->string
+                                      (command-stdin command))
+                                     ".path)")))
+          '())))
 
 (define (write-cwl step file)
   (call-with-output-file file
@@ -248,11 +270,7 @@
 
 (define (command-input-keys command)
   "Return the list of input keys accepted by COMMAND."
-  (map input-id
-       (append (filter input? (command-args command))
-               (command-additional-inputs command)
-               (cond ((command-stdin command) => list)
-                     (else (list))))))
+  (map input-id (command-inputs command)))
 
 (define-immutable-record-type <key>
   (make-key name step)
-- 
cgit v1.2.3