.
This commit is contained in:
parent
eedc88f8e2
commit
5ba9ab5130
73
copy-attribute.rkt
Normal file
73
copy-attribute.rkt
Normal 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
212
ddd.rkt
Normal 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
48
derived-valvar.rkt
Normal 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)))))
|
3
info.rkt
3
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))))
|
||||
|
|
65
main.rkt
65
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))))
|
||||
|
|
|
@ -15,4 +15,5 @@
|
|||
stxparse-info/parse
|
||||
stxparse-info/parse/experimental/template
|
||||
stxparse-info/case
|
||||
racket/syntax))
|
||||
racket/syntax)
|
||||
(rename-out [... …]))
|
|
@ -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
|
||||
|
|
323
test/test-copy-attribute.rkt
Normal file
323
test/test-copy-attribute.rkt
Normal 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
30
test/test-ddd.rkt
Normal 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))
|
Loading…
Reference in New Issue
Block a user