aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--generate-cwl/generate-cwl.scm183
-rw-r--r--generate-cwl/yaml.scm85
2 files changed, 268 insertions, 0 deletions
diff --git a/generate-cwl/generate-cwl.scm b/generate-cwl/generate-cwl.scm
new file mode 100644
index 0000000..03ce77d
--- /dev/null
+++ b/generate-cwl/generate-cwl.scm
@@ -0,0 +1,183 @@
+;;
+;; CWL generator
+;;
+;; This file implements a generator to generate CWL files.
+
+(define-module (generate-cwl generate-cwl)
+ #:use-module (rnrs records syntactic)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-71)
+ #:use-module (ice-9 match)
+ #:export (clitool
+ workflow
+ input
+ output
+ step
+ workflow-output))
+
+(define-record-type (<input> make-input input?)
+ (fields (immutable id input-id)
+ (immutable type input-type)
+ (immutable default input-default)
+ (immutable label input-label)
+ (immutable other input-other)))
+
+(define-record-type unspecified-default)
+
+(define* (input id #:key type label (default (make-unspecified-default)) (other '()))
+ "Build and return an <input> object."
+ (make-input id type default label other))
+
+(define-record-type (<output> make-output output?)
+ (fields (immutable id output-id)
+ (immutable type output-type)
+ (immutable binding output-binding)
+ (immutable other output-other)))
+
+(define* (output id #:key type binding (other '()))
+ "Build and return an <output> object."
+ (make-output id type binding other))
+
+(define* (parse-arguments args #:optional (position 1))
+ "Parse ARGS, a list of command line arguments and return a parse
+tree of labelled arguments. POSITION is an internal recursion
+variable."
+ (match args
+ (((? string? head) tail ...)
+ (if (string-prefix? "-" head)
+ (match tail
+ ((tail-head tail ...)
+ (cons (list 'keyword head tail-head)
+ (parse-arguments tail position))))
+ (error "Unrecognized argument" head)))
+ ((head tail ...)
+ (cons (list 'positional position head)
+ (parse-arguments tail (1+ position))))
+ (() '())))
+
+(define (parse-command args)
+ "Parse ARGS, a list of command line arguments and return two
+lists---the base command and the actual arguments."
+ (let ((base-command arguments
+ (break (match-lambda
+ ((arg next)
+ (and (string? arg)
+ (string-prefix? "-" arg)
+ (input? next))))
+ (map list args (drop args 1)))))
+ (values (append (map (match-lambda
+ ((arg next) arg))
+ base-command)
+ (if (input? (last args))
+ (list)
+ (take-right args 1)))
+ (parse-arguments
+ (append (map (match-lambda
+ ((arg next) arg))
+ arguments)
+ (if (input? (last args))
+ (take-right args 1)
+ (list)))))))
+
+(define (input->tree input)
+ "Convert INPUT, an <input> object, to a tree."
+ `(,(input-id input)
+ ,@(filter identity
+ (list (and (input-type input)
+ (cons 'type (input-type input)))
+ (and (input-label input)
+ (cons 'label (input-label input)))
+ (and (not (unspecified-default? (input-default input)))
+ (cons 'default (input-default input)))))
+ ,@(input-other input)))
+
+(define* (clitool args #:key (additional-inputs '()) (outputs '()) stdout stderr (other '()))
+ "Build a CommandLineTool class CWL workflow."
+ (let ((base-command arguments (parse-command args)))
+ `((cwl-version . "v1.1")
+ (class . Command-line-tool)
+ ,@other
+ (base-command . ,(list->vector base-command))
+ ,@(let ((inputs (append arguments additional-inputs)))
+ (if (not (null? inputs))
+ `((inputs . ,(map (match-lambda
+ (('keyword prefix input)
+ (append (input->tree input)
+ `((input-binding (prefix . ,prefix)))))
+ (('positional position input)
+ (append (input->tree input)
+ `((input-binding (position . ,position)))))
+ (input
+ (input->tree input)))
+ inputs)))
+ (list)))
+ ,@(if (or (not (null? outputs)) stdout stderr)
+ `((outputs . ,(map (lambda (output)
+ `(,(output-id output)
+ ,@(filter identity
+ (list (and (output-type output)
+ (cons 'type (output-type output)))
+ (and (output-binding output)
+ (cons 'output-binding (output-binding output)))))
+ ,@(output-other output)))
+ outputs)))
+ (list))
+ ,@(if stdout
+ `((stdout . ,stdout))
+ '())
+ ,@(if stderr
+ `((stderr . ,stderr))
+ '()))))
+
+(define-record-type (<workflow-output> make-workflow-output workflow-output?)
+ (fields (immutable id workflow-output-id)
+ (immutable type workflow-output-type)
+ (immutable source workflow-output-source)
+ (immutable other workflow-output-other)))
+
+(define* (workflow-output id #:key type source (other '()))
+ "Build and return a <workflow-output> object."
+ (make-workflow-output id type source other))
+
+(define-record-type (<step> step step?)
+ (fields (immutable id step-id)
+ (immutable run step-run)
+ (immutable in step-in)
+ (immutable out step-out)))
+
+(define* (workflow steps outputs #:key (other '()))
+ "Build a Workflow class CWL workflow."
+ `((cwlVersion . "v1.1")
+ (class . Workflow)
+ ,@other
+ (inputs . ,(delete-duplicates
+ (map input->tree
+ (append
+ (append-map (lambda (step)
+ (filter-map (match-lambda
+ ((id . (? input? input)) input)
+ (_ #f))
+ (step-in step)))
+ steps)
+ (filter-map (lambda (output)
+ (and (input? (workflow-output-source output))
+ (workflow-output-source output)))
+ outputs)))))
+ (outputs . ,(map (lambda (output)
+ `(,(workflow-output-id output)
+ (type . ,(workflow-output-type output))
+ (output-source . ,(match (workflow-output-source output)
+ ((? string? source) source)
+ ((? input? input) (input-id input))))))
+ outputs))
+ (steps . ,(map (lambda (step)
+ `(,(step-id step)
+ (in . ,(map (match-lambda
+ ((id . input)
+ (cons id (if (input? input)
+ (input-id input)
+ input))))
+ (step-in step)))
+ (out . ,(list->vector (step-out step)))
+ (run . ,(step-run step))))
+ steps))))
diff --git a/generate-cwl/yaml.scm b/generate-cwl/yaml.scm
new file mode 100644
index 0000000..f4691ca
--- /dev/null
+++ b/generate-cwl/yaml.scm
@@ -0,0 +1,85 @@
+;;
+;; scm->yaml
+;;
+;; This file implements a library to convert a scm tree to yaml.
+
+(define-module (generate-cwl yaml)
+ #:use-module (ice-9 match)
+ #:export (scm->yaml))
+
+(define (kebab->camel string)
+ "Convert STRING from kebab case to CAMEL case."
+ (match (string-split string #\-)
+ ((head tail ...)
+ (string-concatenate
+ (cons head (map string-titlecase tail))))))
+
+(define (display-atom atom port)
+ "Display ATOM in PORT converting from kebab case to camel case if
+ATOM is a symbol."
+ (cond
+ ((symbol? atom)
+ (display (string->symbol (kebab->camel (symbol->string atom))) port))
+ ((number? atom)
+ (display atom port))
+ ((string? atom)
+ ;; Escape string with double quotes if
+ ;; - every character is a digit or period, and the unescaped
+ ;; string can therefore be misinterpreted as a number
+ ;; - string contains the colon character
+ (if (or (string-every (char-set-union char-set:digit (char-set #\.)) atom)
+ (string-any #\: atom))
+ (write atom port)
+ (display atom port)))
+ ((boolean? atom)
+ (display (if atom "true" "false") port))
+ (else (error "Unknown atom" atom))))
+
+(define (indent-level port level)
+ "Emit whitespaces to PORT corresponding to nesting LEVEL."
+ (display (make-string (* 2 level) #\space) port))
+
+(define (display-array-element element port level)
+ "Display array ELEMENT to PORT at nesting LEVEL."
+ (display "- " port)
+ (scm->yaml element port (1+ level)))
+
+(define (display-dictionary-entry entry port level)
+ "Display dictionary ENTRY to PORT at nesting LEVEL."
+ (match entry
+ ((key . value)
+ (display-atom key port)
+ (display ":" port)
+ (match value
+ ((or #(_ ...)
+ ((_ . _) (_ . _) ...))
+ (newline port)
+ (indent-level port (1+ level))
+ (scm->yaml value port (1+ level)))
+ (_ (display " " port)
+ (scm->yaml value port level))))))
+
+(define* (scm->yaml scm #:optional (port (current-output-port)) (level 0))
+ "Convert SCM, an S-expression tree, to YAML and display to
+PORT. LEVEL is an internal recursion variable."
+ (match scm
+ (#(head tail ...)
+ (display-array-element head port level)
+ (for-each (lambda (element)
+ (indent-level port level)
+ (display-array-element element port level))
+ tail))
+ (#()
+ (display "[]" port))
+ ((head tail ...)
+ (display-dictionary-entry head port level)
+ (for-each (lambda (entry)
+ (indent-level port level)
+ (display-dictionary-entry entry port level))
+ tail))
+ (()
+ (display "{}" port)
+ (newline port))
+ (symbol
+ (display-atom symbol port)
+ (newline port))))