From 5a1badf397a0d510155114132f8d08f0a77a9b5a Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Fri, 10 Feb 2012 16:05:12 -0700 Subject: [PATCH] syntax/parse: added template metafunctions Also fixed some bugs and added simple optimizations. --- .../syntax/parse/experimental/template.rkt | 234 +++++++++++++----- .../scribblings/parse/experimental.scrbl | 32 +++ collects/tests/stxparse/test-template.rkt | 30 ++- 3 files changed, 233 insertions(+), 63 deletions(-) diff --git a/collects/syntax/parse/experimental/template.rkt b/collects/syntax/parse/experimental/template.rkt index 02e2bd177a..062c196287 100644 --- a/collects/syntax/parse/experimental/template.rkt +++ b/collects/syntax/parse/experimental/template.rkt @@ -11,6 +11,7 @@ syntax/parse/private/residual unstable/struct) (provide template + define-template-metafunction ?? ?@) @@ -27,6 +28,7 @@ To do: A Template (T) is one of: - pvar - atom (including (), not pvar) + - (metafunction . T) - (H . T) - (H ... . T), (H ... ... . T), etc - (?? T T) @@ -42,18 +44,32 @@ A HeadTemplate (H) is one of: (parameterize ((current-syntax-context stx)) (syntax-case stx () [(template t) - (let-values ([(guide pvars) (parse-template #'t)]) + (let-values ([(guide deps) (parse-template #'t)]) ;; (eprintf "guide = ~s\n" guide) - (with-syntax ([guide - guide] - [(var ...) - (for/list ([pvar (in-vector pvars)]) - (let* ([valvar (syntax-mapping-valvar pvar)] - [attr (syntax-local-value valvar (lambda () #f))]) - (cond [(attribute-mapping? attr) - (attribute-mapping-var attr)] - [else valvar])))]) - (syntax-arm #'(substitute (quote-syntax t) 'guide (vector var ...)))))]))) + (let ([vars + (for/list ([dep (in-vector deps)]) + (cond [(syntax-pattern-variable? dep) + (let* ([valvar (syntax-mapping-valvar dep)] + [attr (syntax-local-value valvar (lambda () #f))]) + (cond [(attribute-mapping? attr) + (attribute-mapping-var attr)] + [else valvar]))] + [(template-metafunction? dep) + (template-metafunction-var 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 ...)))]))))]))) (define-syntaxes (?? ?@) (let ([tx (lambda (stx) (raise-syntax-error #f "not allowed as an expression" stx))]) @@ -65,8 +81,7 @@ A HeadTemplate (H) is one of: A Guide (G) is one of: - _ - (G . G) - - positive-integer - - negative-integer + - integer - #s(stxvector G) - #s(stxstruct G) - #&G @@ -74,11 +89,17 @@ A Guide (G) is one of: - #s(app HG G) - #s(escaped G) - #s(orelse G (vector-of integer) G) + - #s(metafun integer G) + "optimized" forms: + - #s(sdots G integer G) ; simple head template, one driver, nesting=1 A HeadGuide (HG) is one of: - G - #s(app-opt G (vector-of integer)) - #s(splice G) + +A Pre-Guide is like a Guide but with pvars and pvar sets instead of +integers and integer vectors. |# (define-syntax-rule (begin-both-phases form ...) @@ -92,8 +113,31 @@ A HeadGuide (HG) is one of: (struct app (head tail) #:prefab) (struct escaped (body) #:prefab) (struct orelse (g1 drivers1 g2) #:prefab) + (struct metafun (index g) #:prefab) (struct app-opt (g drivers) #:prefab) - (struct splice (g) #:prefab)) + (struct splice (g) #:prefab) + + (struct sdots (head driver tail) #:prefab) + + (define (head-guide? x) + (or (app-opt? x) (splice? x))) + ) + +;; ============================================================ + +(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))) ;; ============================================================ @@ -101,29 +145,37 @@ A HeadGuide (HG) is one of: (define (parse-template t) (let-values ([(_const? drivers pre-guide) (parse-t t 0 #f)]) - ;; (eprintf "pre-guide = ~s\n" pre-guide) - (define (pvar-set->env drivers) + (define (set->env drivers) (for/hash ([pvar (in-set drivers)] [n (in-naturals 1)]) (values pvar n))) - (define main-env (pvar-set->env drivers)) + (define main-env (set->env drivers)) (define (loop g loop-env) - (define (pvar->index pvar) - (let ([loop-index (hash-ref loop-env pvar #f)]) + (define (get-index x) + (let ([loop-index (hash-ref loop-env x #f)]) (if loop-index (- loop-index) - (hash-ref main-env pvar)))) + (hash-ref main-env x)))) (match g ['_ '_] [(cons g1 g2) (cons (loop g1 loop-env) (loop g2 loop-env))] - [(? syntax-pattern-variable? pvar) (pvar->index pvar)] + [(? syntax-pattern-variable? pvar) (get-index pvar)] [(dots head hdrivers nesting tail) - (let* ([sub-loop-env (pvar-set->env hdrivers)] - [sub-loop-vector (index-hash->vector sub-loop-env pvar->index)]) - (dots (loop head sub-loop-env) - sub-loop-vector - nesting - (loop tail loop-env)))] + (cond [(and (= nesting 1) + (= (set-count hdrivers) 1) + (not (head-guide? head))) + (let* ([pvar (for/first ([pvar (in-set hdrivers)]) pvar)] + [sub-loop-env (hash pvar 0)]) + (sdots (loop head sub-loop-env) + (get-index pvar) + (loop tail loop-env)))] + [else + (let* ([sub-loop-env (set->env hdrivers)] + [sub-loop-vector (index-hash->vector sub-loop-env get-index)]) + (dots (loop head sub-loop-env) + sub-loop-vector + nesting + (loop tail loop-env)))])] [(app head tail) (app (loop head loop-env) (loop tail loop-env))] [(escaped g1) @@ -131,8 +183,11 @@ A HeadGuide (HG) is one of: [(orelse g1 drivers1 g2) (orelse (loop g1 loop-env) (for/vector ([pvar (in-set drivers1)]) - (pvar->index pvar)) + (get-index pvar)) (loop g2 loop-env))] + [(metafun mf g1) + (metafun (get-index mf) + (loop g1 loop-env))] [(stxvector g1) (stxvector (loop g1 loop-env))] [(stxstruct g1) @@ -142,10 +197,10 @@ A HeadGuide (HG) is one of: [(app-opt g1 drivers1) (app-opt (loop g1 loop-env) (for/vector ([pvar (in-set drivers1)]) - (pvar->index pvar)))] + (get-index pvar)))] [(splice g1) (splice (loop g1 loop-env))] - [else (error 'parse:convert "bad pre-guide: ~e" g)])) + [else (error 'template "internal error: bad pre-guide: ~e" g)])) (define guide (loop pre-guide #hash())) (values guide (index-hash->vector main-env)))) @@ -162,12 +217,36 @@ A HeadGuide (HG) is one of: (free-identifier=? #'id (quote-syntax ?@)))) (wrong-syntax #'id "illegal use")] [else - (let ([pvar (lookup-pvar #'id depth)]) - (cond [pvar (values #f (set pvar) pvar)] + (let ([pvar (lookup #'id depth)]) + (cond [(syntax-pattern-variable? pvar) + (values #f (set pvar) pvar)] + [(template-metafunction? pvar) + (wrong-syntax t "illegal use of syntax metafunction")] [else (values #t (set) '_)]))])] [atom (atom? (syntax-e #'atom)) (values #t (set) '_)] + [(mf . template) + (and (not esc?) + (identifier? #'mf) + (template-metafunction? (lookup #'mf #f))) + (let-values ([(mf) (lookup #'mf #f)] + [(const? drivers guide) (parse-t #'template depth esc?)]) + (values #f + (set-union (set mf) drivers) + (metafun mf guide)))] + [(DOTS template) + (and (not esc?) + (identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...))) + (let-values ([(const? drivers guide) (parse-t #'template depth #t)]) + (values #f drivers (escaped guide)))] + [(?? t1 t2) + (not esc?) + (let-values ([(const1? drivers1 guide1) (parse-t #'t1 depth esc?)] + [(const2? drivers2 guide2) (parse-t #'t2 depth esc?)]) + (values #f + (set-union drivers1 drivers2) + (orelse guide1 (set-filter drivers1 syntax-pattern-variable?) guide2)))] [(head DOTS . tail) (and (not esc?) (identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...))) @@ -180,24 +259,11 @@ A HeadGuide (HG) is one of: [else (values nesting tail)]))]) (let-values ([(hconst? hdrivers _hsplice? hguide) (parse-h #'head (+ depth nesting) esc?)] [(tconst? tdrivers tguide) (parse-t tail depth esc?)]) + (unless (positive? (set-count hdrivers)) + (wrong-syntax #'head "no pattern variables in term before ellipsis")) (values #f (set-union hdrivers tdrivers) - (dots hguide hdrivers nesting tguide))))] - [(DOTS template) - (and (not esc?) - (identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...))) - (let-values ([(const? drivers guide) (parse-t #'template depth #t)]) - (values #f drivers (escaped guide)))] - [(?? t1 t2) - (not esc?) - (let-values ([(const1? drivers1 guide1) (parse-t #'t1 depth esc?)] - [(const2? drivers2 guide2) (parse-t #'t2 depth esc?)]) - (values #f - (set-union drivers1 drivers2) - (orelse guide1 drivers1 guide2)))] - [(?? . _) - (not esc?) - (wrong-syntax t "bad pattern")] + (dots hguide (set-filter hdrivers pvar/depth>0?) nesting tguide))))] [(head . tail) (let-values ([(hconst? hdrivers hsplice? hguide) (parse-h #'head depth esc?)] [(tconst? tdrivers tguide) (parse-t #'tail depth esc?)]) @@ -225,7 +291,7 @@ A HeadGuide (HG) is one of: [(?? t) (not esc?) (let-values ([(const? drivers guide) (parse-t #'t depth esc?)]) - (values #f drivers #t (app-opt guide drivers)))] + (values #f drivers #t (app-opt guide (set-filter drivers syntax-pattern-variable?))))] [(?@ . t) (not esc?) (let-values ([(const? drivers guide) (parse-t #'t depth esc?)]) @@ -244,16 +310,23 @@ A HeadGuide (HG) is one of: (regexp? x) (char? x))) - (define (lookup-pvar id depth) + ;; 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) - (unless (or (= (syntax-mapping-depth v) depth) + (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] + [(template-metafunction? v) + v] [else #f]))) (define (index-hash->vector hash [f values]) @@ -261,17 +334,22 @@ A HeadGuide (HG) is one of: (for ([(value index) (in-hash hash)]) (vector-set! vec (sub1 index) (f value))) vec)) + + (define (pvar/depth>0? x) + (and (syntax-pattern-variable? x) + (positive? (syntax-mapping-depth x)))) + ) ;; ============================================================ (define (substitute stx g main-env) - ;; (eprintf "main-env = ~s\n" main-env) (define (get index lenv) (cond [(positive? index) (vector-ref main-env (sub1 index))] - [else - (vector-ref lenv (- -1 index))])) + [(negative? index) + (vector-ref lenv (- -1 index))] + [(zero? index) lenv])) (define (loop stx g lenv) (match g ['_ stx] @@ -279,9 +357,21 @@ A HeadGuide (HG) is one of: (restx stx (cons (loop (stx-car stx) g1 lenv) (loop (stx-cdr stx) g2 lenv)))] [(? exact-integer? index) (let ([v (get index lenv)]) - (unless (syntax? v) - (error 'template "syntax pattern variable is not syntax-valued")) - v)] + (if (syntax? v) + v + (error/not-stx stx v)))] + [(sdots ghead loop-var gtail) + (let ([lenv* (get loop-var lenv)]) + (unless lenv* (error 'template "pattern variable used in ellipsis pattern is not defined")) + (restx stx + (if (equal? ghead '0) ;; pattern was just (pvar ... . T) + (append lenv* (loop (stx-cddr stx) gtail lenv)) + (let ([head-stx (stx-car stx)]) + (let dotsloop ([lenv* lenv*]) + (if (null? lenv*) + (loop (stx-cddr stx) gtail lenv) + (cons (loop head-stx ghead (car lenv*)) + (dotsloop (cdr lenv*)))))))))] [(dots ghead henv nesting gtail) (define head-stx (stx-car stx)) (define (nestloop lenv* nesting) @@ -289,11 +379,13 @@ A HeadGuide (HG) is one of: (loop-h head-stx ghead lenv*)] [else (for ([v (in-vector lenv*)]) - (unless v (error 'template "loop variable is not defined"))) + (unless v (error 'template "pattern variable used in ellipsis pattern is not defined"))) (let ([len0 (length (vector-ref lenv* 0))]) (for ([v (in-vector lenv*)]) (unless (= len0 (length v)) - (error 'template "loop variable count mismatch"))) + (raise-syntax-error 'template + "incomplatible ellipsis match counts for template" + stx))) (let dotsloop ([len0 len0] [lenv* lenv*]) (if (zero? len0) null @@ -313,6 +405,16 @@ A HeadGuide (HG) is one of: (if (for/and ([index (in-vector drivers1)]) (get index lenv)) (loop (stx-cadr stx) g1 lenv) (loop (stx-caddr stx) g2 lenv))] + [(metafun index g1) + (let ([v (restx stx (cons (stx-car stx) (loop (stx-cdr stx) g1 lenv)))] + [mark (make-syntax-introducer)] + [old-mark (current-template-metafunction-introducer)] + [mf (get index lenv)]) + (parameterize ((current-template-metafunction-introducer mark)) + (let ([r (mf (mark (old-mark v)))]) + (unless (syntax? r) + (raise-syntax-error 'template "result of metafunction was not syntax" stx)) + (restx stx (old-mark (mark r))))))] [(stxvector g1) (restx stx (list->vector (loop (vector->list (syntax-e stx)) g1 lenv)))] [(stxstruct g1) @@ -332,11 +434,20 @@ A HeadGuide (HG) is one of: (let* ([v (loop (stx-cdr stx) g1 lenv)] [v* (stx->list v)]) (unless v* - (error 'template "not a syntax list: ~e" v)) + (raise-syntax-error 'template + "splicing template did not produce a syntax list" + stx)) v*)] [else (list (loop stx hg lenv))])) (loop stx g #f)) +(define current-template-metafunction-introducer + (make-parameter + (lambda (stx) + (if (syntax-transforming?) + (syntax-local-introduce stx) + 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)))) @@ -357,3 +468,6 @@ A HeadGuide (HG) is one of: [(zero? nesting) (append lst onto)] [else (deep-append (car lst) (sub1 nesting) (deep-append (cdr lst) nesting onto))])) + +(define (error/not-stx stx val) + (raise-syntax-error 'template "pattern variable is not syntax-valued" stx)) diff --git a/collects/syntax/scribblings/parse/experimental.scrbl b/collects/syntax/scribblings/parse/experimental.scrbl index bc4f7276b0..68fd6f1c65 100644 --- a/collects/syntax/scribblings/parse/experimental.scrbl +++ b/collects/syntax/scribblings/parse/experimental.scrbl @@ -278,6 +278,7 @@ patterns as @racket[target-stxclass-id] but with the given atomic-tmpl (head-tmpl . tmpl) (head-tmpl ellipsis ...+ . tmpl) + (metafunction-id . tmpl) (?? tmpl tmpl) #(@#,svar[tmpl] ...) #s(prefab-struct-key @#,svar[tmpl] ...) @@ -348,6 +349,13 @@ template: (template ((?@ . x) ...))) ] } + +@specsubform[(metafunction-id . tmpl)]{ + +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. +} } @deftogether[[ @@ -356,3 +364,27 @@ template: ]]{ Auxiliary forms used by @racket[template]. } + +@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. + +@examples[#:eval the-eval +(define-template-metafunction (join stx) + (syntax-parse stx + [(join a:id b:id ...) + (datum->syntax #'a + (string->symbol + (apply string-append + (map symbol->string + (syntax->datum #'(a b ...))))) + stx)])) +(template (join a b c)) +(with-syntax ([(x ...) #'(a b c)]) + (template ((x (join tmp- x)) ...))) +] +} diff --git a/collects/tests/stxparse/test-template.rkt b/collects/tests/stxparse/test-template.rkt index 44a9f33d01..49ca3ede95 100644 --- a/collects/tests/stxparse/test-template.rkt +++ b/collects/tests/stxparse/test-template.rkt @@ -19,7 +19,7 @@ ;; Common pattern variable definitions ;; (avoids having to have 'with-syntax' in every test case) -(define/with-syntax uu #'ABC) +(define/with-syntax uu #'abc) (define/with-syntax (aa ...) #'(a b c)) (define/with-syntax (xx ...) #'(x y z)) (define/with-syntax (nn ...) #'(1 2 3)) @@ -30,7 +30,7 @@ ;; ---------------------------------------- -(tc (template uu) 'ABC) +(tc (template uu) 'abc) ;; FIXME: add other atoms when supported ;; FIXME: add other compound stx when supported @@ -39,7 +39,7 @@ (tc (template 5) '5) (tc (template (1 2 #f #t "hey")) '(1 2 #f #t "hey")) (tc (template (1 . b)) '(1 . b)) -(tc (template (1 . uu)) '(1 . ABC)) +(tc (template (1 . uu)) '(1 . abc)) (tc (template #(aa ... done)) '#(a b c done)) @@ -48,6 +48,8 @@ (tc (template (aa ...)) '(a b c)) +(tc (template ((uu aa) ...)) + '((abc a) (abc b) (abc c))) (tc (template ((aa aa) ...)) '((a a) (b b) (c c))) (tc (template (start (aa ok) ... done)) @@ -101,3 +103,25 @@ [(a:id ... (~optional s:str) n:nat ...) (template (a ... n ... (?@ . (?? (string: s) ()))))]) '(a b c 1 2 3 string: "hello!")) + +;; ---------------------------------------- + + +(define-template-metafunction (join stx) + (syntax-parse stx + [(join a:id b:id ...) + (datum->syntax #'a + (string->symbol + (apply string-append + (map symbol->string + (syntax->datum #'(a b ...))))) + stx)])) + +(tc (template (join a b c)) + 'abc) +(tc (template ((xx (join tmp- xx)) ...)) + '((x tmp-x) (y tmp-y) (z tmp-z))) +(tc (template ((xx (join uu - xx)) ...)) + '((x abc-x) (y abc-y) (z abc-z))) +(tc (template ((xx (join aa xx)) ...)) + '((x ax) (y by) (z cz)))