suzanne.soy/subtemplate
1
0
Fork 0
Code Issues 2 Pull Requests Actions Packages Projects Releases Wiki Activity

Partially fixed copy-attribute, debugging.

Browse Source
This commit is contained in:
Georges Dupéron 2017-03-14 21:34:03 +01:00
parent 5920708c47
commit e71857df5d
5 changed files with 39 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
info.rkt
View File

@ -7,7 +7,8 @@
"srfi-lite-lib" "srfi-lite-lib"
"stxparse-info" "stxparse-info"
"alexis-util" "alexis-util"
"scope-operations")) "scope-operations"
"auto-syntax-e"))
(define build-deps '("scribble-lib" (define build-deps '("scribble-lib"
"racket-doc" "racket-doc"
"scribble-math")) "scribble-math"))

25
private/copy-attribute.rkt
View File

@ -6,11 +6,16 @@
(require stxparse-info/current-pvars (require stxparse-info/current-pvars
phc-toolkit/untyped phc-toolkit/untyped
stxparse-info/parse stxparse-info/parse
(for-syntax racket/contract (for-syntax "optcontract.rkt";racket/contract
racket/syntax racket/syntax
phc-toolkit/untyped phc-toolkit/untyped
racket/function 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 (begin-for-syntax
(define/contract (nest-map f last n) (define/contract (nest-map f last n)
@ -40,10 +45,6 @@
val) val)
#f))) #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 (define-syntax/parse (copy-raw-syntax-attribute name:id
attr-value:expr attr-value:expr
ellipsis-depth:nat ellipsis-depth:nat
@ -63,8 +64,16 @@
extract-non-syntax}}) extract-non-syntax}})
(syntax-e #'ellipsis-depth)) (syntax-e #'ellipsis-depth))
(if (syntax-e #'syntax?) (if (syntax-e #'syntax?)
#'(begin (with-syntax ([vtmp (generate-temporary #'name)]
(define/syntax-parse nested attr-value)) [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 #'(begin
(define-syntax-class extract-non-syntax (define-syntax-class extract-non-syntax
#:attributes (name) #:attributes (name)

4
private/template-subscripts.rkt
View File

@ -191,7 +191,7 @@
(copy-raw-syntax-attribute bound (copy-raw-syntax-attribute bound
(hash-ref #,lift-target 'token) (hash-ref #,lift-target 'token)
ellipsis-depth ellipsis-depth
#t) #f) ;; TODO: #t iff the original was #t
… …
#,(if get-attribute* #,(if get-attribute*
#'(list (attribute* bound ) …) #'(list (attribute* bound ) …)
@ -374,7 +374,7 @@
(copy-raw-syntax-attribute bound (copy-raw-syntax-attribute bound
temp-cached temp-cached
ellipsis-depth ellipsis-depth
#t)))) #f)))) ;; TODO: #t iff the original was #t
(define (check-derived-ellipsis-shape ellipsis-depth (define (check-derived-ellipsis-shape ellipsis-depth
temp-generated temp-generated

16
test/test-copy-attribute-template-problem.rkt
View File

@ -2,10 +2,14 @@
(require subtemplate/private/copy-attribute (require subtemplate/private/copy-attribute
stxparse-info/parse stxparse-info/parse
stxparse-info/parse/experimental/template stxparse-info/parse/experimental/template
phc-toolkit/untyped) phc-toolkit/untyped
rackunit)
(syntax->datum (check-not-exn
(syntax-parse #'([1 2 3] #:kw [4 5]) (λ ()
[({~and {~or #:kw (x …)}} …) (syntax-parse #'([1 2 3] #:kw [4 5])
(copy-raw-syntax-attribute y (attribute* x) 2 #t) [({~and {~or #:kw (x …)}} …)
(template [(?? (?@ y …) empty) …])])) ;; 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) …])])))

16
test/test-copy-attribute.rkt
View File

@ -62,7 +62,7 @@
(check-equal? (syntax->datum (check-equal? (syntax->datum
(syntax-parse #'([1 2 3] #:kw [4 5]) (syntax-parse #'([1 2 3] #:kw [4 5])
[({~and {~or #:kw (x …)}} …) [({~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) …)])])) (template [(?? (?@ y …) empty) … ((?? (y …) empty) …)])]))
'(1 2 3 empty 4 5 ((1 2 3) empty (4 5)))) '(1 2 3 empty 4 5 ((1 2 3) empty (4 5))))
@ -70,7 +70,7 @@
(check-equal? (syntax->datum (check-equal? (syntax->datum
(syntax-parse #'([1 2 3] #:kw [4 5]) (syntax-parse #'([1 2 3] #:kw [4 5])
[({~and {~or #:kw (x …)}} … y) [({~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) …)])])) (template [(?? (?@ y …) empty) … ((?? (y …) empty) …)])]))
'(1 2 3 empty ((1 2 3) empty))) '(1 2 3 empty ((1 2 3) empty)))
@ -110,7 +110,7 @@
(check-equal? (syntax->datum (check-equal? (syntax->datum
(syntax-parse #'([1 #:kw 3] [4 5]) (syntax-parse #'([1 #:kw 3] [4 5])
[(({~and {~or #:kw x}} …) …) [(({~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) …) …)])])) (template [(?@ (?? y empty) …) … (((?? y empty) …) …)])]))
'(1 empty 3 4 5 ((1 empty 3) (4 5)))) '(1 empty 3 4 5 ((1 empty 3) (4 5))))
@ -118,7 +118,7 @@
(check-equal? (syntax->datum (check-equal? (syntax->datum
(syntax-parse #'([1 #:kw 3] [4 5]) (syntax-parse #'([1 #:kw 3] [4 5])
[(({~and {~or #:kw x}} …) … y) [(({~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) …) …)])])) (template [(?@ (?? y empty) …) … (((?? y empty) …) …)])]))
'(1 empty 3 ((1 empty 3)))) '(1 empty 3 ((1 empty 3))))
@ -158,7 +158,7 @@
(check-equal? (syntax->datum (check-equal? (syntax->datum
(syntax-parse #'(1 #:kw 3) (syntax-parse #'(1 #:kw 3)
[({~and {~or #:kw x}} …) [({~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} …))])) (template ({?? y empty} …))]))
'(1 empty 3)) '(1 empty 3))
@ -166,7 +166,7 @@
(check-equal? (syntax->datum (check-equal? (syntax->datum
(syntax-parse #'(1 #:kw 3 4) (syntax-parse #'(1 #:kw 3 4)
[({~and {~or #:kw x}} … y) [({~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} …))])) (template ({?? y empty} …))]))
'(1 empty 3)) '(1 empty 3))
@ -266,7 +266,7 @@
(check-equal? (syntax->datum (check-equal? (syntax->datum
(syntax-parse #'(#:kw) (syntax-parse #'(#:kw)
[({~optional (x …)} #: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})])) (template {?? (y …) empty})]))
'empty) 'empty)
@ -297,7 +297,7 @@
(check-equal? (syntax->datum (check-equal? (syntax->datum
(syntax-parse #'(#:kw) (syntax-parse #'(#:kw)
[({~optional ((x …) …)} #: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})])) (template {?? ((y …) …) empty})]))
'empty) 'empty)