more template improvements
- loosen pattern variable depth rules (now compatible with syntax) - generalize ?? form to head-templates - doc improvements - propagate paren-shape property
This commit is contained in:
Ryan Culpepper
parent
df265ddc67
commit
74ca931f5a
|
|
@ -24,7 +24,7 @@ A Guide (G) is one of:
|
|||
- (vector 'vector G)
|
||||
- (vector 'struct G)
|
||||
- (vector 'box G)
|
||||
- (vector 'dots HG (vector-of integer) nat G)
|
||||
- (vector 'dots HG (listof (vector-of integer)) nat (listof nat) G)
|
||||
- (vector 'app HG G)
|
||||
- (vector 'escaped G)
|
||||
- (vector 'orelse G (vector-of integer) G)
|
||||
|
|
@ -32,7 +32,8 @@ A Guide (G) is one of:
|
|||
|
||||
A HeadGuide (HG) is one of:
|
||||
- G
|
||||
- (vector 'app-opt G (vector-of integer))
|
||||
- (vector 'app-opt H (vector-of integer))
|
||||
- (vector 'orelse-h H (vector-of integer) H)
|
||||
- (vector 'splice G)
|
||||
|#
|
||||
|
||||
|
|
@ -40,6 +41,7 @@ A HeadGuide (HG) is one of:
|
|||
(match x
|
||||
[(vector 'app-opt g vars) #t]
|
||||
[(vector 'splice g) #t]
|
||||
[(vector 'orelse-h g1 vars g2) #t]
|
||||
[_ #f]))
|
||||
|
||||
;; ============================================================
|
||||
|
|
@ -85,12 +87,26 @@ A HeadGuide (HG) is one of:
|
|||
[else
|
||||
(lambda (env lenv)
|
||||
(cons (f1 env lenv) (f2 env lenv)))]))]
|
||||
[(vector 'dots ghead henv nesting gtail)
|
||||
[(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 to 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))
|
||||
;; template was just (pvar ... . T)
|
||||
(let ([fhead (translate-g stx0 (stx-car stx) ghead env-length 'one)])
|
||||
|
|
@ -111,24 +127,26 @@ A HeadGuide (HG) is one of:
|
|||
(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)
|
||||
(define (nestloop lenv* nesting)
|
||||
(define (nestloop lenv* nesting uptos)
|
||||
(cond [(zero? nesting)
|
||||
(fhead env lenv*)]
|
||||
[else
|
||||
(check-lenv stx lenv*)
|
||||
(let ([len0 (length (vector-ref lenv* 0))])
|
||||
(let ([lenv** (make-vector (vector-length lenv*))])
|
||||
(let dotsloop ([len0 len0])
|
||||
(if (zero? len0)
|
||||
(let ([iters (length (vector-ref lenv* 0))])
|
||||
(let ([lenv** (make-vector lenv*-len)]
|
||||
[upto** (car uptos)]
|
||||
[uptos** (cdr uptos)])
|
||||
(let dotsloop ([iters iters])
|
||||
(if (zero? iters)
|
||||
null
|
||||
(begin (vector-car/cdr! lenv** lenv*)
|
||||
(cons (nestloop lenv** (sub1 nesting))
|
||||
(dotsloop (sub1 len0))))))))]))
|
||||
(begin (vector-car/cdr! lenv** lenv* upto**)
|
||||
(cons (nestloop lenv** (sub1 nesting) uptos**)
|
||||
(dotsloop (sub1 iters))))))))]))
|
||||
(let ([head-results
|
||||
;; if ghead-is-hg?, is (listof^(nesting+1) stx) -- extra listof for loop-h
|
||||
;; otherwise, is (listof^nesting stx)
|
||||
(nestloop (vector-map (lambda (index) (get index env lenv)) henv)
|
||||
nesting)]
|
||||
nesting uptos)]
|
||||
[tail-result (ftail env lenv)])
|
||||
(restx stx
|
||||
(nested-append head-results
|
||||
|
|
@ -182,14 +200,23 @@ A HeadGuide (HG) is one of:
|
|||
(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 g1 drivers1)
|
||||
(let ([f1 (loop (stx-cadr stx) g1)])
|
||||
[(vector 'app-opt hg1 drivers1)
|
||||
(let ([f1 (loop-h (stx-cadr stx) hg1)])
|
||||
(for ([var (in-vector drivers1)])
|
||||
(check-var var env-length lenv-mode))
|
||||
(lambda (env lenv)
|
||||
(if (for/and ([index (in-vector drivers1)]) (get index env lenv))
|
||||
(list (f1 env lenv))
|
||||
(f1 env lenv)
|
||||
null)))]
|
||||
[(vector 'orelse-h hg1 drivers1 hg2)
|
||||
(let ([f1 (loop-h (stx-cadr stx) hg1)]
|
||||
[f2 (loop-h (stx-caddr stx) hg2)])
|
||||
(for ([var (in-vector drivers1)])
|
||||
(check-var var env-length lenv-mode))
|
||||
(lambda (env lenv)
|
||||
(if (for/and ([index (in-vector drivers1)]) (get index env lenv))
|
||||
(f1 env lenv)
|
||||
(f2 env lenv))))]
|
||||
[(vector 'splice g1)
|
||||
(let ([f1 (loop (stx-cdr stx) g1)])
|
||||
(lambda (env lenv)
|
||||
|
|
@ -256,7 +283,11 @@ A HeadGuide (HG) is one of:
|
|||
|
||||
(define (restx basis val)
|
||||
(if (syntax? basis)
|
||||
(datum->syntax basis val basis basis)
|
||||
(let ([stx (datum->syntax basis val basis)]
|
||||
[paren-shape (syntax-property basis 'paren-shape)])
|
||||
(if paren-shape
|
||||
(syntax-property stx 'paren-shape paren-shape)
|
||||
stx))
|
||||
val))
|
||||
|
||||
;; nested-append : (listof^(nesting+1) A) nat (listof A) -> (listof A)
|
||||
|
|
@ -278,14 +309,18 @@ A HeadGuide (HG) is one of:
|
|||
(define (error/bad-index index)
|
||||
(error 'template "internal error: bad index: ~e" index))
|
||||
|
||||
(define (vector-car/cdr! dest-v src-v)
|
||||
(define (vector-car/cdr! dest-v src-v upto)
|
||||
(let ([len (vector-length dest-v)])
|
||||
(let loop ([i 0])
|
||||
(when (< i len)
|
||||
(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))))))
|
||||
(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)]
|
||||
|
|
|
|||
|
|
@ -14,26 +14,23 @@
|
|||
#|
|
||||
To do:
|
||||
- improve error messages
|
||||
- support flexible depths, eg
|
||||
(with-syntax ([(a ...) #'(1 2 3)]
|
||||
[((b ...) ...) #'((1 2 3) (4 5 6) (7 8 9))])
|
||||
#'(((a b) ...) ...)) ;; a has depth 1, used at depth 2
|
||||
- support #hash templates, etc (check for other atomic & compound forms)
|
||||
|#
|
||||
|
||||
#|
|
||||
A Template (T) is one of:
|
||||
- pvar
|
||||
- atom (including (), not pvar)
|
||||
- const (including () and non-pvar identifiers)
|
||||
- (metafunction . T)
|
||||
- (H . T)
|
||||
- (H ... . T), (H ... ... . T), etc
|
||||
- (?? T T)
|
||||
- ... other standard compound forms
|
||||
- #(T*)
|
||||
- #s(prefab-struct-key T*)
|
||||
|
||||
A HeadTemplate (H) is one of:
|
||||
- T
|
||||
- (?? T)
|
||||
- (?? H)
|
||||
- (?? H H)
|
||||
- (?@ . T)
|
||||
|#
|
||||
|
||||
|
|
@ -42,17 +39,21 @@ A HeadTemplate (H) is one of:
|
|||
(syntax-case stx ()
|
||||
[(template t)
|
||||
(let-values ([(guide deps) (parse-template #'t)])
|
||||
;; (eprintf "guide = ~s\n" guide)
|
||||
(let ([vars
|
||||
(for/list ([dep (in-vector deps)])
|
||||
(cond [(syntax-pattern-variable? dep)
|
||||
(let* ([valvar (syntax-mapping-valvar dep)]
|
||||
(cond [(pvar? dep)
|
||||
(let* ([sm (pvar-sm dep)]
|
||||
[valvar (syntax-mapping-valvar sm)]
|
||||
[attr (syntax-local-value valvar (lambda () #f))])
|
||||
(cond [(attribute-mapping? attr)
|
||||
(attribute-mapping-var attr)]
|
||||
[else valvar]))]
|
||||
[(template-metafunction? dep)
|
||||
(template-metafunction-var dep)]))])
|
||||
(template-metafunction-var dep)]
|
||||
[else
|
||||
(error 'template
|
||||
"internal error: bad environment entry: ~e"
|
||||
dep)]))])
|
||||
(syntax-arm
|
||||
(cond [(equal? guide '1) ;; was (template pvar)
|
||||
(with-syntax ([var (car vars)])
|
||||
|
|
@ -91,14 +92,39 @@ A HeadTemplate (H) is one of:
|
|||
#|
|
||||
See private/substitute for definition of Guide (G) and HeadGuide (HG).
|
||||
|
||||
An env-entry is one of
|
||||
- syntax-mapping (for pattern variables)
|
||||
A env-entry is one of
|
||||
- (pvar syntax-mapping 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 dd) #:prefab))
|
||||
|
||||
;; ============================================================
|
||||
|
||||
(define-syntax (define-template-metafunction stx)
|
||||
|
|
@ -122,16 +148,17 @@ instead of integers and integer vectors.
|
|||
;; parse-template : stx -> (values guide (vectorof env-entry))
|
||||
(define (parse-template t)
|
||||
(let-values ([(drivers pre-guide) (parse-t t 0 #f)])
|
||||
(define main-env (set->env drivers))
|
||||
(define main-env (set->env drivers (hash)))
|
||||
(define guide (guide-resolve-env pre-guide main-env))
|
||||
(values guide
|
||||
(index-hash->vector main-env))))
|
||||
|
||||
;; set->env : (setof env-entry) -> hash[env-entry => nat]
|
||||
(define (set->env drivers)
|
||||
(for/hash ([pvar (in-set drivers)]
|
||||
[n (in-naturals 1)])
|
||||
(values pvar n)))
|
||||
(define (set->env drivers init-env)
|
||||
(for/fold ([env init-env])
|
||||
([pvar (in-set 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)
|
||||
|
|
@ -144,15 +171,20 @@ instead of integers and integer vectors.
|
|||
(match g
|
||||
['_ '_]
|
||||
[(cons g1 g2) (cons (loop g1 loop-env) (loop g2 loop-env))]
|
||||
[(? syntax-pattern-variable? pvar) (get-index pvar)]
|
||||
[(vector 'dots head hdrivers nesting tail)
|
||||
(let* ([sub-loop-env (set->env hdrivers)]
|
||||
[sub-loop-vector (index-hash->vector sub-loop-env get-index)])
|
||||
(vector 'dots
|
||||
(loop head sub-loop-env)
|
||||
sub-loop-vector
|
||||
nesting
|
||||
(loop tail loop-env)))]
|
||||
[(? pvar? 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 (set->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)
|
||||
|
|
@ -160,8 +192,14 @@ instead of integers and integer vectors.
|
|||
[(vector 'orelse g1 drivers1 g2)
|
||||
(vector 'orelse
|
||||
(loop g1 loop-env)
|
||||
(for/vector ([pvar (in-set drivers1)])
|
||||
(get-index pvar))
|
||||
(for/vector ([ee (in-set drivers1)])
|
||||
(get-index ee))
|
||||
(loop g2 loop-env))]
|
||||
[(vector 'orelse-h g1 drivers1 g2)
|
||||
(vector 'orelse-h
|
||||
(loop g1 loop-env)
|
||||
(for/vector ([ee (in-set drivers1)])
|
||||
(get-index ee))
|
||||
(loop g2 loop-env))]
|
||||
[(vector 'metafun mf g1)
|
||||
(vector 'metafun
|
||||
|
|
@ -176,8 +214,8 @@ instead of integers and integer vectors.
|
|||
[(vector 'app-opt g1 drivers1)
|
||||
(vector 'app-opt
|
||||
(loop g1 loop-env)
|
||||
(for/vector ([pvar (in-set drivers1)])
|
||||
(get-index pvar)))]
|
||||
(for/vector ([ee (in-set drivers1)])
|
||||
(get-index ee)))]
|
||||
[(vector 'splice g1)
|
||||
(vector 'splice (loop g1 loop-env))]
|
||||
[else (error 'template "internal error: bad pre-guide: ~e" g)]))
|
||||
|
|
@ -197,14 +235,11 @@ instead of integers and integer vectors.
|
|||
(wrong-syntax #'id "illegal use")]
|
||||
[else
|
||||
(let ([pvar (lookup #'id depth)])
|
||||
(cond [(syntax-pattern-variable? pvar)
|
||||
(cond [(pvar? pvar)
|
||||
(values (set pvar) pvar)]
|
||||
[(template-metafunction? pvar)
|
||||
(wrong-syntax t "illegal use of syntax metafunction")]
|
||||
[else (values (set) '_)]))])]
|
||||
[atom
|
||||
(atom? (syntax-e #'atom))
|
||||
(values (set) '_)]
|
||||
[(mf . template)
|
||||
(and (not esc?)
|
||||
(identifier? #'mf)
|
||||
|
|
@ -223,7 +258,7 @@ instead of integers and integer vectors.
|
|||
(let-values ([(drivers1 guide1) (parse-t #'t1 depth esc?)]
|
||||
[(drivers2 guide2) (parse-t #'t2 depth esc?)])
|
||||
(values (set-union drivers1 drivers2)
|
||||
(vector 'orelse guide1 (set-filter drivers1 syntax-pattern-variable?) guide2)))]
|
||||
(vector 'orelse guide1 (set-filter drivers1 pvar?) guide2)))]
|
||||
[(head DOTS . tail)
|
||||
(and (not esc?)
|
||||
(identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...)))
|
||||
|
|
@ -239,7 +274,18 @@ instead of integers and integer vectors.
|
|||
(unless (positive? (set-count hdrivers))
|
||||
(wrong-syntax #'head "no pattern variables in term before ellipsis"))
|
||||
(values (set-union hdrivers tdrivers)
|
||||
(vector 'dots hguide (set-filter hdrivers pvar/depth>0?) nesting tguide))))]
|
||||
;; pre-guide hdrivers is (listof (setof pvar))
|
||||
;; set of pvars new to each level
|
||||
(let* ([hdrivers/level
|
||||
(for/list ([i (in-range nesting)])
|
||||
(set-filter hdrivers (pvar/dd<=? (+ depth i))))]
|
||||
[new-hdrivers/level
|
||||
(let loop ([raw hdrivers/level] [last (set)])
|
||||
(cond [(null? raw) null]
|
||||
[else
|
||||
(cons (set-subtract (car raw) last)
|
||||
(loop (cdr raw) (car raw)))]))])
|
||||
(vector 'dots hguide new-hdrivers/level nesting #f tguide)))))]
|
||||
[(head . tail)
|
||||
(let-values ([(hdrivers hsplice? hguide) (parse-h #'head depth esc?)]
|
||||
[(tdrivers tguide) (parse-t #'tail depth esc?)])
|
||||
|
|
@ -259,15 +305,24 @@ instead of integers and integer vectors.
|
|||
[#&template
|
||||
(let-values ([(drivers guide) (parse-t #'template depth esc?)])
|
||||
(values drivers (if (eq? guide '_) '_ (vector 'box guide))))]
|
||||
[_ (wrong-syntax t "bad template")]))
|
||||
[const
|
||||
(values (set) '_)]))
|
||||
|
||||
;; parse-h : stx nat boolean -> (values (setof env-entry) boolean pre-head-guide)
|
||||
(define (parse-h h depth esc?)
|
||||
(syntax-case h (?? ?@)
|
||||
[(?? t)
|
||||
(not esc?)
|
||||
(let-values ([(drivers guide) (parse-t #'t depth esc?)])
|
||||
(values drivers #t (vector 'app-opt guide (set-filter drivers syntax-pattern-variable?))))]
|
||||
(let-values ([(drivers splice? guide) (parse-h #'t depth esc?)])
|
||||
(values drivers #t (vector 'app-opt guide (set-filter drivers pvar?))))]
|
||||
[(?? t1 t2)
|
||||
(not esc?)
|
||||
(let-values ([(drivers1 splice?1 guide1) (parse-h #'t1 depth esc?)]
|
||||
[(drivers2 splice?2 guide2) (parse-h #'t2 depth esc?)])
|
||||
(values (set-union drivers1 drivers2)
|
||||
(or splice?1 splice?2)
|
||||
(vector (if (or splice?1 splice?2) 'orelse-h 'orelse)
|
||||
guide1 (set-filter drivers1 pvar?) guide2)))]
|
||||
[(?@ . t)
|
||||
(not esc?)
|
||||
(let-values ([(drivers guide) (parse-t #'t depth esc?)])
|
||||
|
|
@ -276,16 +331,6 @@ instead of integers and integer vectors.
|
|||
(let-values ([(drivers guide) (parse-t #'t depth esc?)])
|
||||
(values drivers #f guide))]))
|
||||
|
||||
(define (atom? x)
|
||||
(or (null? x)
|
||||
(number? x)
|
||||
(boolean? x)
|
||||
(string? x)
|
||||
(bytes? x)
|
||||
(keyword? x)
|
||||
(regexp? x)
|
||||
(char? x)))
|
||||
|
||||
;; Note: always creates equal?-based set.
|
||||
(define (set-filter s pred?)
|
||||
(for/set ([el (in-set s)] #:when (pred? el)) el))
|
||||
|
|
@ -293,14 +338,18 @@ instead of integers and integer vectors.
|
|||
(define (lookup id depth)
|
||||
(let ([v (syntax-local-value id (lambda () #f))])
|
||||
(cond [(syntax-pattern-variable? v)
|
||||
(unless (or (not depth)
|
||||
(= (syntax-mapping-depth v) depth)
|
||||
(= (syntax-mapping-depth v) 0))
|
||||
(wrong-syntax id
|
||||
"pattern variable used at wrong ellipsis depth (expected ~s, used at ~s)"
|
||||
(syntax-mapping-depth v)
|
||||
depth))
|
||||
v]
|
||||
(let ([pvar-depth (syntax-mapping-depth v)])
|
||||
(cond [(not depth) ;; not looking for pvars, only for metafuns
|
||||
#f]
|
||||
[(zero? pvar-depth)
|
||||
(pvar v #f)]
|
||||
[(>= depth pvar-depth)
|
||||
(pvar v (- depth pvar-depth))]
|
||||
[else
|
||||
(wrong-syntax id
|
||||
(string-append "pattern variable used at wrong ellipsis depth "
|
||||
"(expected at least ~s, used at ~s)")
|
||||
pvar-depth depth)]))]
|
||||
[(template-metafunction? v)
|
||||
v]
|
||||
[else
|
||||
|
|
@ -322,7 +371,8 @@ instead of integers and integer vectors.
|
|||
(vector-set! vec (sub1 index) (f value)))
|
||||
vec))
|
||||
|
||||
(define (pvar/depth>0? x)
|
||||
(and (syntax-pattern-variable? x)
|
||||
(positive? (syntax-mapping-depth x))))
|
||||
(define ((pvar/dd<=? expected-dd) x)
|
||||
(match x
|
||||
[(pvar sm dd) (and dd (<= dd expected-dd))]
|
||||
[_ #f]))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -275,22 +275,25 @@ patterns as @racket[target-stxclass-id] but with the given
|
|||
@defform/subs[#:literals (?? ?@)
|
||||
(template tmpl)
|
||||
([tmpl pattern-variable-id
|
||||
atomic-tmpl
|
||||
(head-tmpl . tmpl)
|
||||
(head-tmpl ellipsis ...+ . tmpl)
|
||||
(metafunction-id . tmpl)
|
||||
(?? tmpl tmpl)
|
||||
#(@#,svar[tmpl] ...)
|
||||
#s(prefab-struct-key @#,svar[tmpl] ...)
|
||||
#&@#,svar[tmpl]]
|
||||
#(@#,svar[head-tmpl] ...)
|
||||
#s(prefab-struct-key @#,svar[head-tmpl] ...)
|
||||
#&@#,svar[tmpl]
|
||||
constant-term]
|
||||
[head-templ tmpl
|
||||
(?? tmpl)
|
||||
(?? head-tmpl)
|
||||
(?? head-tmpl head-tmpl)
|
||||
(?@ . tmpl)]
|
||||
[ellipsis @#,literal-ellipsis])]{
|
||||
|
||||
Constructs a syntax object from a syntax template, like
|
||||
@racket[syntax], but provides additional templating forms for dealing
|
||||
with optional terms and splicing sequences of terms.
|
||||
with optional terms and splicing sequences of terms. Only the
|
||||
additional forms are described here; see @racket[syntax] for
|
||||
descriptions of pattern variables, etc.
|
||||
|
||||
@specsubform[#:literals (??)
|
||||
(?? tmpl alt-tmpl)]{
|
||||
|
|
@ -306,14 +309,28 @@ an absent value; in that case, @racket[alt-tmpl] is used instead.
|
|||
[(_ (~optional (~seq #:op op:expr)) arg:expr ...)
|
||||
(template ((?? op +) arg ...))])
|
||||
]
|
||||
|
||||
If @racket[??] is used as a head-template, then its sub-templates may
|
||||
also be head-templates.
|
||||
|
||||
@examples[#:eval the-eval
|
||||
(syntax-parse #'(m 1)
|
||||
[(_ x:expr (~optional y:expr))
|
||||
(template (m2 x (?? (?@ #:y y) (?@ #:z 0))))])
|
||||
(syntax-parse #'(m 1 2)
|
||||
[(_ x:expr (~optional y:expr))
|
||||
(template (m2 x (?? (?@ #:y y) (?@ #:z 0))))])
|
||||
]
|
||||
}
|
||||
|
||||
@specsubform[#:literals (??)
|
||||
(?? tmpl)]{
|
||||
(?? head-tmpl)]{
|
||||
|
||||
Produces @racket[tmpl] unless any attribute used in @racket[tmpl] has
|
||||
an absent value; in that case, the term is omitted. Can only occur in
|
||||
head position in a template.
|
||||
Produces @racket[head-tmpl] unless any attribute used in
|
||||
@racket[head-tmpl] has an absent value; in that case, the term is
|
||||
omitted. Can only occur in head position in a template.
|
||||
|
||||
Equivalent to @racket[(?? head-tmpl (?@))].
|
||||
|
||||
@examples[#:eval the-eval
|
||||
(syntax-parse #'(m 1)
|
||||
|
|
@ -322,6 +339,9 @@ head position in a template.
|
|||
(syntax-parse #'(m 1 2)
|
||||
[(_ x:expr (~optional y:expr))
|
||||
(template (m2 x (?? y)))])
|
||||
(syntax-parse #'(m 1 2)
|
||||
[(_ x:expr (~optional y:expr))
|
||||
(template (m2 x (?? (?@ #:y y))))])
|
||||
]
|
||||
}
|
||||
|
||||
|
|
@ -329,7 +349,7 @@ head position in a template.
|
|||
(?@ . tmpl)]{
|
||||
|
||||
Similar to @racket[unquote-splicing], splices the result of
|
||||
@racket[tmpl] (which must be a syntax list) into the surrounding
|
||||
@racket[tmpl] (which must produce a syntax list) into the surrounding
|
||||
template. Can only occur in head position in a template.
|
||||
|
||||
@examples[#:eval the-eval
|
||||
|
|
@ -338,10 +358,10 @@ template. Can only occur in head position in a template.
|
|||
(template (m2 (?@ kw kwarg) ... pos ...))])
|
||||
]
|
||||
|
||||
The @racket[tmpl] must produce proper syntax lists, but it does not
|
||||
itself need to be expressed as a proper list. For example, to unpack
|
||||
pattern variables that contain syntax lists, use a ``dotted''
|
||||
template:
|
||||
The @racket[tmpl] must produce a proper syntax list, but it does not
|
||||
need to be expressed as a proper list. For example, to unpack pattern
|
||||
variables that contain syntax lists, use a ``dotted'' template:
|
||||
|
||||
@examples[#:eval the-eval
|
||||
(with-syntax ([x #'(a b c)])
|
||||
(template ((?@ . x) d)))
|
||||
|
|
@ -356,28 +376,39 @@ Applies the template metafunction named @racket[metafunction-id] to
|
|||
the result of the template (including @racket[metafunction-id]
|
||||
itself). See @racket[define-template-metafunction] for examples.
|
||||
}
|
||||
|
||||
The @racket[??] and @racket[?@] forms and metafunction applications
|
||||
are disabled in an ``escaped template'' (see @racket[_stat-template]
|
||||
under @racket[syntax]).
|
||||
|
||||
@examples[#:eval the-eval
|
||||
(template (... ((?@ a b c) d)))
|
||||
]
|
||||
}
|
||||
|
||||
@deftogether[[
|
||||
@defidform[??]
|
||||
@defidform[?@]
|
||||
]]{
|
||||
Auxiliary forms used by @racket[template].
|
||||
|
||||
Auxiliary forms used by @racket[template]. They may not be used as
|
||||
expressions.
|
||||
}
|
||||
|
||||
@defform*[[(define-template-metafunction metafunction-id expr)
|
||||
(define-template-metafunction (metafunction-id . formals) body ...+)]]{
|
||||
|
||||
Defines @racket[metafunction-id] as a @deftech{template metafunction}. A
|
||||
metafunction application in a @racket[template] expression (but not a
|
||||
@racket[syntax] expression) is evaluated by applying the metafunction
|
||||
to the result of processing the ``argument'' part of the template.
|
||||
Defines @racket[metafunction-id] as a @deftech{template
|
||||
metafunction}. A metafunction application in a @racket[template]
|
||||
expression (but not a @racket[syntax] expression) is evaluated by
|
||||
applying the metafunction to the result of processing the ``argument''
|
||||
part of the template.
|
||||
|
||||
@examples[#:eval the-eval
|
||||
(define-template-metafunction (join stx)
|
||||
(syntax-parse stx
|
||||
[(join a:id b:id ...)
|
||||
(datum->syntax #'a
|
||||
[(join (~optional (~seq #:lctx lctx)) a:id b:id ...)
|
||||
(datum->syntax (or (attribute lctx) #'a)
|
||||
(string->symbol
|
||||
(apply string-append
|
||||
(map symbol->string
|
||||
|
|
@ -387,4 +418,23 @@ to the result of processing the ``argument'' part of the template.
|
|||
(with-syntax ([(x ...) #'(a b c)])
|
||||
(template ((x (join tmp- x)) ...)))
|
||||
]
|
||||
|
||||
Metafunctions are useful for performing transformations in contexts
|
||||
where macro expansion does not occur, such as binding occurrences. For
|
||||
example:
|
||||
|
||||
@interaction[#:eval the-eval
|
||||
(syntax->datum
|
||||
(with-syntax ([name #'posn]
|
||||
[(field ...) #'(x y)])
|
||||
(template (let-values ([((join name ?)
|
||||
(join #:lctx name make- name)
|
||||
(join name - field) ...)
|
||||
(make-struct-type ___)])
|
||||
___))))
|
||||
]
|
||||
|
||||
If @racket[join] were defined as a macro, it would not be usable in
|
||||
the context above; instead, @racket[let-values] would report an
|
||||
invalid binding list.
|
||||
}
|
||||
|
|
|
|||
|
|
@ -92,6 +92,33 @@
|
|||
(tc (template ((?? (ready oo)) done))
|
||||
'(done))
|
||||
|
||||
;; liberal depth rules
|
||||
|
||||
(tc (template (((uu aa yy) ...) ...))
|
||||
'(((abc a 1) (abc b 2) (abc c 3))
|
||||
((abc a 4) (abc b 5) (abc c 6))
|
||||
((abc a 7) (abc b 8) (abc c 9))))
|
||||
(tc (template (((uu aa yy) ...) ...))
|
||||
;; compatible with syntax
|
||||
(syntax->datum #'(((uu aa yy) ...) ...)))
|
||||
|
||||
;; liberal depth rules with consecutive ellipses
|
||||
|
||||
(tc (template ((aa yy) ... ...))
|
||||
'((a 1) (b 2) (c 3) (a 4) (b 5) (c 6) (a 7) (b 8) (c 9)))
|
||||
(tc (template ((aa yy) ... ...))
|
||||
(syntax->datum #'((aa yy) ... ...)))
|
||||
|
||||
;; head ??
|
||||
|
||||
(tc (template ((?? (?@ #:yes uu) (?@ #:no)) done))
|
||||
'(#:yes abc done))
|
||||
(tc (template ((?? (?@ #:yes oo) (?@ #:no)) done))
|
||||
'(#:no done))
|
||||
|
||||
(tc (template ((?? (?@ #:yes pp) (?@ #:no)) ...))
|
||||
'(#:no #:yes 1 #:no #:yes 2 #:yes 3))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
;; combined ?? ?@
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user