commit e71857df5d31d93dc412db1a13ea6e99a3a70c4e
parent 5920708c4778915dbe5f116dee7a79564d397d93
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Tue, 14 Mar 2017 21:34:03 +0100
Partially fixed copy-attribute, debugging.
Diffstat:
5 files changed, 40 insertions(+), 26 deletions(-)
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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)
