Initial commit

.gitignore

@@ -0,0 +1,6 @@
+*~
+\#*
+.\#*
+.DS_Store
+compiled/
+/doc/

.travis.yml

@@ -0,0 +1,60 @@
+language: c
+
+# Based from: https://github.com/greghendershott/travis-racket
+
+# Optional: Remove to use Travis CI's older infrastructure.
+sudo: false
+
+env:
+  global:
+    # Supply a global RACKET_DIR environment variable. This is where
+    # Racket will be installed. A good idea is to use ~/racket because
+    # that doesn't require sudo to install and is therefore compatible
+    # with Travis CI's newer container infrastructure.
+    - RACKET_DIR=~/racket
+  matrix:
+    # Supply at least one RACKET_VERSION environment variable. This is
+    # used by the install-racket.sh script (run at before_install,
+    # below) to select the version of Racket to download and install.
+    #
+    # 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
+    # - RACKET_VERSION=6.1
+    # - RACKET_VERSION=6.1.1
+    - RACKET_VERSION=6.2
+    - RACKET_VERSION=6.3
+    - RACKET_VERSION=6.4
+    - RACKET_VERSION=6.5
+    - RACKET_VERSION=6.6
+    - RACKET_VERSION=6.7
+    - RACKET_VERSION=HEAD
+
+matrix:
+  allow_failures:
+#   - env: RACKET_VERSION=HEAD
+  fast_finish: true
+
+before_install:
+- git clone https://github.com/greghendershott/travis-racket.git ~/travis-racket
+- cat ~/travis-racket/install-racket.sh | bash # pipe to bash not sh!
+- export PATH="${RACKET_DIR}/bin:${PATH}" #install-racket.sh can't set for us
+
+install:
+ - raco pkg install --deps search-auto
+
+before_script:
+
+# Here supply steps such as raco make, raco test, etc.  You can run
+# `raco pkg install --deps search-auto` to install any required
+# packages without it getting stuck on a confirmation prompt.
+script:
+ - raco test -x -p auto-syntax-e
+ - raco setup --check-pkg-deps --pkgs auto-syntax-e;
+ - raco pkg install doc-coverage
+ - raco doc-coverage auto-syntax-e
+
+after_success:
+ - raco pkg install --deps search-auto cover cover-coveralls
+ - raco cover -b -f coveralls -d $TRAVIS_BUILD_DIR/coverage .

LICENSE.txt

@@ -0,0 +1,11 @@
+auto-syntax-e
+Copyright (c) 2016 georges
+
+This package is distributed under the GNU Lesser General Public
+License (LGPL).  This means that you can link auto-syntax-e into proprietary
+applications, provided you follow the rules stated in the LGPL.  You
+can also modify this package; if you distribute a modified version,
+you must distribute it under the terms of the LGPL, which in
+particular means that you must release the source code for the
+modified software.  See http://www.gnu.org/copyleft/lesser.html
+for more information.

README.md

@@ -0,0 +1,3 @@
+auto-syntax-e
+=============
+README text here.

info.rkt

