Closes FB case 178 Attempt to allow escaping (template …) but keep the current nesting of ellipses

cross-phase-splicing-list.rkt

@@ -0,0 +1,26 @@
+(module cross-phase-splicing-list '#%kernel
+  (#%declare #:cross-phase-persistent)
+  (#%provide struct:splicing-list
+             splicing-list
+             splicing-list?
+             splicing-list-l)
+  (define-values (struct:splicing-list
+                  splicing-list
+                  splicing-list?
+                  splicing-list-ref
+                  _splicing-list-set!)
+    (#%app make-struct-type
+           'splicing-list   ;; name
+           #f               ;; super
+           1                ;; fields
+           0                ;; auto fields
+           #f               ;; auto value
+           '()              ;; props
+           #f               ;; inspector
+           #f               ;; proc-spec
+           (cons 0 '())     ;; immutables
+           #f               ;; guard
+           'splicing-list)) ;; constructor-name
+  (define-values (splicing-list-l)
+    (lambda (instance)
+      (splicing-list-ref instance 0))))

ddd-forms.rkt

@@ -5,7 +5,12 @@
          (rename-out [begin #%intef-begin])
          (rename-out [app #%app])
          ??
-         ?@)
+         ?@
+         splice-append
+         splice-append*
+         splicing-list?
+         splicing-list
+         splicing-list-l)
 
 (require racket/list
          subtemplate/ddd
@@ -98,30 +103,31 @@
              #:with expanded #`(splicing-list #,(ddd* e ooo*)))
     (pattern other
              ;#:with expanded #'(#%app list other)
-             #:with expanded #'other)))
+             #:with expanded #'other))
+  (define-syntax-class not-stx-pair
+    (pattern {~not (_ . _)})))
 (define-syntax app
   (syntax-parser
-    #;[(_ fn {~and arg {~not {~literal …}}} …) ;; TODO: check for ?@ too
-     #'(#%app fn arg …)]
-    [{~and (_ fn arg:arg …)
+    [{~and (_ fn arg:arg … #;.rest:not-stx-pair)
            {~not (_ _ {~literal …} . _)}} ;; not fn directly followed by a …
      ;#'(#%app apply fn (#%app append arg.expanded …))
      (syntax/top-loc this-syntax
-       (#%app apply fn (#%app splice-append arg.expanded …)))]
-    [(_ arg:arg …) ;; shorthand for list creation
+       (#%app apply fn (#%app splice-append arg.expanded … #;#:rest #;rest)))]
+    [(_ arg:arg … #;.rest:not-stx-pair) ;; shorthand for list creation
      ;#'(#%app apply list (#%app append arg.expanded …))
      (syntax/top-loc this-syntax
-       (#%app apply list (#%app splice-append arg.expanded …)))]))
+       (#%app apply list (#%app splice-append arg.expanded … #;#:rest #;rest)))]))
 
-(define (splice-append . l*) (splice-append* l*))
+(define (splice-append #:rest [rest '()] . l*)
+  (splice-append* (if (null? rest) l* (append l* rest))))
 (define (splice-append* l*)
   (cond
     [(pair? l*)
      (if (splicing-list? (car l*))
-         (append (splice-append* (splicing-list-l (car l*)))
-                 (splice-append* (cdr l*)))
+         (splice-append* (append (splicing-list-l (car l*))
+                                 (cdr l*)))
          (cons (car l*) (splice-append* (cdr l*))))]
     [(splicing-list? l*)
-     (splicing-list-l l*)]
+     (splice-append* (splicing-list-l l*))]
     [else ;; should be null.
      l*]))

ddd.rkt

@@ -125,32 +125,41 @@
   (define present-variables (map syntax-e present-variables*))
   present-variables)
 
-(struct splicing-list (l))
+;(struct splicing-list (l) #:transparent)
+(require "cross-phase-splicing-list.rkt")
+
 ;; TODO: dotted rest, identifier macro
 #;(define-syntax-rule (?@ v ...)
     (splicing-list (list v ...)))
-(define ?@ (compose splicing-list list))
+(define (?@ . vs) (splicing-list vs))
 
-(define-syntax/case (?? a b) ()
-  (define/with-syntax (pvar …) (current-pvars-shadowers))
+(define-syntax (?? stx)
+  (define (parse stx)
+    (syntax-case stx ()
+      [(self a)
+       (parse (datum->syntax stx `(,#'self ,#'a ,#'(?@)) stx stx))]
+      [(_ a b)
+       (let ()
+         (define/with-syntax (pvar …) (current-pvars-shadowers))
 
-  (define/with-syntax expanded-a
-    (local-expand #'(detect-present-pvars (pvar …) a) 'expression '()))
+         (define/with-syntax expanded-a
+           (local-expand #'(detect-present-pvars (pvar …) a) 'expression '()))
 
-  (define present-variables (extract-present-variables #'expanded-a stx))
+         (define present-variables (extract-present-variables #'expanded-a stx))
 
-  (define/with-syntax (test-present-attribute …)
-    (for/list ([present? (in-list present-variables)]
-               [pv (in-syntax #'(pvar …))]
-               #:when present?
-               ;; only attributes can have missing elements.
-               #:when (eq? 'attr (car (attribute-info pv '(pvar attr)))))
-      #`(attribute* #,pv)))
+         (define/with-syntax (test-present-attribute …)
+           (for/list ([present? (in-list present-variables)]
+                      [pv (in-syntax #'(pvar …))]
+                      #:when present?
+                      ;; only attributes can have missing elements.
+                      #:when (eq? 'attr (car (attribute-info pv '(pvar attr)))))
+             #`(attribute* #,pv)))
              
 
-  #'(if (and test-present-attribute …)
-        a
-        b))
+         #'(if (and test-present-attribute …)
+               a
+               b))]))
+  (parse stx))
 
 (define-syntax/case (ddd body) ()
   (define/with-syntax (pvar …) (current-pvars-shadowers))

info.rkt

@@ -11,6 +11,6 @@
 (define build-deps '("scribble-lib"
                      "racket-doc"))
 (define scribblings '(("scribblings/subtemplate.scrbl" () (parsing-library))))
-(define pkg-desc "Description Here")
-(define version "0.0")
+(define pkg-desc "Various enhancements on syntax templates")
+(define version "1.0")
 (define pkg-authors '("Georges Dupéron"))

template-subscripts.rkt

@@ -123,7 +123,7 @@
      (unless (attribute force-no-stxinfo)
        (for ([sym (in-list '(syntax-parse define/syntax-parse syntax-parser
                               syntax-case define/with-syntax with-syntax))])
-         (let ([shadower (syntax-local-get-shadower (datum->syntax #'self sym))]
+         (let ([shadower (datum->syntax #'self sym)];syntax-local-get-shadower ?
                [good (datum->syntax #'here sym)])
            (when (or (not (identifier-binding shadower))
                      (not (free-identifier=? shadower good)))

test/assumption-weak-hash.rkt

@@ -1,5 +1,9 @@
 #lang racket
 
+;; We use a weak hash to associate a pvar xᵢ with its the values contained in
+;; the derived yᵢ. The assumptions below must hold, otherwise we would risk
+;; memory leaks.
+
 (require (for-syntax racket/private/sc)
          rackunit)
 

test/test-ddd-top.rkt

@@ -10,10 +10,10 @@
          phc-toolkit/untyped
          (only-in racket/base [... …]))
 
-#;(check-equal? (syntax-parse #'(a b c)
-                  [(xᵢ …)
-                   yᵢ])
-                '(a/y b/y c/y))
+(check-equal? (syntax-parse #'(a b c)
+                [(xᵢ …)
+                 yᵢ])
+              '(a/y b/y c/y))
 
 (check-equal? (syntax-case #'(a b c) ()
                 [(xᵢ …)

test/test-splice-append.rkt

@@ -0,0 +1,22 @@
+#lang racket/base
+(require (only-in subtemplate/ddd-forms
+                  splicing-list
+                  splice-append
+                  splice-append*)
+         rackunit)
+
+(define (mk . vs) (splicing-list vs))
+
+(check-equal? (splice-append* '(1 2 3)) '(1 2 3))
+(check-equal? (splice-append* (mk 1 2 3)) '(1 2 3))
+(check-equal? (splice-append* (mk (mk 1 2 3))) '(1 2 3))
+(check-equal? (splice-append* (mk (mk (mk 1 2 3)))) '(1 2 3))
+(check-equal? (splice-append* (mk -1 (mk 0 (mk 1 2 3) 4 5) 6 7))
+              '(-1 0 1 2 3 4 5 6 7))
+
+(check-equal? (splice-append '(1 2 3)) '((1 2 3)))
+(check-equal? (splice-append (mk 1 2 3)) '(1 2 3))
+(check-equal? (splice-append (mk (mk 1 2 3))) '(1 2 3))
+(check-equal? (splice-append (mk (mk (mk 1 2 3)))) '(1 2 3))
+(check-equal? (splice-append (mk -1 (mk 0 (mk 1 2 3) 4 5) 6 7))
+              '(-1 0 1 2 3 4 5 6 7))

test/test-splice.rkt

@@ -0,0 +1,13 @@
+#lang racket
+
+(require subtemplate/top-subscripts
+         subtemplate/ddd-forms
+         subtemplate/unsyntax-preparse
+         subtemplate/template-subscripts
+         (except-in subtemplate/override ?? ?@)
+         stxparse-info/case
+         stxparse-info/parse
+         rackunit
+         syntax/macro-testing
+         phc-toolkit/untyped
+         (only-in racket/base [... …]))

test/test-unsyntax.rkt

@@ -0,0 +1,75 @@
+#lang racket/base
+
+(require subtemplate/top-subscripts
+         subtemplate/ddd-forms
+         subtemplate/unsyntax-preparse
+         subtemplate/template-subscripts
+         (except-in subtemplate/override ?? ?@)
+         stxparse-info/case
+         stxparse-info/parse
+         rackunit
+         syntax/macro-testing
+         phc-toolkit/untyped
+         (only-in racket/base [... …]))
+
+(check-equal? (syntax->datum
+               (syntax-parse #'(1 2 3)
+                 [(x …)
+                  (quasisubtemplate-ddd (x …))]))
+              '(1 2 3))
+
+(check-equal? (syntax->datum
+               (syntax-case #'(1 2 3) ()
+                 [(x …)
+                  (quasisubtemplate-ddd (#,(+ x 4) …))]))
+              '(5 6 7))
+
+(check-equal? (syntax->datum
+               (syntax-case #'(1 2 3) ()
+                 [(x …)
+                  (quasisubtemplate-ddd (a b c))]))
+              '(a b c))
+
+(check-equal? (syntax->datum
+               (syntax-case #'(1 2 3) ()
+                 [(xᵢ …)
+                  (quasisubtemplate-ddd (#,(cons yᵢ (+ xᵢ 4)) …))]))
+              '([1/y . 5] [2/y . 6] [3/y . 7]))
+
+(check-equal? (syntax->datum
+               (syntax-case #'(1 2 3) ()
+                 [(xᵢ …)
+                  (quasisubtemplate-ddd (#,@(list yᵢ (+ xᵢ 4)) …))]))
+              '(1/y 5 2/y 6 3/y 7))
+
+(check-equal? (syntax->datum
+               (syntax-case #'(1 2 3) ()
+                 [(xᵢ …)
+                  (quasisubtemplate-ddd (#,(?@ yᵢ (+ xᵢ 4)) …))]))
+              '(1/y 5 2/y 6 3/y 7))
+
+(check-equal? (syntax->datum
+               (syntax-parse #'([1 2 3] [a #:kw c])
+                 [([xᵢ …] [{~and {~or zᵢ:id #:kw}} …])
+                  (quasisubtemplate-ddd (#,(?? #'zᵢ (?@ #'yᵢ (+ xᵢ 4))) …))]))
+              '(a 2/y 6 c))
+
+(check-equal? (syntax->datum
+               (syntax-case #'([1 2 3] [4 5 6]) ()
+                 [([x …] …)
+                  (quasisubtemplate-ddd ((#,(- x) …) …))]))
+              '((-1 -2 -3) (-4 -5 -6)))
+
+(check-equal? (syntax->datum
+               (syntax-case #'([1 2 3] [4 5 6]) ()
+                 [([x …] …)
+                  (quasisubtemplate-ddd (([#,(- x) #,,x] …) …))]))
+              (let ([l '((1 2 3) (4 5 6))])
+                `(([-1 ,l] [-2 ,l] [-3 ,l]) ([-4 ,l] [-5 ,l] [-6 ,l]))))
+
+(check-equal? (syntax->datum
+               (syntax-case #'([1 2 3] [4 5 6]) ()
+                 [([x …] …)
+                  (quasisubtemplate-ddd (([#,(- x) #,,@x] …) …))]))
+              (let ([l '((1 2 3) (4 5 6))])
+                `(([-1 ,@l] [-2 ,@l] [-3 ,@l]) ([-4 ,@l] [-5 ,@l] [-6 ,@l]))))

unsyntax-preparse.rkt

@@ -0,0 +1,100 @@
+#lang racket/base
+
+(provide quasitemplate-ddd
+         quasisubtemplate-ddd)
+
+(require (rename-in stxparse-info/parse/experimental/template
+                    [?? stxparse:??]
+                    [?@ stxparse:?@])
+         subtemplate/ddd-forms
+         subtemplate/template-subscripts
+         (only-in racket/base [... …])
+         stxparse-info/parse
+         stxparse-info/case
+         (for-syntax racket/base
+                     racket/list
+                     racket/syntax
+                     stxparse-info/parse
+                     (only-in racket/base [... …])
+                     phc-toolkit/untyped))
+
+(define-for-syntax lifted (make-parameter #f))
+
+(define-for-syntax (pre-parse-unsyntax tmpl depth escapes)
+  ;; TODO: a nested quasisubtemplate should escape an unsyntax!
+  (define (ds e)
+    ;; TODO: should preserve the shape of the original stx
+    ;; (syntax list vs syntax pair)
+    (datum->syntax tmpl e tmpl tmpl))
+  (define-syntax-class ooo
+    (pattern {~and ooo {~literal ...}}))
+  (define (recur t) (pre-parse-unsyntax t depth escapes))
+  (define (stx-length stx) (length (syntax->list stx)))
+  (define (lift! e) (set-box! (lifted) (cons e (unbox (lifted)))))
+  (syntax-parse tmpl
+    #:literals (unsyntax unsyntax-splicing unquote unquote-splicing
+                         quasitemplate ?? ?@)
+    [:id tmpl]
+    [({~and u unsyntax} (unquote e)) ;; full unquote with #,,
+     (ds `(,#'u ,#'e))]
+    [({~and u unsyntax-splicing} (unquote e)) ;; full unquote with #,@,
+     (ds `(,#'u ,#'e))]
+    [({~and u unsyntax} (unquote-splicing e)) ;; full unquote with #,,@
+     (ds `(,(datum->syntax #'here 'unsyntax-splicing #'u) ,#'e))]
+    [({~and u unsyntax} e)
+     #:when (= escapes 0)
+     (with-syntax ([tmp (generate-temporary #'e)]
+                   [ooo* (map (λ (_) (quote-syntax …)) (range depth))])
+       (lift! #`(begin (define/with-syntax tmp (splice-append e)) . ooo*))
+       (ds `(,#'stxparse:?@ . ,(datum->syntax #'tmp #'tmp #'e))))]
+    [({~and u unsyntax-splicing} e)
+     #:when (= escapes 0)
+     (with-syntax ([tmp (generate-temporary #'e)]
+                   [ooo* (map (λ (_) (quote-syntax …)) (range depth))])
+       (lift! #`(begin (define/with-syntax tmp (splice-append* e)) . ooo*))
+       #'(stxparse:?@ . tmp))]
+    [({~and u {~or unsyntax unsyntax-splicing}} e)
+     ;; when escapes ≠ 0
+     (ds `(,#'u ,(pre-parse-unsyntax e depth (sub1 escapes))))]
+    [(quasitemplate t . opts)
+     (ds `(,#'quasitemplate ,(pre-parse-unsyntax #'t depth (add1 escapes))
+                            . ,#'opts))]
+    [({~var mf (static template-metafunction? "template metafunction")} . args)
+     (ds `(,#'mf . ,(recur #'args)))]
+    [(:ooo t)
+     tmpl] ;; fully escaped, do not change
+    [(?? . args)
+     (ds `(,#'stxparse:?? . ,(recur #'args)))]
+    [(?@ . args)
+     (ds `(,#'stxparse:?@ . ,(recur #'args)))]
+    [(hd :ooo ...+ . tl)
+     (ds `(,(pre-parse-unsyntax #'hd (+ depth (stx-length #'(ooo …))) escapes)
+           ,@(syntax->list #'(ooo ...))
+           . ,(recur #'tl)))]
+    [(hd . tl)
+     (ds `(,(recur #'hd) . ,(recur #'tl)))]
+    [#(t …)
+     (ds (list->vector (stx-map recur #'(t …))))]
+    [()
+     tmpl]))
+
+(define-for-syntax ((quasi*template-ddd form) stx)
+  (syntax-case stx ()
+    [(_ tmpl . opts)
+     (parameterize ([lifted (box '())])
+       (let ([new-tmpl (pre-parse-unsyntax #'tmpl 0 0)])
+         (if (null? (unbox (lifted)))
+             (datum->syntax stx
+                            `(,form ,new-tmpl . ,#'opts)
+                            stx
+                            stx)
+             (quasisyntax/top-loc stx
+               (let-values ()
+                 #,@(unbox (lifted))
+                 #,(datum->syntax stx
+                                  `(,form ,new-tmpl . ,#'opts)
+                                  stx
+                                  stx))))))]))
+
+(define-syntax quasitemplate-ddd (quasi*template-ddd #'quasitemplate))
+(define-syntax quasisubtemplate-ddd (quasi*template-ddd #'quasisubtemplate))