From 17a76711d1f9bdaad133c9364a9bfd2ef10b8f22 Mon Sep 17 00:00:00 2001
From: Arun Isaac
Date: Mon, 9 Oct 2023 20:28:31 +0100
Subject: ccwl: Allow literals as arguments.
* ccwl/ccwl.scm ()[set-input-default]: New setter.
* ccwl/ccwl.scm ()[set-command-inputs]: Add setter.
* ccwl/ccwl.scm (apply-partially): New function.
(collect-steps): Support literal strings as arguments.
* tests/ccwl.scm ("allow literal strings as arguments"): New test.
* .dir-locals.el (scheme-mode): Indent set-command-inputs and
set-input-default.
---
.dir-locals.el | 2 ++
ccwl/ccwl.scm | 85 +++++++++++++++++++++++++++++++++++++++++++---------------
tests/ccwl.scm | 4 +++
3 files changed, 69 insertions(+), 22 deletions(-)
diff --git a/.dir-locals.el b/.dir-locals.el
index 6b65dec..ce473a1 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -7,5 +7,7 @@
(indent-tabs-mode t))
(scheme-mode
(eval put 'lambda** 'scheme-indent-function 1)
+ (eval put 'set-command-inputs 'scheme-indent-function 1)
+ (eval put 'set-input-default 'scheme-indent-function 1)
(eval put 'syntax-lambda** 'scheme-indent-function 1)
(eval put 'workflow 'scheme-indent-function 1)))
diff --git a/ccwl/ccwl.scm b/ccwl/ccwl.scm
index 286fd7a..f3d5c36 100644
--- a/ccwl/ccwl.scm
+++ b/ccwl/ccwl.scm
@@ -81,7 +81,7 @@
(id input-id)
(type input-type)
(label input-label)
- (default input-default)
+ (default input-default set-input-default)
(position input-position set-input-position)
(prefix input-prefix set-input-prefix)
(other input-other))
@@ -188,7 +188,7 @@
(define-immutable-record-type
(make-command inputs outputs args stdin other)
command?
- (inputs command-inputs)
+ (inputs command-inputs set-command-inputs)
(outputs command-outputs)
(args command-args)
(stdin command-stdin)
@@ -407,6 +407,22 @@ object or a object."
;; 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
+an association list mapping keyword arguments to their values."
+ (set-command-inputs command
+ (map (lambda (input)
+ (set-input-default input
+ (or (any (match-lambda
+ ((arg . value)
+ (and (eq? (input-id input)
+ (keyword->symbol arg))
+ value)))
+ partial-arguments)
+ (input-default input))))
+ (command-inputs command))))
+
(define (function-object x)
"Return the ccwl function object (a or a
object) described by syntax X. If such a ccwl function is not defined,
@@ -468,7 +484,7 @@ represented by objects."
;; messages.
(let ((input-key-symbols (map key-name input-keys))
(function-object (function-object #'function))
- (step-id (syntax->datum #'step-id)))
+ (step-id-symbol (syntax->datum #'step-id)))
;; Test for undefined command.
(unless function-object
(raise-exception
@@ -493,7 +509,7 @@ represented by objects."
;; step.
(condition (ccwl-violation #'function)
(formatted-message "Step ~a missing required parameters ~a"
- step-id
+ step-id-symbol
(map symbol->keyword missing-parameters))))))
;; Test for unknown keys.
(for-each (match-lambda
@@ -506,33 +522,58 @@ represented by objects."
;; TODO: Do not report accepted keys
;; that have already been satisfied.
(formatted-message "Step ~a does not accept input key ~a. Accepted keys are ~a."
- step-id
+ step-id-symbol
(syntax->datum arg)
(map symbol->keyword
(function-input-keys function-object))))))
- (unless (memq (syntax->datum value)
- input-key-symbols)
+ ;; If value is neither a literal nor a known key,
+ ;; error out.
+ (when (and (symbol? value)
+ (not (memq (syntax->datum value)
+ input-key-symbols)))
(raise-exception
(condition (ccwl-violation value)
(formatted-message "Step ~a supplied with unknown key ~a. Known keys at this step are ~a."
- step-id
+ step-id-symbol
(syntax->datum value)
input-key-symbols))))))
(pairify #'(args ...)))
- (values (append (remove key-step input-keys)
- (map (lambda (output)
- (key (output-id output) step-id))
- (function-outputs function-object)))
- (list (make-step step-id
- #'function
- (map (match-lambda
- ((arg . value)
- (cons (keyword->symbol arg)
- (cwl-key-address
- (find (lambda (key)
- (eq? value (key-name key)))
- input-keys)))))
- (pairify (syntax->datum #'(args ...)))))))))
+ (let ((symbolic-arguments
+ literal-arguments
+ (partition (match-lambda
+ ((_ . value)
+ (symbol? value)))
+ (pairify (syntax->datum #'(args ...))))))
+ (match literal-arguments
+ ;; If there are no literal arguments, construct
+ ;; object.
+ (()
+ (values (append (remove key-step input-keys)
+ (map (lambda (output)
+ (key (output-id output) step-id-symbol))
+ (function-outputs function-object)))
+ (list (make-step step-id-symbol
+ #'function
+ (map (match-lambda
+ ((arg . value)
+ (cons (keyword->symbol arg)
+ (cwl-key-address
+ (find (lambda (key)
+ (eq? value (key-name key)))
+ input-keys)))))
+ (pairify (syntax->datum #'(args ...))))))))
+ ;; If literal values are provided as arguments, partially
+ ;; apply those literal values to the command and recurse.
+ (_
+ (collect-steps #`(((module-ref (resolve-module '(ccwl ccwl))
+ 'apply-partially)
+ function '#,literal-arguments)
+ (step-id)
+ #,@(append-map (match-lambda
+ ((arg . value)
+ (list arg value)))
+ symbolic-arguments))
+ input-keys))))))
;; ccwl functions with an implicit step identifier
((function args ...)
;; Ensure that steps with expression commands have identifiers.
diff --git a/tests/ccwl.scm b/tests/ccwl.scm
index 219e3f7..af76372 100644
--- a/tests/ccwl.scm
+++ b/tests/ccwl.scm
@@ -163,4 +163,8 @@
#:message message)))
#f)))
+(test-assert "allow literals as arguments"
+ (workflow ()
+ (print #:message "Hello")))
+
(test-end "ccwl")
--
cgit v1.2.3