Beginning of an attempt to implement unsyntax in a ellipsis-preserving way (does not work)

.travis.yml

@@ -20,7 +20,7 @@ env:
     # Supply more than one RACKET_VERSION (as in the example below) to
     # create a Travis-CI build matrix to test against multiple Racket
     # versions.
-    #- RACKET_VERSION=6.0 # Version 6.0 fails to download some packages from the catalog because of an SSL version incompatibility. Build for that version disabled for now.
+    - RACKET_VERSION=6.0
     - RACKET_VERSION=6.1
     - RACKET_VERSION=6.1.1
     - RACKET_VERSION=6.2
@@ -29,15 +29,6 @@ env:
     - RACKET_VERSION=6.5
     - RACKET_VERSION=6.6
     - RACKET_VERSION=6.7
-    - RACKET_VERSION=6.8
-    - RACKET_VERSION=6.9
-    - RACKET_VERSION=6.10
-    - RACKET_VERSION=6.10.1
-    - RACKET_VERSION=6.11
-    - RACKET_VERSION=6.12
-    - RACKET_VERSION=7.0
-    - RACKET_VERSION=7.1
-    - RACKET_VERSION=7.2
     - RACKET_VERSION=HEAD
 
 matrix:
@@ -59,7 +50,7 @@ before_script:
 # `raco pkg install --deps search-auto` to install any required
 # packages without it getting stuck on a confirmation prompt.
 script:
- - raco test -r -p backport-template-pr1514
+ - raco test -x -p backport-template-pr1514
  - if test $RACKET_VERSION != 6.0 -a $RACKET_VERSION != 6.1; then raco setup --check-pkg-deps --pkgs backport-template-pr1514; fi
 
 after_success:

LICENSE.txt

@@ -1,6 +1,5 @@
 backport-template-pr1514
-
-This package is based on the patch https://github.com/racket/racket/pull/1514 and on the code that it modifies as well as related code from that same repository.
+Copyright (c) 2016 georges
 
 This package is distributed under the GNU Lesser General Public
 License (LGPL).  This means that you can link backport-template-pr1514 into proprietary

experimental/template.rkt

@@ -1,6 +1,4 @@
 #lang racket/base
