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

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

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
+        (-nest* wrapper
-                after
+                (wrapper -v)
-                #`(#,@(syntax->list before) #,-v . #,after)
                 (stx-cdr -ooo*)
                 (add1 depth))))
   
   (define-syntax nest*
     (syntax-parser
-      [(self (before … {~datum %} . after) v ooo*)
+      [(self wrapper-stx v ooo*)
-       (with-syntax ([s (datum->syntax #'self 'syntax)])
+       (with-syntax ([s (datum->syntax #'self 'syntax)]
-         #'(-nest* (s ((… …) (before …))) (s ((… …) after)) (s v) (s ooo*)))]))
+                     [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*)
+             #`(-define/syntax-parse
-                                    #,(nest* (ddd %) e ooo*)))
+                #,(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*)))

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,7 +97,33 @@
       #t
       (apply = vs)))
 
-(define (map#f* f attr-ids 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)
@@ -103,7 +133,7 @@
         (unless (apply =* (map length l*))
           (raise-syntax-error 'ddd
                               "incompatible ellipis counts for template"))
-  (apply map f l*))
+        (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) …

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

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))
+     ])

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]
+ @item{When a definition form (@racket[define], @racket[define/with-syntax] or
-     for now) is followed by @${n} ellipses, then the defined identifier is a
+     @racket[define/syntax-parse] for now) is followed by @${n} ellipses, then
-     @${\text{nested}^n} list, or a syntax pattern variable with an ellipsis
+     the defined identifier is a @${\text{nested}^n} list, or a syntax pattern
-     depth of @${n}. The expression is evaluated for each value of the template
+     variable with an ellipsis depth of @${n}. The expression is evaluated for
-     variables it contains. Note that the structure of the nested lists is not
+     each value of the template variables it contains. Note that the structure
-     flattened, despite the fact that the ellipses are written one after
+     of the nested lists is not flattened, despite the fact that the ellipses
-     another. This is because it is usually the desired outcome, and nesting
+     are written one after another. This is because it is usually the desired
-     parentheses around the definition form would produce rather unreadable
+     outcome, and nesting parentheses around the definition form would produce
-     code.}
+     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
+ (using @racket[define], @racket[define/with-syntax] or
- expressions, in which case the results are grouped into a splicing list, which
+ @racket[define/syntax-parse]). Supports ellipses after expressions, in which
- makes it possible to write @racket[(+ (begin x ...))] and obtain the same
+ case the results are grouped into a splicing list, which makes it possible to
- result as with @racket[(+ x ...)].}
+ 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)]]{

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

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