diff options
| -rw-r--r-- | generate-cwl/generate-cwl.scm | 183 | ||||
| -rw-r--r-- | generate-cwl/yaml.scm | 85 |
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)))) |