commit 8bf9e48c025e37d0ada0421c787946a915e278d0
parent 925de55a92a459543ff5e17c737f2c1fe40a3578
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Fri, 5 May 2017 19:51:35 +0200
Fixed bug with ellipses and omitted values for (define/with-syntax foo e) …
Diffstat:
8 files changed, 292 insertions(+), 37 deletions(-)
diff --git a/info.rkt b/info.rkt
@@ -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"))
diff --git a/private/ddd-forms.rkt b/private/ddd-forms.rkt
@@ -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*)))
diff --git a/private/ddd.rkt b/private/ddd.rkt
@@ -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) …
diff --git a/private/find-defined-pvars.rkt b/private/find-defined-pvars.rkt
@@ -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))
+\ No newline at end of file
diff --git a/private/syntax-case-as-syntax-parse.rkt b/private/syntax-case-as-syntax-parse.rkt
@@ -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))
+ ])
+\ No newline at end of file
diff --git a/scribblings/subtemplate.scrbl b/scribblings/subtemplate.scrbl
@@ -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)]]{
diff --git a/test/test-missing-nested.rkt b/test/test-missing-nested.rkt
@@ -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])))
+\ No newline at end of file
diff --git a/test/test-use-before-definition.rkt b/test/test-use-before-definition.rkt
@@ -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)))
+\ No newline at end of file
