commit 5580d9ee2cf2ac131301648f8363f58cf3dd74ad
parent a46326c300ce26a381e875dc58b1dbccc9e5ef8f
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Wed, 1 Feb 2017 07:40:52 +0100
Propper handling of omitted elements
Diffstat:
4 files changed, 74 insertions(+), 47 deletions(-)
diff --git a/copy-attribute.rkt b/copy-attribute.rkt
@@ -53,9 +53,13 @@
#:with nested (nest-map (λ (pat) #`{~or #f ({~and #,pat} (... ...))})
(if (syntax-e #'syntax?)
#'{~or #f name}
- ;; variable with empty name, so that the attribute
+ ;; Variable with empty name, so that the attribute
;; gets exported without a prefix.
- #`{~or #f {~var #,(datum->syntax #'name '||)
+ ;; Take care to keep the original srcloc,
+ ;; otherwise error messages lack the proper srcloc
+ #`{~or #f {~var #,(datum->syntax #'name
+ '||
+ #'name)
extract-non-syntax}})
(syntax-e #'ellipsis-depth))
(if (syntax-e #'syntax?)
diff --git a/ddd.rkt b/ddd.rkt
@@ -81,15 +81,22 @@
(quote-syntax #,(x-pvar-present-marker #'present-variables))
body))
-(define (map#f* f l*)
- (cond [(andmap (λ (l) (eq? l #f)) l*)
- '(#f)]
- [(andmap (or/c null? #f) l*)
- '()]
- [else (let ([cars (map (λ (l) (if l (car l) #f)) l*)]
- [cdrs (map (λ (l) (if l (cdr l) #f)) l*)])
- (cons (apply f cars)
- (map#f* f cdrs)))]))
+(define (=* . vs)
+ (if (< (length vs) 2)
+ #t
+ (apply = vs)))
+
+(define (map#f* f attr-ids l*)
+ (for ([l (in-list l*)]
+ [attr-id (in-list attr-ids)])
+ (when (eq? l #f)
+ (raise-syntax-error (syntax-e attr-id)
+ "attribute contains an omitted element"
+ attr-id)))
+ (unless (apply =* (map length l*))
+ (raise-syntax-error 'ddd
+ "incompatible ellipis counts for template"))
+ (apply map f l*))
(define-syntax/case (ddd body) ()
(define/with-syntax (pvar …)
@@ -159,9 +166,11 @@
[(list #f pv pvᵢ #t _) #`(attribute* #,pv)]
[(list #f pv pvᵢ #f _) #'#f])
present?+pvars)))
-
+
#'(map#f* (λ (iterated-pvarᵢ …)
(expanded-f filling-pvar …))
+ (list (quote-syntax iterated-pvar)
+ …)
(list (attribute* iterated-pvar)
…)))
diff --git a/test/test-ddd-forms.rkt b/test/test-ddd-forms.rkt
@@ -176,13 +176,13 @@
;; TODO: expr … inside begin and let
(check-equal? (syntax-case #'((1 2 3) (4 5)) ()
- [((x …) …)
- (let ()
- (list (length (syntax->list #'(x …)))
- (+ (syntax-e #'x) 3) …)
- …)])
- '([3 4 5 6]
- [2 7 8]))
+ [((x …) …)
+ (let ()
+ (list (length (syntax->list #'(x …)))
+ (+ (syntax-e #'x) 3) …)
+ …)])
+ '([3 4 5 6]
+ [2 7 8]))
(check-equal? (syntax-parse #'([1 2 3] [4 5 6])
[([x …] …)
@@ -212,16 +212,16 @@
;; Implicit apply with (+ y … …)
(check-equal? (syntax-parse #'([1 2 3] [4 5 6])
- [([x …] …)
- (define/with-syntax y (+ x 10)) … …
- (+ y … …)])
- 81)
+ [([x …] …)
+ (define/with-syntax y (+ x 10)) … …
+ (+ y … …)])
+ 81)
;; Implicit apply with (+ (* x 2) … …)
(check-equal? (syntax-parse #'([1 2 3] [4 5 6])
- [([x …] …)
- (+ (* x 2) … …)])
- 42)
+ [([x …] …)
+ (+ (* x 2) … …)])
+ 42)
;; TODO: (define ) … … should register the variable with current-pvars.
#;(syntax-parse #'([1 2 3] [4 5 6])
@@ -230,16 +230,16 @@
y … …])
+;; omitted element in the tree = not ok under ellipses
+(check-exn
+ #rx"attribute contains an omitted element"
+ (λ ()
+ (syntax-parse #'([1 2 3] #:kw [4 5 6])
+ [({~and {~or [x …] #:kw}} …)
+ ((x …) …)])))
-#lang racket
-
-(require subtemplate/ddd-forms
- stxparse-info/case
- stxparse-info/parse
- rackunit
- syntax/macro-testing
- phc-toolkit/untyped)
-
-(syntax-parse #'([1 2 3] #:kw [4 5 6])
- [({~and {~or [x …] #:kw}} …)
- ((x …) …)])
-\ No newline at end of file
+;; omitted element in the tree = ok as auto-syntax-e
+(check-equal? (syntax-parse #'([1 2 3] #:kw [4 5 6])
+ [({~and {~or [x …] #:kw}} …)
+ (x …)])
+ '((1 2 3) #f (4 5 6)))
+\ No newline at end of file
diff --git a/test/test-ddd.rkt b/test/test-ddd.rkt
@@ -25,12 +25,12 @@
'(4 5 6))
(check-equal? (syntax-case #'(((1 2) (3)) ((4 5 6))) ()
- [(((x …) …) …)
- (ddd (list (length (syntax->list #'((x …) …)))
- (length (syntax->list #'(x … …)))
- (ddd (ddd (- (syntax-e #'x))))))])
- '([2 3 ((-1 -2) (-3))]
- [1 3 ((-4 -5 -6))]))
+ [(((x …) …) …)
+ (ddd (list (length (syntax->list #'((x …) …)))
+ (length (syntax->list #'(x … …)))
+ (ddd (ddd (- (syntax-e #'x))))))])
+ '([2 3 ((-1 -2) (-3))]
+ [1 3 ((-4 -5 -6))]))
(check-equal? (syntax-case #'([1 2 3] [a]) ()
[([x …] [y …])
@@ -71,4 +71,19 @@
(ddd (list (length (syntax->list #'(x …)))
(ddd (+ (syntax-e #'x) 3))))])
'([3 (4 5 6)]
- [2 (7 8)]))
-\ No newline at end of file
+ [2 (7 8)]))
+
+
+;; omitted element at the leaves = ok (should it be ok?)
+(check-equal? (syntax-parse #'(1 #f 3)
+ [({~and {~or x:nat #f}} …)
+ (ddd x)])
+ '(1 #f 3))
+
+;; omitted element in the tree = not ok
+(check-exn
+ #rx"attribute contains an omitted element"
+ (λ ()
+ (syntax-parse #'((1 1) #f (1 2 1 1))
+ [({~and {~or (x:nat …) #f}} …)
+ (ddd (ddd x))])))
