commit a9c8f48832e25ca1c2e67dbb3c9f3f4106e25cba
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Thu, 20 Oct 2016 00:53:37 +0200
Initial commit
Diffstat:
7 files changed, 268 insertions(+), 0 deletions(-)
diff --git a/.gitignore b/.gitignore
@@ -0,0 +1,6 @@
+*~
+\#*
+.\#*
+.DS_Store
+compiled/
+/doc/
diff --git a/.travis.yml b/.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 .
diff --git a/LICENSE.txt b/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.
diff --git a/README.md b/README.md
@@ -0,0 +1,3 @@
+auto-syntax-e
+=============
+README text here.
diff --git a/info.rkt b/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))
diff --git a/main.rkt b/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])))
diff --git a/scribblings/auto-syntax-e.scrbl b/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ᵢ].}
+\ No newline at end of file
