diff options
33 files changed, 1084 insertions, 670 deletions
diff --git a/.dir-locals.el b/.dir-locals.el index 7e8c09c..fe4eb82 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -6,8 +6,9 @@ (makefile-gmake-mode (indent-tabs-mode t)) (scheme-mode + (eval put 'call-with-current-directory 'scheme-indent-function 1) (eval put 'lambda** 'scheme-indent-function 1) - (eval put 'set-command-inputs 'scheme-indent-function 1) + (eval put 'set-function-inputs 'scheme-indent-function 1) (eval put 'set-input-default 'scheme-indent-function 1) (eval put 'syntax-lambda** 'scheme-indent-function 1) (eval put 'test-condition 'scheme-indent-function 1) diff --git a/.guix/ccwl-distribution.scm b/.guix/ccwl-distribution.scm index 2b97f94..0598a00 100644 --- a/.guix/ccwl-distribution.scm +++ b/.guix/ccwl-distribution.scm @@ -1,5 +1,5 @@ ;;; ccwl --- Concise Common Workflow Language -;;; Copyright © 2024 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2024, 2026 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of ccwl. ;;; @@ -54,14 +54,14 @@ "GUILE_LOAD_COMPILED_PATH" (list (string-append "/lib/guile/" (target-guile-effective-version) "/site-ccache")) (list #$development-profile)) - (invoke "git" "clone" #$ccwl-git-repo (getcwd)) + (invoke "git" "clone" (string-append "file://" #$ccwl-git-repo) (getcwd)) (invoke "sh" "configure") (invoke "make" "dist") (match (scandir (getcwd) (cut string-suffix? ".tar.lz" <>)) ((tarball) - (install-file tarball #$output))))))) + (copy-file tarball #$output))))))) (define-public ccwl-distribution - (computed-file "ccwl-distribution" ccwl-distribution-gexp)) + (computed-file "ccwl.tar.lz" ccwl-distribution-gexp)) ccwl-distribution diff --git a/.guix/ccwl-package.scm b/.guix/ccwl-package.scm index a70e3e0..ddb5452 100644 --- a/.guix/ccwl-package.scm +++ b/.guix/ccwl-package.scm @@ -1,5 +1,5 @@ ;;; ccwl --- Concise Common Workflow Language -;;; Copyright © 2021, 2023–2024 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2021, 2023–2026 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of ccwl. ;;; @@ -18,13 +18,10 @@ (define-module (ccwl-package) #:use-module ((gnu packages bioinformatics) #:prefix guix:) - #:use-module ((gnu packages emacs) #:select (emacs-minimal)) - #:use-module ((gnu packages fonts) #:select (font-charter font-fira-code)) - #:use-module ((guix build-system guile) #:select (%guile-build-system-modules)) + #:use-module ((gnu packages guile-xyz) #:select (guile-filesystem)) #:use-module (guix gexp) #:use-module (guix git-download) #:use-module (guix packages) - #:use-module (guix profiles) #:use-module (guix utils)) (define-public ccwl @@ -34,52 +31,9 @@ "ccwl-checkout" #:recursive? #t #:select? (or (git-predicate (dirname (current-source-directory))) - (const #t)))))) - -(define ccwl-website-gexp - (let ((development-profile - (profile - (content (package->development-manifest ccwl)) - (allow-collisions? #t)))) - (with-imported-modules %guile-build-system-modules - #~(begin - (use-modules (guix build guile-build-system) - (guix build utils)) - - (set-path-environment-variable - "PATH" (list "/bin") (list #$development-profile #$emacs-minimal)) - (set-path-environment-variable - "LIBRARY_PATH" (list "/lib") (list #$development-profile)) - (set-path-environment-variable - "GUILE_LOAD_PATH" - (list (string-append "/share/guile/site/" - (target-guile-effective-version))) - (list #$development-profile)) - (set-path-environment-variable - "GUILE_LOAD_COMPILED_PATH" - (list (string-append "/lib/guile/" (target-guile-effective-version) "/site-ccache")) - (list #$development-profile)) - (copy-recursively #$(package-source ccwl) - (getcwd)) - ;; Emacs modifies README.org presumably for the contained - ;; org dynamic block. So, grant write permissions. - (chmod "README.org" #o644) - (for-each patch-shebang - (list "pre-inst-env" - "build-aux/generate-cwl-output.sh" - "scripts/ccwl")) - (substitute* "Makefile" - (("\\$\\(GUIX_ENVIRONMENT\\)") - #$(profile - (content (packages->manifest (list font-charter font-fira-code)))))) - (invoke "sh" "configure") - (invoke "make" - "--jobs" (number->string (parallel-job-count))) - (invoke "make" "website" - "--jobs" (number->string (parallel-job-count))) - (copy-recursively "website" #$output))))) - -(define-public ccwl-website - (computed-file "ccwl-website" ccwl-website-gexp)) + (const #t)))) + (propagated-inputs + (modify-inputs (package-propagated-inputs guix:ccwl) + (prepend guile-filesystem))))) ccwl diff --git a/.guix/ccwl-website.scm b/.guix/ccwl-website.scm new file mode 100644 index 0000000..754a0d5 --- /dev/null +++ b/.guix/ccwl-website.scm @@ -0,0 +1,74 @@ +;;; ccwl --- Concise Common Workflow Language +;;; Copyright © 2025 Arun Isaac <arunisaac@systemreboot.net> +;;; +;;; This file is part of ccwl. +;;; +;;; ccwl is free software: you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation, either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; ccwl is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with ccwl. If not, see <https://www.gnu.org/licenses/>. + +(define-module (ccwl-website) + #:use-module ((ccwl-package) #:select (ccwl)) + #:use-module ((gnu packages emacs) #:select (emacs-minimal)) + #:use-module ((gnu packages fonts) #:select (font-charter font-fira-code)) + #:use-module ((guix build-system guile) #:select (%guile-build-system-modules)) + #:use-module (guix gexp) + #:use-module (guix packages) + #:use-module (guix profiles)) + +(define ccwl-website-gexp + (let ((development-profile + (profile + (content (package->development-manifest ccwl)) + (allow-collisions? #t)))) + (with-imported-modules %guile-build-system-modules + #~(begin + (use-modules (guix build guile-build-system) + (guix build utils)) + + (set-path-environment-variable + "PATH" (list "/bin") (list #$development-profile #$emacs-minimal)) + (set-path-environment-variable + "LIBRARY_PATH" (list "/lib") (list #$development-profile)) + (set-path-environment-variable + "GUILE_LOAD_PATH" + (list (string-append "/share/guile/site/" + (target-guile-effective-version))) + (list #$development-profile)) + (set-path-environment-variable + "GUILE_LOAD_COMPILED_PATH" + (list (string-append "/lib/guile/" (target-guile-effective-version) "/site-ccache")) + (list #$development-profile)) + (copy-recursively #$(package-source ccwl) + (getcwd)) + ;; Emacs modifies README.org presumably for the contained + ;; org dynamic block. So, grant write permissions. + (chmod "README.org" #o644) + (for-each patch-shebang + (list "pre-inst-env" + "build-aux/generate-cwl-output.sh" + "scripts/ccwl")) + (substitute* "Makefile" + (("\\$\\(GUIX_ENVIRONMENT\\)") + #$(profile + (content (packages->manifest (list font-charter font-fira-code)))))) + (invoke "sh" "configure") + (invoke "make" + "--jobs" (number->string (parallel-job-count))) + (invoke "make" "website" + "--jobs" (number->string (parallel-job-count))) + (copy-recursively "website" #$output))))) + +(define-public ccwl-website + (computed-file "ccwl-website" ccwl-website-gexp)) + +ccwl-website diff --git a/HACKING.md b/HACKING.md new file mode 100644 index 0000000..7bfe8c7 --- /dev/null +++ b/HACKING.md @@ -0,0 +1,32 @@ +# Set up development environment + +Drop into a development environment using `guix shell`. +``` +guix shell -L .guix -m manifest.scm +``` + +# Make a release +## Tag a release +Tag a release `vx.x.x` putting news into the tag message. +## Create a release tarball, test it, and sign it +``` +cp $(guix build -L .guix -f .guix/ccwl-distribution.scm) ccwl-x.x.x.tar.lz +guix build --with-source=ccwl=ccwl-x.x.x.tar.lz -f guix.scm +make distsign +``` +## Build guix pack, docker and singularity images +``` +guix pack --with-source=ccwl=ccwl-x.x.x.tar.lz --file=guix.scm +guix pack -f docker -S /bin=bin --with-source=ccwl=ccwl-x.x.x.tar.lz --file=guix.scm +guix pack -f squashfs --with-source=ccwl=ccwl-x.x.x.tar.lz bash --file=guix.scm +``` +## Publish release tarball +Add release tarball and signature to website. Publish release tarball, guix pack, docker and singularity images to GitHub. +## Update Guix package +## Publicize +Publicize on +- [ccwl public inbox](mailto:ccwl@systemreboot.net) +- [guix-science mailing list](mailto:guix-science@gnu.org) +- [CWL Discourse forum](https://cwl.discourse.group/) +- genenetwork sphere Matrix room (invite-only room) +- pangenome Matrix room (invite-only room) diff --git a/Makefile b/Makefile index f4487d9..be958ae 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ # ccwl --- Concise Common Workflow Language -# Copyright © 2022, 2024 Arun Isaac <arunisaac@systemreboot.net> +# Copyright © 2022, 2024–2026 Arun Isaac <arunisaac@systemreboot.net> # # This file is part of ccwl. # @@ -24,12 +24,12 @@ GIT = git GPG = gpg GUILD = guild GUILE = guile +GUILE_RUN64 = guile-run64 LZIP = lzip SKRIBILO = skribilo FIND_DEPENDENCIES = build-aux/find-dependencies.scm GENERATE_CWL_OUTPUT = build-aux/generate-cwl-output.sh -TEST_DRIVER = build-aux/test-driver.scm top_level_module_dir = $(project) sources = $(wildcard $(top_level_module_dir)/*.scm) @@ -46,13 +46,13 @@ fonts = $(addprefix $(GUIX_ENVIRONMENT)/share/fonts/web/, charter_regular.woff2 distribute_files = $(sources) $(scripts) $(tests) $(test_data) \ $(doc_sources) doc/skribilo.scm $(doc_data) $(DOC_SCM) $(DOC_OTHER) \ pre-inst-env guix.scm Makefile configure configure.scm \ - $(FIND_DEPENDENCIES) $(GENERATE_CWL_OUTPUT) $(TEST_DRIVER) \ + $(FIND_DEPENDENCIES) $(GENERATE_CWL_OUTPUT) \ COPYING NEWS.org README.org scmdir = $(datarootdir)/guile/site/$(guile_effective_version)/$(top_level_module_dir) godir = $(libdir)/guile/$(guile_effective_version)/site-ccache/$(top_level_module_dir) -.PHONY: all check clean dist distcheck info install +.PHONY: all check clean dist distcheck info install ares # Build @@ -63,8 +63,8 @@ all: $(objects) # Run tests -check: $(tests) $(TEST_DRIVER) - $(GUILE) --no-auto-compile -L . $(TEST_DRIVER) $(tests) +check: + ./pre-inst-env $(GUILE_RUN64) $(tests) # Build documentation @@ -177,3 +177,6 @@ clean: $(DOC_SCM:.scm=.cwl) $(DOC_IMAGES) $(DOC_IMAGES:.png=.dot) $(DOC_OUT) \ $(doc_info) doc/skribilo.go rm -rf $(doc_html) website/manual website/fonts + +ares: + ./pre-inst-env $(GUILE) -c '((@ (ares server) run-nrepl-server))' diff --git a/NEWS.org b/NEWS.org index c351602..02fe372 100644 --- a/NEWS.org +++ b/NEWS.org @@ -1,6 +1,8 @@ #+TITLE: ccwl NEWS – History of user-visible changes -Copyright © 2021, 2024, 2025 Arun Isaac <arunisaac@systemreboot.net> +Copyright © 2021, 2024–2026 Arun Isaac <arunisaac@systemreboot.net> + +Changes in 0.5.0 and later are in the git tag messages. * Changes in 0.4.0 (since 0.3.0) ** Documentation diff --git a/README.org b/README.org index 3d8e31a..30f4be4 100644 --- a/README.org +++ b/README.org @@ -21,6 +21,13 @@ If you don't have [[https://guix.gnu.org/][GNU Guix]] set up, the easiest way to is to using the provided software bundles---either using the Guix tarball pack or the Docker image. +*** Using singularity + +Download the Singularity image from [[https://github.com/arunisaac/ccwl/releases][the GitHub releases page]]. Then, run ccwl like so: +#+BEGIN_SRC shell + $ singularity exec ccwl.squashfs ccwl [ARGS...] +#+END_SRC + *** Using the Guix tarball pack Download the Guix tarball pack from [[https://github.com/arunisaac/ccwl/releases][the GitHub releases page]] and @@ -36,14 +43,14 @@ Download the Docker image from [[https://github.com/arunisaac/ccwl/releases][the it. Then, run ccwl with command-line arguments of your choice. #+BEGIN_SRC shell $ docker load -i ccwl-docker.tar.gz - $ docker run ccwl [ARGS...] + $ docker run ccwl ccwl [ARGS...] #+END_SRC When passing files into the Docker container, remember to share the filesystem. The following command is one way to share the current directory with the container. #+BEGIN_SRC shell - $ docker run -v "$PWD:$PWD" -w "$PWD" ccwl compile foo.scm + $ docker run -v "$PWD:$PWD" -w "$PWD" ccwl ccwl compile foo.scm #+END_SRC ** Using Guix @@ -80,13 +87,16 @@ introduction to ccwl. * Contributing Feedback, suggestions, feature requests, bug reports and pull requests -are all welcome. Unclear and unspecific error messages are considered -a bug. Do report them! +are all welcome. Please write to [[mailto:ccwl@systemreboot.net][ccwl@systemreboot.net]]. You may also +browse the [[https://lists.systemreboot.net/ccwl][archives]] of previous discussions. Unclear and unspecific +error messages are considered a bug. Do report them! + +We do not accept issues or pull requests on GitHub. Thank you! To hack on ccwl, you can use GNU Guix to quickly drop into a development environment by running #+BEGIN_SRC shell - $ guix shell -Df guix.scm + $ guix shell -L .guix -m manifest.scm #+END_SRC * License diff --git a/build-aux/build-home-page.el b/build-aux/build-home-page.el index fd76a9e..15867bd 100644 --- a/build-aux/build-home-page.el +++ b/build-aux/build-home-page.el @@ -1,5 +1,5 @@ ;;; ccwl --- Concise Common Workflow Language -;;; Copyright © 2021, 2022, 2024, 2025 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2021, 2022, 2024–2026 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of ccwl. ;;; @@ -41,7 +41,8 @@ Download release tarballs. ") - (dolist (release '(("2025-01-28" "0.4.0") + (dolist (release '(("2026-01-13" "0.5.0") + ("2025-01-28" "0.4.0") ("2024-01-26" "0.3.0") ("2021-11-05" "0.2.0") ("2021-07-06" "0.1.0"))) diff --git a/build-aux/test-driver.scm b/build-aux/test-driver.scm deleted file mode 100644 index adac481..0000000 --- a/build-aux/test-driver.scm +++ /dev/null @@ -1,92 +0,0 @@ -;;; ccwl --- Concise Common Workflow Language -;;; Copyright © 2021, 2022 Arun Isaac <arunisaac@systemreboot.net> -;;; -;;; This file is part of ccwl. -;;; -;;; ccwl is free software: you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation, either version 3 of the License, or -;;; (at your option) any later version. -;;; -;;; ccwl is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with ccwl. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; This is a better test driver for Guile's (srfi srfi-64). -;; -;; TODO: Improve Guile's test driver so this module won't be -;; necessary. - -;;; Code: - -(use-modules (ice-9 format) - (ice-9 match) - (srfi srfi-26) - (srfi srfi-64) - (term ansi-color)) - -(define (color color-symbol str color?) - (if color? - (colorize-string str color-symbol) - str)) - -(define red (cut color 'RED <> <>)) -(define green (cut color 'GREEN <> <>)) -(define magenta (cut color 'MAGENTA <> <>)) - -(define (my-gnu-runner color?) - (let ((runner (test-runner-null))) - (test-runner-on-group-begin! runner - (lambda (runner suite-name count) - (format #t (magenta "%%%% ~a~%" color?) suite-name))) - (test-runner-on-group-end! runner - (lambda _ - (newline))) - (test-runner-on-test-end! runner - (lambda (runner) - (let ((name (test-runner-test-name runner)) - (result (string-upcase - (symbol->string (test-result-kind runner)))) - (result-alist (test-result-alist runner))) - (format #t "~a ~a~%" - (case (test-result-kind runner) - ((pass) (green result color?)) - (else (red result color?))) - name) - ;; If test did not pass, print details. - (unless (eq? (test-result-kind runner) 'pass) - (format (current-error-port) - "~a:~a~%expected: ~s~%actual: ~s~%" - (assq-ref result-alist 'source-file) - (assq-ref result-alist 'source-line) - (match (assq-ref result-alist 'source-form) - (('test-assert _ ...) #t) - (_ (assq-ref result-alist 'expected-value))) - (assq-ref result-alist 'actual-value)))))) - runner)) - -(match (command-line) - ((_ test-files ...) - (let ((runner (my-gnu-runner #t))) - (test-with-runner runner - (for-each load-from-path test-files) - (display (magenta "SUMMARY" #t)) - (newline) - (format #t "PASS: ~a -FAIL: ~a -XPASS: ~a -XFAIL: ~a -SKIP: ~a -" - (test-runner-pass-count runner) - (test-runner-fail-count runner) - (test-runner-xpass-count runner) - (test-runner-xfail-count runner) - (test-runner-skip-count runner)) - (exit (zero? (test-runner-fail-count runner))))))) diff --git a/ccwl/ccwl.scm b/ccwl/ccwl.scm index 3fc5364..f15392b 100644 --- a/ccwl/ccwl.scm +++ b/ccwl/ccwl.scm @@ -1,5 +1,5 @@ ;;; ccwl --- Concise Common Workflow Language -;;; Copyright © 2021–2024 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2021–2026 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of ccwl. ;;; @@ -25,7 +25,8 @@ (define-module (ccwl ccwl) #:use-module ((rnrs conditions) #:select (condition condition-irritants)) - #:use-module ((rnrs exceptions) #:select (guard (raise . raise-exception))) + #:use-module ((rnrs exceptions) #:select (raise-continuable + guard)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-2) #:use-module (srfi srfi-9) @@ -72,6 +73,7 @@ input-default input-position input-prefix + input-separate? input-separator input-stage? input-other @@ -93,7 +95,7 @@ unspecified-default?)) (define-immutable-record-type <input> - (make-input id type label default position prefix stage? other) + (make-input id type label default position prefix separate? separator stage? other) input? (id input-id) (type input-type) @@ -101,6 +103,7 @@ (default input-default set-input-default) (position input-position set-input-position) (prefix input-prefix set-input-prefix) + (separate? input-separate? set-input-separate?) (separator input-separator set-input-separator) (stage? input-stage?) (other input-other)) @@ -136,7 +139,7 @@ compared using @code{equal?}." ;; TODO: If tree is a quoted expression, emit a warning. (unless (false-if-exception (scm->yaml-string (syntax->datum tree))) - (raise-exception + (raise-continuable (condition (ccwl-violation tree) (formatted-message (string-append parameter-name " parameter not serializable to YAML")))))) @@ -160,54 +163,60 @@ compared using @code{equal?}." "Return syntax to build an <input> object from INPUT-SPEC." (syntax-case input-spec () ((id args ...) - (guard (exception - ((unrecognized-keyword-assertion? exception) - (raise-exception - (match (condition-irritants exception) - ((irritant _ ...) - (condition (ccwl-violation irritant) - (formatted-message "Unrecognized keyword argument ~a in input" - (syntax->datum irritant))))))) - ((invalid-keyword-arity-assertion? exception) - (raise-exception - (match (condition-irritants exception) - ;; TODO: Report all extra arguments, not just the - ;; first one. - ((keyword _ extra _ ...) - (condition (ccwl-violation extra) - (formatted-message "Unexpected extra argument ~a for unary keyword argument ~a" - (syntax->datum extra) - (syntax->datum keyword))))))) - ((invalid-positional-arguments-arity-assertion? exception) - (raise-exception - (match (condition-irritants exception) - ;; TODO: Report all extra positional arguments, not - ;; just the first one. - ((id extra _ ...) - (condition (ccwl-violation extra) - (formatted-message "Unexpected extra positional argument ~a in input" - (syntax->datum extra)))) - (() - (condition (ccwl-violation input-spec) - (formatted-message "Input has no identifier"))))))) - (apply (syntax-lambda** (id #:key (type #'File) label (default (make-unspecified-default)) (stage? #'#f) (other #'())) - (unless (memq (syntax->datum stage?) - (list #t #f)) - (raise-exception - (condition (ccwl-violation stage?) - (formatted-message "Invalid #:stage? parameter ~a. #:stage? must either be #t or #f." - (syntax->datum stage?))))) - (ensure-yaml-serializable other "#:other") - (let ((position #f) - (prefix #f)) - #`(make-input '#,id - #,(construct-type-syntax type) - #,label - #,(if (unspecified-default? default) - #'(make-unspecified-default) - default) - #,position #,prefix #,stage? '#,other))) - #'(id args ...)))) + (with-exception-handler + (lambda (c) + (cond + ((unrecognized-keyword-assertion? c) + (for-each (lambda (irritant) + (raise-continuable + (condition (ccwl-violation irritant) + (formatted-message "Unrecognized keyword argument ~a in input" + (syntax->datum irritant))))) + (condition-irritants c))) + ((invalid-keyword-arity-assertion? c) + (raise-continuable + (match (condition-irritants c) + ;; TODO: Report all extra arguments, not just the + ;; first one. + ((keyword _ extra _ ...) + (condition (ccwl-violation extra) + (formatted-message "Unexpected extra argument ~a for unary keyword argument ~a" + (syntax->datum extra) + (syntax->datum keyword))))))) + ((invalid-positional-arguments-arity-assertion? c) + (raise-continuable + (match (condition-irritants c) + ;; TODO: Report all extra positional arguments, not + ;; just the first one. + ((id extra _ ...) + (condition (ccwl-violation extra) + (formatted-message "Unexpected extra positional argument ~a in input" + (syntax->datum extra)))) + (() + (condition (ccwl-violation input-spec) + (formatted-message "Input has no identifier")))))) + (else + (raise-continuable c)))) + (cut apply + (syntax-lambda** (id #:key (type #'File) label (default (make-unspecified-default)) (stage? #'#f) (other #'())) + (unless (memq (syntax->datum stage?) + (list #t #f)) + (raise-continuable + (condition (ccwl-violation stage?) + (formatted-message "Invalid #:stage? parameter ~a. #:stage? must either be #t or #f." + (syntax->datum stage?))))) + (ensure-yaml-serializable other "#:other") + (let ((position #f) + (prefix #f)) + #`(make-input '#,id + #,(construct-type-syntax type) + #,label + #,(if (unspecified-default? default) + #'(make-unspecified-default) + default) + #,position #,prefix #f #f + #,stage? '#,other))) + #'(id args ...)))) (id (identifier? #'id) (input #'(id))) (_ (error "Invalid input:" (syntax->datum input-spec))))) @@ -224,43 +233,68 @@ compared using @code{equal?}." "Return syntax to build an <output> object from OUTPUT-SPEC." (syntax-case output-spec () ((id args ...) (identifier? #'id) - (guard (exception - ((unrecognized-keyword-assertion? exception) - (raise-exception - (match (condition-irritants exception) - ((irritant _ ...) - (condition (ccwl-violation irritant) - (formatted-message "Unrecognized keyword argument ~a in output" - (syntax->datum irritant))))))) - ((invalid-keyword-arity-assertion? exception) - (raise-exception - (match (condition-irritants exception) - ;; TODO: Report all extra arguments, not just the - ;; first one. - ((keyword _ extra _ ...) - (condition (ccwl-violation extra) - (formatted-message "Unexpected extra argument ~a for unary keyword argument ~a" - (syntax->datum extra) - (syntax->datum keyword))))))) - ((invalid-positional-arguments-arity-assertion? exception) - (raise-exception - (match (condition-irritants exception) - ;; TODO: Report all extra positional arguments, not - ;; just the first one. - ((id extra _ ...) - (condition (ccwl-violation extra) - (formatted-message "Unexpected extra positional argument ~a in output" - (syntax->datum extra)))) - (() - (condition (ccwl-violation output-spec) - (formatted-message "Output has no identifier"))))))) - (apply (syntax-lambda** (id #:key (type #'File) binding source (other #'())) - (ensure-yaml-serializable binding "#:binding") - (ensure-yaml-serializable other "#:other") - #`(make-output '#,id - #,(construct-type-syntax type) - '#,binding #,source '#,other)) - #'(id args ...)))) + (with-exception-handler + (lambda (c) + (cond + ((unrecognized-keyword-assertion? c) + (for-each (lambda (irritant) + (raise-continuable + (condition (ccwl-violation irritant) + (formatted-message "Unrecognized keyword argument ~a in output" + (syntax->datum irritant))))) + (condition-irritants c))) + ((invalid-keyword-arity-assertion? c) + (raise-continuable + (match (condition-irritants c) + ;; TODO: Report all extra arguments, not just the + ;; first one. + ((keyword _ extra _ ...) + (condition (ccwl-violation extra) + (formatted-message "Unexpected extra argument ~a for unary keyword argument ~a" + (syntax->datum extra) + (syntax->datum keyword))))))) + ((invalid-positional-arguments-arity-assertion? c) + (raise-continuable + (match (condition-irritants c) + ;; TODO: Report all extra positional arguments, not + ;; just the first one. + ((id extra _ ...) + (condition (ccwl-violation extra) + (formatted-message "Unexpected extra positional argument ~a in output" + (syntax->datum extra)))) + (() + (condition (ccwl-violation output-spec) + (formatted-message "Output has no identifier")))))) + (else + (raise-continuable c)))) + ;; TODO: Why let the user specify source? + (cut apply + (syntax-lambda** (id #:key (type #'File) binding source (other #'())) + (ensure-yaml-serializable binding "#:binding") + (ensure-yaml-serializable other "#:other") + (when (and (eq? (syntax->datum type) + 'stdout) + (syntax->datum binding)) + (raise-continuable + (condition (ccwl-violation + ;; Find the syntax object corresponding + ;; to the #:binding keyword. The binding + ;; variable is only the value of the + ;; argument. TODO: Highlight both the + ;; #:binding keyword and its value in the + ;; error message once our condition + ;; system is capable of representing + ;; that. + (find (lambda (arg) + (eq? (syntax->datum arg) + #:binding)) + #'(args ...))) + (formatted-message "~a not allowed with stdout type output" + #:binding)))) + #`(make-output '#,id + #,(construct-type-syntax type) + '#,binding #,source '#,other)) + #'(id args ...)))) (id (identifier? #'id) (output #'(id))) (_ (error "Invalid output:" (syntax->datum output-spec))))) @@ -279,7 +313,7 @@ compared using @code{equal?}." (define-immutable-record-type <js-expression> (make-js-expression inputs expression outputs requirements other) js-expression? - (inputs js-expression-inputs) + (inputs js-expression-inputs set-js-expression-inputs) (expression js-expression-expression) (outputs js-expression-outputs) (requirements js-expression-requirements) @@ -289,14 +323,14 @@ compared using @code{equal?}." (make-cwl-workflow file inputs outputs) cwl-workflow? (file cwl-workflow-file) - (inputs cwl-workflow-inputs) + (inputs cwl-workflow-inputs set-cwl-workflow-inputs) (outputs cwl-workflow-outputs)) (define-immutable-record-type <workflow> (make-workflow steps inputs outputs other) workflow? (steps workflow-steps) - (inputs workflow-inputs) + (inputs workflow-inputs set-workflow-inputs) (outputs workflow-outputs) (other workflow-other)) @@ -331,13 +365,13 @@ compared using @code{equal?}." (syntax-case input-spec () ((id _ ...) (if (not (identifier? #'id)) - (raise-exception + (raise-continuable (condition (ccwl-violation input-spec) (formatted-message "Input has no identifier"))) #'id)) (id (identifier? #'id) #'id) - (_ (raise-exception (condition (ccwl-violation input-spec) - (formatted-message "Invalid input"))))))) + (_ (raise-continuable (condition (ccwl-violation input-spec) + (formatted-message "Invalid input"))))))) (define (find-run-arg input-id run-args) "Return run argument specification identified by symbol @var{input-id} in @@ -350,13 +384,13 @@ return @code{#f}." (input (identifier? #'input) (syntax->datum #'input)) ;; prefixed input - ((_ input) (identifier? #'input) + ((_ input _ ...) (identifier? #'input) (syntax->datum #'input)) ;; array input specifier ((array input _ ...) (identifier? #'input) (syntax->datum #'input)) ;; prefixed array input specifier - ((_ (array input _ ...)) (identifier? #'input) + ((_ (array input _ ...) _ ...) (identifier? #'input) (syntax->datum #'input)) (_ #f)))) (and run-arg-input @@ -367,7 +401,31 @@ return @code{#f}." "Return the prefix specified in @var{run-arg} syntax. If not a prefixed input, return #f." (syntax-case run-arg () - ((prefix _) #'prefix) + ((prefix _ ...) (string? (syntax->datum #'prefix)) + #'prefix) + (_ #f))) + +(define (validate-separate? separate?) + "Validate @var{separate?} and raise a continuable exception if it is +not valid. Return validated @var{separate?}---either @code{#'#t} or +@code{#'#f}." + (if (boolean? (syntax->datum separate?)) + separate? + (begin + (raise-continuable + (condition (ccwl-violation separate?) + (formatted-message "Invalid #:separate? flag ~a. #:separate? flag must be a boolean." + (syntax->datum separate?)))) + #'#f))) + +(define (run-arg-separate? run-arg) + "Return the separate? specified in @var{run-arg} syntax. If not a +prefixed input, return #f." + (syntax-case run-arg (array) + ((prefix _ args ...) (string? (syntax->datum #'prefix)) + (apply (syntax-lambda** (#:key (separate? #'#t)) + (validate-separate? separate?)) + #'(args ...))) (_ #f))) (define (run-arg-separator run-arg) @@ -378,14 +436,14 @@ input, return #f." (apply (syntax-lambda** (#:key separator) (if (and separator (not (string? (syntax->datum separator)))) - (raise-exception + (raise-continuable (condition (ccwl-violation separator) (formatted-message "Invalid #:separator parameter ~a. #:separator parameter must be a string." (syntax->datum separator)))) separator)) #'(args ...))) ;; prefixed array input specifier - ((_ (array input args ...)) + ((_ (array input args ...) _ ...) (run-arg-separator #'(array input args ...))) (_ #f))) @@ -402,7 +460,7 @@ identifiers defined in the commands." (begin (unless (memq (syntax->datum #'input) defined-input-identifiers) - (raise-exception + (raise-continuable (condition (ccwl-violation #'input) (formatted-message "Undefined input ~a" (syntax->datum #'input))))) @@ -415,20 +473,25 @@ identifiers defined in the commands." (syntax->run-arg #'input)) ;; Flatten prefixed string arguments. They have no ;; special meaning. - ((prefix string-arg) (and (string? (syntax->datum #'prefix)) - (string? (syntax->datum #'string-arg))) - (list #'prefix #'string-arg)) + ((prefix string-arg args ...) (and (string? (syntax->datum #'prefix)) + (string? (syntax->datum #'string-arg))) + (apply (syntax-lambda** (#:key (separate? #'#t)) + (if (syntax->datum (validate-separate? separate?)) + (list #'prefix #'string-arg) + (list #`#,(string-append (syntax->datum #'prefix) + (syntax->datum #'string-arg))))) + #'(args ...))) ;; Recurse on prefixed inputs. - ((prefix input) (string? (syntax->datum #'prefix)) + ((prefix input _ ...) (string? (syntax->datum #'prefix)) (syntax->run-arg #'input)) ;; Prefixes that are not strings - ((prefix _) - (raise-exception + ((prefix _ ...) + (raise-continuable (condition (ccwl-violation #'prefix) (formatted-message "Invalid prefix ~a. Prefixes must be strings." (syntax->datum #'prefix))))) (_ - (raise-exception + (raise-continuable (condition (ccwl-violation x) (formatted-message "Invalid command element ~a. Command elements must either be input identifiers or literal strings." (syntax->datum x))))))) @@ -441,178 +504,193 @@ identifiers defined in the commands." (lambda (x) (syntax-case x () ((_ args ...) - (guard (exception - ((unrecognized-keyword-assertion? exception) - (raise-exception - (match (condition-irritants exception) - ((irritant _ ...) - (condition (ccwl-violation irritant) - (formatted-message "Unrecognized keyword argument ~a in command definition" - (syntax->datum irritant))))))) - ((invalid-keyword-arity-assertion? exception) - (raise-exception - (match (condition-irritants exception) - ;; TODO: Report all extra arguments, not just the - ;; first one. - ((keyword _ extra _ ...) - (condition (ccwl-violation extra) - (formatted-message "Unexpected extra argument ~a for unary keyword argument ~a" - (syntax->datum extra) - (syntax->datum keyword))))))) - ((invalid-positional-arguments-arity-assertion? exception) - (raise-exception - (match (condition-irritants exception) - ;; TODO: Report all extra positional arguments, not - ;; just the first one. - ((extra _ ...) - (condition (ccwl-violation extra) - (formatted-message "Unexpected extra positional argument ~a in command definition" - (syntax->datum extra)))))))) - (apply (syntax-lambda** (#:key stdin stderr stdout (requirements #'()) (other #'()) #:key* inputs outputs run) - (when (null? run) - (raise-exception - (condition (ccwl-violation x) - (formatted-message "Missing ~a key in command definition" - #:run)))) - (ensure-yaml-serializable requirements "#:requirements") - (ensure-yaml-serializable other "#:other") - (let ((flattened-args (run-args run (map input-spec-id inputs)))) - #`(make-command - (list #,@(map (lambda (input-spec) - (let* ((id (input-spec-id input-spec)) - (run-arg (find-run-arg id run))) - #`(set-input-separator - (set-input-prefix - (set-input-position - #,(input input-spec) - ;; `run-args' returns inputs as quoted symbols. - ;; So, we add quote. - #,(list-index (match-lambda - (`(quote ,input) - (eq? input id)) - (_ #f)) - (syntax->datum flattened-args))) - #,(and run-arg - (run-arg-prefix run-arg))) + (with-exception-handler + (lambda (c) + (cond + ((unrecognized-keyword-assertion? c) + (for-each (lambda (irritant) + (raise-continuable + (condition (ccwl-violation irritant) + (formatted-message "Unrecognized keyword argument ~a in command definition" + (syntax->datum irritant))))) + (condition-irritants c))) + ((invalid-keyword-arity-assertion? c) + (raise-continuable + (match (condition-irritants c) + ;; TODO: Report all extra arguments, not just the + ;; first one. + ((keyword _ extra _ ...) + (condition (ccwl-violation extra) + (formatted-message "Unexpected extra argument ~a for unary keyword argument ~a" + (syntax->datum extra) + (syntax->datum keyword))))))) + ((invalid-positional-arguments-arity-assertion? c) + (raise-continuable + (match (condition-irritants c) + ;; TODO: Report all extra positional arguments, not + ;; just the first one. + ((extra _ ...) + (condition (ccwl-violation extra) + (formatted-message "Unexpected extra positional argument ~a in command definition" + (syntax->datum extra))))))) + (else + (raise-continuable c)))) + (cut apply + (syntax-lambda** (#:key stdin stderr stdout (requirements #'()) (other #'()) #:key* inputs outputs run) + (when (null? run) + (raise-continuable + (condition (ccwl-violation x) + (formatted-message "Missing ~a key in command definition" + #:run)))) + (ensure-yaml-serializable requirements "#:requirements") + (ensure-yaml-serializable other "#:other") + (let ((flattened-args (run-args run (map input-spec-id inputs)))) + #`(make-command + (list #,@(map (lambda (input-spec) + (let* ((id (input-spec-id input-spec)) + (run-arg (find-run-arg id run))) + #`(set-input-separator + (set-input-separate? + (set-input-prefix + (set-input-position + #,(input input-spec) + ;; `run-args' returns inputs as quoted symbols. + ;; So, we add quote. + #,(list-index (match-lambda + (`(quote ,input) + (eq? input id)) + (_ #f)) + (syntax->datum flattened-args))) #,(and run-arg - (run-arg-separator run-arg))))) - inputs)) - (list #,@(map output outputs)) - (list #,@flattened-args) - #,(and stdin #`'#,stdin) - #,(if (and stderr - (not (string? (syntax->datum stderr)))) - (raise-exception - (condition (ccwl-violation stderr) - (formatted-message "Invalid #:stderr parameter ~a. #:stderr parameter must be a string" - (syntax->datum stderr)))) - stderr) - #,(if (and stdout - (not (string? (syntax->datum stdout)))) - (raise-exception - (condition (ccwl-violation stdout) - (formatted-message "Invalid #:stdout parameter ~a. #:stdout parameter must be a string" - (syntax->datum stdout)))) - stdout) - '#,requirements - '#,other))) - #'(args ...))))))) + (run-arg-prefix run-arg))) + #,(and run-arg + (run-arg-separate? run-arg))) + #,(and run-arg + (run-arg-separator run-arg))))) + inputs)) + (list #,@(map output outputs)) + (list #,@flattened-args) + #,(and stdin #`'#,stdin) + #,(if (and stderr + (not (string? (syntax->datum stderr)))) + (raise-continuable + (condition (ccwl-violation stderr) + (formatted-message "Invalid #:stderr parameter ~a. #:stderr parameter must be a string" + (syntax->datum stderr)))) + stderr) + #,(if (and stdout + (not (string? (syntax->datum stdout)))) + (raise-continuable + (condition (ccwl-violation stdout) + (formatted-message "Invalid #:stdout parameter ~a. #:stdout parameter must be a string" + (syntax->datum stdout)))) + stdout) + '#,requirements + '#,other))) + #'(args ...))))))) (define-syntax js-expression (lambda (x) (syntax-case x () ((_ args ...) - (guard (exception - ((unrecognized-keyword-assertion? exception) - (raise-exception - (match (condition-irritants exception) - ((irritant _ ...) - (condition (ccwl-violation irritant) - (formatted-message "Unrecognized keyword argument ~a in js-expression definition" - (syntax->datum irritant))))))) - ((invalid-keyword-arity-assertion? exception) - (raise-exception - (match (condition-irritants exception) - ;; TODO: Report all extra arguments, not just the - ;; first one. - ((keyword _ extra _ ...) - (condition (ccwl-violation extra) - (formatted-message "Unexpected extra argument ~a for unary keyword argument ~a" - (syntax->datum extra) - (syntax->datum keyword))))))) - ((invalid-positional-arguments-arity-assertion? exception) - (raise-exception - (match (condition-irritants exception) - ;; TODO: Report all extra positional arguments, not - ;; just the first one. - ((extra _ ...) - (condition (ccwl-violation extra) - (formatted-message "Unexpected extra positional argument ~a in js-expression definition" - (syntax->datum extra)))))))) - (apply (syntax-lambda** (#:key expression (requirements #'()) (other #'()) #:key* inputs outputs) - (unless expression - (raise-exception - (condition (ccwl-violation x) - (formatted-message "Missing ~a key in command definition" - #:expression)))) - (ensure-yaml-serializable requirements "#:requirements") - (ensure-yaml-serializable other "#:other") - #`(make-js-expression - (list #,@(map input inputs)) - #,expression - (list #,@(map output outputs)) - '#,requirements - '#,other)) - #'(args ...))))))) + (with-exception-handler + (lambda (c) + (cond + ((unrecognized-keyword-assertion? c) + (for-each (lambda (irritant) + (raise-continuable + (condition (ccwl-violation irritant) + (formatted-message "Unrecognized keyword argument ~a in js-expression definition" + (syntax->datum irritant))))) + (condition-irritants c))) + ((invalid-keyword-arity-assertion? c) + (raise-continuable + (match (condition-irritants c) + ;; TODO: Report all extra arguments, not just the + ;; first one. + ((keyword _ extra _ ...) + (condition (ccwl-violation extra) + (formatted-message "Unexpected extra argument ~a for unary keyword argument ~a" + (syntax->datum extra) + (syntax->datum keyword))))))) + ((invalid-positional-arguments-arity-assertion? c) + (raise-continuable + (match (condition-irritants c) + ;; TODO: Report all extra positional arguments, not + ;; just the first one. + ((extra _ ...) + (condition (ccwl-violation extra) + (formatted-message "Unexpected extra positional argument ~a in js-expression definition" + (syntax->datum extra))))))) + (else + (raise-continuable c)))) + (cut apply + (syntax-lambda** (#:key expression (requirements #'()) (other #'()) #:key* inputs outputs) + (unless expression + (raise-continuable + (condition (ccwl-violation x) + (formatted-message "Missing ~a key in command definition" + #:expression)))) + (ensure-yaml-serializable requirements "#:requirements") + (ensure-yaml-serializable other "#:other") + #`(make-js-expression + (list #,@(map input inputs)) + #,expression + (list #,@(map output outputs)) + '#,requirements + '#,other)) + #'(args ...))))))) (define-syntax cwl-workflow (lambda (x) (syntax-case x () ((_ file-syntax) - (let ((file (syntax->datum #'file-syntax)) - (parameters->id+type - (lambda (parameters) - (if (vector? parameters) - ;; Vector of dictionaries - (map (lambda (alist) - (cons (string->symbol (assoc-ref alist "id")) - (string->symbol (assoc-ref alist "type")))) - (vector->list parameters)) - ;; One dictionary - (map (match-lambda - ((id . (? string? type)) - (cons (string->symbol id) - (string->symbol type))) - ((id . alist) - (cons (string->symbol id) - (string->symbol (assoc-ref alist "type"))))) - parameters))))) - (unless (file-exists? file) - (raise-exception - (condition (ccwl-violation #'file-syntax) - (formatted-message "CWL workflow file ~a does not exist" file)))) - ;; Read inputs/outputs from CWL workflow YAML file and build - ;; a <cwl-workflow> object. - (let ((yaml (read-yaml-file file))) - #`(make-cwl-workflow - file-syntax - (list #,@(map (match-lambda - ((id . type) - (with-syntax ((id (datum->syntax #f id)) - (type (datum->syntax #f type))) - #`(make-input 'id 'type #f #f #f #f #f '())))) - (parameters->id+type (assoc-ref yaml "inputs")))) - (list #,@(map (match-lambda - ((id . type) - (with-syntax ((id (datum->syntax #f id)) - (type (datum->syntax #f type))) - #`(make-output 'id 'type '() #f '())))) - (parameters->id+type (assoc-ref yaml "outputs"))))))))))) + (let* ((parameters->id+type + (lambda (parameters) + (if (vector? parameters) + ;; Vector of dictionaries + (map (lambda (alist) + (cons (string->symbol (assoc-ref alist "id")) + (string->symbol (assoc-ref alist "type")))) + (vector->list parameters)) + ;; One dictionary + (map (match-lambda + ((id . (? string? type)) + (cons (string->symbol id) + (string->symbol type))) + ((id . alist) + (cons (string->symbol id) + (string->symbol (assoc-ref alist "type"))))) + parameters)))) + (file (syntax->datum #'file-syntax)) + (path (resolve-file-syntax file #'file-syntax)) + (yaml + (if (file-exists? path) + (read-yaml-file path) + (raise-continuable + (condition (ccwl-violation #'file-syntax) + (formatted-message "CWL workflow file ~a does not exist" + file)))))) + ;; Build a <cwl-workflow> object from read CWL workflow YAML. + #`(make-cwl-workflow + file-syntax + (list #,@(map (match-lambda + ((id . type) + (with-syntax ((id (datum->syntax #f id)) + (type (datum->syntax #f type))) + #`(make-input 'id 'type #f #f #f #f #f #f #f '())))) + (parameters->id+type (assoc-ref yaml "inputs")))) + (list #,@(map (match-lambda + ((id . type) + (with-syntax ((id (datum->syntax #f id)) + (type (datum->syntax #f type))) + #`(make-output 'id 'type '() #f '())))) + (parameters->id+type (assoc-ref yaml "outputs")))))))))) (define (function-inputs function) "Return the list of inputs accepted by @var{function}---a @code{<command>}, @code{<js-expression>}, @code{<cwl-workflow>} or -@code{<workflow> object." +@code{<workflow>} object." ((cond ((command? function) command-inputs) ((js-expression? function) js-expression-inputs) @@ -621,6 +699,21 @@ identifiers defined in the commands." (else (error "Unrecognized ccwl function" function))) function)) +(define (set-function-inputs function inputs) + "Set inputs of @var{function} to @var{inputs}---a +@code{<command>}, @code{<js-expression>}, @code{<cwl-workflow>} or +@code{<workflow> object. @code{set-function-inputs} is purely +functional. It returns a copy of @var{function}. @var{function} is not +mutated." + ((cond + ((command? function) set-command-inputs) + ((js-expression? function) set-js-expression-inputs) + ((cwl-workflow? function) set-cwl-workflow-inputs) + ((workflow? function) set-workflow-inputs) + (else (error "Unrecognized ccwl function" function))) + function + inputs)) + (define (function-input-keys function) "Return the list of input keys accepted by FUNCTION, a <command>, <js-expression>, <cwl-workflow> or <workflow> object." @@ -647,11 +740,11 @@ identifiers defined in the commands." ;; Global input/output (symbol->string (key-cwl-id key)))) -(define (apply-partially command partial-arguments) - "Return a new command that is a partial application of -@var{partial-arguments} to @var{command}. @var{partial-arguments} is +(define (apply-partially function partial-arguments) + "Return a new function that is a partial application of +@var{partial-arguments} to @var{function}. @var{partial-arguments} is an association list mapping keyword arguments to their values." - (set-command-inputs command + (set-function-inputs function (map (lambda (input) (set-input-default input (or (any (match-lambda @@ -661,7 +754,7 @@ an association list mapping keyword arguments to their values." value))) partial-arguments) (input-default input)))) - (command-inputs command)))) + (function-inputs function)))) (define (function-object x) "Return the ccwl function object (a <command>, <js-expression>, @@ -711,7 +804,7 @@ represented by <step> objects." (list))) ;; tee ((tee expressions ...) - (let ((key-lists step-lists (mapn (cut collect-steps <> input-keys) + (let ((key-lists step-lists (map2 (cut collect-steps <> input-keys) #'(expressions ...)))) (values ;; Global workflow input keys may be duplicated across the @@ -725,15 +818,20 @@ represented by <step> objects." ;; rename keys (base case) ((rename new-key old-key) (begin - ;; Error out on non-keyword arguments. + ;; Error out if new key is not a keyword. (unless (keyword? (syntax->datum #'new-key)) - (raise-exception + (raise-continuable (condition (ccwl-violation #'new-key) (formatted-message "Expected keyword (for example: #:foo, #:bar)")))) + ;; Error out if old key is a keyword. + (when (keyword? (syntax->datum #'old-key)) + (raise-continuable + (condition (ccwl-violation #'old-key) + (formatted-message "Unexpected keyword; expected symbol (for example: foo, bar)")))) ;; Ensure old key exists. (unless (memq (syntax->datum #'old-key) (map key-name input-keys)) - (raise-exception + (raise-continuable (condition (ccwl-violation #'old-key) (formatted-message "Unknown key ~a. Known keys at this step are ~a." (syntax->datum #'old-key) @@ -766,7 +864,7 @@ represented by <step> objects." (step-id-symbol (syntax->datum #'step-id))) ;; Test for undefined command. (unless function-object - (raise-exception + (raise-continuable (condition (ccwl-violation #'function) (formatted-message "Undefined ccwl command ~a" (syntax->datum #'function))))) @@ -783,7 +881,7 @@ represented by <step> objects." (syntax->datum (pairify #'(args ...))))) (() #t) (missing-parameters - (raise-exception + (raise-continuable ;; TODO: Report entire form, not just the name of the ;; step. (condition (ccwl-violation #'function) @@ -795,7 +893,7 @@ represented by <step> objects." ((arg . value) (unless (memq (keyword->symbol (syntax->datum arg)) (function-input-keys function-object)) - (raise-exception + (raise-continuable ;; TODO: Report arg and value, not just arg. (condition (ccwl-violation arg) ;; TODO: Do not report accepted keys @@ -810,7 +908,7 @@ represented by <step> objects." (when (and (symbol? (syntax->datum value)) (not (memq (syntax->datum value) input-key-symbols))) - (raise-exception + (raise-continuable (condition (ccwl-violation value) (formatted-message "Step ~a supplied with unknown key ~a. Known keys at this step are ~a." step-id-symbol @@ -822,7 +920,7 @@ represented by <step> objects." (((key-syntax . _) seen) (let ((key (syntax->datum key-syntax))) (when (memq key seen) - (raise-exception + (raise-continuable (condition (ccwl-violation key-syntax) (formatted-message "~a argument already supplied" key)))) @@ -858,7 +956,9 @@ represented by <step> objects." input-keys))))) (pairify (syntax->datum #'(args ...)))))))) ;; If literal values are provided as arguments, partially - ;; apply those literal values to the command and recurse. + ;; apply those literal values to the function object + ;; (command, workflow, js-expression, cwl-workflow) and + ;; recurse. (_ (collect-steps #`(((module-ref (resolve-module '(ccwl ccwl)) 'apply-partially) @@ -873,7 +973,7 @@ represented by <step> objects." ((function args ...) ;; Ensure that steps with expression commands have identifiers. (unless (symbol? (syntax->datum #'function)) - (raise-exception + (raise-continuable (condition (ccwl-violation #'function) (formatted-message "Step with expression ~a that evaluates to a command must have identifier" (syntax->datum #'function))))) @@ -980,7 +1080,7 @@ commands." ;; Guess that these are multiple unconnected expressions in the ;; workflow body, and try to produce a helpful error message. ((_ (inputs ...) expressions ...) - (raise-exception + (raise-continuable (condition (ccwl-violation x) (formatted-message "More than one expression ~a in workflow body. Perhaps you need to combine them with a pipe or a tee?" @@ -990,6 +1090,6 @@ commands." (cut write expression <>))) (syntax->datum #'(expressions ...)))))))) (x - (raise-exception + (raise-continuable (condition (ccwl-violation #'x) (formatted-message "Unrecognized workflow syntax [expected (workflow (input ...) tree)]"))))))) diff --git a/ccwl/conditions.scm b/ccwl/conditions.scm index c6523cb..abbd404 100644 --- a/ccwl/conditions.scm +++ b/ccwl/conditions.scm @@ -1,5 +1,5 @@ ;;; ccwl --- Concise Common Workflow Language -;;; Copyright © 2022 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2022, 2025 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of ccwl. ;;; @@ -63,7 +63,7 @@ (arguments formatted-message-arguments)) (define (formatted-message format-string . arguments) - "Return &ccwl-message condition for FORMAT-STRING with ARGUMENTS." + "Return &formatted-message condition for FORMAT-STRING with ARGUMENTS." (make-formatted-message (apply format format-string arguments) format-string arguments)) diff --git a/ccwl/cwl.scm b/ccwl/cwl.scm index baef519..f954f08 100644 --- a/ccwl/cwl.scm +++ b/ccwl/cwl.scm @@ -1,5 +1,5 @@ ;;; ccwl --- Concise Common Workflow Language -;;; Copyright © 2021, 2023–2024 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2021, 2023–2025 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of ccwl. ;;; @@ -51,16 +51,34 @@ specification." (scm->yaml (workflow->cwl-scm workflow) port)) -(define (filter-alist alist) - "Filter ALIST removing entries with #f as the value. If the -resulting association list is empty, return #f. Else, return that -association list." - (match (filter (match-lambda - ((_ . #f) #f) - (_ #t)) - alist) - (() #f) - (result result))) +(define (vector-filter-map proc vec) + "Map @var{proc} over @var{vec} and return a vector of the results that +are not @code{#f}." + (list->vector (filter-map proc (vector->list vec)))) + +(define (prune-tree tree) + "Prune JSON-like @var{tree} removing dictionary keys without a mapping." + (match tree + ;; Array + (#(elements ...) + (vector-filter-map (lambda (element) + (match (prune-tree element) + (() #f) + (pruned-element pruned-element))) + tree)) + ;; Dictionary + ((pairs ...) + (filter-map (match-lambda + ;; Key with a mapping + ((key . value) + (match (prune-tree value) + (() #f) + (pruned-value (cons key pruned-value)))) + ;; Key without a mapping + ((key) #f)) + pairs)) + ;; Atom + (atom atom))) (define* (workflow->cwl-scm workflow) "Render WORKFLOW, a <workflow> object, into a CWL tree." @@ -114,17 +132,17 @@ association list." "Render @var{output}, a @code{<output>} object, into a CWL tree. If @var{workflow?} is @code{#t}, this is a workflow output." `(,(output-id output) - ,@(or (filter-alist - `((type . ,(type->cwl (output-type output))) - ;; outputBinding is relevant only to commands, and - ;; outputSource is relevant only to workflows. - ,@(if workflow? - `((outputSource . ,(match (output-source output) - ((? string? source) source) - ((? input? input) (input-id input))))) - `((outputBinding . ,(output-binding output)))))) - '()) - ,@(output-other output))) + ,@(prune-tree + `((type . ,(type->cwl (output-type output))) + ;; outputBinding is relevant only to commands, and + ;; outputSource is relevant only to workflows. + ,@(if workflow? + `((outputSource . ,(match (output-source output) + ((? string? source) source) + ((? input? input) (input-id input))))) + `((outputBinding . ,(or (output-binding output) + '())))) + ,@(output-other output))))) (define (command->cwl command port) "Render @var{command}, a @code{<command>} object, to @var{port} as a @@ -135,21 +153,30 @@ CWL YAML specification." (define (input->cwl-scm input) "Render @var{input}, a @code{<input>} object, into a CWL tree." `(,(input-id input) - (type . ,(type->cwl (input-type input))) - ,@(or (filter-alist - `((label . ,(input-label input)) - (default . ,(and (not (unspecified-default? (input-default input))) - (input-default input))) - ;; inputBinding is only relevant to commands, not - ;; workflows. But, the input position and prefix are not set - ;; for worklow inputs and therefore this sub-expression has - ;; no effect. So, leave this be. - (inputBinding . ,(filter-alist - `((position . ,(input-position input)) - (prefix . ,(input-prefix input)) - (itemSeparator . ,(input-separator input))))))) - '()) - ,@(input-other input))) + ,@(prune-tree + `((type . ,(type->cwl (input-type input))) + (default . ,(if (unspecified-default? (input-default input)) + '() + (input-default input))) + (label . ,(or (input-label input) + '())) + ;; inputBinding is only relevant to commands, not workflows. + ;; But, the input position and prefix are not set for worklow + ;; inputs and therefore this sub-expression has no effect. + ;; So, leave this be. + (inputBinding + (position . ,(or (input-position input) + '())) + (prefix . ,(or (input-prefix input) + '())) + ;; separate? has a meaningful value only with prefix. + (separate . ,(if (input-prefix input) + (and (input-separate? input) + '()) + '())) + (itemSeparator . ,(or (input-separator input) + '()))) + ,@(input-other input))))) (define (staging-requirements inputs) "Return @samp{InitialWorkDirRequirement} to stage any @var{inputs} that diff --git a/ccwl/lang.scm b/ccwl/lang.scm new file mode 100644 index 0000000..b52a5ab --- /dev/null +++ b/ccwl/lang.scm @@ -0,0 +1,82 @@ +;;; ccwl --- Concise Common Workflow Language +;;; Copyright © 2026 Arun Isaac <arunisaac@systemreboot.net> +;;; +;;; This file is part of ccwl. +;;; +;;; ccwl is free software: you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation, either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; ccwl is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with ccwl. If not, see <https://www.gnu.org/licenses/>. + +(define-module (ccwl lang) + #:declarative? #f + #:use-module (rnrs conditions) + #:use-module (rnrs exceptions) + #:use-module (srfi srfi-1) + #:use-module (ice-9 textual-ports) + #:use-module (ccwl conditions) + #:use-module (ccwl utils) + #:export (ccwl-read + ccwl-load)) + +(define (syntax-list->vector x) + "Convert syntax @var{x} of a list into syntax of a vector." + (datum->syntax #f + (syntax-case x () + ((elements ...) + #'#(elements ...))) + #:source x)) + +(define (read-hash-vector chr port) + "Read vector from @var{port}. This function is intended for use with +@code{read-hash-extend}." + (unget-char port chr) + (let ((lst (read-syntax port))) + (if (dotted-list? (syntax->datum lst)) + (raise-exception + (condition (ccwl-violation lst) + (formatted-message "Malformed vector: unexpected dotted list ~a" + (syntax->datum lst)))) + (syntax-list->vector lst)))) + +(read-hash-extend #\( read-hash-vector) + +(define* (ccwl-read #:optional (port (current-input-port))) + "Read an S-expression from @var{port}. This function wraps +@code{read-syntax} to raise read errors the way ccwl likes to handle +it." + (guard (c ((and (eq? (exception-kind c) + 'read-error) + (message-condition? c) + (irritants-condition? c)) + ;; TODO: Once https://codeberg.org/guile/guile/issues/206 + ;; is fixed, report error in source context using + ;; report-ccwl-violation. + (raise-exception + (apply formatted-message + (condition-message c) + (condition-irritants c))))) + (read-syntax port))) + +(define (ccwl-load-helper file file-syntax) + "Load ccwl source @var{file}. @var{file-syntax} is the syntax object +wrapping @var{file}." + (let ((source-path (resolve-file-syntax file file-syntax))) + (if (file-exists? source-path) + (load source-path ccwl-read) + (raise-continuable + (condition (ccwl-violation file-syntax) + (formatted-message "File ~a does not exist" + file)))))) + +(define-syntax-rule (ccwl-load file) + "Load ccwl source @var{file}." + (ccwl-load-helper file #'file)) diff --git a/ccwl/ui.scm b/ccwl/ui.scm index 3b46a23..2e7356e 100644 --- a/ccwl/ui.scm +++ b/ccwl/ui.scm @@ -1,5 +1,5 @@ ;;; ccwl --- Concise Common Workflow Language -;;; Copyright © 2022, 2023 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2022, 2023, 2026 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of ccwl. ;;; @@ -35,7 +35,10 @@ user." ;; the arguments are strings. (string-replace-substring (string-replace-substring - (formatted-message-format exception) + (string-replace-substring + (string-replace-substring + (formatted-message-format exception) "~A" "~a") + "~S" "~s") "~a" (colorize-string "~a" 'BOLD 'MAGENTA)) "~s" @@ -177,4 +180,5 @@ red. LINE-NUMBER and COLUMN-NUMBER are zero-based." (display-with-line-numbers (call-with-input-file file (cut source-in-context <> line column)) (current-error-port) - (max 1 line)))) + (max 1 line)) + (newline (current-error-port)))) diff --git a/ccwl/utils.scm b/ccwl/utils.scm index 3c18efd..d266029 100644 --- a/ccwl/utils.scm +++ b/ccwl/utils.scm @@ -1,5 +1,5 @@ ;;; ccwl --- Concise Common Workflow Language -;;; Copyright © 2021, 2022, 2023 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2021–2023, 2025–2026 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of ccwl. ;;; @@ -27,10 +27,11 @@ condition-irritants (make-irritants-condition . irritants-condition))) #:use-module ((rnrs exceptions) #:select (guard - (raise . raise-exception))) + raise-continuable)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-71) + #:use-module (ice-9 filesystem) #:use-module (ice-9 match) #:use-module (ccwl conditions) #:export (indent-level @@ -39,8 +40,10 @@ lambda** syntax-lambda** mapn + map2 foldn - filter-mapi)) + filter-mapi + resolve-file-syntax)) (define (indent-level port level) "Emit whitespaces to PORT corresponding to nesting LEVEL." @@ -82,7 +85,7 @@ If a unary keyword is passed multiple arguments, a ;; unary keyword argument (match this-keyword-args ((this-keyword-arg) this-keyword-arg) - (_ (raise-exception + (_ (raise-continuable (condition (invalid-keyword-arity-assertion) (irritants-condition (cons this-keyword this-keyword-args)))))) @@ -150,21 +153,13 @@ arguments. Note that the default default value for unary arguments is 1 2 #:vale 123 #:naal 321 456) => (1 2 #f 123 9 (321 456) (7) (3 2 1) ()) -Like lambda*, lambda** supports #:allow-other-keys. For example, - -((lambda** (#:key foo #:allow-other-keys) - foo) - #:foo 1 #:bar 2) -=> 1 - -However, #:optional and #:rest are not supported. - If an unrecognized keyword is passed to the lambda function, a &unrecognized-keyword-assertion condition is raised. If a unary keyword argument is passed more than one argument, a &invalid-keyword-arity-assertion condition is raised. If a wrong number of positional arguments is passed, a -&invalid-positional-arguments-arity-assertion condition is raised." +&invalid-positional-arguments-arity-assertion condition is raised. +However these exceptions are continuable." (syntax-case x () ((_ (args-spec ...) body ...) #`(lambda args @@ -174,9 +169,7 @@ number of positional arguments is passed, a (unary-arguments (or (plist-ref grouped-rest #:key) (list))) (nary-arguments (or (plist-ref grouped-rest #:key*) - (list))) - (allow-other-keys? (if (plist-ref grouped-rest #:allow-other-keys) - #t #f))) + (list)))) (let ((unrecognized-keywords (lset-difference (lambda (x y) (let ((x (if (keyword? x) x (syntax->datum x))) @@ -184,9 +177,9 @@ number of positional arguments is passed, a (eq? x y))) (filter (compose keyword? syntax->datum) #'(args-spec ...)) - (list #:key #:key* #:allow-other-keys)))) + (list #:key #:key*)))) (unless (null? unrecognized-keywords) - (raise-exception + (raise-continuable (condition (unrecognized-keyword-assertion) (irritants-condition unrecognized-keywords))))) #`(apply (lambda* #,(append positionals @@ -197,16 +190,14 @@ number of positional arguments is passed, a #'(arg (list defaults ...))) (arg #'(arg '())))) nary-arguments) - (if allow-other-keys? - (list #:allow-other-keys) - (list))) + (list #:allow-other-keys)) body ...) (let ((positionals rest (break keyword? args))) ;; Test for correct number of positional ;; arguments. (unless (= (length positionals) #,(length positionals)) - (raise-exception + (raise-continuable (condition (invalid-positional-arguments-arity-assertion) (irritants-condition positionals)))) ;; Test if all keywords are recognized. @@ -220,9 +211,8 @@ number of positional arguments is passed, a (arg #'arg))))) (append unary-arguments nary-arguments))))) - (unless (or #,allow-other-keys? - (null? unrecognized-keywords)) - (raise-exception + (unless (null? unrecognized-keywords) + (raise-continuable (condition (unrecognized-keyword-assertion) (irritants-condition unrecognized-keywords))))) (append positionals @@ -252,49 +242,45 @@ that for n-ary arguments is the empty list. For example, #'1 #'2 #'#:vale #'123 #'#:naal #'321 #'456) => (#'1 #'2 #'123 9 (#'321 #'456) (7) (3 2 1)) -Like lambda**, syntax-lambda** supports #:allow-other-keys. - -((syntax-lambda** (#:key foo #:allow-other-keys) - foo) - #'#:foo #'1 #'#:bar #'2) -=> #'1 - -#:optional and #:rest are not supported. - If an unrecognized keyword is passed to the lambda function, a &unrecognized-keyword-assertion condition is raised. If a unary keyword argument is passed more than one argument, a &invalid-keyword-arity-assertion condition is raised. If a wrong number of positional arguments is passed, a -&invalid-positional-arguments-arity-assertion condition is raised." +&invalid-positional-arguments-arity-assertion condition is raised. +However these exceptions are continuable." (lambda args - (guard (exception - ((unrecognized-keyword-assertion? exception) - (raise-exception - (condition (unrecognized-keyword-assertion) - (irritants-condition - ;; Resyntax irritant keywords. - (map (lambda (irritant-keyword) - (find (lambda (arg) - (eq? (syntax->datum arg) - irritant-keyword)) - args)) - (condition-irritants exception)))))) - ((invalid-keyword-arity-assertion? exception) - (raise-exception - (condition (invalid-keyword-arity-assertion) - (irritants-condition - ;; Resyntax irritant keyword. - (match (condition-irritants exception) - ((irritant-keyword . irritant-args) - (cons (find (lambda (arg) - (eq? (syntax->datum arg) - irritant-keyword)) - args) - irritant-args)))))))) - (apply - (lambda** formal-args body ...) - (unsyntax-keywords args))))) + (with-exception-handler + (lambda (c) + (cond + ((unrecognized-keyword-assertion? c) + (raise-continuable + (condition (unrecognized-keyword-assertion) + (irritants-condition + ;; Resyntax irritant keywords. + (map (lambda (irritant-keyword) + (find (lambda (arg) + (eq? (syntax->datum arg) + irritant-keyword)) + args)) + (condition-irritants c)))))) + ((invalid-keyword-arity-assertion? c) + (raise-continuable + (condition (invalid-keyword-arity-assertion) + (irritants-condition + ;; Resyntax irritant keyword. + (match (condition-irritants c) + ((irritant-keyword . irritant-args) + (cons (find (lambda (arg) + (eq? (syntax->datum arg) + irritant-keyword)) + args) + irritant-args))))))) + (else + (raise-continuable c)))) + (cut apply + (lambda** formal-args body ...) + (unsyntax-keywords args))))) (define (filter-mapi proc lst) "Indexed filter-map. Like filter-map, but PROC calls are (proc item @@ -311,22 +297,31 @@ element. For example, lst (iota (length lst)))) -(define (mapn proc lst) +(define (mapn proc lst n) "Map the procedure PROC over list LST and return a list containing -the results. PROC can return multiple values, in which case, an equal -number of lists are returned. For example, +the results. PROC must return N values, in which case, N lists are +returned. For example, (mapn (lambda (n) (values (expt n 2) (expt n 3))) - (iota 5)) + (iota 5) + 2) => (0 1 4 9 16) => (0 1 8 27 64)" (apply values - (apply zip - (map (lambda (x) - (call-with-values (cut proc x) list)) - lst)))) + (match lst + ;; With an empty list, we cannot know the number of values + ;; proc would return. Hence this special case. + (() (make-list n '())) + (_ + (apply zip + (map (lambda (x) + (call-with-values (cut proc x) list)) + lst)))))) + +(define map2 + (cut mapn <> <> 2)) (define (foldn proc lst . inits) "Apply PROC to the elements of LST to build a result, and return @@ -348,3 +343,15 @@ the first call. For example, (call-with-values (cut apply proc element results) list)) inits lst))) + +(define (resolve-file-syntax file-path file-syntax) + "Resolve @var{file-path} relative to the file location of +@var{file-syntax}. If @var{file-syntax} has no source location, +resolve relative to the current directory." + (let ((source-file (assq-ref (syntax-source file-syntax) + 'filename))) + (if (file-name-absolute? file-path) + file-path + (expand-file-name file-path + (and source-file + (dirname (canonicalize-path source-file))))))) diff --git a/ccwl/yaml.scm b/ccwl/yaml.scm index cc27be4..9ccd946 100644 --- a/ccwl/yaml.scm +++ b/ccwl/yaml.scm @@ -1,5 +1,5 @@ ;;; ccwl --- Concise Common Workflow Language -;;; Copyright © 2021, 2023 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2021, 2023, 2026 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of ccwl. ;;; @@ -57,10 +57,13 @@ serialized to YAML. Else, return @code{#f}." ;; string can therefore be misinterpreted as a number ;; - string contains indicator characters as mentioned in the YAML ;; spec https://yaml.org/spec/1.2.2/#53-indicator-characters + ;; - string contains whitespace characters other than space (if (or (string-every (char-set-union char-set:digit (char-set #\.)) atom) (string-any (char-set #\- #\? #\: #\, #\[ #\] #\{ #\} #\# #\& #\* #\! #\| #\> #\' #\" #\% #\@ #\`) - atom)) + atom) + (and (string-any char-set:whitespace atom) + (not (string-any #\space atom)))) (write atom port) (display atom port))) ((boolean? atom) diff --git a/doc/ccwl-load.scm b/doc/ccwl-load.scm new file mode 100644 index 0000000..a899a51 --- /dev/null +++ b/doc/ccwl-load.scm @@ -0,0 +1,6 @@ +(define checksum + (ccwl-load "checksum.scm")) + +(workflow ((input #:type File)) + (pipe (checksum …) + […])) diff --git a/doc/ccwl.skb b/doc/ccwl.skb index 9001f20..4bc3f39 100644 --- a/doc/ccwl.skb +++ b/doc/ccwl.skb @@ -1,5 +1,5 @@ ;;; ccwl --- Concise Common Workflow Language -;;; Copyright © 2021, 2023–2024 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2021, 2023–2026 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of ccwl. ;;; @@ -232,6 +232,7 @@ following output.]) compiled executable is in ,(file "run-output.txt"). Success!])) (subsection :title [tee] + :ident "section-tee" (p [Next, the tee topology. The following workflow computes three different checksums of a given input file.]) @@ -363,6 +364,14 @@ prefix. For example, in the following example, we associate the input ,(code "output_filename") to the prefix ,(code "-o"). Notice the parentheses around ,(code "-o output_filename").] (scheme-source "doc/prefix-arguments.scm"))) + (section :title [Unseparated prefix arguments] + :ident "section-unseparated-prefix-arguments" + (p [Some programs don't like it when you separate arguments from +their prefixes. You can specify this using the ,(code [#:separate?]) +flag.] + (scheme-source "doc/unseparated-prefix-arguments.scm") + [This is executed as ,(samp [gcc foo.c -ofoo]), rather than +as ,(samp [gcc foo.c -o foo]).])) (section :title [Array types] :ident "section-array-types" (p [ccwl supports array types using the following syntax.] @@ -388,6 +397,14 @@ workflow is an array of strings that is scattered over the ,(code [print]) step. Each run of the ,(code [print]) step gets an element of ,(code [other-messages]) as its ,(code [other-message]) argument.] (scheme-source "doc/scatter-gather.scm"))) + (section :title [Reuse workflows from other files] + :ident "section-reuse-workflows-from-other-files" + (p [It's sometimes useful to break up long ccwl workflows into +separate files. You can load a ccwl workflow from another file using +,(code "ccwl-load"). Here is an example that loads the ,(file +"checksum.scm") from the ,(ref :ident "section-tee" :text "tee") +section and reuses it in another workflow.] + (scheme-source "doc/ccwl-load.scm"))) (section :title [Reuse external CWL workflows] :ident "section-reuse-external-cwl-workflows" (p [Even though you may be a ccwl convert (hurrah!), others may diff --git a/doc/prefix-arguments.scm b/doc/prefix-arguments.scm index ec95aeb..bb54620 100644 --- a/doc/prefix-arguments.scm +++ b/doc/prefix-arguments.scm @@ -1,5 +1,2 @@ (command #:inputs (source #:type File) (output_filename #:type string) - #:run "gcc" source ("-o" output_filename) - #:outputs (executable - #:type File - #:binding ((glob . "$(inputs.output_filename)")))) + #:run "gcc" source ("-o" output_filename)) diff --git a/doc/unseparated-prefix-arguments.scm b/doc/unseparated-prefix-arguments.scm new file mode 100644 index 0000000..9e1e767 --- /dev/null +++ b/doc/unseparated-prefix-arguments.scm @@ -0,0 +1,2 @@ +(command #:inputs (source #:type File) (output_filename #:type string) + #:run "gcc" source ("-o" output_filename #:separate? #f)) diff --git a/manifest.scm b/manifest.scm new file mode 100644 index 0000000..6e46198 --- /dev/null +++ b/manifest.scm @@ -0,0 +1,19 @@ +(use-modules ((gnu packages fonts) #:select (font-charter font-fira-code)) + ((gnu packages guile-xyz) #:select (guile-ares-rs)) + ((gnu packages task-management) #:select (git-bug)) + ((ccwl-package) #:select (ccwl)) + (srfi srfi-1)) + +(define (manifest-cons* . args) + "ARGS is of the form (PACKAGES ... ONTO-MANIFEST). Return a manifest +with PACKAGES and all packages in ONTO-MANIFEST." + (let ((packages (drop-right args 1)) + (onto-manifest (last args))) + (manifest (append (map package->manifest-entry packages) + (manifest-entries onto-manifest))))) + +(manifest-cons* font-charter + font-fira-code + git-bug + guile-ares-rs + (package->development-manifest ccwl)) diff --git a/scripts/ccwl b/scripts/ccwl index 984d22a..c1f8073 100755 --- a/scripts/ccwl +++ b/scripts/ccwl @@ -3,7 +3,7 @@ exec guile --no-auto-compile -e main -s "$0" "$@" !# ;;; ccwl --- Concise Common Workflow Language -;;; Copyright © 2021–2024 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2021–2026 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of ccwl. ;;; @@ -26,8 +26,8 @@ exec guile --no-auto-compile -e main -s "$0" "$@" ;;; Code: -(use-modules (rnrs conditions) - (rnrs exceptions) +(use-modules (rnrs exceptions) + (srfi srfi-26) (srfi srfi-28) (srfi srfi-37) (ice-9 match) @@ -36,100 +36,126 @@ exec guile --no-auto-compile -e main -s "$0" "$@" (ccwl conditions) (ccwl cwl) (ccwl graphviz) + (ccwl lang) (ccwl ui)) (define (invalid-option opt name arg result) (error "Invalid option" name)) -(define (invalid-operand arg result) - (error "Invalid argument" arg)) - (define %help-option - (option (list "help") #f #t + (option (list #\h "help") #f #f (lambda (opt name arg result) (acons 'help #t result)))) +(define %options + (list (option (list #\t "to") #t #f + (lambda (opt name arg result) + (let ((supported (list "cwl" "dot"))) + (unless (member arg supported) + (raise-exception + (formatted-message "Invalid target ~a argument ~s. Supported targets are ~a." + (if (char? name) + (string #\- name) + (string-append "--" name)) + arg + (string-join supported ", "))))) + (acons 'to (string->symbol arg) + result))) + (option (list #\o "output") #t #f + (lambda (opt name arg result) + (acons 'output-file arg result))) + %help-option)) + +(define %compile-error + (make-parameter #f)) + +(define (ccwl-compile source to port) + "Compile @var{source} file to @var{to} format writing output to +@var{port}. @var{to} is either @code{'cwl} or @code{'dot}." + ;; We don't need to compile ccwl files. Loading is sufficient for + ;; our purposes. Besides, compiling would fail since the workflow + ;; macro cannot access command definitions. + (set! %load-should-auto-compile #f) + (unless (file-exists? source) + (raise-exception + (formatted-message "File ~a does not exist" + source))) + (parameterize ((%compile-error #f)) + (let ((result + (with-exception-handler (lambda (c) + (if (ccwl-violation? c) + ;; Report syntax violations, + ;; and set the error state. + (begin + (report-ccwl-violation c) + (%compile-error #t)) + (raise-exception c))) + (cut ccwl-load source)))) + (if (%compile-error) + (exit #f) + (if (or (command? result) + (js-expression? result) + (workflow? result)) + ((case to + ((cwl) function->cwl) + ((dot) function->dot)) + result port) + (raise-exception + (formatted-message "Last expression in file ~a returns none of workflow, command or js-expression" + source))))))) + (define (main args) (with-exception-handler (lambda (condition) - ;; Catch uncaught exceptions, print their backtrace and - ;; request the user report an issue. Pass quit exceptions - ;; through since those may be raised by exceptions that have - ;; been handled. + ;; Catch uncaught exceptions, request the user report an + ;; issue, and re-raise the exception so the default exception + ;; handler can deal with it. Pass quit exceptions through + ;; since those may be raised by exceptions that have been + ;; handled. (cond ((formatted-message? condition) (report-formatted-message condition)) ((not (quit-exception? condition)) - (display-backtrace (make-stack #t) (current-error-port)) - (newline (current-error-port)) + (display "You have discovered a bug! ccwl crashed! :-( +Please report this to ccwl@systemreboot.net +Thank you!\n\n" + (current-error-port)) (write condition (current-error-port)) (newline (current-error-port)) - (display " -You have discovered a bug! ccwl crashed! :-( -Please report this to https://github.com/arunisaac/ccwl/issues -Thank you! -" - (current-error-port)))) + (newline (current-error-port)) + (raise-exception condition))) (exit #f)) (lambda () (match args ((program "compile" args ...) - (let* ((args (args-fold args - (list (option (list #\t "to") #t #f - (lambda (opt name arg result) - (let ((supported (list "cwl" "dot"))) - (unless (member arg supported) - (scm-error 'misc-error - #f - "Invalid target ~A argument ~S. Supported targets are ~A." - (list (if (char? name) - (string #\- name) - (string-append "--" name)) - arg - (string-join supported ", ")) - #f))) - (acons 'to arg result))) - %help-option) - invalid-option - (lambda (arg result) - (acons 'source-file arg result)) - '((to . "cwl"))))) + (let ((args (args-fold args + %options + invalid-option + (lambda (arg result) + (acons 'source-file arg result)) + '((to . cwl))))) (when (or (assq 'help args) (not (assq-ref args 'source-file))) (display (format "Usage: ~a compile [OPTIONS] SOURCE-FILE Compile SOURCE-FILE. + -o, --output=FILE write compiled output to file -t, --to=TARGET compile SOURCE-FILE to TARGET language; Supported targets are cwl (default) and dot. - + --help display this help and exit " program) (current-error-port)) (exit (assq 'help args))) - ;; We don't need to compile ccwl files. Loading is sufficient - ;; for our purposes. Besides, compiling would fail since the - ;; workflow macro cannot access command definitions. - (set! %load-should-auto-compile #f) - (let ((to (assq-ref args 'to))) - ((cond - ((string=? to "cwl") function->cwl) - ((string=? to "dot") function->dot)) - (guard (exception - ;; Handle syntax violation exceptions by reporting - ;; them and exiting. - ((ccwl-violation? exception) - (report-ccwl-violation exception) - (exit #f))) - (let ((result (load (canonicalize-path (assq-ref args 'source-file)) - read-syntax))) - (if (or (command? result) - (js-expression? result) - (workflow? result)) - result - (raise-exception - (condition (formatted-message "Last expression in file ~a returns none of workflow, command or js-expression" - (assq-ref args 'source-file))))))) - (current-output-port))))) + (if (assq-ref args 'output-file) + (call-with-output-file (assq-ref args 'output-file) + (cut ccwl-compile + (assq-ref args 'source-file) + (assq-ref args 'to) + <>)) + (ccwl-compile (assq-ref args 'source-file) + (assq-ref args 'to) + (current-output-port))))) ((program args ...) (let ((args (args-fold args (list %help-option) diff --git a/test-utils/utils.scm b/test-utils/utils.scm new file mode 100644 index 0000000..9a8897c --- /dev/null +++ b/test-utils/utils.scm @@ -0,0 +1,29 @@ +;;; ccwl --- Concise Common Workflow Language +;;; Copyright © 2026 Arun Isaac <arunisaac@systemreboot.net> +;;; +;;; This file is part of ccwl. +;;; +;;; ccwl is free software: you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation, either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; ccwl is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with ccwl. If not, see <https://www.gnu.org/licenses/>. + +(define-module (test-utils utils) + #:use-module (rnrs exceptions) + #:use-module (srfi srfi-64) + #:export (test-condition)) + +(define-syntax-rule (test-condition test-name condition-predicate test-expression) + (test-assert test-name + (guard (condition + (else (condition-predicate condition))) + (begin test-expression + #f)))) diff --git a/tests/ccwl.scm b/tests/ccwl.scm index 2d755ad..b2da5cd 100644 --- a/tests/ccwl.scm +++ b/tests/ccwl.scm @@ -1,5 +1,5 @@ ;;; ccwl --- Concise Common Workflow Language -;;; Copyright © 2021–2024 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2021–2026 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of ccwl. ;;; @@ -16,10 +16,11 @@ ;;; You should have received a copy of the GNU General Public License ;;; along with ccwl. If not, see <https://www.gnu.org/licenses/>. -(use-modules (rnrs exceptions) - (srfi srfi-1) +(use-modules (srfi srfi-1) (srfi srfi-64) (srfi srfi-71) + (ice-9 match) + (test-utils utils) (ccwl ccwl) (ccwl conditions)) @@ -45,13 +46,6 @@ ((@@ (ccwl ccwl) construct-type-syntax) #'type-spec))))) -(define-syntax-rule (test-condition test-name condition-predicate test-expression) - (test-assert test-name - (guard (condition - (else (condition-predicate condition))) - (begin test-expression - #f)))) - (define (ccwl-violation-with-message? message) (lambda (condition) (and (ccwl-violation? condition) @@ -60,23 +54,23 @@ (test-begin "ccwl") -(test-assert "stdin input should not have inputBinding" - (not (assoc-ref - (assoc-ref - (assoc-ref - ((@@ (ccwl cwl) command->cwl-scm) - (command #:inputs (file #:type File) - #:run "wc" "-c" - #:stdin file)) - 'inputs) - 'file) - 'inputBinding))) +(test-equal "stdin input should not have inputBinding" + '((file (type . File))) + (assoc-ref + ((@@ (ccwl cwl) command->cwl-scm) + (command #:inputs (file #:type File) + #:run "wc" "-c" + #:stdin file)) + 'inputs)) + +(test-assert "resolve CWL workflow relative to source file" + (cwl-workflow "echo.cwl")) (test-equal "read all forms of inputs and outputs from a CWL workflow" '(((spam string)) ((ham stdout) (eggs stdout))) - (let ((cwl-workflow (cwl-workflow "tests/input-output-parameters.cwl"))) + (let ((cwl-workflow (cwl-workflow "input-output-parameters.cwl"))) (list (map (lambda (input) (list (input-id input) (input-type input))) @@ -110,6 +104,11 @@ ccwl-violation? (output #'(message #:type int string))) +(test-condition "output, when passed a #:binding to an stdout type, must raise a &ccwl-violation condition" + ccwl-violation? + (output #'(message #:type stdout + #:binding ((glob . "output.txt"))))) + (test-condition "command, when passed positional arguments, must raise a &ccwl-violation condition" ccwl-violation? (macroexpand @@ -189,6 +188,16 @@ (workflow () (print-int #:number 42))) +;; TODO: Define this in the lexical scope of the test that requires +;; it. +(define print-workflow + (workflow ((message #:type string)) + (print #:message message))) + +(test-assert "allow literals as arguments to workflows" + (workflow () + (print-workflow #:message "foo"))) + (test-condition "step supplied with an unknown key must raise a &ccwl-violation condition" ccwl-violation? (macroexpand @@ -323,6 +332,13 @@ '(command #:inputs (messages #:type (array string)) #:run "echo" (array messages #:separator foo)))) +(test-condition "Non-boolean #:separate? flag must raise a &ccwl-violation condition" + (ccwl-violation-with-message? + "Invalid #:separate? flag ~a. #:separate? flag must be a boolean.") + (macroexpand + '(command #:inputs (arg #:type string) + #:run "foo" ("-o" arg #:separate? bar)))) + (test-assert "tee must deduplicate global workflow input keys" (let ((keys steps (collect-steps #'(tee (print #:message message) (identity)) diff --git a/tests/cwl.scm b/tests/cwl.scm index ba619ab..ae8fa6b 100644 --- a/tests/cwl.scm +++ b/tests/cwl.scm @@ -1,5 +1,5 @@ ;;; ccwl --- Concise Common Workflow Language -;;; Copyright © 2023 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2023, 2025 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of ccwl. ;;; @@ -18,6 +18,12 @@ (use-modules (srfi srfi-64)) +(define make-input + (@@ (ccwl ccwl) make-input)) + +(define input->cwl-scm + (@@ (ccwl cwl) input->cwl-scm)) + (define type->cwl (@@ (ccwl cwl) type->cwl)) @@ -41,4 +47,12 @@ (items . File)))) (type->cwl (make-array-type (make-array-type 'File)))) +(test-equal "Serialize #f defaults in input values" + '("foo" + (type . boolean) + (default . #f) + (label . "foo")) + (input->cwl-scm + (make-input "foo" 'boolean "foo" #f #f #f #t #f #f '()))) + (test-end "cwl") diff --git a/tests/echo.cwl b/tests/echo.cwl new file mode 100644 index 0000000..b957a59 --- /dev/null +++ b/tests/echo.cwl @@ -0,0 +1,7 @@ +cwlVersion: v1.2 +class: CommandLineTool +baseCommand: echo +inputs: + message: + type: string +outputs: {} diff --git a/tests/lang.scm b/tests/lang.scm new file mode 100644 index 0000000..5c506bc --- /dev/null +++ b/tests/lang.scm @@ -0,0 +1,30 @@ +;;; ccwl --- Concise Common Workflow Language +;;; Copyright © 2026 Arun Isaac <arunisaac@systemreboot.net> +;;; +;;; This file is part of ccwl. +;;; +;;; ccwl is free software: you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation, either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; ccwl is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with ccwl. If not, see <https://www.gnu.org/licenses/>. + +(use-modules (srfi srfi-64) + (test-utils utils) + (ccwl conditions) + (ccwl lang)) + +(test-begin "lang") + +(test-condition "loading non-existent source file must raise a &ccwl-violation" + ccwl-violation? + (ccwl-load "/non-existent/file.scm")) + +(test-end "lang") diff --git a/tests/ui.scm b/tests/ui.scm index a5741c0..115a20e 100644 --- a/tests/ui.scm +++ b/tests/ui.scm @@ -1,5 +1,5 @@ ;;; ccwl --- Concise Common Workflow Language -;;; Copyright © 2023 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2023, 2025 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of ccwl. ;;; @@ -16,7 +16,8 @@ ;;; You should have received a copy of the GNU General Public License ;;; along with ccwl. If not, see <https://www.gnu.org/licenses/>. -(use-modules (srfi srfi-64) +(use-modules (srfi srfi-26) + (srfi srfi-64) (term ansi-color) (ccwl ui) (ccwl conditions)) diff --git a/tests/utils.scm b/tests/utils.scm index 50c3396..735bea8 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -1,5 +1,5 @@ ;;; ccwl --- Concise Common Workflow Language -;;; Copyright © 2021, 2022, 2023 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2021–2023, 2025–2026 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of ccwl. ;;; @@ -21,6 +21,7 @@ (srfi srfi-1) (srfi srfi-64) (srfi srfi-71) + (ice-9 filesystem) (ccwl conditions) (ccwl utils)) @@ -89,11 +90,13 @@ '(lambda** (#:key foo #:foo bar) foo)))) -(test-equal "Allow other keys in lambda**" +(test-equal "Allow other keys in lambda**, but raise an exception" 1 - ((lambda** (#:key foo #:allow-other-keys) - foo) - #:foo 1 #:bar 2)) + (with-exception-handler (const #t) + (lambda () + ((lambda** (#:key foo) + foo) + #:foo 1 #:bar 2)))) (test-assert "Unrecognized keyword argument passed to lambda** should raise an &unrecognized-keyword-assertion condition" (guard (exception @@ -138,14 +141,13 @@ ((syntax-lambda** (#:key* foo) foo))) -;; We cannot use test-equal to compare syntax objects, since -;; test-equal does not preserve the lexical contexts of the test -;; expressions. -(test-assert "Allow other keys in syntax-lambda**" - (equal? #'1 - ((syntax-lambda** (#:key foo #:allow-other-keys) - foo) - #'#:foo #'1 #'#:bar #'2))) +(test-equal "Allow other keys in syntax-lambda**, but raise an exception" + 1 + (syntax->datum (with-exception-handler (const #t) + (lambda () + ((syntax-lambda** (#:key foo) + foo) + #'#:foo #'1 #'#:bar #'2))))) (test-assert "syntax-lambda** should raise an &unrecognized-keyword-assertion on unrecognized keywords in arguments" (guard (exception @@ -194,7 +196,17 @@ (let ((squares cubes (mapn (lambda (n) (values (expt n 2) (expt n 3))) - (iota 5)))) + (iota 5) + 2))) + (list squares cubes))) + +(test-equal "mapn on an empty list" + '(() ()) + (let ((squares cubes (mapn (lambda (n) + (values (expt n 2) + (expt n 3))) + '() + 2))) (list squares cubes))) (test-equal "foldn" @@ -211,4 +223,17 @@ '((1 . 2) (3 . 4) (5 . 6)) (pairify (list 1 2 3 4 5 6 7))) +(test-equal "resolve file syntax relative path" + (expand-file-name "foo.scm" + (dirname (current-filename))) + (resolve-file-syntax "foo.scm" #'"foo.scm")) + +(test-equal "resolve file syntax absolute path" + "/foo/bar.scm" + (resolve-file-syntax "/foo/bar.scm" #'"/foo/bar.scm")) + +(test-equal "resolve file syntax relative to current directory" + (expand-file-name "foo.scm") + (resolve-file-syntax "foo.scm" (datum->syntax #f "foo.scm" #:source '()))) + (test-end "utils") diff --git a/tests/yaml.scm b/tests/yaml.scm index f9df12d..c475dd9 100644 --- a/tests/yaml.scm +++ b/tests/yaml.scm @@ -1,5 +1,5 @@ ;;; ccwl --- Concise Common Workflow Language -;;; Copyright © 2021, 2023 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2021, 2023, 2026 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of ccwl. ;;; @@ -41,6 +41,12 @@ bar: {} " (scm->yaml-string #("*foo" "*bar"))) +(test-equal "strings with whitespace characters other than space must be escaped" + "- \"foo\\nbar\" +- \"foo\\tbar\" +" + (scm->yaml-string #("foo\nbar" "foo\tbar"))) + (test-equal "single element vectors must be serialized on the same line" "[foo] " diff --git a/website/releases/ccwl-0.5.0.tar.lz b/website/releases/ccwl-0.5.0.tar.lz new file mode 100644 index 0000000..d8b622a --- /dev/null +++ b/website/releases/ccwl-0.5.0.tar.lz Binary files differdiff --git a/website/releases/ccwl-0.5.0.tar.lz.asc b/website/releases/ccwl-0.5.0.tar.lz.asc new file mode 100644 index 0000000..d99264d --- /dev/null +++ b/website/releases/ccwl-0.5.0.tar.lz.asc @@ -0,0 +1,11 @@ +-----BEGIN PGP SIGNATURE----- + +iQEzBAABCAAdFiEEf3MDQ/Lwnzx3v3nTLiXui2GAK7MFAmllmDoACgkQLiXui2GA +K7MseQgAnkLn1tTRRzv9q02vmnLBLhNf/BN1yHFJnbxzRRzezJK4n3eGGw0fWq8j +vlwlX+uWsGEPZ4Ru7jMfLRlunT4SnJYQTBgZy5rLYyFNRs6ltCaz6DL9JQbS0Hqo +5AY6MWPWSXim1YnKK/cAhIxcL1Lzq65ka5aaeqhTEi8L0/wgjWZHsMLG07dsejsm +dcPwyKCwjyWT7+ypyo61axfiuImlrrfNH0pwRNhhThIXLBCCPffdYkUnsakNg0aY +l3nRKUpbUWMXXMMDABthAFLG1ny6Aw346Irk03Nc/JYsODEiaYTO5+2fdLiipPpY +CiwR7ftRkqXdoR6BH2kwhUCmlgsmeA== +=BrLX +-----END PGP SIGNATURE----- |