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

Fixed bug with ellipses and omitted values for (define/with-syntax foo e) …

Browse Source
This commit is contained in:
Georges Dupéron 2017-05-05 19:51:35 +02:00
parent 925de55a92
commit 8bf9e48c02
8 changed files with 288 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
info.rkt
View File

@ -14,5 +14,5 @@
"scribble-math"))
(define scribblings '(("scribblings/subtemplate.scrbl" () (parsing-library))))
(define pkg-desc "Various enhancements on syntax templates")
(define version "1.1")
(define version "1.2")
(define pkg-authors '("Georges Dupéron"))

41
private/ddd-forms.rkt
View File

@ -20,10 +20,20 @@
stxparse-info/case
stxparse-info/parse
phc-toolkit/untyped
subtemplate/private/copy-attribute
(for-meta -2 subtemplate/private/syntax-case-as-syntax-parse)
(for-meta -1 subtemplate/private/syntax-case-as-syntax-parse)
(for-meta 0 subtemplate/private/syntax-case-as-syntax-parse)
(for-meta 1 subtemplate/private/syntax-case-as-syntax-parse)
(for-meta 2 subtemplate/private/syntax-case-as-syntax-parse)
(for-meta 3 subtemplate/private/syntax-case-as-syntax-parse)
(prefix-in - (only-in racket/base
begin let lambda define))
(prefix-in - (only-in stxparse-info/case
define/with-syntax))
(prefix-in - (only-in stxparse-info/parse
define/syntax-parse
syntax-parse))
(for-syntax racket/base
racket/list
stxparse-info/parse
@ -34,20 +44,24 @@
(for-meta 2 stxparse-info/parse))
(begin-for-syntax
(define (-nest* before after -v -ooo* [depth 0])
(define (-nest* wrapper -v -ooo* [depth 0])
(if (stx-null? -ooo*)
-v
(-nest* before
after
#`(#,@(syntax->list before) #,-v . #,after)
(-nest* wrapper
(wrapper -v)
(stx-cdr -ooo*)
(add1 depth))))
(define-syntax nest*
(syntax-parser
[(self (before … {~datum %} . after) v ooo*)
(with-syntax ([s (datum->syntax #'self 'syntax)])
#'(-nest* (s ((… …) (before …))) (s ((… …) after)) (s v) (s ooo*)))]))
[(self wrapper-stx v ooo*)
(with-syntax ([s (datum->syntax #'self 'syntax)]
[qs (datum->syntax #'self 'quasisyntax)])
#`(-nest* (λ (new-v)
(with-syntax ([#,(datum->syntax #'self '%) new-v])
(qs wrapper-stx)))
(s v)
(s ooo*)))]))
(define-syntax ddd*
(syntax-parser
@ -79,15 +93,22 @@
(pattern (:not-macro-id . _)))
(define-splicing-syntax-class stmt
#:literals (define define/with-syntax)
#:literals (define define/with-syntax -define/syntax-parse)
(pattern {~seq (define name:id e:expr) :ooo+}
#:with expanded
#`(-define name
#,(nest* (ddd %) e ooo*)))
(pattern {~seq (define/with-syntax pat e:expr) :ooo+}
#:with expanded
#`(-define/with-syntax #,(nest* (% …) pat ooo*)
#,(nest* (ddd %) e ooo*)))
#`(-define/syntax-parse
#,(nest* (… {~and {~or (% …) #f}}) ({~syntax-case pat}) ooo*)
#,(nest* (ddd % #:allow-missing) (list e) ooo*)))
(pattern {~seq (-define/syntax-parse pat e:expr) :ooo+}
;; Same as above, except that pat is not wrapped with ~syntax-case.
#:with expanded
#`(-define/syntax-parse
#,(nest* (… {~and {~or (% …) #f}}) (pat) ooo*)
#,(nest* (ddd % #:allow-missing) (list e) ooo*)))
(pattern {~seq e :ooo+}
;#:with expanded #`(apply values #,(ddd* e ooo*))
#:with expanded #`(splicing-list #,(ddd* e ooo*)))

59
private/ddd.rkt
View File

@ -1,5 +1,9 @@
#lang racket
;; Implementation of the (ddd e) macro, which iterates e over the syntax pattern
;; variables present in e. e should contain at least one syntax pattern variable
;; which is under ellipses.
(provide ddd ?? ?if ?cond ?attr ?@ ?@@
splicing-list splicing-list-l splicing-list?)
@ -93,17 +97,43 @@
#t
(apply = vs)))
(define (map#f* f attr-ids l*)
(for ([l (in-list l*)]
[attr-id (in-list attr-ids)])
(when (eq? l #f)
(raise-syntax-error (syntax-e attr-id)
"attribute contains an omitted element"
attr-id)))
(unless (apply =* (map length l*))
(raise-syntax-error 'ddd
"incompatible ellipis counts for template"))
(apply map f l*))
;; map, with extra checks for missing elements (i.e. when one of the l* lists
;; is #f). If allow-missing? is specified, each #f list is replaced by
;; a stream of #f values. If all l* lists are #f, then there is no way to know
;; the number of iterations to make, so #f is returned (indicating that the
;; whole sequence is missing, instead of being merely empty.
(define (map#f* allow-missing? f attr-ids l*)
(if allow-missing?
(let ()
(define non-#f-l* (filter identity l*))
(unless (apply =* (map length non-#f-l*))
(raise-syntax-error 'ddd
"incompatible ellipis counts for template"))
(if (= (length non-#f-l*) 0)
;; If all lists are missing (#f), return a single #f value, indicating
;; that there are no elements to create the result list from.
#f
;; Or should we use this?
;(apply f (map (const #f) l*))
;; i.e. just call the function once with every variable bound to #f,
;; i.e. missing.
;; replace the missing (#f) lists with a list of N #f values, where N
;; is the length of the other lists.
(let* ([repeated-#f (map (const #f) (car non-#f-l*))]
[l*/repeated-#f (map (λ (l) (or l repeated-#f)) l*)])
(apply map f l*/repeated-#f))))
(let ()
(for ([l (in-list l*)]
[attr-id (in-list attr-ids)])
(when (eq? l #f)
(raise-syntax-error (syntax-e attr-id)
"attribute contains an omitted element"
attr-id)))
(unless (apply =* (map length l*))
(raise-syntax-error 'ddd
"incompatible ellipis counts for template"))
(apply map f l*))))
(define-for-syntax (current-pvars-shadowers)
@ -259,7 +289,9 @@
;;; extract-present-variables can find it.
;;; In effect, this is semantically equivalent to lifting the problematic
;;; pvar outside of the body.
(define-syntax/case (ddd body) ()
(define-syntax/case (ddd body . tail) ()
(define/with-syntax allow-missing?
(syntax-case #'tail () [() #'#f] [(#:allow-missing) #'#t]))
(define/with-syntax (pvar …) (current-pvars-shadowers))
(define-temp-ids "~aᵢ" (pvar …))
@ -314,7 +346,8 @@
[(presence-info #f pv pvᵢ #f _) #'#f])
present?+pvars)))
#'(map#f* (λ (iterated-pvarᵢ … lifted-key …)
#'(map#f* allow-missing?
(λ (iterated-pvarᵢ … lifted-key …)
(expanded-f filling-pvar …
(make-hash (list (cons 'lifted-key lifted-key) …))))
(list (quote-syntax iterated-pvar) …

46
private/find-defined-pvars.rkt Normal file
View File

@ -0,0 +1,46 @@
#lang racket
;; This module is an experiment to extract the pattern variables defined by a
;; define/with-syntax form (it could easily be made to work with
;; define/syntax-parse too). Ti relies on inspecting current-pvars before and
;; after the define/with-syntax form. In order to be able to access the updated
;; current-pvars, the macro needs to call a second macro which gets expanded
;; after the define/with-syntax.
(require stxparse-info/parse
stxparse-info/case)
(require stxparse-info/current-pvars
(for-syntax racket/list))
(define-syntax (continue stx)
(syntax-case stx ()
[(_ old-pvars-stx)
(let ()
(define old-pvars (syntax->list #'old-pvars-stx))
(define now-pvars (current-pvars))
(define-values (new-pvars rest-pvars)
(split-at now-pvars (- (length now-pvars) (length old-pvars))))
(unless (andmap free-identifier=? old-pvars rest-pvars)
(log-error
(string-append "Internal error: The tail of current-pvars changed"
" between two calls.\n"
" Before: ~a\n"
" After: ~a\n"
" New items: ~a"
old-pvars
rest-pvars
new-pvars)))
(displayln old-pvars)
(displayln new-pvars)
#'(begin))]))
(define-syntax (find-defined-pvars stx)
(syntax-case stx ()
[(_ pat val)
#`(begin
(define/with-syntax pat val)
(continue #,(current-pvars)))]))
(define/with-syntax (a . b) #'(1 2))
(find-defined-pvars (x . y) #'(3 4))
(define/with-syntax (c . d) #'(5 6))

65
private/syntax-case-as-syntax-parse.rkt Normal file
View File

@ -0,0 +1,65 @@
#lang racket/base
(provide ~syntax-case ~syntax-case-stat)
(require syntax/parse
(for-syntax racket/base))
(define-for-syntax (~syntax-case-impl not-stat? stx)
(with-syntax ([(_ stx1) stx])
(define (id=? a b) (and (identifier? a)
(free-identifier=? a b)))
(define (ds e [ctx #'stx1])
(datum->syntax ctx e ctx ctx))
(define (ds2 sym [locprop #'stx1])
(datum->syntax #'here sym locprop locprop))
(define (sc e)
(datum->syntax #'here `{~syntax-case ,e} e e))
(define (process-sequence stx2)
(syntax-case stx2 ()
[(pat ooo . rest)
(and (id=? #'ooo (quote-syntax ...)) not-stat?)
`(,{sc #'pat} ,#'ooo . ,(process-sequence #'rest))]
[(pat . rest)
`(,{sc #'pat} . ,(process-sequence #'rest))]
[()
stx2]))
(syntax-case #'stx1 ()
[underscore (and (id=? #'underscore #'_) not-stat?)
#'underscore]
[id (identifier? #'id)
(ds `{,{ds2 '~var #'id} ,#'id})]
[(ooo stat) (and (id=? #'ooo (quote-syntax ...)) not-stat?)
{ds
`(,{ds2 '~syntax-case-stat #'ooo}
,#'stat)}]
[(pat ooo . rest) (and (id=? #'ooo (quote-syntax ...)) not-stat?)
(ds `(,{sc #'pat} ,#'ooo . ,{sc #'rest}))]
[(pat . rest) (ds `(,{sc #'pat} . ,{sc #'rest}))]
[() #'stx1]
[#(pat ...)
(ds (vector->immutable-vector
(list->vector
(process-sequence #'(pat ...)))))]
[#&pat
(ds (box-immutable (sc #'pat)))]
[p
(prefab-struct-key (syntax-e #'p))
(ds (make-prefab-struct
(prefab-struct-key (syntax-e #'p))
(process-sequence
(cdr (vector->list (struct->vector (syntax-e #'p)))))))]
[other
(ds `{,(ds2 '~datum #'other) ,#'other})])))
#;(syntax-case (quote-syntax #s(a b c d)) ()
[#s(a ... bb) #'bb]
[(... #s(a ... b)) 'y])
(define-syntax ~syntax-case
(pattern-expander (λ (stx) (~syntax-case-impl #t stx))))
(define-syntax ~syntax-case-stat
(pattern-expander (λ (stx) (~syntax-case-impl #f stx))))
#;(syntax-parse #'(1 2 3)
[{~syntax-case (~var ... ~and)}
(displayln (attribute ~var))
(displayln (attribute ~and))
])

33
scribblings/subtemplate.scrbl
View File

@ -96,15 +96,15 @@ with @racketmodname[syntax/parse] and @|orig:syntax-case|.
@${m - 1} levels in the result list). It is also possible to nest the use
of these ellipses, e.g. with @racket[(x ...) ...], which keeps the
structure of the nested lists in the result.}
@item{When a definition form (@racket[define] or @racket[define/with-syntax]
for now) is followed by @${n} ellipses, then the defined identifier is a
@${\text{nested}^n} list, or a syntax pattern variable with an ellipsis
depth of @${n}. The expression is evaluated for each value of the template
variables it contains. Note that the structure of the nested lists is not
flattened, despite the fact that the ellipses are written one after
another. This is because it is usually the desired outcome, and nesting
parentheses around the definition form would produce rather unreadable
code.}
@item{When a definition form (@racket[define], @racket[define/with-syntax] or
@racket[define/syntax-parse] for now) is followed by @${n} ellipses, then
the defined identifier is a @${\text{nested}^n} list, or a syntax pattern
variable with an ellipsis depth of @${n}. The expression is evaluated for
each value of the template variables it contains. Note that the structure
of the nested lists is not flattened, despite the fact that the ellipses
are written one after another. This is because it is usually the desired
outcome, and nesting parentheses around the definition form would produce
rather unreadable code.}
@item{These ellipses can also be used ``inline'' within function calls
(@racketmodname[subtemplate] overrides @racket[#%app] to achieve this). For
example: @racket[(/ (+ x ...) (length x))] would compute the average of
@ -250,10 +250,17 @@ to their equivalents from this library, and without @orig:template/loc] and
@defform[(begin body ...)]{
Overridden version of @|orig:begin|. Supports ellipses after definitions
(using @racket[define] and @racket[define-syntax]). Supports ellipses after
expressions, in which case the results are grouped into a splicing list, which
makes it possible to write @racket[(+ (begin x ...))] and obtain the same
result as with @racket[(+ x ...)].}
(using @racket[define], @racket[define/with-syntax] or
@racket[define/syntax-parse]). Supports ellipses after expressions, in which
case the results are grouped into a splicing list, which makes it possible to
write @racket[(+ (begin x ...))] and obtain the same result as with
@racket[(+ x ...)].
@history[
#:changed "1.2"
@elem{Added support @racket[define/syntax-parse], fixed documentation which
incorrectly claimed support for @racket[define-syntax] instead of
@racket[define/with-syntax]}]}
@defform*[[(let ([var val] …) . body)
(let name ([var val] …) . body)]]{

60
test/test-missing-nested.rkt Normal file
View File

@ -0,0 +1,60 @@
#lang racket
(require subtemplate/override
rackunit)
(check-equal? (syntax-parse #'((yy 1 2) #:kw (yyy 3 4))
[({~and {~or (y x …) :keyword}} …)
(syntax->datum
(quasitemplate
(0 #,(list (quasitemplate
(?? (~~~
y
#,(list x) ...
~~~)
oops)))
... 9)))])
'(0 ((~~~ yy (1) (2) ~~~)) (oops) ((~~~ yyy (3) (4) ~~~)) 9))
(check-equal?
(syntax-parse #'((y a b 3 d 5 f) #:kw (z g 8 i) #:kww)
[({~and {~or (y {~and {~or x:id _}} …) :keyword}} …)
(syntax->datum
(quasitemplate
(0 #,(list (quasitemplate
(?? (~~~
y
#,(list (template (?? x -)) (template (?? x -))) ...
~~~)
oops)))
... 9)))])
'(0
((~~~ y (a a) (b b) (- -) (d d) (- -) (f f) ~~~))
(oops)
((~~~ z (g g) (- -) (i i) ~~~))
(oops)
9))
(check-equal? (syntax-parse #'((yy 1 2) #:kw (yyy 3 4))
[({~and {~or (y x …) :keyword}} …)
(list (?? (list y (?? x '-) …) 'oops) …)])
'((yy 1 2) oops (yyy 3 4)))
(check-equal? (syntax-parse #'((y a b 3 d 5 f) #:kw (z g 8 i) #:kww)
[({~and {~or (y {~and {~or x:id _}} …) :keyword}} …)
(list (?? (list y (?? x '-) …) 'oops) …)])
'((y a b - d - f) oops (z g - i) oops))
(check-exn
#rx"attribute contains an omitted element"
(λ ()
(syntax-parse #'((y a b 3 d 5 f) #:kw (z g 8 i) #:kww)
[({~and {~or (y {~and {~or x:id _}} …) :keyword}} …)
(list (?? x '-) … …)])))
(check-exn
#rx"attribute contains an omitted element"
(λ ()
(syntax-parse #'((y a b 3 d 5 f) #:kw (z g 8 i) #:kww)
[({~and {~or (y {~and {~or x:id _}} …) :keyword}} …)
(define l (?if y (?? x '-) 'oops)) … …
l])))

19
test/test-use-before-definition.rkt Normal file
View File

@ -0,0 +1,19 @@
#lang racket
(require subtemplate/override
rackunit)
;; f is defined after xᵢ
(check-equal?
(let ()
(define/with-syntax (xᵢ …) #'(a b c))
(define (f) (list zᵢ ... (syntax->datum (subtemplate (yᵢ …)))))
(f))
'(a/z b/z c/z (a/y b/y c/y)))
;; f is defined before xᵢ (still works, yay!)
(check-equal?
(let ()
(define (f) (list zᵢ ... (syntax->datum (subtemplate (yᵢ …)))))
(define/with-syntax (xᵢ …) #'(a b c))
(f))
'(a/z b/z c/z (a/y b/y c/y)))