74ca931f5a
- loosen pattern variable depth rules (now compatible with syntax) - generalize ?? form to head-templates - doc improvements - propagate paren-shape property
379 lines
15 KiB
Racket
379 lines
15 KiB
Racket
#lang racket/base
|
|
(require (for-syntax racket/base
|
|
racket/set
|
|
racket/syntax
|
|
syntax/parse/private/minimatch
|
|
racket/private/sc)
|
|
syntax/parse/private/residual
|
|
"private/substitute.rkt")
|
|
(provide template
|
|
define-template-metafunction
|
|
??
|
|
?@)
|
|
|
|
#|
|
|
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*)
|
|
|
|
A HeadTemplate (H) is one of:
|
|
- T
|
|
- (?? H)
|
|
- (?? H H)
|
|
- (?@ . T)
|
|
|#
|
|
|
|
(define-syntax (template stx)
|
|
(parameterize ((current-syntax-context stx))
|
|
(syntax-case stx ()
|
|
[(template t)
|
|
(let-values ([(guide deps) (parse-template #'t)])
|
|
(let ([vars
|
|
(for/list ([dep (in-vector deps)])
|
|
(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)]
|
|
[else
|
|
(error 'template
|
|
"internal error: bad environment entry: ~e"
|
|
dep)]))])
|
|
(syntax-arm
|
|
(cond [(equal? guide '1) ;; was (template pvar)
|
|
(with-syntax ([var (car vars)])
|
|
#'(if (syntax? var)
|
|
var
|
|
(error/not-stx (quote-syntax t) var)))]
|
|
[(equal? guide '_) ;; constant
|
|
#`(quote-syntax t)]
|
|
[else
|
|
(with-syntax ([guide guide]
|
|
[(var ...) vars])
|
|
#'(substitute (quote-syntax t)
|
|
'guide
|
|
(vector var ...)))]))))])))
|
|
|
|
;; 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))
|
|
|
|
(define (substitute stx g main-env)
|
|
(let ([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 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)
|
|
(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
|
|
|
|
;; 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 (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 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)
|
|
(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) (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)
|
|
(vector 'escaped (loop g1 loop-env))]
|
|
[(vector 'orelse g1 drivers1 g2)
|
|
(vector 'orelse
|
|
(loop g1 loop-env)
|
|
(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
|
|
(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 'app-opt g1 drivers1)
|
|
(vector 'app-opt
|
|
(loop g1 loop-env)
|
|
(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)]))
|
|
(loop g0 '#hash()))
|
|
|
|
;; ----------------------------------------
|
|
|
|
;; parse-t : stx nat boolean -> (values (setof env-entry) pre-guide)
|
|
(define (parse-t t depth esc?)
|
|
(syntax-case t (?? ?@)
|
|
[id
|
|
(identifier? #'id)
|
|
(cond [(and (not esc?)
|
|
(or (free-identifier=? #'id (quote-syntax ...))
|
|
(free-identifier=? #'id (quote-syntax ??))
|
|
(free-identifier=? #'id (quote-syntax ?@))))
|
|
(wrong-syntax #'id "illegal use")]
|
|
[else
|
|
(let ([pvar (lookup #'id depth)])
|
|
(cond [(pvar? pvar)
|
|
(values (set pvar) pvar)]
|
|
[(template-metafunction? pvar)
|
|
(wrong-syntax t "illegal use of syntax metafunction")]
|
|
[else (values (set) '_)]))])]
|
|
[(mf . template)
|
|
(and (not esc?)
|
|
(identifier? #'mf)
|
|
(template-metafunction? (lookup #'mf #f)))
|
|
(let-values ([(mf) (lookup #'mf #f)]
|
|
[(drivers guide) (parse-t #'template depth esc?)])
|
|
(values (set-union (set mf) drivers)
|
|
(vector 'metafun mf guide)))]
|
|
[(DOTS template)
|
|
(and (not esc?)
|
|
(identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...)))
|
|
(let-values ([(drivers guide) (parse-t #'template depth #t)])
|
|
(values drivers (vector 'escaped guide)))]
|
|
[(?? t1 t2)
|
|
(not esc?)
|
|
(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 pvar?) 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) (parse-h #'head (+ depth nesting) esc?)]
|
|
[(tdrivers tguide) (parse-t tail depth esc?)])
|
|
(unless (positive? (set-count hdrivers))
|
|
(wrong-syntax #'head "no pattern variables in term before ellipsis"))
|
|
(values (set-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)])
|
|
(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?)])
|
|
(values (set-union hdrivers tdrivers)
|
|
(cond [(and (eq? hguide '_) (eq? tguide '_)) '_]
|
|
[hsplice? (vector 'app hguide tguide)]
|
|
[else (cons hguide tguide)])))]
|
|
[vec
|
|
(vector? (syntax-e #'vec))
|
|
(let-values ([(drivers guide) (parse-t (vector->list (syntax-e #'vec)) depth esc?)])
|
|
(values drivers (if (eq? guide '_) '_ (vector 'vector guide))))]
|
|
[pstruct
|
|
(prefab-struct-key (syntax-e #'pstruct))
|
|
(let-values ([(drivers guide)
|
|
(parse-t (cdr (vector->list (struct->vector (syntax-e #'pstruct)))) depth esc?)])
|
|
(values drivers (if (eq? guide '_) '_ (vector 'struct guide))))]
|
|
[#&template
|
|
(let-values ([(drivers guide) (parse-t #'template depth esc?)])
|
|
(values drivers (if (eq? guide '_) '_ (vector 'box guide))))]
|
|
[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 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?)])
|
|
(values drivers #t (vector 'splice guide)))]
|
|
[t
|
|
(let-values ([(drivers guide) (parse-t #'t depth esc?)])
|
|
(values drivers #f guide))]))
|
|
|
|
;; Note: always creates equal?-based set.
|
|
(define (set-filter s pred?)
|
|
(for/set ([el (in-set s)] #:when (pred? el)) el))
|
|
|
|
(define (lookup id depth)
|
|
(let ([v (syntax-local-value id (lambda () #f))])
|
|
(cond [(syntax-pattern-variable? 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
|
|
;; id is a literal; check that for all x s.t. id = x.y, x is not a pattern variable
|
|
(for ([pfx (in-list (dotted-prefixes id))])
|
|
(when (syntax-pattern-variable? (syntax-local-value pfx (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 dd) (and dd (<= dd expected-dd))]
|
|
[_ #f]))
|
|
)
|