@@ -0,0 +1,10 @@
+#lang info
+(define collection "auto-syntax-e")
+(define deps '("base"
+               "rackunit-lib"))
+(define build-deps '("scribble-lib"
+                     "racket-doc"))
+(define scribblings '(("scribblings/auto-syntax-e.scrbl" ())))
+(define pkg-desc "Description Here")
+(define version "0.0")
+(define pkg-authors '(georges))

main.rkt

@@ -0,0 +1,127 @@
+#lang racket/base
+
+(require racket/match
+         syntax/parse
+         (for-syntax racket/base
+                     racket/syntax
+                     racket/list
+                     racket/struct
+                     syntax/parse
+                     racket/private/sc)
+         ;; attribute-mapping? is provided for-syntax
+         (only-in syntax/parse/private/residual attribute-mapping?))
+
+(provide auto-with-syntax)
+(provide auto-syntax)
+
+(define (leaves->datum e depth)
+  (if (> depth 0)
+      (map (λ (eᵢ) (leaves->datum eᵢ (sub1 depth))) e)
+      (if (syntax? e)
+          (syntax->datum e)
+          e)))
+        
+
+(define-syntax (to-datum stx)
+  (syntax-case stx ()
+    [(_ id)
+     (syntax-pattern-variable? (syntax-local-value #'id (λ () #f)))
+     (begin
+       (let* ([mapping (syntax-local-value #'id)]
+              [valvar (syntax-mapping-valvar mapping)]
+              [depth (syntax-mapping-depth mapping)])
+         (if (attribute-mapping? (syntax-local-value valvar (λ () #f)))
+             #`(leaves->datum (attribute id) #,depth)
+             #`(leaves->datum #,valvar #,depth))))]))
+
+(begin-for-syntax
+  (define-values (struct:auto-pvar
+                  make-auto-pvar
+                  auto-pvar?
+                  auto-pvar-ref
+                  auto-pvar-set!)
+    (make-struct-type 'auto-pvar
+                      (eval #'struct:syntax-mapping
+                            (module->namespace 'racket/private/sc))
+                      0
+                      0
+                      #f
+                      null
+                      (current-inspector)
+                      (λ (self stx)
+                        #`(to-datum #,stx)))))
+
+(define-for-syntax (syntax->tree/ids e)
+  (cond [(identifier? e) e]
+        [(syntax? e) (syntax->tree/ids (syntax-e e))]
+        [(pair? e) (cons (syntax->tree/ids (car e))
+                         (syntax->tree/ids (cdr e)))]
+        [(vector? e) (map syntax->tree/ids (vector->list e))]
+        [(box? e) (syntax->tree/ids (unbox e))]
+        [(prefab-struct-key e) (map syntax->tree/ids (struct->list e))]
+        [else e]))
+
+(define-for-syntax (syntax->ids e)
+  (filter identifier? (flatten (syntax->tree/ids e))))
+
+(define-syntax auto-syntax
+  (syntax-parser
+    [(_ (id ...) body ...)
+     #:with (pvar-id ...) (filter (λ (id)
+                                    (syntax-pattern-variable?
+                                     (syntax-local-value id (λ () #f))))
+                                  (syntax->list #'(id ...)))
+     (with-disappeared-uses
+      (record-disappeared-uses (syntax->list #'(pvar-id ...)))
+      #'(let-syntax ([pvar-id
+                      (make-set!-transformer
+                       (let ([mapping (syntax-local-value
+                                       (quote-syntax pvar-id))])
+                         (make-auto-pvar (syntax-mapping-depth mapping)
+                                         (syntax-mapping-valvar mapping))))]
+                     ...)
+          body ...))]))
+
+(define-syntax auto-with-syntax
+  (syntax-parser
+    [(_ ([pat e] ...) body ...)
+     #:with (id ...) (syntax->ids #'(pat ...))
+     #'(with-syntax ([pat e] ...)
+         (auto-syntax (id ...)
+           body ...))]))
+
+(module+ test
+  (require rackunit
+           syntax/parse)
+  (check-equal? (match (auto-with-syntax ([x #'123])
+                         (list (add1 x) #'x))
+                  [(list a (? syntax? b))
+                   (list a (syntax-e b))]
+                  [_ 'error])
+                '(124 123))
+
+  (check-equal? (match (syntax-parse #'(1 2 3)
+                         [(x:nat y:nat ...)
+                          (auto-syntax (x y)
+                            (list (map add1 (cons x y)) #'(x y ...)))])
+                  [(list a (? syntax? b))
+                   (list a (syntax->datum b))]
+                  [_ 'error])
+                '((2 3 4) (1 2 3)))
+
+  (check-equal? (match (syntax-parse #'(1 2 3)
+                         [({~seq x:nat {~optional y:nat}} ...)
+                          (auto-syntax (x y)
+                            (list (map cons x y)
+                                  (attribute x)
+                                  (attribute y)))])
+                  [(list a
+                         (list (? syntax? b₁) (? syntax? b₂))
+                         (list (? syntax? c₁) (and #f c₂)))
+                   (list a
+                         (list (syntax->datum b₁) (syntax->datum b₂))
+                         (list (syntax->datum c₁) c₂))]
+                  [_ 'error])
+                '([(1 . 2) (3 . #f)]
+                  [1 3]
+                  [2 #f])))

scribblings/auto-syntax-e.scrbl

@@ -0,0 +1,50 @@
+#lang scribble/manual
+@require[scribble/example
+         @for-label[auto-syntax-e
+                    racket/base
+                    syntax/parse]]
+
+@title{auto-syntax-e}
+@author{georges}
+
+@defmodule[auto-syntax-e]
+
+This package allows using syntax pattern variables outside of syntax
+templates: when @racket[_x] is bound as a syntax pattern variable, writing
+@racket[_x] then becomes roughly equivalent to
+@racket[(syntax->datum #'_x-ddd)], where @racket[_x-ddd] is @racket[x] wrapped
+under the appropriate number of ellipses. If the pattern variable is bound by
+@racket[syntax-parse] and contains non-syntax parts (e.g. it was bound within
+an @racket[~optional] clause, or using @racket[#:attr]), they are left
+unchanged.
+
+@defform[(auto-with-syntax ([patᵢ eᵢ] ...) body ...)]{
+ Like @racket[(with-syntax ([patᵢ eᵢ] ...) body ...)], but the syntax pattern
+ variables bound by the @racket[patᵢ ...] can be used outside of syntax patterns
+ (they are implicitly transformed using @racket[syntax->datum]):
+
+ @examples[#:eval ((make-eval-factory '(auto-syntax-e)))
+           (auto-with-syntax ([x #'123])
+             (list (add1 x) #'x))]}
+
+@defform[(auto-syntax (pvarᵢ ...) body ...)]{
+ Re-binds the syntax pattern variables @racket[pvarᵢ ...], so that can be used
+ outside of syntax patterns like in @racket[auto-with-syntax]:
+
+ @examples[#:eval ((make-eval-factory '(auto-syntax-e syntax/parse)))
+           (syntax-parse #'(1 2 3)
+             [(x:nat y:nat ...)
+              (auto-syntax (x y)
+                (list (map add1 (cons x y)) #'(x y ...)))])
+           (syntax-parse #'(1 2 3)
+             [({~seq x:nat {~optional y:nat}} ...)
+              (auto-syntax (x y)
+                (list (map cons x y)
+                      (attribute x)
+                      (attribute y)))])]
+
+ When one of the @racket[pvarᵢ ...] is not a syntax pattern variable, it is
+ ignored and the existing binding, if any, is left untouched.
+
+ Note that it is not necessary to specify the ellipsis-depth of each
+ @racket[pvarᵢ].}