commit 5ba9ab5130c7f4de082ce2a8361cf2586ecc1e2c
parent eedc88f8e20f6f0c7728cf19a130712c02ad76e2
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Sun, 29 Jan 2017 23:46:37 +0100
.
Diffstat:
9 files changed, 703 insertions(+), 61 deletions(-)
diff --git a/copy-attribute.rkt b/copy-attribute.rkt
@@ -0,0 +1,73 @@
+#lang racket
+
+(provide copy-raw-syntax-attribute
+ attribute-val/c)
+
+(require stxparse-info/current-pvars
+ phc-toolkit/untyped
+ stxparse-info/parse
+ (for-syntax racket/contract
+ racket/syntax
+ phc-toolkit/untyped
+ racket/function
+ stxparse-info/parse))
+
+(begin-for-syntax
+ (define/contract (nest-map f last n)
+ (-> (-> syntax? syntax?) syntax? exact-nonnegative-integer? syntax?)
+ (if (= n 0)
+ last
+ (f (nest-map f last (sub1 n))))))
+
+(define/contract (attribute-val/c depth [bottom-predicate any/c])
+ (->* {exact-nonnegative-integer?} {flat-contract?} flat-contract?)
+ (flat-named-contract
+ (build-compound-type-name 'attribute-val/c depth bottom-predicate)
+ (λ (l)
+ (if (= depth 0)
+ (or (false? l) (bottom-predicate l))
+ (or (false? l)
+ (and (list? l)
+ (andmap (attribute-val/c (sub1 depth)) l)))))))
+
+(struct wrapped (value))
+
+(define (attribute-wrap val depth)
+ (if (= depth 0)
+ (wrapped val)
+ (if val
+ (map (λ (v) (attribute-wrap v (sub1 depth)))
+ val)
+ #f)))
+
+;; manually creating the attribute with (make-attribute-mapping …)
+;; works, but the attribute behaves in a bogus way when put inside
+;; an (?@ yᵢ ...). I must be missing some step in the construction
+;; of the attribute
+(define-syntax/parse (copy-raw-syntax-attribute name:id
+ attr-value:expr
+ ellipsis-depth:nat
+ syntax?:boolean
+ props:expr)
+ ;; the ~and is important, to prevent the nested ~or from being treated as
+ ;; an ellipsis-head pattern.
+ #:with nested (nest-map (λ (pat) #`{~or #f ({~and #,pat} (... ...))})
+ (if (syntax-e #'syntax?)
+ #'{~or #f name}
+ ;; variable with empty name, so that the attribute
+ ;; gets exported without a prefix.
+ #`{~or #f {~var #,(datum->syntax #'name '||)
+ extract-non-syntax}})
+ (syntax-e #'ellipsis-depth))
+ (if (syntax-e #'syntax?)
+ #'(begin
+ (define/syntax-parse nested attr-value)
+ (define-pvars name))
+ #'(begin
+ (define-syntax-class extract-non-syntax
+ #:attributes (name)
+ (pattern v
+ #:attr name (wrapped-value (syntax-e #'v))))
+ (define/syntax-parse nested (attribute-wrap attr-value
+ ellipsis-depth))
+ (define-pvars name))))
diff --git a/ddd.rkt b/ddd.rkt
@@ -0,0 +1,212 @@
+#lang racket
+
+(provide ddd)
+
+(require stxparse-info/current-pvars
+ phc-toolkit/untyped
+ subtemplate/copy-attribute
+ (prefix-in - syntax/parse/private/residual)
+ (for-syntax "derived-valvar.rkt"
+ racket/contract
+ racket/syntax
+ phc-toolkit/untyped
+ racket/function
+ racket/struct
+ racket/list
+ syntax/id-set
+ racket/private/sc
+ scope-operations
+ racket/string))
+
+(define-for-syntax x-pvar-scope (make-syntax-introducer))
+(define-for-syntax x-pvar-present-marker (make-syntax-introducer))
+
+(begin-for-syntax
+ (define/contract (attribute-real-valvar attr)
+ (-> identifier? (or/c #f identifier?))
+ (define valvar1
+ (let ([slv (syntax-local-value attr (λ () #f))])
+ (if (syntax-pattern-variable? slv)
+ (let* ([valvar (syntax-mapping-valvar slv)]
+ [valvar-slv (syntax-local-value valvar (λ () #f))])
+ (if (-attribute-mapping? valvar-slv)
+ (-attribute-mapping-var valvar-slv)
+ valvar))
+ (raise-syntax-error
+ 'attribute*
+ "not bound as an attribute or pattern variable"
+ attr))))
+ ;; Try to extract the actual variable from a subtemplate derived valvar.
+ (define valvar2
+ (let ([valvar1-slv (syntax-local-value valvar1 (λ () #f))])
+ (if (derived-valvar? valvar1-slv)
+ (derived-valvar-valvar valvar1-slv)
+ valvar1)))
+ (if (syntax-local-value valvar2 (λ () #f)) ;; is it a macro-ish thing?
+ (begin
+ (log-warning
+ (string-append "Could not extract the plain variable corresponding to"
+ " the pattern variable or attribute ~a"
+ (syntax-e attr)))
+ #f)
+ valvar2)))
+
+;; free-identifier=? seems to stop working on the valvars once we are outside of
+;; the local-expand containing the let which introduced these valvars, therefore
+;; we find which pvars were present within that let.
+(define-syntax/case (detect-present-pvars (pvar …) body) ()
+ (define/with-syntax (pvar-real-valvar …)
+ (map syntax-local-introduce
+ (stx-map attribute-real-valvar #'(pvar …))))
+
+ (define/with-syntax expanded-body
+ (local-expand #`(let-values ()
+ (quote-syntax #,(stx-map x-pvar-scope #'(pvar-real-valvar …)) #:local)
+ body)
+ 'expression
+ '()))
+
+ ;; Separate the valvars marked with x-pvar-scope, so that we know which valvar
+ ;; to look for.
+ (define-values (marked-real-valvar expanded-ids)
+ (partition (λ (id) (all-scopes-in? x-pvar-scope id))
+ (extract-ids #'expanded-body)))
+ (define/with-syntax (real-valvar …)
+ (map (λ (x-vv) (x-pvar-scope x-vv 'remove))
+ marked-real-valvar))
+ (define expanded-ids-set (immutable-free-id-set expanded-ids))
+
+ ;; grep for valvars in expanded-body
+ (define/with-syntax present-variables
+ (for/vector ([x-vv (in-syntax #'(real-valvar …))]
+ [pv (in-syntax #'(pvar …))])
+ (if (free-id-set-member? expanded-ids-set x-vv)
+ #t
+ #f)))
+
+ #`(let-values ()
+ (quote-syntax #,(x-pvar-present-marker #'present-variables))
+ body))
+
+(define-syntax/case (ddd body) ()
+ (define/with-syntax (pvar …)
+ (map syntax-local-introduce
+ (filter (conjoin identifier?
+ (λ~> (syntax-local-value _ (thunk #f))
+ syntax-pattern-variable?)
+ attribute-real-valvar)
+ (current-pvars))))
+ (define-temp-ids "~aᵢ" (pvar …))
+ (define/with-syntax f
+ #`(#%plain-lambda (pvarᵢ …)
+ (shadow pvar pvarᵢ) …
+ (let-values ()
+ (detect-present-pvars (pvar …)
+ body))))
+
+ ;; extract all the variable ids present in f
+ (define/with-syntax expanded-f (local-expand #'f 'expression '()))
+
+ (begin
+ (define present-variables** (find-present-variables-vector #'expanded-f))
+ (define present-variables*
+ (and (vector? present-variables**)
+ (vector->list present-variables**)))
+ (unless ((listof (syntax/c boolean?)) present-variables*)
+ (raise-syntax-error 'ddd
+ (string-append
+ "internal error: could not extract the vector of"
+ " pattern variables present in the body.")
+ stx))
+ (define present-variables (map syntax-e present-variables*)))
+
+ (unless (ormap identity present-variables)
+ (raise-syntax-error 'ddd
+ "no pattern variables were found in the body"
+ stx))
+
+ (begin
+ (define present?+pvars
+ (for/list ([present? (in-list present-variables)]
+ [pv (in-syntax #'(pvar …))]
+ [pvᵢ (in-syntax #'(pvarᵢ …))])
+ (if present?
+ (match (attribute-info pv)
+ [(list* _ _valvar depth _)
+ (if (> depth 0)
+ (list #t pv pvᵢ #t depth)
+ (list #f pv pvᵢ #t depth))]) ;; TODO: detect shadowed bindings, if the pvar was already iterated on, raise an error (we went too deep).
+ (list #f pv pvᵢ #f))))
+ ;; Pvars which are iterated over
+ (define/with-syntax ((_ iterated-pvar iterated-pvarᵢ _ _) …)
+ (filter car present?+pvars))
+
+ (when (stx-null? #'(iterated-pvar …))
+ (no-pvar-to-iterate-error present?+pvars))
+
+ ;; If the pvar is iterated, use the iterated pvarᵢ
+ ;; otherwise use the original (attribute* pvar)
+ (define/with-syntax (filling-pvar …)
+ (map (match-λ [(list #t pv pvᵢ _ _) pvᵢ]
+ [(list #f pv pvᵢ _ _) #`(attribute* #,pv)])
+ present?+pvars)))
+
+ #'(map (λ (iterated-pvarᵢ …)
+ (expanded-f filling-pvar …))
+ (attribute* iterated-pvar)
+ …))
+
+(define-syntax/case (shadow pvar new-value) ()
+ (match (attribute-info #'pvar '(pvar attr))
+ [`(attr ,valvar ,depth ,_name ,syntax?)
+ #`(copy-raw-syntax-attribute pvar
+ new-value
+ #,(max 0 (sub1 depth))
+ #,syntax?)]
+ [`(pvar ,valvar ,depth)
+ #`(define-raw-syntax-mapping pvar
+ tmp-valvar
+ new-value
+ #,(sub1 depth))]))
+
+(define-for-syntax (extract-ids/tree e)
+ (cond
+ [(identifier? e) e]
+ [(syntax? e) (extract-ids/tree (syntax-e e))]
+ [(pair? e) (cons (extract-ids/tree (car e)) (extract-ids/tree (cdr e)))]
+ [(vector? e) (extract-ids/tree (vector->list e))]
+ [(hash? e) (extract-ids/tree (hash->list e))]
+ [(prefab-struct-key e) (extract-ids/tree (struct->list e))]
+ [else null]))
+
+(define-for-syntax (extract-ids e)
+ (flatten (extract-ids/tree e)))
+
+(define-for-syntax (find-present-variables-vector e)
+ (cond
+ [(and (syntax? e)
+ (vector? (syntax-e e))
+ (all-scopes-in? x-pvar-present-marker e))
+ (syntax-e e)]
+ [(syntax? e) (find-present-variables-vector (syntax-e e))]
+ [(pair? e) (or (find-present-variables-vector (car e))
+ (find-present-variables-vector (cdr e)))]
+ [(vector? e) (find-present-variables-vector (vector->list e))]
+ [(hash? e) (find-present-variables-vector (hash->list e))]
+ [(prefab-struct-key e) (find-present-variables-vector (struct->list e))]
+ [else #f]))
+
+(define-for-syntax (no-pvar-to-iterate-error present?+pvars)
+ (raise-syntax-error
+ 'ddd
+ (string-append
+ "no pattern variables with depth > 0 were found in the body\n"
+ " pattern varialbes present in the body:\n"
+ " "
+ (string-join
+ (map (λ (present?+pvar)
+ (format "~a at depth ~a"
+ (syntax-e (second present?+pvar))
+ (fifth present?+pvar)))
+ (filter fourth present?+pvars))
+ "\n "))))
+\ No newline at end of file
diff --git a/derived-valvar.rkt b/derived-valvar.rkt
@@ -0,0 +1,48 @@
+#lang racket/base
+
+(provide valvar+props
+ valvar+props-valvar
+ valvar+props-properties
+ pvar->valvar+props
+ pvar-property)
+
+(require racket/function
+ racket/contract
+ racket/private/sc
+ (for-template (prefix-in - stxparse-info/parse/private/residual)))
+
+;; Act like a syntax transformer, but which is recognizable via the
+;; derived-pattern-variable? predicate.
+(struct valvar+props (valvar properties)
+ #:property prop:procedure
+ (λ (self stx)
+ #`(#%expression #,(valvar+props-valvar self))))
+
+(define (pvar->valvar+props id)
+ (define mapping (syntax-local-value id (thunk #f)))
+ (and mapping ;; … defined as syntax
+ (syntax-pattern-variable? mapping) ; and is a syntax pattern variable
+ (let ()
+ (define mapping-slv
+ (syntax-local-value (syntax-mapping-valvar mapping) (thunk #f)))
+ ;; either a mapping → attribute → derived,
+ ;; or directly mapping → derived
+ (or (and (-attribute-mapping? mapping-slv) ;; is an attribute
+ (let ([attribute-slv (syntax-local-value
+ (-attribute-mapping-var mapping-slv)
+ (thunk #f))])
+ ;; and the pvar's valvar is a derived
+ (and (valvar+props? attribute-slv)
+ attribute-slv))
+ ;; or the pvar's valvar is derived
+ (and (valvar+props? mapping-slv)
+ mapping-slv))))))
+
+(define/contract (pvar-property id property)
+ (-> identifier? symbol? any/c)
+ (let ([valvar+props (valvar+props-properties id)])
+ (and valvar+props
+ (let ([properties (valvar+props-properties valvar+props)])
+ (hash? properties)
+ (immutable? properties)
+ (hash-ref properties property #f)))))
+\ No newline at end of file
diff --git a/info.rkt b/info.rkt
@@ -6,7 +6,8 @@
"phc-toolkit"
"srfi-lite-lib"
"stxparse-info"
- "alexis-util"))
+ "alexis-util"
+ "scope-operations"))
(define build-deps '("scribble-lib"
"racket-doc"))
(define scribblings '(("scribblings/subtemplate.scrbl" () (parsing-library))))
diff --git a/main.rkt b/main.rkt
@@ -12,7 +12,9 @@
(prefix-in dbg: stxparse-info/parse/private/runtime)
syntax/id-table
(subtract-in racket/syntax stxparse-info/case)
+ "copy-attribute.rkt"
(for-syntax "patch-arrows.rkt"
+ "derived-valvar.rkt"
racket/format
stxparse-info/parse
racket/private/sc
@@ -32,29 +34,6 @@
(define derived-valvar-cache (make-weak-hash))
(begin-for-syntax
- ;; Act like a syntax transformer, but which is recognizable via the
- ;; derived-pattern-variable? predicate.
- (struct derived-valvar (valvar)
- #:property prop:procedure
- (λ (self stx)
- #`(#%expression #,(derived-valvar-valvar self))))
-
- (define (id-is-derived-valvar? id)
- (define mapping (syntax-local-value id (thunk #f)))
- (and mapping ;; … defined as syntax
- (syntax-pattern-variable? mapping) ; and is a syntax pattern variable
- (let ()
- (define mapping-slv
- (syntax-local-value (syntax-mapping-valvar mapping) (thunk #f)))
- ;; either a mapping → attribute → derived,
- ;; or directly mapping → derived
- (or (and (-attribute-mapping? mapping-slv) ;; is an attribute
- (derived-valvar? ;; and the pvar's valvar is a derived
- (syntax-local-value (-attribute-mapping-var mapping-slv)
- (thunk #f))))
- ;; or the pvar's valvar is derived
- (derived-valvar? mapping-slv)))))
-
(define/contract (string-suffix a b)
(-> string? string? string?)
(define suffix-length (string-suffix-length a b))
@@ -100,12 +79,6 @@
#`(#,(nest-ellipses stx (sub1 n))
(… …))))
- (define/contract (nest-map f last n)
- (-> (-> syntax? syntax?) syntax? exact-nonnegative-integer? syntax?)
- (if (= n 0)
- last
- (f (nest-map f last (sub1 n)))))
-
(define/contract (find-subscript-binder bound)
(-> identifier?
(or/c #f (list/c identifier? ; bound
@@ -121,7 +94,9 @@
(define/with-syntax ([binder . unique-at-runtime-id] …)
(filter (compose (conjoin identifier?
- (negate id-is-derived-valvar?)
+ (λ (pv)
+ (not
+ (pvar-property pv 'subtemplate-derived)))
(λ~> (syntax-local-value _ (thunk #f))
syntax-pattern-variable?)
;; force call syntax-local-value to prevent
@@ -141,9 +116,9 @@
;; Or write it as:
#;(define/with-syntax ([binder . unique-at-runtime] …)
- (for/list ([binder (current-pvars)]
+ (for/list ([binder (current-pvars+unique)]
#:when (identifier? (car binder))
- #:unless (id-is-derived-pvar? (car binder))
+ #:unless (pvar-property (car binder) 'subtemplate-derived)
#:when (syntax-pattern-variable?
(syntax-local-value (car binder) (thunk #f)))
;; force call syntax-local-value to prevent ambiguous
@@ -183,17 +158,6 @@
#'(unique-at-runtime-id …)
(car depths))))))
-(define/contract (attribute-val/c depth [bottom-predicate any/c])
- (->* {exact-nonnegative-integer?} {flat-contract?} flat-contract?)
- (flat-named-contract
- (build-compound-type-name 'attribute-val/c depth bottom-predicate)
- (λ (l)
- (if (= depth 0)
- (or (false? l) (bottom-predicate l))
- (or (false? l)
- (and (list? l)
- (andmap (attribute-val/c (sub1 depth)) l)))))))
-
;; Checks that all the given attribute values have the same structure.
;;
;; ellipsis-count/c works with the value of pattern variables and of attributes
@@ -441,14 +405,6 @@
(define/with-syntax temp-cached (generate-temporary #'bound))
(define/with-syntax temp-generated (generate-temporary #'bound))
(define/with-syntax temp-id-table (generate-temporary #'bound))
- ;; works only for syntax patterns, luckily that's all we need since we
- ;; produce a tree of (possibly missing) identifiers.
- (define/with-syntax copy-attribute-pattern
- ;; the ~and is important, to prevent the nested ~or from being treated as
- ;; an ellipsis-head pattern.
- (nest-map (λ (pat) #`{~or #f ({~and #,pat} (... ...))})
- #'{~or #f {~var bound id}}
- (syntax-e #'ellipsis-depth)))
;; HERE: cache the define-temp-ids in the free-id-table, and make sure
;; that we retrieve the cached ones, so that two subtemplate within the same
;; syntax-case or syntax-parse clause use the same derived ids.
@@ -539,9 +495,4 @@
(quote-syntax bound)
(free-id-table-map temp-id-table (λ (k v) k))))
- ;; manually creating the attribute with (make-attribute-mapping …)
- ;; works, but the attribute behaves in a bogus way when put inside
- ;; an (?@ yᵢ ...). I must be missing some step in the construction
- ;; of the attribute
- (define/syntax-parse copy-attribute-pattern temp-cached)
- (define-pvars bound))))
+ (copy-raw-syntax-attribute bound temp-cached ellipsis-depth #t))))
diff --git a/override.rkt b/override.rkt
@@ -15,4 +15,5 @@
stxparse-info/parse
stxparse-info/parse/experimental/template
stxparse-info/case
- racket/syntax))
-\ No newline at end of file
+ racket/syntax)
+ (rename-out [... …]))
+\ No newline at end of file
diff --git a/scribblings/subtemplate.scrbl b/scribblings/subtemplate.scrbl
@@ -84,7 +84,7 @@ compile-time and run-time performance will not be as good as with
Despite the rather extensive test suite, there are probably a few bugs lurking,
please report them to @url{https://github.com/jsmaniac/subtemplate/issues}.
-@subsection{Omitted elements in attributes (via @racket[~optional]}
+@subsection{Omitted elements in attributes (via @racket[~optional])}
When some values are missing in the ellipses of a template variable, e.g. via
@racket[~optional], @racket[subtemplate] combines all the existing bound
diff --git a/test/test-copy-attribute.rkt b/test/test-copy-attribute.rkt
@@ -0,0 +1,323 @@
+#lang racket
+
+(require subtemplate/copy-attribute
+ stxparse-info/parse
+ stxparse-info/parse/experimental/template
+ phc-toolkit/untyped
+ rackunit)
+
+(define (to-datum x) (syntax->datum (datum->syntax #f x)))
+
+;; Depth 2, no missing values
+(begin
+ ;; with just x in the pattern
+ (check-equal? (syntax->datum
+ (syntax-parse #'([1 2 3] [4 5])
+ [((x …) …)
+ (copy-raw-syntax-attribute y (attribute* x) 2 #t)
+ (template [(?@ y …) … ((y …) …)])]))
+ '(1 2 3 4 5 ((1 2 3) (4 5))))
+
+ ;; shadowing the y in the pattern
+ (check-equal? (syntax->datum
+ (syntax-parse #'([1 2 3] [4 5])
+ [((x …) … y)
+ (copy-raw-syntax-attribute y (attribute* x) 2 #t)
+ (template [(?@ y …) … ((y …) …)])]))
+ '(1 2 3 ((1 2 3))))
+
+ ;; syntax? is #f (the leaves are still syntax though)
+ (check-equal? (to-datum
+ (syntax-parse #'([1 2 3] [4 5])
+ [((x …) …)
+ (copy-raw-syntax-attribute y (attribute* x) 2 #f)
+ (attribute* y)]))
+ '([1 2 3] [4 5]))
+
+ ;; same as above, check that we have syntax at the leaves
+ (check-match (syntax-parse #'([1 2 3] [4 5])
+ [((x …) …)
+ (copy-raw-syntax-attribute y (attribute* x) 2 #f)
+ (attribute* y)])
+ (list (list (? syntax?) ...) ...))
+
+ ;; syntax? is #f (the leaves are still syntax though), use it in a template
+ (check-equal? (to-datum
+ (syntax-parse #'([1 2 3] [4 5])
+ [((x …) …)
+ (copy-raw-syntax-attribute y (attribute* x) 2 #f)
+ (template [(?@ y …) … ((y …) …)])]))
+ '(1 2 3 4 5 ((1 2 3) (4 5))))
+
+ ;; syntax? is #f, the leaves are NOT syntax.
+ ;; Checks that (attribute* y) is not syntax either.
+ (check-equal? (let ()
+ (copy-raw-syntax-attribute y `((1 2 3) (4 5)) 2 #f)
+ (attribute* y))
+ '([1 2 3] [4 5])))
+
+;; Depth 2, missing values at depth 1
+(begin
+ ;; with just x in the pattern
+ (check-equal? (syntax->datum
+ (syntax-parse #'([1 2 3] #:kw [4 5])
+ [({~and {~or #:kw (x …)}} …)
+ (copy-raw-syntax-attribute y (attribute* x) 2 #t)
+ (template [(?? (?@ y …) empty) … ((?? (y …) empty) …)])]))
+ '(1 2 3 empty 4 5 ((1 2 3) empty (4 5))))
+
+ ;; shadowing the y in the pattern
+ (check-equal? (syntax->datum
+ (syntax-parse #'([1 2 3] #:kw [4 5])
+ [({~and {~or #:kw (x …)}} … y)
+ (copy-raw-syntax-attribute y (attribute* x) 2 #t)
+ (template [(?? (?@ y …) empty) … ((?? (y …) empty) …)])]))
+ '(1 2 3 empty ((1 2 3) empty)))
+
+ ;; syntax? is #f (the leaves are still syntax though)
+ (check-equal? (to-datum
+ (syntax-parse #'([1 2 3] #:kw [4 5])
+ [({~and {~or #:kw (x …)}} …)
+ (copy-raw-syntax-attribute y (attribute* x) 2 #f)
+ (attribute* y)]))
+ '([1 2 3] #f [4 5]))
+
+ ;; same as above, check that we have syntax at the leaves
+ (check-match (syntax-parse #'([1 2 3] #:kw [4 5])
+ [({~and {~or #:kw (x …)}} …)
+ (copy-raw-syntax-attribute y (attribute* x) 2 #f)
+ (attribute* y)])
+ (list (list (? syntax?) ...) #f (list (? syntax?) ...)))
+
+ ;; syntax? is #f (the leaves are still syntax though), use it in a template
+ (check-equal? (to-datum
+ (syntax-parse #'([1 2 3] #:kw [4 5])
+ [({~and {~or #:kw (x …)}} …)
+ (copy-raw-syntax-attribute y (attribute* x) 2 #f)
+ (template [(?? (?@ y …) empty) … ((?? (y …) empty) …)])]))
+ '(1 2 3 empty 4 5 ((1 2 3) empty (4 5))))
+
+ ;; syntax? is #f, the leaves are NOT syntax.
+ ;; Checks that (attribute* y) is not syntax either.
+ (check-equal? (let ()
+ (copy-raw-syntax-attribute y '((1 2 3) #f (4 5)) 2 #f)
+ (attribute* y))
+ '([1 2 3] #f [4 5])))
+
+;; Depth 2, missing values at depth 2
+(begin
+ ;; with just x in the pattern
+ (check-equal? (syntax->datum
+ (syntax-parse #'([1 #:kw 3] [4 5])
+ [(({~and {~or #:kw x}} …) …)
+ (copy-raw-syntax-attribute y (attribute* x) 2 #t)
+ (template [(?@ (?? y empty) …) … (((?? y empty) …) …)])]))
+ '(1 empty 3 4 5 ((1 empty 3) (4 5))))
+
+ ;; shadowing the y in the pattern
+ (check-equal? (syntax->datum
+ (syntax-parse #'([1 #:kw 3] [4 5])
+ [(({~and {~or #:kw x}} …) … y)
+ (copy-raw-syntax-attribute y (attribute* x) 2 #t)
+ (template [(?@ (?? y empty) …) … (((?? y empty) …) …)])]))
+ '(1 empty 3 ((1 empty 3))))
+
+ ;; syntax? is #f (the leaves are still syntax though)
+ (check-equal? (to-datum
+ (syntax-parse #'([1 #:kw 3] [4 5])
+ [(({~and {~or #:kw x}} …) …)
+ (copy-raw-syntax-attribute y (attribute* x) 2 #f)
+ (attribute* y)]))
+ '([1 #f 3] [4 5]))
+
+ ;; same as above, check that we have syntax at the leaves
+ (check-match (syntax-parse #'([1 #:kw 3] [4 5])
+ [(({~and {~or #:kw x}} …) …)
+ (copy-raw-syntax-attribute y (attribute* x) 2 #f)
+ (attribute* y)])
+ (list (list (or #f (? syntax?)) ...) ...))
+
+ ;; syntax? is #f (the leaves are still syntax though), use it in a template
+ (check-equal? (to-datum
+ (syntax-parse #'([1 #:kw 3] [4 5])
+ [(({~and {~or #:kw x}} …) …)
+ (copy-raw-syntax-attribute y (attribute* x) 2 #f)
+ (template [(?@ (?? y empty) …) … (((?? y empty) …) …)])]))
+ '(1 empty 3 4 5 ((1 empty 3) (4 5))))
+
+ ;; syntax? is #f, the leaves are NOT syntax.
+ ;; Checks that (attribute* y) is not syntax either.
+ (check-equal? (let ()
+ (copy-raw-syntax-attribute y '((1 #f 3) (4 5)) 2 #f)
+ (attribute* y))
+ '([1 #f 3] [4 5])))
+
+;; Depth 1, missing values at depth 1
+(begin
+ ;; with just x in the pattern
+ (check-equal? (syntax->datum
+ (syntax-parse #'(1 #:kw 3)
+ [({~and {~or #:kw x}} …)
+ (copy-raw-syntax-attribute y (attribute* x) 1 #t)
+ (template ({?? y empty} …))]))
+ '(1 empty 3))
+
+ ;; shadowing the y in the pattern
+ (check-equal? (syntax->datum
+ (syntax-parse #'(1 #:kw 3 4)
+ [({~and {~or #:kw x}} … y)
+ (copy-raw-syntax-attribute y (attribute* x) 1 #t)
+ (template ({?? y empty} …))]))
+ '(1 empty 3))
+
+ ;; syntax? is #f (the leaves are still syntax though)
+ (check-equal? (to-datum
+ (syntax-parse #'(1 #:kw 3)
+ [({~and {~or #:kw x}} …)
+ (copy-raw-syntax-attribute y (attribute* x) 1 #f)
+ (attribute* y)]))
+ '(1 #f 3))
+
+ ;; same as above, check that we have syntax at the leaves
+ (check-match (syntax-parse #'(1 #:kw 3)
+ [({~and {~or #:kw x}} …)
+ (copy-raw-syntax-attribute y (attribute* x) 1 #f)
+ (attribute* y)])
+ (list (or #f (? syntax?)) ...))
+
+ ;; syntax? is #f (the leaves are still syntax though), use it in a template
+ (check-equal? (to-datum
+ (syntax-parse #'(1 #:kw 3)
+ [({~and {~or #:kw x}} …)
+ (copy-raw-syntax-attribute y (attribute* x) 1 #f)
+ (template ({?? y empty} …))]))
+ '(1 empty 3))
+
+ ;; syntax? is #f, the leaves are NOT syntax.
+ ;; Checks that (attribute* y) is not syntax either.
+ (check-equal? (let ()
+ (copy-raw-syntax-attribute y '(1 #f 3) 1 #f)
+ (attribute* y))
+ '(1 #f 3))
+
+ ;; syntax? is #f, compound values
+ (check-equal? (let ()
+ (copy-raw-syntax-attribute y '((1 1 1) #f (3 (#t) #f)) 1 #f)
+ (attribute* y))
+ '((1 1 1) #f (3 (#t) #f))))
+
+;; Depth 1, no missing values
+(begin
+ ;; with just x in the pattern
+ (check-equal? (syntax->datum
+ (syntax-parse #'(1 2 3)
+ [(x …)
+ (copy-raw-syntax-attribute y (attribute* x) 1 #t)
+ (template ({?? y empty} …))]))
+ '(1 2 3))
+
+ ;; shadowing the y in the pattern
+ (check-equal? (syntax->datum
+ (syntax-parse #'(1 2 3 4)
+ [(x … y)
+ (copy-raw-syntax-attribute y (attribute* x) 1 #t)
+ (template ({?? y empty} …))]))
+ '(1 2 3))
+
+ ;; syntax? is #f (the leaves are still syntax though)
+ (check-equal? (to-datum
+ (syntax-parse #'(1 2 3)
+ [(x …)
+ (copy-raw-syntax-attribute y (attribute* x) 1 #f)
+ (attribute* y)]))
+ '(1 2 3))
+
+ ;; same as above, check that we have syntax at the leaves
+ (check-match (syntax-parse #'(1 2 3)
+ [(x …)
+ (copy-raw-syntax-attribute y (attribute* x) 1 #f)
+ (attribute* y)])
+ (list (? syntax?) ...))
+
+ ;; syntax? is #f (the leaves are still syntax though), use it in a template
+ (check-equal? (to-datum
+ (syntax-parse #'(1 2 3)
+ [(x …)
+ (copy-raw-syntax-attribute y (attribute* x) 1 #f)
+ (template ({?? y empty} …))]))
+ '(1 2 3))
+
+ ;; syntax? is #f, the leaves are NOT syntax.
+ ;; Checks that (attribute* y) is not syntax either.
+ (check-equal? (let ()
+ (copy-raw-syntax-attribute y '(1 2 3) 1 #f)
+ (attribute* y))
+ '(1 2 3))
+
+ ;; syntax? is #f, compound values
+ (check-equal? (let ()
+ (copy-raw-syntax-attribute y '((1 1 1) 2 (3 (#t) #f)) 1 #f)
+ (attribute* y))
+ '((1 1 1) 2 (3 (#t) #f))))
+
+;; Depth 1, missing value at depth 0
+(begin
+ ;; with just x in the pattern
+ (check-equal? (syntax->datum
+ (syntax-parse #'(#:kw)
+ [({~optional (x …)} #:kw)
+ (copy-raw-syntax-attribute y (attribute* x) 1 #t)
+ (template {?? (y …) empty})]))
+ 'empty)
+
+ ;; syntax? is #f, use it in a template
+ (check-equal? (to-datum
+ (syntax-parse #'(#:kw)
+ [({~optional (x …)} #:kw)
+ (copy-raw-syntax-attribute y (attribute* x) 1 #f)
+ (template {?? (y …) empty})]))
+ 'empty)
+
+ ;; syntax? is #f, check with a raw attribute explicitly
+ (check-equal? (let ()
+ (copy-raw-syntax-attribute y #f 1 #f)
+ (attribute* y))
+ #f)
+
+ ;; syntax? is #f, check (in a template) with a raw attribute explicitly
+ (check-equal? (syntax->datum
+ (let ()
+ (copy-raw-syntax-attribute y #f 1 #f)
+ (template {?? (y …) empty})))
+ 'empty))
+
+;; Depth 2, missing value at depth 0
+(begin
+ ;; with just x in the pattern
+ (check-equal? (syntax->datum
+ (syntax-parse #'(#:kw)
+ [({~optional ((x …) …)} #:kw)
+ (copy-raw-syntax-attribute y (attribute* x) 2 #t)
+ (template {?? ((y …) …) empty})]))
+ 'empty)
+
+ ;; syntax? is #f, use it in a template
+ (check-equal? (to-datum
+ (syntax-parse #'(#:kw)
+ [({~optional ((x …) …)} #:kw)
+ (copy-raw-syntax-attribute y (attribute* x) 2 #f)
+ (template {?? ((y …) …) empty})]))
+ 'empty)
+
+ ;; syntax? is #f, check with a raw attribute explicitly
+ (check-equal? (let ()
+ (copy-raw-syntax-attribute y #f 2 #f)
+ (attribute* y))
+ #f)
+
+ ;; syntax? is #f, check (in a template) with a raw attribute explicitly
+ (check-equal? (syntax->datum
+ (let ()
+ (copy-raw-syntax-attribute y #f 2 #f)
+ (template {?? ((y …) …) empty})))
+ 'empty))
diff --git a/test/test-ddd.rkt b/test/test-ddd.rkt
@@ -0,0 +1,30 @@
+#lang racket
+(require subtemplate/ddd
+ stxparse-info/case
+ stxparse-info/parse
+ (only-in racket/base [... …])
+ rackunit
+ syntax/macro-testing)
+
+(check-equal? (syntax-case #'(1 2 3) ()
+ [(x …)
+ (ddd (+ (syntax-e #'x) 3))])
+ '(4 5 6))
+
+(check-equal? (syntax-parse #'(1 2 3)
+ [(x …)
+ (ddd (+ (syntax-e #'x) 3))])
+ '(4 5 6))
+
+(check-exn
+ #rx"no pattern variables with depth > 0 were found in the body"
+ (λ ()
+ (convert-compile-time-error
+ (syntax-parse #'(1 2 3)
+ [(x y z)
+ (ddd (+ (syntax-e #'x) 3))]))))
+
+(check-equal? (syntax-parse #'(1 2 3 4)
+ [(x … y)
+ (ddd (+ (syntax-e #'x) (syntax-e #'y)))])
+ '(5 6 7))
+\ No newline at end of file
