suzanne.soy/backport-template-pr1514
1
0
Fork 0
Code Issues 1 Pull Requests Actions Packages Projects Releases Wiki Activity

Initial commit

Browse Source
This commit is contained in:
Georges Dupéron 2016-11-10 17:32:48 +01:00
commit e463102f09
10 changed files with 1349 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
.gitignore vendored Normal file
View File

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

55
.travis.yml Normal file
View File

@ -0,0 +1,55 @@
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=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 backport-template-pr1514
after_success:
- raco setup --check-pkg-deps --pkgs backport-template-pr1514
- raco pkg install --deps search-auto cover cover-coveralls
- raco cover -b -f coveralls -d $TRAVIS_BUILD_DIR/coverage .

11
LICENSE.txt Normal file
View File

@ -0,0 +1,11 @@
backport-template-pr1514
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
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.

19
README.md Normal file
View File

@ -0,0 +1,19 @@
backport-template-pr1514
========================
Pull Request https://github.com/racket/racket/pull/1514 for syntax/parse/experimental/template, backported as a package, so that `syntax-local-template-metafunction-introduce` can be used on older versions.
License
-------
Racket
Copyright (c) 2010-2016 PLT Design Inc.
Racket is distributed under the GNU Lesser General Public License
(LGPL). This implies that you may link Racket into proprietary
applications, provided you follow the rules stated in the LGPL. You can
also modify Racket; if you distribute a modified version, you must
distribute it under the terms of the LGPL, which in particular states
that you must release the source code for the modified software.
See racket/src/COPYING_LESSER.txt for more information.

54
experimental/dset.rkt Normal file
View File

