From 008d1f7f1bed7138a0a84fecfab2b29928942734 Mon Sep 17 00:00:00 2001
From: Ryan Culpepper <ryanc@racket-lang.org>
Date: Sun, 23 Sep 2012 01:24:16 -0400
Subject: [PATCH] syntax/parse/experimental/template: quasitemplate,
 template/loc

---
 .../parse/experimental/private/substitute.rkt |  32 ++-
 .../syntax/parse/experimental/template.rkt    | 246 ++++++++++++++----
 collects/tests/stxparse/test-template.rkt     |  47 +++-
 3 files changed, 279 insertions(+), 46 deletions(-)

diff --git a/collects/syntax/parse/experimental/private/substitute.rkt b/collects/syntax/parse/experimental/private/substitute.rkt
index 92ae21fedc..9e3cdc002c 100644
--- a/collects/syntax/parse/experimental/private/substitute.rkt
+++ b/collects/syntax/parse/experimental/private/substitute.rkt
@@ -30,12 +30,15 @@ A Guide (G) is one of:
   - (vector 'metafun integer G)
   - (vector 'copy-props G (listof symbol))
   - (vector 'set-props G (listof (cons symbol any)))
+  - (vector 'unsyntax VarRef)
+  - (vector 'relocate G)
 
 A HeadGuide (HG) is one of:
   - G
   - (vector 'app-opt H (vector-of integer))
   - (vector 'orelse-h H (vector-of integer) H)
   - (vector 'splice G)
+  - (vector 'unsyntax-splicing VarRef)
 
 An VarRef is one of
   - positive-exact-integer  ;; represents depth=0 pvar ref or metafun ref
@@ -47,6 +50,7 @@ An VarRef is one of
     [(vector 'app-opt g vars) #t]
     [(vector 'splice g) #t]
     [(vector 'orelse-h g1 vars g2) #t]
+    [(vector 'unsyntax-splicing var) #t]
     [_ #f]))
 
 ;; ============================================================
@@ -252,7 +256,22 @@ An VarRef is one of
      (let ([f1 (loop stx g1)])
        (lambda (env lenv)
          (for/fold ([v (f1 env lenv)]) ([entry (in-list props-alist)])
-           (syntax-property v (car entry) (cdr entry)))))]))
+           (syntax-property v (car entry) (cdr entry)))))]
+
+    [(vector 'unsyntax var)
+     (let ([f1 (loop stx var)])
+       (lambda (env lenv)
+         (restx stx (f1 env lenv))))]
+
+    [(vector 'relocate g1 var)
+     (let ([f1 (loop stx g1)])
+       (lambda (env lenv)
+         (let ([result (f1 env lenv)]
+               [loc (get var env lenv)])
+           (if (or (syntax-source loc)
+                   (syntax-position loc))
+               (datum->syntax result (syntax-e result) loc result)
+               result))))]))
 
 (define (translate-hg stx0 stx hg env-length lenv-mode)
   (define (loop stx g) (translate-g stx0 stx g env-length lenv-mode))
@@ -291,6 +310,17 @@ An VarRef is one of
                                  stx))
            v*)))]
 
+    [(vector 'unsyntax-splicing index)
+     (check-var index env-length lenv-mode)
+     (lambda (env lenv)
+       (let* ([v (get index env lenv)]
+              [v* (stx->list v)])
+         (unless (list? v*)
+           (raise-syntax-error 'template
+                               "unsyntax-splicing expression did not produce a syntax list"
+                               stx))
+         v*))]
+
     [_
      (let ([f (loop stx hg)])
        (lambda (env lenv)
diff --git a/collects/syntax/parse/experimental/template.rkt b/collects/syntax/parse/experimental/template.rkt
index d563295e96..dd229110a8 100644
--- a/collects/syntax/parse/experimental/template.rkt
+++ b/collects/syntax/parse/experimental/template.rkt
@@ -8,6 +8,9 @@
          syntax/parse/private/residual
          "private/substitute.rkt")
 (provide template
+         template/loc
+         quasitemplate
+         quasitemplate/loc
          define-template-metafunction
          ??
          ?@)
@@ -27,55 +30,90 @@ A Template (T) is one of:
   - (?? T T)
   - #(T*)
   - #s(prefab-struct-key T*)
+  * (unquote expr)
 
 A HeadTemplate (H) is one of:
   - T
   - (?? H)
   - (?? H H)
   - (?@ . T)
+  * (unquote-splicing expr)
 |#
 
 (begin-for-syntax
- (define (do-template ctx tstx)
-   (parameterize ((current-syntax-context ctx))
-     (let-values ([(guide deps props-guide) (parse-template tstx)])
-       (let ([vars
-              (for/list ([dep (in-vector deps)])
-                (cond [(pvar? dep) (pvar-var dep)]
-                      [(template-metafunction? dep)
-                       (template-metafunction-var dep)]
-                      [else
-                       (error 'template
-                              "internal error: bad environment entry: ~e"
-                              dep)]))])
-         (with-syntax ([t tstx])
-           (syntax-arm
-            (cond [(equal? guide '1)
-                   ;; was (template pvar), implies props-guide = '_
-                   (car vars)]
-                  [(and (equal? guide '_) (equal? props-guide '_))
-                   #'(quote-syntax t)]
-                  [else
-                   (with-syntax ([guide guide]
-                                 [props-guide props-guide]
-                                 [vars-vector
-                                  (if (pair? vars)
-                                      #`(vector . #,vars)
-                                      #''#())])
-                     #'(substitute (quote-syntax t)
+ (define (do-template ctx tstx quasi? loc-id)
+   (parameterize ((current-syntax-context ctx)
+                  (quasi (and quasi? (box null))))
+     (let*-values ([(guide deps props-guide) (parse-template tstx loc-id)]
+                   [(vars)
+                    (for/list ([dep (in-vector deps)])
+                      (cond [(pvar? dep) (pvar-var dep)]
+                            [(template-metafunction? dep)
+                             (template-metafunction-var dep)]
+                            [else
+                             (error 'template
+                                    "internal error: bad environment entry: ~e"
+                                    dep)]))])
+       (with-syntax ([t tstx])
+         (syntax-arm
+          (cond [(equal? guide '1)
+                 ;; was (template pvar), implies props-guide = '_
+                 (car vars)]
+                [(and (equal? guide '_) (equal? props-guide '_))
+                 #'(quote-syntax t)]
+                [else
+                 (with-syntax ([guide guide]
+                               [props-guide props-guide]
+                               [vars-vector
+                                (if (pair? vars)
+                                    #`(vector . #,vars)
+                                    #''#())]
+                               [((un-var . un-form) ...)
+                                (if quasi? (reverse (unbox (quasi))) null)])
+                   #'(let ([un-var (handle-unsyntax un-form)] ...)
+                       (substitute (quote-syntax t)
                                    'props-guide
                                    'guide
-                                   vars-vector))]))))))))
+                                   vars-vector)))])))))))
 
 (define-syntax (template stx)
   (syntax-case stx ()
     [(template t)
-     (do-template stx #'t)]
+     (do-template stx #'t #f #f)]
     [(template t #:properties (prop ...))
      (andmap identifier? (syntax->list #'(prop ...)))
      (parameterize ((props-to-serialize (syntax->datum #'(prop ...)))
                     (props-to-transfer (syntax->datum #'(prop ...))))
-       (do-template stx #'t))]))
+       (do-template stx #'t #f #f))]))
+
+(define-syntax (quasitemplate stx)
+  (syntax-case stx ()
+    [(quasitemplate t)
+     (do-template stx #'t #t #f)]))
+
+(define-syntaxes (template/loc quasitemplate/loc)
+  ;; FIXME: better to replace unsyntax form, shrink template syntax constant
+  (let ([make-tx
+         (lambda (quasi?)
+           (lambda (stx)
+             (syntax-case stx ()
+               [(?/loc loc-expr t)
+                (syntax-arm
+                 (with-syntax ([main-expr (do-template stx #'t quasi? #'loc-stx)])
+                   #'(let ([loc-stx (handle-loc '?/loc loc-expr)])
+                       main-expr)))])))])
+    (values (make-tx #f) (make-tx #t))))
+
+(define (handle-loc who x)
+  (if (syntax? x)
+      x
+      (raise-argument-error who "syntax?" x)))
+
+;; FIXME: what lexical context should result of expr get if not syntax?
+(define-syntax handle-unsyntax
+  (syntax-rules (unsyntax unsyntax-splicing)
+    [(handle-syntax (unsyntax expr)) expr]
+    [(handle-syntax (unsyntax-splicing expr)) expr]))
 
 ;; substitute-table : hash[stx => translated-template]
 ;; Cache for closure-compiled templates. Key is just syntax of
@@ -179,14 +217,26 @@ instead of integers and integer vectors.
  ;; props-to-transfer : (parameterof (listof symbol))
  (define props-to-transfer (make-parameter '(paren-shape)))
 
- ;; parse-template : stx -> (values guide (vectorof env-entry) guide)
- (define (parse-template t)
-   (let-values ([(drivers pre-guide props-guide) (parse-t t 0 #f)])
-     (define main-env (set->env drivers (hash)))
-     (define guide (guide-resolve-env pre-guide main-env))
-     (values guide
-             (index-hash->vector main-env)
-             props-guide)))
+ ;; quasi : (parameterof (or/c #f (list^n (boxof QuasiPairs))))
+ ;; each list wrapper represents nested quasi wrapping
+ ;; QuasiPairs = (listof (cons/c identifier syntax))
+ (define quasi (make-parameter #f))
+
+ ;; parse-template : stx id/#f -> (values guide (vectorof env-entry) guide)
+ (define (parse-template t loc-id)
+   (let*-values ([(drivers pre-guide props-guide) (parse-t t 0 #f)]
+                 [(drivers pre-guide)
+                  (if loc-id
+                      (let* ([loc-sm (make-syntax-mapping 0 loc-id)]
+                             [loc-pvar (pvar loc-sm #f #f)])
+                        (values (set-union drivers (set loc-pvar))
+                                (relocate-guide pre-guide loc-pvar)))
+                      (values drivers pre-guide))])
+     (let* ([main-env (set->env drivers (hash))]
+            [guide (guide-resolve-env pre-guide main-env)])
+       (values guide
+               (index-hash->vector main-env)
+               props-guide))))
 
  ;; set->env : (setof env-entry) -> hash[env-entry => nat]
  (define (set->env drivers init-env)
@@ -261,11 +311,73 @@ instead of integers and integer vectors.
                   (get-index ee)))]
        [(vector 'splice g1)
         (vector 'splice (loop g1 loop-env))]
+       [(vector 'unsyntax var)
+        (vector 'unsyntax (get-index var))]
+       [(vector 'unsyntax-splicing var)
+        (vector 'unsyntax-splicing (get-index var))]
+       [(vector 'relocate g1 var)
+        (vector 'relocate (loop g1 loop-env) (get-index var))]
        [else (error 'template "internal error: bad pre-guide: ~e" g)]))
    (loop g0 '#hash()))
 
  ;; ----------------------------------------
 
+ ;; relocate-gude : stx guide -> guide
+ (define (relocate-guide g0 loc-pvar)
+   (define (relocate g)
+     (vector 'relocate g loc-pvar))
+   (define (error/no-relocate)
+     (wrong-syntax #f "cannot apply syntax location to template"))
+   (define (loop g)
+     (match g
+       ['_
+        (relocate g)]
+       [(cons g1 g2)
+        (relocate g)]
+       [(? pvar? g)
+        g]
+       [(vector 'dots head new-hdrivers/level nesting '#f tail)
+        ;; Ideally, should error. For perfect backwards compatability,
+        ;; should relocate. But if there are zero iterations, that
+        ;; means we'd relocate tail (which might be bad). Making
+        ;; relocation depend on number of iterations would be
+        ;; complicated. So just ignore.
+        g]
+       [(vector 'escaped g1)
+        (vector 'escaped (loop g1))]
+       [(vector 'vector g1)
+        (relocate g)]
+       [(vector 'struct g1)
+        (relocate g)]
+       [(vector 'box g1)
+        (relocate g)]
+       [(vector 'copy-props g1 keys)
+        (vector 'copy-props (loop g1) keys)]
+       [(vector 'unsyntax var)
+        g]
+       ;; ----
+       [(vector 'app ghead gtail)
+        (match ghead
+          [(vector 'unsyntax-splicing _) g]
+          [_ (error/no-relocate)])]
+       ;; ----
+       [(vector 'orelse g1 drivers1 g2)
+        (error/no-relocate)]
+       [(vector 'orelse-h g1 drivers1 g2)
+        (error/no-relocate)]
+       [(vector 'metafun mf g1)
+        (error/no-relocate)]
+       [(vector 'app-opt g1 drivers1)
+        (error/no-relocate)]
+       [(vector 'splice g1)
+        (error/no-relocate)]
+       [(vector 'unsyntax-splicing var)
+        g]
+       [else (error 'template "internal error: bad guide for relocation: ~e" g0)]))
+   (loop g0))
+
+ ;; ----------------------------------------
+
  (define (wrap-props stx env-set pre-guide props-guide)
    (let ([saved-prop-values
           (if (syntax? stx)
@@ -315,13 +427,16 @@ instead of integers and integer vectors.
 
  ;; parse-t : stx nat boolean -> (values (setof env-entry) pre-guide props-guide)
  (define (parse-t t depth esc?)
-   (syntax-case t (?? ?@)
+   (syntax-case t (?? ?@ unsyntax quasitemplate)
      [id
       (identifier? #'id)
-      (cond [(and (not esc?)
-                  (or (free-identifier=? #'id (quote-syntax ...))
-                      (free-identifier=? #'id (quote-syntax ??))
-                      (free-identifier=? #'id (quote-syntax ?@))))
+      (cond [(or (and (not esc?)
+                      (or (free-identifier=? #'id (quote-syntax ...))
+                          (free-identifier=? #'id (quote-syntax ??))
+                          (free-identifier=? #'id (quote-syntax ?@))))
+                 (and (quasi)
+                      (or (free-identifier=? #'id (quote-syntax unsyntax))
+                          (free-identifier=? #'id (quote-syntax unsyntax-splicing)))))
              (wrong-syntax #'id "illegal use")]
             [else
              (let ([pvar (lookup #'id depth)])
@@ -340,6 +455,31 @@ instead of integers and integer vectors.
         (values (set-union (set mf) drivers)
                 (vector 'metafun mf guide)
                 (cons-guide '_ props-guide)))]
+     [(unsyntax t1)
+      (quasi)
+      (let ([qval (quasi)])
+        (cond [(box? qval)
+               (with-syntax ([(tmp) (generate-temporaries #'(unsyntax-expr))])
+                 (set-box! qval (cons (cons #'tmp t) (unbox qval)))
+                 (let* ([fake-sm (make-syntax-mapping 0 #'tmp)]
+                        [fake-pvar (pvar fake-sm #f #f)])
+                   (values (set fake-pvar) (vector 'unsyntax fake-pvar) '_)))]
+              [else
+               (parameterize ((quasi (car qval)))
+                 (let-values ([(drivers guide props-guide) (parse-t #'t1 depth esc?)])
+                   (wrap-props t
+                               drivers
+                               (list-guide '_ guide)
+                               (list-guide '_ props-guide))))]))]
+     [(quasitemplate t1)
+      ;; quasitemplate escapes inner unsyntaxes
+      (quasi)
+      (parameterize ((quasi (list (quasi))))
+        (let-values ([(drivers guide props-guide) (parse-t #'t1 depth esc?)])
+          (wrap-props t
+                      drivers
+                      (list-guide '_ guide)
+                      (list-guide '_ props-guide))))]
      [(DOTS template)
       (and (not esc?)
            (identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...)))
@@ -426,7 +566,7 @@ instead of integers and integer vectors.
 
  ;; parse-h : stx nat boolean -> (values (setof env-entry) boolean pre-head-guide props-guide)
  (define (parse-h h depth esc?)
-   (syntax-case h (?? ?@)
+   (syntax-case h (?? ?@ unsyntax-splicing)
      [(?? t)
       (not esc?)
       (let-values ([(drivers splice? guide props-guide)
@@ -447,6 +587,24 @@ instead of integers and integer vectors.
       (not esc?)
       (let-values ([(drivers guide props-guide) (parse-t #'t depth esc?)])
         (values drivers #t (vector 'splice guide) (cons-guide '_ props-guide)))]
+     [(unsyntax-splicing t1)
+      (quasi)
+      (let ([qval (quasi)])
+        (cond [(box? qval)
+               (with-syntax ([(tmp) (generate-temporaries #'(unsyntax-splicing-expr))])
+                 (set-box! qval (cons (cons #'tmp h) (unbox qval)))
+                 (let* ([fake-sm (make-syntax-mapping 0 #'tmp)]
+                        [fake-pvar (pvar fake-sm #f #f)])
+                   (values (set fake-pvar) #t (vector 'unsyntax-splicing fake-pvar) '_)))]
+              [else
+               (parameterize ((quasi (car qval)))
+                 (let*-values ([(drivers guide props-guide) (parse-t #'t1 depth esc?)]
+                               [(drivers guide props-guide)
+                                (wrap-props h
+                                            drivers
+                                            (list-guide '_ guide)
+                                            (list-guide '_ props-guide))])
+                   (values drivers #f guide props-guide)))]))]
      [t
       (let-values ([(drivers guide props-guide) (parse-t #'t depth esc?)])
         (values drivers #f guide props-guide))]))
diff --git a/collects/tests/stxparse/test-template.rkt b/collects/tests/stxparse/test-template.rkt
index 1ab58b4c11..16a50b6017 100644
--- a/collects/tests/stxparse/test-template.rkt
+++ b/collects/tests/stxparse/test-template.rkt
@@ -142,7 +142,6 @@
 
 ;; ----------------------------------------
 
-
 (define-template-metafunction (join stx)
   (syntax-parse stx
     [(join a:id b:id ...)
@@ -162,6 +161,18 @@
 (tc (template ((xx (join aa xx)) ...))
     '((x ax) (y by) (z cz)))
 
+;; ----------------------------------------
+
+(tc (quasitemplate (a #,'b))
+    '(a b))
+(tc (quasitemplate ((aa #,'0) ...))
+    '((a 0) (b 0) (c 0)))
+
+;; quasiquote-style nesting
+(tc (quasitemplate (#,1 (quasitemplate #,(+ 1 2))))
+    '(1 (quasitemplate (unsyntax (+ 1 2)))))
+(tc (quasitemplate (#,1 (quasitemplate #,#,(+ 1 2))))
+    '(1 (quasitemplate (unsyntax 3))))
 
 ;; ============================================================
 
@@ -192,3 +203,37 @@
 
 (terx (with-syntax ([(bb ...) #'(y z)]) (template ((aa bb) ...)))
       #rx"incompatible ellipsis match counts")
+
+;; ============================================================
+
+(define loc (datum->syntax #'here 'loc (list "I have a location!" #f #f 42 17)))
+
+(define-syntax-rule (tloc tform tmpl loc?)
+  (test-case (format "~s" '(loc tmpl))
+    (let ([result (convert-syntax-error (tform loc tmpl))])
+      (cond [loc?
+             (check-equal? (syntax-source result) (syntax-source loc))
+             (check-equal? (syntax-position result) (syntax-position loc))]
+            [else
+             (check-equal? (syntax-source result) (syntax-source (quote-syntax here)))]))))
+
+(tloc template/loc uu #f)
+(tloc template/loc lambda #t)
+(tloc template/loc (lambda (x) x) #t)
+(tloc template/loc (aa ... 1) #f)
+(terx (template/loc loc ((?@ aa ...) 2))
+      #rx"cannot apply syntax location to template")
+(terx (template/loc loc (?? 1 2))
+      #rx"cannot apply syntax location to template")
+
+(tloc quasitemplate/loc uu #f)
+(tloc quasitemplate/loc lambda #t)
+(tloc quasitemplate/loc (lambda (x) x) #t)
+(tloc quasitemplate/loc (aa ... 1) #f)
+(tloc quasitemplate/loc (#,'a) #t)
+(tloc quasitemplate/loc #,'a #f)
+(tloc quasitemplate/loc (#,@(list 1 2 3)) #f)
+(terx (quasitemplate/loc loc ((?@ aa ...) 2))
+      #rx"cannot apply syntax location to template")
+(terx (quasitemplate/loc loc (?? 1 2))
+      #rx"cannot apply syntax location to template")