diff --git a/copy-attribute.rkt b/copy-attribute.rkt new file mode 100644 index 0000000..8cd43b3 --- /dev/null +++ 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 new file mode 100644 index 0000000..4e34a45 --- /dev/null +++ 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 new file mode 100644 index 0000000..8836f6c --- /dev/null +++ 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 index e8b1557..d8c9079 100644 --- 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 index af9183a..14a9e5b 100644 --- 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 index bb625d7..5539969 100644 --- 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 index 7c1e6f8..108aaba 100644 --- 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 new file mode 100644 index 0000000..524533b --- /dev/null +++ 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 new file mode 100644 index 0000000..ab75c59 --- /dev/null +++ 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