-(require version-case (for-syntax racket/base))
-(version-case [(version< (version) "6.90.0.24") ;; not exactly the precise version number I think
 (require (for-syntax racket/base
                      "dset.rkt"
                      racket/syntax
@@ -445,6 +443,9 @@ instead of integers and integer vectors.
            (template-metafunction? (lookup #'mf #f)))
       (let-values ([(mf) (lookup #'mf #f)]
                    [(drivers guide props-guide) (parse-t #'template depth esc?)])
+        (displayln drivers)
+        (displayln guide)
+        (displayln props-guide)
         (values (dset-add drivers mf)
                 (vector 'metafun mf guide)
                 (cons-guide '_ props-guide)))]
@@ -660,54 +661,3 @@ instead of integers and integer vectors.
    (cond [(zero? n) x]
          [else (stx-drop (sub1 n) (stx-cdr x))]))
  )
-]
-[else
-(require (for-syntax racket/base)
-         (only-in racket/private/template
-                  metafunction))
-(provide (rename-out [syntax template]
-                     [syntax/loc template/loc]
-                     [quasisyntax quasitemplate]
-                     [quasisyntax/loc quasitemplate/loc]
-                     [~? ??]
-                     [~@ ?@])
-         define-template-metafunction
-         syntax-local-template-metafunction-introduce)
-
-;; ============================================================
-;; Metafunctions
-
-(define-syntax (define-template-metafunction stx)
-  (syntax-case stx ()
-    [(dsm (id arg ...) . body)
-     #'(dsm id (lambda (arg ...) . body))]
-    [(dsm id expr)
-     (identifier? #'id)
-     (with-syntax ([(internal-id) (generate-temporaries #'(id))])
-       #'(begin (define internal-id (make-hygienic-metafunction expr))
-                (define-syntax id (metafunction (quote-syntax internal-id)))))]))
-
-(define current-template-metafunction-introducer
-  (make-parameter (lambda (stx) (if (syntax-transforming?) (syntax-local-introduce stx) stx))))
-
-(define old-template-metafunction-introducer
-  (make-parameter #f))
-
-(define ((make-hygienic-metafunction transformer) stx)
-  (define mark (make-syntax-introducer))
-  (define old-mark (current-template-metafunction-introducer))
-  (parameterize ((current-template-metafunction-introducer mark)
-                 (old-template-metafunction-introducer old-mark))
-    (define r (call-with-continuation-barrier (lambda () (transformer (mark (old-mark stx))))))
-    (unless (syntax? r)
-      (raise-syntax-error #f "result of template metafunction was not syntax" stx))
-    (old-mark (mark r))))
-
-(define (syntax-local-template-metafunction-introduce stx)
-  (let ([mark (current-template-metafunction-introducer)]
-        [old-mark (old-template-metafunction-introducer)])
-    (unless old-mark
-      (error 'syntax-local-template-metafunction-introduce
-             "must be called within the dynamic extent of a template metafunction"))
-    (mark (old-mark stx))))
-])

info.rkt

@@ -1,10 +1,9 @@
 #lang info
 (define collection "backport-template-pr1514")
 (define deps '("base"
-               "rackunit-lib"
-               "version-case"))
+               "rackunit-lib"))
 (define build-deps '("scribble-lib" "racket-doc"))
 (define scribblings '(("scribblings/backport-template-pr1514.scrbl" ())))
 (define pkg-desc "Description Here")
 (define version "0.0")
-(define pkg-authors '(|Suzanne Soy|))
+(define pkg-authors '(georges))

scribblings/backport-template-pr1514.scrbl

@@ -3,7 +3,7 @@
                     racket/base]]
 
 @title{backport-template-pr1514}
-@author[@author+email["Suzanne Soy" "racket@suzanne.soy"]]
+@author{georges}
 
 @defmodule[backport-template-pr1514]
 

template-unsyntax-ellipsis.rkt

@@ -0,0 +1,94 @@
+#lang racket
+
+(require (for-syntax phc-toolkit/untyped
+                     racket/contract
+                     racket/private/sc)
+         syntax/parse/experimental/template
+         (prefix-in backport: backport-template-pr1514/experimental/template))
+(provide escape)
+
+(begin-for-syntax
+  (require racket/syntax)
+  (define/with-syntax ooo #'(... ...)))
+
+(define-syntax (mysyntax stx)
+  (syntax-case stx ()
+    [(_ v)
+     #'(syntax (ooo v))]))
+
+(define-for-syntax (force-expand e)
+  (define e1 (local-expand e 'expression (list #'quote
+                                               #'syntax
+                                               #'template
+                                               #'backport:template)))
+  ;(displayln (list (syntax->datum e) (syntax->datum e1)))
+  (syntax-case e1 (syntax template backport:template
+                          begin quote set! #%plain-lambda
+                          ;; TODO:
+                          case-lambda let-values
+                          letrec-values if begin0 with-continuation-mark
+                          letrec-syntaxes+values #%plain-app #%expression #%top
+                          #%variable-reference)
+    [(begin _ ...)
+     (datum->syntax e1 (map force-expand (syntax->list e1)) e1 e1)]
+    [(set! _ ...)
+     (datum->syntax e1 (map force-expand (syntax->list e1)) e1 e1)]
+    [(#%plain-lambda args body ...)
+     (datum->syntax e1 (list (stx-car e1)
+                             #'args
+                             (stx-map force-expand #'(body ...)))
+                    e1 e1)]
+    [(quote _)
+     e1]
+    [(syntax . rest)
+     (displayln (syntax->datum #'rest))
+     #`(quote-syntax #,e1)]
+    [(template . rest)
+     (displayln (syntax->datum #'rest))
+     #`(quote-syntax #,e1)]
+    [(backport:template . rest)
+     (displayln (syntax->datum #'rest))
+     #`(quote-syntax #,e1)]
+    [(_ ...)
+     (datum->syntax e1 (map force-expand (syntax->list e1)) e1 e1)]
+    [_
+     e1]))
+
+
+
+;make-syntax-mapping syntax-pattern-variable?
+;syntax-mapping-depth syntax-mapping-valvar
+
+(define-syntax (escape stx)
+  (syntax-case stx ()
+    [(_ body)
+     (force-expand #'body)]))
+
+;; Doesn't work.
+#;(begin
+    (define-for-syntax exn-ellipses/c
+      (struct/c exn:fail:syntax
+                (regexp-match/c
+                 #px"syntax: too few ellipses for pattern variable in template")
+                any/c
+                (list/c identifier?)))
+    (define-syntax (escape stx)
+      (syntax-case stx ()
+        [(_ body)
+         (let ()
+           (define used-pvars '())
+           (define (push-pvar! pvar)
+             (set! used-pvars (cons pvar used-pvars)))
+           ;(let loop ([used-pvars '()])
+           (with-handlers ([exn-ellipses/c
+                            (λ (exn)
+                              ;; Can't do syntax-local-value :-(
+                              (displayln (syntax-local-value (car (exn:fail:syntax-exprs exn))))
+                              (push-pvar! (car (exn:fail:syntax-exprs exn))))])
+             (local-expand #'body 'expression (list)))
+           ;(displayln (syntax-pattern-variable? (syntax-local-value (car used-pvars))))
+           (with-handlers ([exn-ellipses/c
+                            (λ (exn)
+                              (push-pvar! (car (exn:fail:syntax-exprs exn))))])
+             (displayln (local-expand #'body 'expression (list))))
+           #'(void))])))

test-template-unsyntax-ellipsis.rkt

@@ -0,0 +1,18 @@
+#lang racket
+(require "template-unsyntax-ellipsis.rkt"
+         syntax/stx
+         syntax/parse/experimental/template)
+
+#;(syntax-case #'((1 2) (3 4)) ()
+    [((x ...) ...)
+     (escape (stx-map (λ (xᵢ) (+ (syntax-e xᵢ) 1))
+                      (template (x ...))))])
+
+(syntax-case #'((1 2) (3 4)) ()
+  [((x ...) ...)
+   (escape (stx-map (λ (xᵢ)
+                      (define-syntax (a stx)
+                        (datum->syntax stx (string->symbol xᵢ)))
+                      (a)
+                      (+ (syntax-e xᵢ) 1))
+                    #'(x ...)))])