Closes 184 body which supports ddd on define

copy-attribute.rkt

@@ -47,8 +47,7 @@
 (define-syntax/parse (copy-raw-syntax-attribute name:id
                                                 attr-value:expr
                                                 ellipsis-depth:nat
-                                                syntax?:boolean
-                                                props:expr)
+                                                syntax?:boolean)
   ;; the ~and is important, to prevent the nested ~or from being treated as
   ;; an ellipsis-head pattern.
   #:with nested (nest-map (λ (pat) #`{~or #f ({~and #,pat} (... ...))})
@@ -61,13 +60,11 @@
                           (syntax-e #'ellipsis-depth))
   (if (syntax-e #'syntax?)
       #'(begin
-          (define/syntax-parse nested attr-value)
-          (define-pvars name))
+          (define/syntax-parse nested attr-value))
       #'(begin
           (define-syntax-class extract-non-syntax
             #:attributes (name)
             (pattern v
                      #:attr name (wrapped-value (syntax-e #'v))))
           (define/syntax-parse nested (attribute-wrap attr-value
-                                                      ellipsis-depth))
-          (define-pvars name))))
+                                                      ellipsis-depth)))))

ddd-forms.rkt

@@ -0,0 +1,105 @@
+#lang racket
+(provide begin
+         define
+         let
+         (rename-out [begin #%intef-begin])
+         (rename-out [app #%app]))
+
+(require subtemplate/ddd
+         stxparse-info/case
+         stxparse-info/parse
+         phc-toolkit/untyped
+         (prefix-in - (only-in racket/base
+                               begin let lambda define))
+         (prefix-in - (only-in stxparse-info/case
+                               define/with-syntax))
+         (for-syntax racket/list
+                     stxparse-info/parse
+                     stxparse-info/parse/experimental/template
+                     phc-toolkit/untyped)
+         (for-meta 2 racket/base)
+         (for-meta 2 phc-toolkit/untyped)
+         (for-meta 2 stxparse-info/parse))
+
+(begin-for-syntax
+  (define (-nest* before after -v -ooo* [depth 0])
+    (if (stx-null? -ooo*)
+        -v
+        (-nest* before
+                after
+                (datum->syntax before `(,@(syntax->list before) ,-v . ,after))
+                (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*)))]))
+
+  (define-syntax ddd*
+    (syntax-parser
+      [(_ e ooo*)
+       #'(with-syntax ([dotted (nest* (ddd %) e ooo*)])
+           (nest* (append* %)
+                  (list dotted)
+                  ooo*))]))
+
+  (define-syntax-class ooo
+    (pattern {~and ooo {~literal …}}))
+
+  (define-splicing-syntax-class ooo*
+    #:attributes (ooo*)
+    (pattern {~seq {~and ooo {~literal …}} …+}
+             #:with ooo* #'(ooo …)))
+
+  (define-syntax-class not-macro-id
+    #:attributes ()
+    (pattern id:id
+             #:when (not (syntax-local-value #'id (λ () #f))))
+    (pattern id:id
+             #:when (syntax-pattern-variable?
+                     (syntax-local-value #'id (λ () #f)))))
+
+  (define-syntax-class not-macro-expr
+    #:attributes ()
+    (pattern :not-macro-id)
+    (pattern (:not-macro-id . _)))
+  
+  (define-splicing-syntax-class stmt
+    #:literals (define define/with-syntax)
+    (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*)))
+    (pattern {~seq e:not-macro-expr :ooo*}
+             ;#:with expanded #`(apply values #,(ddd* e ooo*))
+             #:with expanded (ddd* e ooo*))
+    (pattern other
+             #:with expanded #'other)))
+
+(define-syntax/parse (begin stmt:stmt …)
+  (template (-begin (?@ stmt.expanded) …)))
+
+(define-syntax/parse (let ([var . val] …) . body)
+  (template (-let ([var (begin . val)] …) (begin . body))))
+
+(begin-for-syntax
+  (define-splicing-syntax-class arg
+    (pattern {~seq e:expr ooo*:ooo*}
+             #:with expanded (ddd* e ooo*))
+    (pattern other
+             #:with expanded #'(#%app list other))))
+(define-syntax app
+  (syntax-parser
+    [(_ fn {~and arg {~not {~literal …}}} …)
+     #'(#%app fn arg …)]
+    [{~and (_ fn arg:arg …)
+           {~not (_ _ {~literal …} . _)}} ;; not fn directly followed by a …
+     #'(#%app apply fn (#%app append arg.expanded …))]
+    [(_ arg:arg …) ;; shorthand for list creation
+     #'(#%app apply list (#%app append arg.expanded …))]))

ddd.rkt

@@ -6,8 +6,7 @@
          phc-toolkit/untyped
          subtemplate/copy-attribute
          (prefix-in - syntax/parse/private/residual)
-         (for-syntax "derived-valvar.rkt"
-                     racket/contract
+         (for-syntax racket/contract
                      racket/syntax
                      phc-toolkit/untyped
                      racket/function
@@ -24,7 +23,7 @@
 (begin-for-syntax
   (define/contract (attribute-real-valvar attr)
     (-> identifier? (or/c #f identifier?))
-    (define valvar1
+    (define valvar
       (let ([slv (syntax-local-value attr (λ () #f))])
         (if (syntax-pattern-variable? slv)
             (let* ([valvar (syntax-mapping-valvar slv)]
@@ -36,20 +35,14 @@
              'attribute*
              "not bound as an attribute or pattern variable"
              attr))))
-    ;; Try to extract the actual variable from a subtemplate derived valvar.
-    (define valvar2
-      (let ([valvar1-slv (syntax-local-value valvar1 (λ () #f))])
-        (if (derived-valvar? valvar1-slv)
-            (derived-valvar-valvar valvar1-slv)
-            valvar1)))
-    (if (syntax-local-value valvar2 (λ () #f)) ;; is it a macro-ish thing?
+    (if (syntax-local-value valvar (λ () #f)) ;; is it a macro-ish thing?
         (begin
           (log-warning
            (string-append "Could not extract the plain variable corresponding to"
                           " the pattern variable or attribute ~a"
                           (syntax-e attr)))
           #f)
-        valvar2)))
+        valvar)))
 
 ;; free-identifier=? seems to stop working on the valvars once we are outside of
 ;; the local-expand containing the let which introduced these valvars, therefore
@@ -90,12 +83,16 @@
 
 (define-syntax/case (ddd body) ()
   (define/with-syntax (pvar …)
-    (map syntax-local-introduce
-         (filter (conjoin identifier?
-                          (λ~> (syntax-local-value _ (thunk #f))
-                               syntax-pattern-variable?)
-                          attribute-real-valvar)
-                 (current-pvars))))
+    (remove-duplicates
+     (map syntax-local-get-shadower
+          (map syntax-local-introduce
+               (filter (conjoin identifier?
+                                (λ~> (syntax-local-value _ (thunk #f))
+                                     syntax-pattern-variable?)
+                                attribute-real-valvar)
+                       (reverse (current-pvars)))))
+     bound-identifier=?))
+  
   (define-temp-ids "~aᵢ" (pvar …))
   (define/with-syntax f
     #`(#%plain-lambda (pvarᵢ …)
@@ -126,6 +123,7 @@
                         stx))
 
   (begin
+    ;; present?+pvars is a list of (list shadow? pv pvᵢ present? depth/#f)
     (define present?+pvars
       (for/list ([present? (in-list present-variables)]
                  [pv (in-syntax #'(pvar …))]
@@ -136,7 +134,7 @@
                (if (> depth 0)
                    (list #t pv pvᵢ #t depth)
                    (list #f pv pvᵢ #t depth))]) ;; TODO: detect shadowed bindings, if the pvar was already iterated on, raise an error (we went too deep).
-            (list #f pv pvᵢ #f))))
+            (list #f pv pvᵢ #f #f))))
     ;; Pvars which are iterated over
     (define/with-syntax ((_ iterated-pvar iterated-pvarᵢ _ _) …)
       (filter car present?+pvars))
@@ -147,8 +145,9 @@
     ;; If the pvar is iterated, use the iterated pvarᵢ 
     ;; otherwise use the original (attribute* pvar)
     (define/with-syntax (filling-pvar …)
-      (map (match-λ [(list #t pv pvᵢ _ _) pvᵢ]
-                    [(list #f pv pvᵢ _ _) #`(attribute* #,pv)])
+      (map (match-λ [(list #t pv pvᵢ #t _) pvᵢ]
+                    [(list #f pv pvᵢ #t _) #`(attribute* #,pv)]
+                    [(list #f pv pvᵢ #f _) #'#f])
            present?+pvars)))
   
   #'(map (λ (iterated-pvarᵢ …)
@@ -164,7 +163,11 @@
                                   #,(max 0 (sub1 depth))
                                   #,syntax?)]
     [`(pvar ,valvar ,depth)
-     #`(define-raw-syntax-mapping pvar
+     #`(copy-raw-syntax-attribute pvar
+                                  new-value
+                                  #,(max 0 (sub1 depth))
+                                  #t)
+     #;#`(define-raw-syntax-mapping pvar
          tmp-valvar
          new-value
          #,(sub1 depth))]))

derived-valvar.rkt

@@ -1,31 +0,0 @@
-#lang racket/base
-
-(provide (struct-out derived-valvar)
-         id-is-derived-valvar?)
-
-(require racket/function
-         racket/private/sc
-         (for-template (prefix-in - stxparse-info/parse/private/residual)))
-
-;; Act like a syntax transformer, but which is recognizable via the
-;; derived-pattern-variable? predicate.
-(struct derived-valvar (valvar)
-  #:property prop:procedure
-  (λ (self stx)
-    #`(#%expression #,(derived-valvar-valvar self))))
-
-(define (id-is-derived-valvar? id)
-  (define mapping (syntax-local-value id (thunk #f)))
-  (and mapping ;; … defined as syntax
-       (syntax-pattern-variable? mapping) ; and is a syntax pattern variable
-       (let ()
-         (define mapping-slv
-           (syntax-local-value (syntax-mapping-valvar mapping) (thunk #f)))
-         ;; either a mapping → attribute → derived,
-         ;; or directly mapping → derived
-         (or (and (-attribute-mapping? mapping-slv) ;; is an attribute
-                  (derived-valvar? ;; and the pvar's valvar is a derived
-                   (syntax-local-value (-attribute-mapping-var mapping-slv)
-                                       (thunk #f))))
-             ;; or the pvar's valvar is derived
-             (derived-valvar? mapping-slv)))))

main.rkt

@@ -14,7 +14,6 @@
          (subtract-in racket/syntax stxparse-info/case)
          "copy-attribute.rkt"
          (for-syntax "patch-arrows.rkt"
-                     "derived-valvar.rkt"
                      racket/format
                      stxparse-info/parse
                      racket/private/sc
@@ -94,7 +93,6 @@
       
       (define/with-syntax ([binder . unique-at-runtime-id] …)
         (filter (compose (conjoin identifier?
-                                  (negate id-is-derived-valvar?)
                                   (λ~> (syntax-local-value _ (thunk #f))
                                        syntax-pattern-variable?)
                                   ;; force call syntax-local-value to prevent
@@ -116,7 +114,6 @@
       #;(define/with-syntax ([binder . unique-at-runtime] …)
           (for/list ([binder (current-pvars+unique)]
                       #:when (identifier? (car binder))
-                      #:unless (id-is-derived-valvar? (car binder))
                       #:when (syntax-pattern-variable?
                               (syntax-local-value (car binder) (thunk #f)))
                       ;; force call syntax-local-value to prevent ambiguous

test/test-ddd-forms.rkt

@@ -0,0 +1,188 @@
+#lang racket
+
+(require subtemplate/ddd-forms
+         stxparse-info/case
+         stxparse-info/parse
+         rackunit
+         syntax/macro-testing
+         phc-toolkit/untyped)
+
+;; case, let + begin, define
+(check-equal? (syntax-case #'((1 2 3) (4 5)) ()
+                [((x …) …)
+                 (let ()
+                   (begin
+                     (define y (- (syntax-e #'x))) … …
+                     y))])
+              '((-1 -2 -3) (-4 -5)))
+
+;; case, let + begin, define/with-syntax
+(check-equal? (syntax->datum
+               (syntax-case #'((1 2 3) (4 5)) ()
+                 [((x …) …)
+                  (let ()
+                    (begin
+                      (define/with-syntax y (- (syntax-e #'x))) … …
+                      #'((y …) …)))]))
+              '((-1 -2 -3) (-4 -5)))
+
+;; case, let, define
+(check-equal? (syntax-case #'((1 2 3) (4 5)) ()
+                [((x …) …)
+                 (let ()
+                   (define y (- (syntax-e #'x))) … …
+                   y)])
+              '((-1 -2 -3) (-4 -5)))
+
+;; case, let, define/with-syntax
+(check-equal? (syntax->datum
+               (syntax-case #'((1 2 3) (4 5)) ()
+                 [((x …) …)
+                  (let ()
+                    (define/with-syntax y (- (syntax-e #'x))) … …
+                    #'((y …) …))]))
+              '((-1 -2 -3) (-4 -5)))
+
+;; parse, let + begin, define
+(check-equal? (syntax-parse #'((1 2 3) (4 5))
+                [((x …) …)
+                 (let ()
+                   (begin
+                     (define y (- (syntax-e #'x))) … …
+                     y))])
+              '((-1 -2 -3) (-4 -5)))
+
+;; parse, let + begin, define/with-syntax
+(check-equal? (syntax->datum
+               (syntax-parse #'((1 2 3) (4 5))
+                 [((x …) …)
+                  (let ()
+                    (begin
+                      (define/with-syntax y (- (syntax-e #'x))) … …
+                      #'((y …) …)))]))
+              '((-1 -2 -3) (-4 -5)))
+
+;; parse, let, define
+(check-equal? (syntax-parse #'((1 2 3) (4 5))
+                [((x …) …)
+                 (let ()
+                   (define y (- (syntax-e #'x))) … …
+                   y)])
+              '((-1 -2 -3) (-4 -5)))
+
+;; parse, let, define/with-syntax
+(check-equal? (syntax->datum
+               (syntax-parse #'((1 2 3) (4 5))
+                 [((x …) …)
+                  (let ()
+                    (define/with-syntax y (- (syntax-e #'x))) … …
+                    #'((y …) …))]))
+              '((-1 -2 -3) (-4 -5)))
+
+;; parse, begin, define
+(check-equal? (syntax-parse #'((1 2 3) (4 5))
+                [((x …) …)
+                 (begin
+                   (define y (- (syntax-e #'x))) … …)
+                 y])
+              '((-1 -2 -3) (-4 -5)))
+
+;; parse, begin, define/with-syntax
+(check-equal? (syntax->datum
+               (syntax-parse #'((1 2 3) (4 5))
+                 [((x …) …)
+                  (begin
+                    (define/with-syntax y (- (syntax-e #'x))) … …)
+                  #'((y …) …)]))
+              '((-1 -2 -3) (-4 -5)))
+
+;; parse, directly in the body, define
+(check-equal? (syntax-parse #'((1 2 3) (4 5))
+                [((x …) …)
+                 (define y (- (syntax-e #'x))) … …
+                 y])
+              '((-1 -2 -3) (-4 -5)))
+
+;; parse, directly in the body, define/with-syntax
+(check-equal? (syntax->datum
+               (syntax-parse #'((1 2 3) (4 5))
+                 [((x …) …)
+                  (define/with-syntax y (- (syntax-e #'x))) … …
+                  #'((y …) …)]))
+              '((-1 -2 -3) (-4 -5)))
+
+;; #%app
+(check-equal? (syntax-case #'([1 2 3] [a]) ()
+                [([x …] [y …])
+                 (vector (syntax-e #'x) … 'then (syntax-e #'y) …)])
+              #(1 2 3 then a))
+
+;; #%app, depth 2 → flat
+(check-equal? (syntax-case #'(([1 2 3] [4 5 6]) [a]) ()
+                [(([x …] …) [y …])
+                 (vector (syntax-e #'x) … … 'then (syntax-e #'y) …)])
+              #(1 2 3 4 5 6 then a))
+
+;; #%app, depth 2 → nested
+(check-equal? (syntax-case #'(([1 2 3] [4 5 6]) [a]) ()
+                [(([x …] …) [y …])
+                 (vector ((syntax-e #'x) …) … 'then (syntax-e #'y) …)])
+              #((1 2 3) (4 5 6) then a))
+
+;; #%app, with auto-syntax-e behaviour :)
+(check-equal? (syntax-case #'([1 2 3] [a]) ()
+                [([x …] [y …])
+                 (vector x … 'then y …)])
+              #(1 2 3 then a))
+
+;; #%app, with auto-syntax-e behaviour, same variable iterated twice
+(check-equal? (syntax-case #'([1 2 3] [a]) ()
+                [([x …] [y …])
+                 (vector x … 'then x …)])
+              #(1 2 3 then 1 2 3))
+
+;; #%app, depth 2 → flat, with auto-syntax-e behaviour :)
+(check-equal? (syntax-case #'(([1 2 3] [4 5 6]) [a]) ()
+                [(([x …] …) [y …])
+                 (vector x … … 'then y …)])
+              #(1 2 3 4 5 6 then a))
+
+;; #%app, depth 2 → nested, with auto-syntax-e behaviour :)
+(check-equal? (syntax-case #'(([1 2 3] [4 5 6]) [a]) ()
+                [(([x …] …) [y …])
+                 (vector (x …) … 'then y …)])
+              #((1 2 3) (4 5 6) then a))
+
+(check-equal? (syntax-parse #'(([1 2 3] [4 5 6]) [a])
+                [(([x …] …) [y …])
+                 (vector (x … …) 'then y …)])
+              #((1 2 3 4 5 6) then a))
+
+(check-equal? (syntax-parse #'(([1 2 3] [4 5 6]) [a])
+                [(([x …] …) [y …])
+                 (y …)])
+              '(a))
+
+(check-equal? (syntax-parse #'(([1 2 3] [4 5 6]) [a])
+                [(([x …] …) [y …])
+                 (x … …)])
+              '(1 2 3 4 5 6))
+
+;; Implicit (list _), could also be changed to an implicit (values).
+(check-equal? (syntax-parse #'(([1 2 3] [4 5 6]) [a])
+                [(([x …] …) [y …])
+                 x … …])
+              '(1 2 3 4 5 6))
+
+#|
+;; TODO: expr … inside begin and let
+(check-equal? (syntax-case #'((1 2 3) (4 5)) ()
+                  [((x …) …)
+                   (let ()
+                     (list (length (syntax->list #'(x …)))
+                           (+ (syntax-e #'x) 3) …)
+                     …)])
+                '([3 (4 5 6)]
+                  [2 (7 8)]))
+|#
+

test/test-ddd.rkt

@@ -4,7 +4,15 @@
          stxparse-info/parse
          (only-in racket/base [... …])
          rackunit
-         syntax/macro-testing)
+         syntax/macro-testing
+         syntax/stx)
+
+(check-equal? (syntax-case #'((1 2 3) (4 5)) ()
+                [((x …) …)
+                 (ddd (list (length (syntax->list #'(x …)))
+                            (ddd (+ (syntax-e #'x) 3))))])
+              '([3 (4 5 6)]
+                [2 (7 8)]))
 
 (check-equal? (syntax-case #'(1 2 3) ()
                 [(x …)
@@ -16,6 +24,35 @@
                  (ddd (+ (syntax-e #'x) 3))])
               '(4 5 6))
 
+(check-equal? (syntax-case #'(((1 2) (3)) ((4 5 6))) ()
+                  [(((x …) …) …)
+                   (ddd (list (length (syntax->list #'((x …) …)))
+                              (length (syntax->list #'(x … …)))
+                              (ddd (ddd (- (syntax-e #'x))))))])
+                '([2 3 ((-1 -2) (-3))]
+                  [1 3 ((-4 -5 -6))]))
+
+(check-equal? (syntax-case #'([1 2 3] [a]) ()
+                [([x …] [y …])
+                 (ddd (+ (syntax-e #'x) 3))])
+              '(4 5 6))
+
+(check-equal? (syntax-case #'(([1 2 3] [a])) ()
+                [(([x …] [y …]) …)
+                 (ddd (ddd (+ (syntax-e #'x) 3)))])
+              '((4 5 6)))
+
+;; The inner ddd should not make the outer one consider the variables actually
+;; used. This test will break if y is considered to be used, because it does not
+;; have the same shape as x anywhere, so map will complain that the lists do not
+;; have the same length.
+(check-equal? (syntax-case #'([#:xs (1 2 3) (4 5)]
+                              [#:ys (a) (b) (c) (d)]) ()
+                [([#:xs (x …) …]
+                  [#:ys (y …) …])
+                 (ddd (ddd (+ (syntax-e #'x) 3)))])
+              '((4 5 6) (7 8)))
+
 (check-exn
  #rx"no pattern variables with depth > 0 were found in the body"
  (λ ()
@@ -27,4 +64,11 @@
 (check-equal? (syntax-parse #'(1 2 3 4)
                 [(x … y)
                  (ddd (+ (syntax-e #'x) (syntax-e #'y)))])
-              '(5 6 7))
+              '(5 6 7))
+
+(check-equal? (syntax-case #'((1 2 3) (4 5)) ()
+                [((x …) …)
+                 (ddd (list (length (syntax->list #'(x …)))
+                            (ddd (+ (syntax-e #'x) 3))))])
+              '([3 (4 5 6)]
+                [2 (7 8)]))