aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--scripts/fastq2fasta.scm6
-rw-r--r--scripts/generate-cwl.scm183
-rw-r--r--scripts/yaml.scm85
3 files changed, 2 insertions, 272 deletions
diff --git a/scripts/fastq2fasta.scm b/scripts/fastq2fasta.scm
index 9eaa88f..c014852 100644
--- a/scripts/fastq2fasta.scm
+++ b/scripts/fastq2fasta.scm
@@ -2,11 +2,9 @@
;; fastq2fasta.cwl workflow
;;
-(add-to-load-path "./scripts")
-
(use-modules (srfi srfi-26)
- (generate-cwl)
- (yaml))
+ (generate-cwl generate-cwl)
+ (generate-cwl yaml))
(define threads
(input "threads"
diff --git a/scripts/generate-cwl.scm b/scripts/generate-cwl.scm
deleted file mode 100644
index 1a26dfb..0000000
--- a/scripts/generate-cwl.scm
+++ /dev/null
@@ -1,183 +0,0 @@
-;;
-;; CWL generator
-;;
-;; This file implements a generator to generate CWL files.
-
-(define-module (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/scripts/yaml.scm b/scripts/yaml.scm
deleted file mode 100644
index f940911..0000000
--- a/scripts/yaml.scm
+++ /dev/null
@@ -1,85 +0,0 @@
-;;
-;; scm->yaml
-;;
-;; This file implements a library to convert a scm tree to yaml.
-
-(define-module (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))))
generated by cgit v1.2.3 (git 2.45.2) at 2024-11-22 13:13:15 +0000