This commit is contained in:
Georges Dupéron 2017-01-29 23:46:37 +01:00
parent eedc88f8e2
commit 5ba9ab5130
9 changed files with 699 additions and 60 deletions

73
copy-attribute.rkt Normal file
View File

@ -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))))

212
ddd.rkt Normal file
View File

@ -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 "))))

48
derived-valvar.rkt Normal file
View File

@ -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)))))

View File

@ -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))))

View File

@ -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))))

View File

@ -15,4 +15,5 @@
stxparse-info/parse
stxparse-info/parse/experimental/template
stxparse-info/case
racket/syntax))
racket/syntax)
(rename-out [... ]))

View File

@ -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

View File

@ -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))

30
test/test-ddd.rkt Normal file
View File

@ -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))