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"
"stxparse-info"
"alexis-util"
"scope-operations"))
"scope-operations"
"auto-syntax-e"))
(define build-deps '("scribble-lib"
"racket-doc"
"scribble-math"))

25
private/copy-attribute.rkt
View File

@ -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)

4
private/template-subscripts.rkt
View File

@ -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

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

@ -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) …])]))
(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) …])])))

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

@ -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)