diff --git a/info.rkt b/info.rkt index 0b051cd..6358775 100644 --- a/info.rkt +++ b/info.rkt @@ -7,7 +7,8 @@ "srfi-lite-lib" "stxparse-info" "alexis-util" - "scope-operations")) + "scope-operations" + "auto-syntax-e")) (define build-deps '("scribble-lib" "racket-doc" "scribble-math")) diff --git a/private/copy-attribute.rkt b/private/copy-attribute.rkt index 4bfbd45..ebbf64f 100644 --- a/private/copy-attribute.rkt +++ b/private/copy-attribute.rkt @@ -6,11 +6,16 @@ (require stxparse-info/current-pvars phc-toolkit/untyped stxparse-info/parse - (for-syntax racket/contract + (for-syntax "optcontract.rkt";racket/contract racket/syntax phc-toolkit/untyped racket/function - stxparse-info/parse)) + stxparse-info/parse) + + + + (only-in stxparse-info/parse/private/residual make-attribute-mapping) + (for-syntax (only-in auto-syntax-e/utils make-auto-pvar))) (begin-for-syntax (define/contract (nest-map f last n) @@ -40,10 +45,6 @@ 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 @@ -63,8 +64,16 @@ extract-non-syntax}}) (syntax-e #'ellipsis-depth)) (if (syntax-e #'syntax?) - #'(begin - (define/syntax-parse nested attr-value)) + (with-syntax ([vtmp (generate-temporary #'name)] + [stmp (generate-temporary #'name)]) + #'(begin + (define vtmp attr-value);; TODO: if already an id, no need to copy it (unless the id is mutated) + (define-syntax stmp + (make-attribute-mapping (quote-syntax vtmp) + 'name 'ellipsis-depth 'syntax?)) + (define-syntax name + (make-auto-pvar 'ellipsis-depth (quote-syntax stmp))))) + ;; TODO ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ vvvvvvvvvvvvvvvvvvvvvvvvvv #'(begin (define-syntax-class extract-non-syntax #:attributes (name) diff --git a/private/template-subscripts.rkt b/private/template-subscripts.rkt index e31df30..8d59ed9 100644 --- a/private/template-subscripts.rkt +++ b/private/template-subscripts.rkt @@ -191,7 +191,7 @@ (copy-raw-syntax-attribute bound (hash-ref #,lift-target 'token) ellipsis-depth - #t) + #f) ;; TODO: #t iff the original was #t … #,(if get-attribute* #'(list (attribute* bound ) …) @@ -374,7 +374,7 @@ (copy-raw-syntax-attribute bound temp-cached ellipsis-depth - #t)))) + #f)))) ;; TODO: #t iff the original was #t (define (check-derived-ellipsis-shape ellipsis-depth temp-generated diff --git a/test/test-copy-attribute-template-problem.rkt b/test/test-copy-attribute-template-problem.rkt index 407733d..3a2b412 100644 --- a/test/test-copy-attribute-template-problem.rkt +++ b/test/test-copy-attribute-template-problem.rkt @@ -2,10 +2,14 @@ (require subtemplate/private/copy-attribute stxparse-info/parse stxparse-info/parse/experimental/template - phc-toolkit/untyped) + phc-toolkit/untyped + rackunit) -(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) …])])) \ No newline at end of file +(check-not-exn + (λ () + (syntax-parse #'([1 2 3] #:kw [4 5]) + [({~and {~or #:kw (x …)}} …) + ;; The syntax? argument must be #f, not #t, when there are some optional + ;; elements, otherwise an exception is raised. + (copy-raw-syntax-attribute y (attribute* x) 2 #f) + (template [(?? (?@ y …) empty) …])]))) \ No newline at end of file diff --git a/test/test-copy-attribute.rkt b/test/test-copy-attribute.rkt index c0356ed..140aa10 100644 --- a/test/test-copy-attribute.rkt +++ b/test/test-copy-attribute.rkt @@ -62,7 +62,7 @@ (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) + (copy-raw-syntax-attribute y (attribute* x) 2 #f); has ~or (template [(?? (?@ y …) empty) … ((?? (y …) empty) …)])])) '(1 2 3 empty 4 5 ((1 2 3) empty (4 5)))) @@ -70,7 +70,7 @@ (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) + (copy-raw-syntax-attribute y (attribute* x) 2 #f); has ~or (template [(?? (?@ y …) empty) … ((?? (y …) empty) …)])])) '(1 2 3 empty ((1 2 3) empty))) @@ -110,7 +110,7 @@ (check-equal? (syntax->datum (syntax-parse #'([1 #:kw 3] [4 5]) [(({~and {~or #:kw x}} …) …) - (copy-raw-syntax-attribute y (attribute* x) 2 #t) + (copy-raw-syntax-attribute y (attribute* x) 2 #f); has ~or (template [(?@ (?? y empty) …) … (((?? y empty) …) …)])])) '(1 empty 3 4 5 ((1 empty 3) (4 5)))) @@ -118,7 +118,7 @@ (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) + (copy-raw-syntax-attribute y (attribute* x) 2 #f); has ~or (template [(?@ (?? y empty) …) … (((?? y empty) …) …)])])) '(1 empty 3 ((1 empty 3)))) @@ -158,7 +158,7 @@ (check-equal? (syntax->datum (syntax-parse #'(1 #:kw 3) [({~and {~or #:kw x}} …) - (copy-raw-syntax-attribute y (attribute* x) 1 #t) + (copy-raw-syntax-attribute y (attribute* x) 1 #f); has ~or (template ({?? y empty} …))])) '(1 empty 3)) @@ -166,7 +166,7 @@ (check-equal? (syntax->datum (syntax-parse #'(1 #:kw 3 4) [({~and {~or #:kw x}} … y) - (copy-raw-syntax-attribute y (attribute* x) 1 #t) + (copy-raw-syntax-attribute y (attribute* x) 1 #f); has ~or (template ({?? y empty} …))])) '(1 empty 3)) @@ -266,7 +266,7 @@ (check-equal? (syntax->datum (syntax-parse #'(#:kw) [({~optional (x …)} #:kw) - (copy-raw-syntax-attribute y (attribute* x) 1 #t) + (copy-raw-syntax-attribute y (attribute* x) 1 #f); has ~opt (template {?? (y …) empty})])) 'empty) @@ -297,7 +297,7 @@ (check-equal? (syntax->datum (syntax-parse #'(#:kw) [({~optional ((x …) …)} #:kw) - (copy-raw-syntax-attribute y (attribute* x) 2 #t) + (copy-raw-syntax-attribute y (attribute* x) 2 #f); has ~opt (template {?? ((y …) …) empty})])) 'empty)