aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--ccwl/ccwl.scm51
1 files changed, 29 insertions, 22 deletions
diff --git a/ccwl/ccwl.scm b/ccwl/ccwl.scm
index cdae1c5..b9ee81f 100644
--- a/ccwl/ccwl.scm
+++ b/ccwl/ccwl.scm
@@ -608,28 +608,35 @@ represented by <step> objects."
((tee expressions ...)
(append-mapn (cut collect-steps <> input-keys)
#'(expressions ...)))
- ;; rename keys
- ((rename mapping ...)
- (values (map (lambda (key)
- (or (any (match-lambda
- ((new . old)
- (unless (keyword? (syntax->datum new))
- (raise-exception
- (condition (ccwl-violation new)
- (formatted-message "Expected keyword (for example: #:foo, #:bar)"))))
- (unless (memq (syntax->datum old)
- (map key-name input-keys))
- (raise-exception
- (condition (ccwl-violation old)
- (formatted-message "Unknown key ~a. Known keys at this step are ~a."
- (syntax->datum old)
- (map key-name input-keys)))))
- (and (eq? (syntax->datum old) (key-name key))
- (set-key-name key (keyword->symbol (syntax->datum new))))))
- (pairify #'(mapping ...)))
- key))
- input-keys)
- (list)))
+ ;; rename keys (base case)
+ ((rename new-key old-key)
+ (begin
+ ;; Error out on non-keyword arguments.
+ (unless (keyword? (syntax->datum #'new-key))
+ (raise-exception
+ (condition (ccwl-violation #'new-key)
+ (formatted-message "Expected keyword (for example: #:foo, #:bar)"))))
+ ;; Ensure old key exists.
+ (unless (memq (syntax->datum #'old-key)
+ (map key-name input-keys))
+ (raise-exception
+ (condition (ccwl-violation #'old-key)
+ (formatted-message "Unknown key ~a. Known keys at this step are ~a."
+ (syntax->datum #'old-key)
+ (map key-name input-keys)))))
+ (values (map (lambda (key)
+ ;; Rename one key. Pass the rest through.
+ (or (and (eq? (syntax->datum #'old-key)
+ (key-name key))
+ (set-key-name key (keyword->symbol (syntax->datum #'new-key))))
+ key))
+ input-keys)
+ (list))))
+ ;; rename keys (recurse)
+ ((rename new-key old-key other-mappings ...)
+ (collect-steps #'(pipe (rename new-key old-key)
+ (rename other-mappings ...))
+ input-keys))
;; TODO: Support cross product scatter methods.
((scatter _ ...)
(collect-scatter-step x input-keys 'dotproduct))