@ -0,0 +1,54 @@
#lang racket/base
;; A dset is an `equal?`-based set, but it preserves order based on
;; the history of additions, so that if items are added in a
;; deterministic order, they come back out in a deterministic order.
(provide dset
dset-empty?
dset->list
dset-add
dset-union
dset-subtract
dset-filter)
(define dset
(case-lambda
[() (hash)]
[(e) (hash e 0)]))
(define (dset-empty? ds)
(zero? (hash-count ds)))
(define (dset->list ds)
(map cdr
(sort (for/list ([(k v) (in-hash ds)])
(cons v k))
<
#:key car)))
(define (dset-add ds e)
(if (hash-ref ds e #f)
ds
(hash-set ds e (hash-count ds))))
(define (dset-union ds1 ds2)
(cond
[((hash-count ds1) . > . (hash-count ds2))
(dset-union ds2 ds1)]
[else
(for/fold ([ds2 ds2]) ([e (dset->list ds1)])
(dset-add ds2 e))]))
(define (dset-subtract ds1 ds2)
;; ! takes O(size(ds2)) time !
(for/fold ([r (dset)]) ([e (in-list (dset->list ds1))])
(if (hash-ref ds2 e #f)
r
(dset-add r e))))
(define (dset-filter ds pred)
(for/fold ([r (dset)]) ([e (in-list (dset->list ds))])
(if (pred e)
(dset-add r e)
r)))

490
experimental/private/substitute.rkt Normal file
View File

@ -0,0 +1,490 @@
#lang racket/base
(require syntax/parse/private/minimatch
racket/private/promise
racket/private/stx) ;; syntax/stx
(provide translate
syntax-local-template-metafunction-introduce)
#|
;; Doesn't seem to make much difference.
(require (rename-in racket/unsafe/ops
[unsafe-vector-ref vector-ref]
[unsafe-vector-set! vector-set!]
[unsafe-car car]
[unsafe-cdr cdr]))
|#
;; ============================================================
#|
A Guide (G) is one of:
- '_
- VarRef ;; no syntax check
- (vector 'check VarRef) ;; check value is syntax
- (cons G G)
- (vector 'vector G)
- (vector 'struct G)
- (vector 'box G)
- (vector 'dots HG (listof (vector-of VarRef)) nat (listof nat) G)
- (vector 'app HG G)
- (vector 'escaped G)
- (vector 'orelse G G)
- (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 'orelse-h H H)
- (vector 'splice G)
- (vector 'unsyntax-splicing VarRef)
An VarRef is one of
- positive-exact-integer ;; represents depth=0 pvar ref or metafun ref
- negative-exact-integer ;; represents depth>0 pvar ref (within ellipsis)
|#
(define (head-guide? x)
(match x
[(vector 'app-opt g) #t]
[(vector 'splice g) #t]
[(vector 'orelse-h g1 g2) #t]
[(vector 'unsyntax-splicing var) #t]
[_ #f]))
;; ============================================================
;; Used to indicate absent pvar in template; ?? catches
;; Note: not an exn, don't need continuation marks
(struct absent-pvar (ctx v wanted-list?))
;; ============================================================
;; A translated-template is (vector loop-env -> syntax)
;; A loop-env is either a vector of values or a single value,
;; depending on lenv-mode of enclosing ellipsis ('dots) form.
(define (translate stx g env-length)
(let ([f (translate-g stx stx g env-length 0)])
(lambda (env lenv)
(unless (>= (vector-length env) env-length)
(error 'template "internal error: environment too short"))
(with-handlers ([absent-pvar?
(lambda (ap)
(err/not-syntax (absent-pvar-ctx ap) (absent-pvar-v ap)))])
(f env lenv)))))
;; lenv-mode is one of
;; - 'one ;; lenv is single value; address as -1
;; - nat ;; lenv is vector; address as (- -1 index); 0 means no loop env
(define (translate-g stx0 stx g env-length lenv-mode)
(define (loop stx g) (translate-g stx0 stx g env-length lenv-mode))
(define (loop-h stx hg) (translate-hg stx0 stx hg env-length lenv-mode))
(define (get index env lenv) (get-var index env lenv lenv-mode))
(match g
['_ (lambda (env lenv) stx)]
[(? exact-integer? index)
(check-var index env-length lenv-mode)
(lambda (env lenv) (get index env lenv))]
[(vector 'check index)
(check-var index env-length lenv-mode)
(lambda (env lenv) (check-stx stx (get index env lenv)))]
[(cons g1 g2)
(let ([f1 (loop (stx-car stx) g1)]
[f2 (loop (stx-cdr stx) g2)])
(cond [(syntax? stx)
(lambda (env lenv)
(restx stx (cons (f1 env lenv) (f2 env lenv))))]
[(eq? g1 '_)
(let ([c1 (stx-car stx)])
(lambda (env lenv)
(cons c1 (f2 env lenv))))]
[(eq? g2 '_)
(let ([c2 (stx-cdr stx)])
(lambda (env lenv)
(cons (f1 env lenv) c2)))]
[else
(lambda (env lenv)
(cons (f1 env lenv) (f2 env lenv)))]))]
[(vector 'dots ghead henv nesting uptos gtail)
;; At each nesting depth, indexes [0,upto) of lenv* vary; the rest are fixed.
;; An alternative would be to have a list of henvs, but that would inhibit
;; the nice simple vector reuse via vector-car/cdr!.
(let* ([lenv*-len (vector-length henv)]
[ghead-is-hg? (head-guide? ghead)]
[ftail (loop (stx-drop (add1 nesting) stx) gtail)])
(for ([var (in-vector henv)])
(check-var var env-length lenv-mode))
(unless (= nesting (length uptos))
(error 'template "internal error: wrong number of uptos"))
(let ([last-upto
(for/fold ([last 1]) ([upto (in-list uptos)])
(unless (<= upto lenv*-len)
(error 'template "internal error: upto is too big"))
(unless (>= upto last)
(error 'template "internal error: uptos decreased: ~e" uptos))
upto)])
(unless (= lenv*-len last-upto)
(error 'template "internal error: last upto was not full env")))
(cond [(and (= lenv*-len 1) (= nesting 1) (not ghead-is-hg?)
(equal? ghead '-1))
;; Fast path for (pvar ... . T) template
;; - no list? or syntax? checks needed (because ghead is just raw varref,
;; no 'check' wrapper)
;; - avoid trivial map, just append
(let ([var-index (vector-ref henv 0)])
(lambda (env lenv)
(let ([lenv* (get var-index env lenv)])
(restx stx (append lenv* (ftail env lenv))))))]
[(and (= lenv*-len 1) (= nesting 1) (not ghead-is-hg?))
;; Fast path for (T ... . T) template
;; - specialize lenv to avoid vector allocation/mutation
;; - body is deforested (append (map _ _) _) preserving eval order
;; - could try to eliminate 'check-list', but probably not worth the bother
(let* ([fhead (translate-g stx0 (stx-car stx) ghead env-length 'one)]
[var-index (vector-ref henv 0)])
(lambda (env lenv)
(restx stx
(let ([lenv* (check-list/depth stx (get var-index env lenv) 1)])
(let dotsloop ([lenv* lenv*])
(if (null? lenv*)
(ftail env lenv)
(cons (fhead env (car lenv*))
(dotsloop (cdr lenv*)))))))))]
[else
;; Slow/general path for (H ...^n . T)
(let ([fhead (if ghead-is-hg?
(translate-hg stx0 (stx-car stx) ghead env-length lenv*-len)
(translate-g stx0 (stx-car stx) ghead env-length lenv*-len))])
(lambda (env lenv)
#|
The template is "driven" by pattern variables bound to (listof^n syntax).
For example, in (H ... ... . T), the pvars of H have (listof (listof syntax)),
and we need a doubly-nested loop, like
(for/list ([stxlist^1 (in-list stxlist^2)])
(for/list ([stx (in-list stxlist^1)])
___ fhead ___))
Since we can have arbitrary numbers of ellipses, we have 'nestloop' recur
over ellipsis levels and 'dotsloop' recur over the contents of the pattern
variables' (listof^n syntax) values.
Also, we reuse lenv vectors to reduce allocation. There is one aux lenv
vector per nesting level, preallocated in aux-lenvs. For continuation-safety
we must install a continuation barrier around metafunction applications.
|#
(define (nestloop lenv* nesting uptos aux-lenvs)
(cond [(zero? nesting)
(fhead env lenv*)]
[else
(let ([iters (check-lenv/get-iterations stx lenv*)])
(let ([lenv** (car aux-lenvs)]
[aux-lenvs** (cdr aux-lenvs)]
[upto** (car uptos)]
[uptos** (cdr uptos)])
(let dotsloop ([iters iters])
(if (zero? iters)
null
(begin (vector-car/cdr! lenv** lenv* upto**)
(let ([row (nestloop lenv** (sub1 nesting) uptos** aux-lenvs**)])
(cons row (dotsloop (sub1 iters)))))))))]))
(define initial-lenv*
(vector-map (lambda (index) (get index env lenv)) henv))
(define aux-lenvs
(for/list ([depth (in-range nesting)]) (make-vector lenv*-len)))
;; Check initial-lenv* contains lists of right depths.
;; At each nesting depth, indexes [0,upto) of lenv* vary;
;; uptos is monotonic nondecreasing (every variable varies in inner
;; loop---this is always counterintuitive to me).
(let checkloop ([depth nesting] [uptos uptos] [start 0])
(when (pair? uptos)
(for ([v (in-vector initial-lenv* start (car uptos))])
(check-list/depth stx v depth))
(checkloop (sub1 depth) (cdr uptos) (car uptos))))
(define head-results
;; if ghead-is-hg?, is (listof^(nesting+1) stx) -- extra listof for loop-h
;; otherwise, is (listof^nesting stx)
(nestloop initial-lenv* nesting uptos aux-lenvs))
(define tail-result (ftail env lenv))
(restx stx
(nested-append head-results
(if ghead-is-hg? nesting (sub1 nesting))
tail-result))))]))]
[(vector 'app ghead gtail)
(let ([fhead (loop-h (stx-car stx) ghead)]
[ftail (loop (stx-cdr stx) gtail)])
(lambda (env lenv)
(restx stx (append (fhead env lenv) (ftail env lenv)))))]
[(vector 'escaped g1)
(loop (stx-cadr stx) g1)]
[(vector 'orelse g1 g2)
(let ([f1 (loop (stx-cadr stx) g1)]
[f2 (loop (stx-caddr stx) g2)])
(lambda (env lenv)
(with-handlers ([absent-pvar?
(lambda (_e)
(f2 env lenv))])
(f1 env lenv))))]
[(vector 'metafun index g1)
(let ([f1 (loop (stx-cdr stx) g1)])
(check-var index env-length lenv-mode)
(lambda (env lenv)
(let ([v (restx stx (cons (stx-car stx) (f1 env lenv)))]
[mark (make-syntax-introducer)]
[old-mark (current-template-metafunction-introducer)]
[mf (get index env lenv)])
(parameterize ((current-template-metafunction-introducer mark)
(old-template-metafunction-introducer old-mark))
(let ([r (call-with-continuation-barrier (lambda () (mf (mark (old-mark v)))))])
(unless (syntax? r)
(raise-syntax-error #f "result of template metafunction was not syntax" stx))
(restx stx (old-mark (mark r))))))))]
[(vector 'vector g1)
(let ([f1 (loop (vector->list (syntax-e stx)) g1)])
(lambda (env lenv)
(restx stx (list->vector (f1 env lenv)))))]
[(vector 'struct g1)
(let ([f1 (loop (cdr (vector->list (struct->vector (syntax-e stx)))) g1)]
[key (prefab-struct-key (syntax-e stx))])
(lambda (env lenv)
(restx stx (apply make-prefab-struct key (f1 env lenv)))))]
[(vector 'box g1)
(let ([f1 (loop (unbox (syntax-e stx)) g1)])
(lambda (env lenv)
(restx stx (box (f1 env lenv)))))]
[(vector 'copy-props g1 keys)
(let ([f1 (loop stx g1)])
(lambda (env lenv)
(for/fold ([v (f1 env lenv)]) ([key (in-list keys)])
(let ([pvalue (syntax-property stx key)])
(if pvalue
(syntax-property v key pvalue)
v)))))]
[(vector 'set-props g1 props-alist)
(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)))))]
[(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))
(define (loop-h stx hg) (translate-hg stx0 stx hg env-length lenv-mode))
(define (get index env lenv) (get-var index env lenv lenv-mode))
(match hg
[(vector 'app-opt hg1)
(let ([f1 (loop-h (stx-cadr stx) hg1)])
(lambda (env lenv)
(with-handlers ([absent-pvar? (lambda (_e) null)])
(f1 env lenv))))]
[(vector 'orelse-h hg1 hg2)
(let ([f1 (loop-h (stx-cadr stx) hg1)]
[f2 (loop-h (stx-caddr stx) hg2)])
(lambda (env lenv)
(with-handlers ([absent-pvar?
(lambda (_e)
(f2 env lenv))])
(f1 env lenv))))]
[(vector 'splice g1)
(let ([f1 (loop (stx-cdr stx) g1)])
(lambda (env lenv)
(let* ([v (f1 env lenv)]
[v* (stx->list v)])
(unless (list? v*)
(raise-syntax-error 'template
"splicing template did not produce a syntax list"
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)
(list (f env lenv))))]))
(define (get-var index env lenv lenv-mode)
(cond [(positive? index)
(vector-ref env (sub1 index))]
[(negative? index)
(case lenv-mode
((one) lenv)
(else (vector-ref lenv (- -1 index))))]))
(define (check-var index env-length lenv-mode)
(cond [(positive? index)
(unless (< (sub1 index) env-length)
(error/bad-index index))]
[(negative? index)
(unless (< (- -1 index)
(case lenv-mode
((one) 1)
(else lenv-mode)))
(error/bad-index))]))
(define (check-lenv/get-iterations stx lenv)
(unless (list? (vector-ref lenv 0))
(error 'template "pattern variable used in ellipsis pattern is not defined"))
(let ([len0 (length (vector-ref lenv 0))])
(for ([v (in-vector lenv)])
(unless (list? v)
(error 'template "pattern variable used in ellipsis pattern is not defined"))
(unless (= len0 (length v))
(raise-syntax-error 'template
"incompatible ellipsis match counts for template"
stx)))
len0))
;; ----
(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 (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))))
;; ----
(define (stx-cadr x) (stx-car (stx-cdr x)))
(define (stx-cddr x) (stx-cdr (stx-cdr x)))
(define (stx-caddr x) (stx-car (stx-cdr (stx-cdr x))))
(define (stx-drop n x)
(cond [(zero? n) x]
[else (stx-drop (sub1 n) (stx-cdr x))]))
(define (restx basis val)
(if (syntax? basis)
(datum->syntax basis val basis)
val))
;; nested-append : (listof^(nesting+1) A) nat (listof A) -> (listof A)
;; (Actually, in practice onto is stx, so this is an improper append.)
(define (nested-append lst nesting onto)
(cond [(zero? nesting) (append lst onto)]
[(null? lst) onto]
[else (nested-append (car lst) (sub1 nesting)
(nested-append (cdr lst) nesting onto))]))
(define (check-stx ctx v)
(let loop ([v v])
(cond [(syntax? v)
v]
[(promise? v)
(loop (force v))]
[(eq? v #f)
(raise (absent-pvar ctx v #f))]
[else (err/not-syntax ctx v)])))
(define (check-list/depth ctx v0 depth0)
(let depthloop ([v v0] [depth depth0])
(cond [(zero? depth) v]
[(and (= depth 1) (list? v)) v]
[else
(let loop ([v v])
(cond [(null? v)
null]
[(pair? v)
(let ([new-car (depthloop (car v) (sub1 depth))]
[new-cdr (loop (cdr v))])
;; Don't copy unless necessary
(if (and (eq? new-car (car v)) (eq? new-cdr (cdr v)))
v
(cons new-car new-cdr)))]
[(promise? v)
(loop (force v))]
[(eq? v #f)
(raise (absent-pvar ctx v0 #t))]
[else
(err/not-syntax ctx v0)]))])))
;; Note: slightly different from error msg in syntax/parse/private/residual:
;; here says "contains" instead of "is bound to", because might be within list
(define (err/not-syntax ctx v)
(raise-syntax-error #f
(format "attribute contains non-syntax value\n value: ~e" v)
ctx))
(define (error/bad-index index)
(error 'template "internal error: bad index: ~e" index))
(define (vector-car/cdr! dest-v src-v upto)
(let ([len (vector-length dest-v)])
(let loop ([i 0])
(when (< i upto)
(let ([p (vector-ref src-v i)])
(vector-set! dest-v i (car p))
(vector-set! src-v i (cdr p)))
(loop (add1 i))))
(let loop ([j upto])
(when (< j len)
(vector-set! dest-v j (vector-ref src-v j))
(loop (add1 j))))))
(define (vector-map f src-v)
(let* ([len (vector-length src-v)]
[dest-v (make-vector len)])
(let loop ([i 0])
(when (< i len)
(vector-set! dest-v i (f (vector-ref src-v i)))
(loop (add1 i))))
dest-v))

660
experimental/template.rkt Normal file
View File

@ -0,0 +1,660 @@
#lang racket/base
(require (for-syntax racket/base
"dset.rkt"
racket/syntax
syntax/parse/private/minimatch
racket/private/stx ;; syntax/stx
racket/private/sc)
syntax/parse/private/residual
"private/substitute.rkt")
(provide template
template/loc
quasitemplate
quasitemplate/loc
define-template-metafunction
syntax-local-template-metafunction-introduce
??
?@)
#|
To do:
- improve error messages
|#
#|
A Template (T) is one of:
- pvar
- const (including () and non-pvar identifiers)
- (metafunction . T)
- (H . T)
- (H ... . T), (H ... ... . T), etc
- (?? 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 quasi? loc-id)
(with-disappeared-uses
(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)))]))))))))
(define-syntax (template stx)
(syntax-case stx ()
[(template 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 #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
;; template, since eq? templates must have equal? guides.
(define substitute-table (make-weak-hasheq))
;; props-syntax-table : hash[stx => stx]
(define props-syntax-table (make-weak-hasheq))
(define (substitute stx props-guide g main-env)
(let* ([stx (if (eq? props-guide '_)
stx
(or (hash-ref props-syntax-table stx #f)
(let* ([pf (translate stx props-guide 0)]
[pstx (pf '#() #f)])
(hash-set! props-syntax-table stx pstx)
pstx)))]
[f (or (hash-ref substitute-table stx #f)
(let ([f (translate stx g (vector-length main-env))])
(hash-set! substitute-table stx f)
f))])
(f main-env #f)))
;; ----
(define-syntaxes (?? ?@)
(let ([tx (lambda (stx) (raise-syntax-error #f "not allowed as an expression" stx))])
(values tx tx)))
;; ============================================================
#|
See private/substitute for definition of Guide (G) and HeadGuide (HG).
A env-entry is one of
- (pvar syntax-mapping attribute-mapping/#f depth-delta)
- template-metafunction
The depth-delta associated with a depth>0 pattern variable is the difference
between the pattern variable's depth and the depth at which it is used. (For
depth 0 pvars, it's #f.) For example, in
(with-syntax ([x #'0]
[(y ...) #'(1 2)]
[((z ...) ...) #'((a b) (c d))])
(template (((x y) ...) ...)))
the depth-delta for x is #f, the depth-delta for y is 1, and the depth-delta for
z is 0. Coincidentally, the depth-delta is the same as the depth of the ellipsis
form at which the variable should be moved to the loop-env. That is, the
template above should be interpreted as roughly similar to
(let ([x (pvar-value-of x)]
[y (pvar-value-of y)]
[z (pvar-value-of z)])
(for ([Lz (in-list z)]) ;; depth 0
(for ([Ly (in-list y)] ;; depth 1
[Lz (in-list Lz)])
(___ x Ly Lz ___))))
A Pre-Guide is like a Guide but with env-entry and (setof env-entry)
instead of integers and integer vectors.
|#
(begin-for-syntax
(struct pvar (sm attr dd) #:prefab))
;; ============================================================
(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 expr)
(define-syntax id
(template-metafunction (quote-syntax internal-id)))))]))
(begin-for-syntax
(struct template-metafunction (var)))
;; ============================================================
(begin-for-syntax
;; props-to-serialize determines what properties are saved even when
;; code is compiled. (Unwritable values are dropped.)
;; props-to-transfer determines what properties are transferred from
;; template to stx constructed.
;; If a property is in props-to-transfer but not props-to-serialize,
;; compiling the module may have caused the property to disappear.
;; If a property is in props-to-serialize but not props-to-transfer,
;; it will show up only in constant subtrees.
;; The behavior of 'syntax' is serialize '(), transfer '(paren-shape).
;; props-to-serialize : (parameterof (listof symbol))
(define props-to-serialize (make-parameter '()))
;; props-to-transfer : (parameterof (listof symbol))
(define props-to-transfer (make-parameter '(paren-shape)))
;; 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 (dset-add drivers loc-pvar)
(relocate-guide pre-guide loc-pvar)))
(values drivers pre-guide))])
(let* ([main-env (dset->env drivers (hash))]
[guide (guide-resolve-env pre-guide main-env)])
(values guide
(index-hash->vector main-env)
props-guide))))
;; dset->env : (dsetof env-entry) -> hash[env-entry => nat]
(define (dset->env drivers init-env)
(for/fold ([env init-env])
([pvar (in-list (dset->list drivers))]
[n (in-naturals (+ 1 (hash-count init-env)))])
(hash-set env pvar n)))
;; guide-resolve-env : pre-guide hash[env-entry => nat] -> guide
(define (guide-resolve-env g0 main-env)
(define (loop g loop-env)
(define (get-index x)
(let ([loop-index (hash-ref loop-env x #f)])
(if loop-index
(- loop-index)
(hash-ref main-env x))))
(match g
['_ '_]
[(cons g1 g2)
(cons (loop g1 loop-env) (loop g2 loop-env))]
[(? pvar? pvar)
(if (pvar-check? pvar)
(vector 'check (get-index pvar))
(get-index pvar))]
[(vector 'dots head new-hdrivers/level nesting '#f tail)
(let-values ([(sub-loop-env r-uptos)
(for/fold ([env (hash)] [r-uptos null])
([new-hdrivers (in-list new-hdrivers/level)])
(let ([new-env (dset->env new-hdrivers env)])
(values new-env (cons (hash-count new-env) r-uptos))))])
(let ([sub-loop-vector (index-hash->vector sub-loop-env get-index)])
(vector 'dots
(loop head sub-loop-env)
sub-loop-vector
nesting
(reverse r-uptos)
(loop tail loop-env))))]
[(vector 'app head tail)
(vector 'app (loop head loop-env) (loop tail loop-env))]
[(vector 'escaped g1)
(vector 'escaped (loop g1 loop-env))]
[(vector 'orelse g1 g2)
(vector 'orelse (loop g1 loop-env) (loop g2 loop-env))]
[(vector 'orelse-h g1 g2)
(vector 'orelse-h (loop g1 loop-env) (loop g2 loop-env))]
[(vector 'metafun mf g1)
(vector 'metafun
(get-index mf)
(loop g1 loop-env))]
[(vector 'vector g1)
(vector 'vector (loop g1 loop-env))]
[(vector 'struct g1)
(vector 'struct (loop g1 loop-env))]
[(vector 'box g1)
(vector 'box (loop (unbox g) loop-env))]
[(vector 'copy-props g1 keys)
(vector 'copy-props (loop g1 loop-env) keys)]
[(vector 'set-props g1 props-alist)
(vector 'set-props (loop g1 loop-env) props-alist)]
[(vector 'app-opt g1)
(vector 'app-opt (loop g1 loop-env))]
[(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 g2)
(error/no-relocate)]
[(vector 'orelse-h g1 g2)
(error/no-relocate)]
[(vector 'metafun mf g1)
(error/no-relocate)]
[(vector 'app-opt g1)
(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)
(for/fold ([entries null]) ([prop (in-list (props-to-serialize))])
(let ([v (syntax-property stx prop)])
(if (and v (quotable? v))
(cons (cons prop v) entries)
entries)))
null)]
[copy-props
(if (syntax? stx)
(for/list ([prop (in-list (props-to-transfer))]
#:when (syntax-property stx prop))
prop)
null)])
(values env-set
(cond [(eq? pre-guide '_)
;; No need to copy props; already on constant
'_]
[(pair? copy-props)
(vector 'copy-props pre-guide copy-props)]
[else pre-guide])
(if (pair? saved-prop-values)
(vector 'set-props props-guide saved-prop-values)
props-guide))))
(define (quotable? v)
(or (null? v)
(string? v)
(bytes? v)
(number? v)
(boolean? v)
(char? v)
(keyword? v)
(regexp? v)
(and (box? v) (quotable? (unbox v)))
(and (symbol? v) (symbol-interned? v))
(and (pair? v) (quotable? (car v)) (quotable? (cdr v)))
(and (vector? v) (andmap quotable? (vector->list v)))
(and (prefab-struct-key v) (andmap quotable? (struct->vector v)))))
(define (cons-guide g1 g2)
(if (and (eq? g1 '_) (eq? g2 '_)) '_ (cons g1 g2)))
(define (list-guide . gs)
(foldr cons-guide '_ gs))
;; parse-t : stx nat boolean -> (values (dsetof env-entry) pre-guide props-guide)
(define (parse-t t depth esc?)
(syntax-case t (?? ?@ unsyntax quasitemplate)
[id
(identifier? #'id)
(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)])
(cond [(pvar? pvar)
(values (dset pvar) pvar '_)]
[(template-metafunction? pvar)
(wrong-syntax t "illegal use of syntax metafunction")]
[else
(wrap-props #'id (dset) '_ '_)]))])]
[(mf . template)
(and (not esc?)
(identifier? #'mf)
(template-metafunction? (lookup #'mf #f)))
(let-values ([(mf) (lookup #'mf #f)]
[(drivers guide props-guide) (parse-t #'template depth esc?)])
(values (dset-add drivers mf)
(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 (dset 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 ...)))
(let-values ([(drivers guide props-guide) (parse-t #'template depth #t)])
(values drivers (vector 'escaped guide)
(list-guide '_ props-guide)))]
[(?? t1 t2)
(not esc?)
(let-values ([(drivers1 guide1 props-guide1) (parse-t #'t1 depth esc?)]
[(drivers2 guide2 props-guide2) (parse-t #'t2 depth esc?)])
(values (dset-union drivers1 drivers2)
(vector 'orelse guide1 guide2)
(list-guide '_ props-guide1 props-guide2)))]
[(head DOTS . tail)
(and (not esc?)
(identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...)))
(let-values ([(nesting tail)
(let loop ([nesting 1] [tail #'tail])
(syntax-case tail ()
[(DOTS . tail)
(and (identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...)))
(loop (add1 nesting) #'tail)]
[else (values nesting tail)]))])
(let-values ([(hdrivers _hsplice? hguide hprops-guide)
(parse-h #'head (+ depth nesting) esc?)]
[(tdrivers tguide tprops-guide)
(parse-t tail depth esc?)])
(when (dset-empty? hdrivers)
(wrong-syntax #'head "no pattern variables before ellipsis in template"))
(when (dset-empty? (dset-filter hdrivers (pvar/dd<=? depth)))
;; FIXME: improve error message?
(let ([bad-dots
;; select the nestingth (last) ellipsis as the bad one
(stx-car (stx-drop nesting t))])
(wrong-syntax bad-dots "too many ellipses in template")))
(wrap-props t
(dset-union hdrivers tdrivers)
;; pre-guide hdrivers is (listof (setof pvar))
;; set of pvars new to each level
(let* ([hdrivers/level
(for/list ([i (in-range nesting)])
(dset-filter hdrivers (pvar/dd<=? (+ depth i))))]
[new-hdrivers/level
(let loop ([raw hdrivers/level] [last (dset)])
(cond [(null? raw) null]
[else
(cons (dset-subtract (car raw) last)
(loop (cdr raw) (car raw)))]))])
(vector 'dots hguide new-hdrivers/level nesting #f tguide))
(cons-guide hprops-guide (cons-guide '_ tprops-guide)))))]
[(head . tail)
(let-values ([(hdrivers hsplice? hguide hprops-guide)
(parse-h #'head depth esc?)]
[(tdrivers tguide tprops-guide)
(parse-t #'tail depth esc?)])
(wrap-props t
(dset-union hdrivers tdrivers)
(cond [(and (eq? hguide '_) (eq? tguide '_)) '_]
[hsplice? (vector 'app hguide tguide)]
[else (cons hguide tguide)])
(cons-guide hprops-guide tprops-guide)))]
[vec
(vector? (syntax-e #'vec))
(let-values ([(drivers guide props-guide)
(parse-t (vector->list (syntax-e #'vec)) depth esc?)])
(wrap-props t drivers
(if (eq? guide '_) '_ (vector 'vector guide))
(if (eq? props-guide '_) '_ (vector 'vector props-guide))))]
[pstruct
(prefab-struct-key (syntax-e #'pstruct))
(let-values ([(drivers guide props-guide)
(parse-t (cdr (vector->list (struct->vector (syntax-e #'pstruct)))) depth esc?)])
(wrap-props t drivers
(if (eq? guide '_) '_ (vector 'struct guide))
(if (eq? props-guide '_) '_ (vector 'struct props-guide))))]
[#&template
(let-values ([(drivers guide props-guide)
(parse-t #'template depth esc?)])
(wrap-props t drivers
(if (eq? guide '_) '_ (vector 'box guide))
(if (eq? props-guide '_) '_ (vector 'box props-guide))))]
[const
(wrap-props t (dset) '_ '_)]))
;; parse-h : stx nat boolean -> (values (dsetof env-entry) boolean pre-head-guide props-guide)
(define (parse-h h depth esc?)
(syntax-case h (?? ?@ unsyntax-splicing)
[(?? t)
(not esc?)
(let-values ([(drivers splice? guide props-guide)
(parse-h #'t depth esc?)])
(values drivers #t
(vector 'app-opt guide)
(list-guide '_ props-guide)))]
[(?? t1 t2)
(not esc?)
(let-values ([(drivers1 splice?1 guide1 props-guide1) (parse-h #'t1 depth esc?)]
[(drivers2 splice?2 guide2 props-guide2) (parse-h #'t2 depth esc?)])
(values (dset-union drivers1 drivers2)
(or splice?1 splice?2)
(vector (if (or splice?1 splice?2) 'orelse-h 'orelse)
guide1 guide2)
(list-guide '_ props-guide1 props-guide2)))]
[(?@ . t)
(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 (dset 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))]))
(define (lookup id depth)
(let ([v (syntax-local-value/record id (lambda (v) (or (syntax-pattern-variable? v)
(template-metafunction? v))))])
(cond [(syntax-pattern-variable? v)
(let* ([pvar-depth (syntax-mapping-depth v)]
[attr (syntax-local-value (syntax-mapping-valvar v) (lambda () #f))]
[attr (and (attribute-mapping? attr) attr)])
(cond [(not depth) ;; not looking for pvars, only for metafuns
#f]
[(zero? pvar-depth)
(pvar v attr #f)]
[(>= depth pvar-depth)
(pvar v attr (- depth pvar-depth))]
[else
(wrong-syntax id "missing ellipses with pattern variable in template")]))]
[(template-metafunction? v)
v]
[else
;; id is a literal; check that for all x s.t. id = x.y, x is not an attribute
(for ([pfx (in-list (dotted-prefixes id))])
(let ([pfx-v (syntax-local-value pfx (lambda () #f))])
(when (and (syntax-pattern-variable? pfx-v)
(let ([valvar (syntax-mapping-valvar pfx-v)])
(attribute-mapping? (syntax-local-value valvar (lambda () #f)))))
(wrong-syntax id "undefined nested attribute of attribute `~a'" (syntax-e pfx)))))
#f])))
(define (dotted-prefixes id)
(let* ([id-string (symbol->string (syntax-e id))]
[dot-locations (map car (regexp-match-positions* #rx"\\.[^.]" id-string))])
(for/list ([loc (in-list dot-locations)])
(datum->syntax id (string->symbol (substring id-string 0 loc))))))
(define (index-hash->vector hash [f values])
(let ([vec (make-vector (hash-count hash))])
(for ([(value index) (in-hash hash)])
(vector-set! vec (sub1 index) (f value)))
vec))
(define ((pvar/dd<=? expected-dd) x)
(match x
[(pvar sm attr dd) (and dd (<= dd expected-dd))]
[_ #f]))
(define (pvar-var x)
(match x
[(pvar sm '#f dd) (syntax-mapping-valvar sm)]
[(pvar sm attr dd) (attribute-mapping-var attr)]))
(define (pvar-check? x)
(match x
[(pvar sm '#f dd) #f]
[(pvar sm attr dd) (not (attribute-mapping-syntax? attr))]))
(define (stx-drop n x)
(cond [(zero? n) x]
[else (stx-drop (sub1 n) (stx-cdr x))]))
)

9
info.rkt Normal file
View File

@ -0,0 +1,9 @@
#lang info
(define collection "backport-template-pr1514")
(define deps '("base"
"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 '(georges))

35
main.rkt Normal file
View File

@ -0,0 +1,35 @@
#lang racket/base
(module+ test
(require rackunit))
;; Notice
;; To install (from within the package directory):
;; $ raco pkg install
;; To install (once uploaded to pkgs.racket-lang.org):
;; $ raco pkg install <<name>>
;; To uninstall:
;; $ raco pkg remove <<name>>
;; To view documentation:
;; $ raco docs <<name>>
;;
;; For your convenience, we have included a LICENSE.txt file, which links to
;; the GNU Lesser General Public License.
;; If you would prefer to use a different license, replace LICENSE.txt with the
;; desired license.
;;
;; Some users like to add a `private/` directory, place auxiliary files there,
;; and require them in `main.rkt`.
;;
;; See the current version of the racket style guide here:
;; http://docs.racket-lang.org/style/index.html
;; Code here
(module+ test
;; Tests to be run with raco test
)
(module+ main
;; Main entry point, executed when run with the `racket` executable or DrRacket.
)

10
scribblings/backport-template-pr1514.scrbl Normal file
View File

@ -0,0 +1,10 @@
#lang scribble/manual
@require[@for-label[backport-template-pr1514
racket/base]]
@title{backport-template-pr1514}
@author{georges}
@defmodule[backport-template-pr1514]
Package Description Here