commit 29c90350b223288fb5f47075ea666ad91fb6ca17
parent 5be04ef8fd1f25516fd59d0ee22ea80c5f2cd02f
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Tue, 24 Jan 2017 03:01:41 +0100
Failed attempt at making metafunctions from syntax/parse/experimental/template and stxparse-info/parse/experimental/template compatible. I can manage to extract the binding from syntax/parse/…, but it seems to recognize a different struct (e.g. as if they were struct instances from two different phases)
Diffstat:
11 files changed, 232 insertions(+), 490 deletions(-)
diff --git a/parse.rkt b/parse.rkt
@@ -22,9 +22,10 @@
[syntax-local-syntax-parse-pattern-introduce
(-> syntax? syntax?)]))
- (define pattern-expander
+ (require (only-in (for-template syntax/parse) pattern-expander))
+ #;(define pattern-expander
(let ()
- (struct pattern-expander (proc) #:transparent
+ #;(struct pattern-expander (proc) #:transparent
#:omit-define-syntaxes
#:property prop:pattern-expander (λ (this) (pattern-expander-proc this)))
pattern-expander)))
diff --git a/parse/experimental/private/substitute.rkt b/parse/experimental/private/substitute.rkt
@@ -1,477 +0,0 @@
-#lang racket/base
-(require syntax/parse/private/minimatch
- racket/private/promise
- racket/private/stx) ;; syntax/stx
-(provide translate)
-
-#|
-;; 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))
- (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 (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 stxparse-info/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))
diff --git a/parse/experimental/steal-box.rkt b/parse/experimental/steal-box.rkt
@@ -0,0 +1,3 @@
+(module steal-box '#%kernel
+ (define-values (bx) (box #f))
+ (#%provide bx))
+\ No newline at end of file
diff --git a/parse/experimental/steal-metafunction.rkt b/parse/experimental/steal-metafunction.rkt
@@ -0,0 +1,59 @@
+#lang racket
+
+;; Manages to grasp the template-metafunction via (namespace-mapped-symbols)
+;; within the eval.
+(module extracted-template-metafunction racket/base
+ (require (for-syntax syntax/parse/experimental/template)
+ (for-syntax racket/base)
+ (for-meta 2 racket/base)
+ (for-meta 2 stxparse-info/parse/experimental/steal-box))
+ (define-syntax (fu stx)
+ (syntax-case stx ()
+ [(_ id-mf? id-mf-v)
+ (let ()
+ (eval #'(begin
+ (require (for-syntax
+ stxparse-info/parse/experimental/steal-box))
+ (define-template-metafunction (mf stx)
+ #'1)
+ (define-syntax (extract stx)
+ ;; Use 3D syntax to return the value:
+ (displayln (namespace-mapped-symbols))
+ ;(displayln (eval 'template-metafunction))
+ (define ctor (namespace-variable-value
+ (for/first ([sym (namespace-mapped-symbols)]
+ #:when (regexp-match #rx"template-metafunction[0-9].*" (symbol->string sym)))
+ sym)))
+ (displayln (list ctor (ctor 5165163)))
+ (displayln (template-metafunction? (syntax-local-value #'mf)))
+ (set-box! bx template-metafunction?)
+ #'(void)
+ #;#`(values #,template-metafunction?
+ #,template-metafunction-var))
+ (extract))
+ (module->namespace 'syntax/parse/experimental/template))
+ #`(begin
+ (define-for-syntax id-mf? 0)
+ (define-for-syntax id-mf-v 1)))]))
+ (fu out-id-mf? out-id-mf-v)
+ (begin-for-syntax
+ (define-for-syntax rsl bx))
+
+ #;(begin-for-syntax
+ (define-syntax (br stx)
+ (displayln rsl)
+ #'(void))
+ (br))
+ #;(begin-for-syntax
+ (begin-for-syntax
+ (displayln rsl)))
+ (provide (for-meta 2 rsl #;out-id-mf? #;out-id-mf-v)))
+
+#;(require (rename-in (for-template 'extracted-template-metafunction)
+ [out-id-mf? template-metafunction?]
+ [out-id-mf-v template-metafunction-var]))
+(require (for-meta -2 'extracted-template-metafunction))
+(displayln rsl)
+
+#;(provide template-metafunction?
+ template-metafunction-var)
diff --git a/parse/experimental/steal-metafunction2.rkt b/parse/experimental/steal-metafunction2.rkt
@@ -0,0 +1,25 @@
+#lang racket
+
+(require (for-syntax syntax/parse/experimental/template)
+ (for-syntax racket/base)
+ (for-meta 2 racket/base)
+ (for-meta 2 stxparse-info/parse/experimental/steal-box))
+
+(begin-for-syntax
+ (eval #'(begin (define-syntax (e2 stx)
+ #`(begin
+ (module #,(cdr (syntax-e stx)) racket
+ (provide (for-syntax e4a e4b))
+ ;(require syntax/parse/experimental/template)
+ (define-for-syntax e4a #,template-metafunction?)
+ (define-for-syntax e4b #,template-metafunction-var)
+ (module* e5 racket/base
+ (require (for-template (submod "..")))
+ (provide e4a e4b)))))
+ (e2 . e3))
+ (module->namespace 'syntax/parse/experimental/template))
+ (define e5a (dynamic-require '(submod 'e3 e5) 'e4a))
+ (define e5b (dynamic-require '(submod 'e3 e5) 'e4b))
+ (provide (rename-out [e5a template-metafunction?]
+ [e5b template-metafunction-var])))
+
diff --git a/parse/experimental/template.rkt b/parse/experimental/template.rkt
@@ -7,7 +7,7 @@
racket/private/sc
racket/struct)
stxparse-info/parse/private/residual
- "private/substitute.rkt")
+ syntax/parse/experimental/private/substitute)
(provide template
template/loc
quasitemplate
@@ -16,6 +16,64 @@
??
?@)
+;; This is a bit ugly. Also, we can't extract the constructor for some reason
+;; (probably because it is a transformer binding, not a variable),
+;; so we require the original `define-template-metafunction` from
+;; syntax/parse/experimental/template to fulfill the defintition below.
+(require (only-in syntax/parse/experimental/template
+ define-template-metafunction))
+(begin-for-syntax
+ (require "steal-metafunction.rkt")
+ (provide template-metafunction?
+ template-metafunction-var))
+#;(begin
+ (require (only-in syntax/parse/experimental/template
+ define-template-metafunction))
+ (begin-for-syntax
+ (module extracted-template-metafunction racket/base
+ (require syntax/parse/experimental/template
+ (for-syntax racket/base))
+ (define-values (template-metafunction?
+ ;template-metafunction
+ template-metafunction-var)
+ (eval #'(begin
+ (define-syntax (extract stx)
+ ;; Use 3D syntax to return the value:
+ #`(values #,template-metafunction?
+ ;; Doesn't work, probably because it's a macro:
+ ;#,template-metafunction
+ #,template-metafunction-var))
+ (extract))
+ (module->namespace 'syntax/parse/experimental/template)))
+ (provide template-metafunction?
+ ;template-metafunction
+ template-metafunction-var))
+
+ (require 'extracted-template-metafunction)
+ (provide template-metafunction?
+ template-metafunction-var)
+
+ ;; Tests:
+ #;(begin
+ (require rackunit)
+
+ (require 'extracted-template-metafunction)
+ (require (for-meta 4 'extracted-template-metafunction))
+ (check-equal? (format "~a" template-metafunction?)
+ "#<procedure:template-metafunction?>")
+
+ (require (for-meta 1 racket/base))
+ (require (for-meta 2 racket/base))
+ (require (for-meta 3 racket/base))
+ (require (for-meta 4 racket/base))
+ (begin-for-syntax
+ (begin-for-syntax
+ (begin-for-syntax
+ (begin-for-syntax
+ (require rackunit)
+ (check-equal? (format "~a" template-metafunction?)
+ "#<procedure:template-metafunction?>"))))))))
+
#|
To do:
- improve error messages
@@ -185,7 +243,8 @@ instead of integers and integer vectors.
;; ============================================================
-(define-syntax (define-template-metafunction stx)
+
+#;(define-syntax (define-template-metafunction stx)
(syntax-case stx ()
[(dsm (id arg ...) . body)
#'(dsm id (lambda (arg ...) . body))]
@@ -197,7 +256,9 @@ instead of integers and integer vectors.
(template-metafunction (quote-syntax internal-id)))))]))
(begin-for-syntax
- (struct template-metafunction (var)))
+ ;; This struct is not declared here, but instead extracted from the official
+ ;; syntax/parse/experimental/template, at the top of this file.
+ #;(struct template-metafunction (var)))
;; ============================================================
diff --git a/parse/experimental/test-steal.rkt b/parse/experimental/test-steal.rkt
@@ -0,0 +1,14 @@
+#lang racket
+(require syntax/parse/experimental/template
+ stxparse-info/parse/experimental/steal-metafunction2)
+(define-template-metafunction (mf stx)
+ #'1)
+(provide mf)
+
+(let ()
+ (define-syntax (foo stx)
+ (displayln
+ (template-metafunction?
+ (syntax-local-value #'mf)))
+ #''ok)
+ (foo))
+\ No newline at end of file
diff --git a/parse/private/runtime-reflect.rkt b/parse/private/runtime-reflect.rkt
@@ -12,10 +12,28 @@
A Reified is
(reified symbol ParserFunction nat (listof (list symbol nat)))
|#
-(define-struct reified-base (name) #:transparent)
-(define-struct (reified reified-base) (parser arity signature))
-(define-struct (reified-syntax-class reified) ())
-(define-struct (reified-splicing-syntax-class reified) ())
+(require (only-in syntax/parse/private/runtime-reflect
+ reified
+ reified?
+ reified-parser
+ reified-arity
+ reified-signature
+ make-reified
+ struct:reified
+
+ reified-syntax-class
+ reified-syntax-class?
+ make-reified-syntax-class
+ struct:reified-syntax-class
+
+ reified-splicing-syntax-class
+ reified-splicing-syntax-class?
+ make-reified-splicing-syntax-class
+ struct:reified-splicing-syntax-class))
+#;(define-struct reified-base (name) #:transparent)
+#;(define-struct (reified reified-base) (parser arity signature))
+#;(define-struct (reified-syntax-class reified) ())
+#;(define-struct (reified-splicing-syntax-class reified) ())
(define (reflect-parser obj e-arity e-attrs splicing?)
;; e-arity represents single call; min and max are same
diff --git a/scribblings/stxparse-info.scrbl b/scribblings/stxparse-info.scrbl
@@ -13,15 +13,15 @@
(require scribble/example)
(define ev ((make-eval-factory '(racket))))])
-@title{stxparse-info : tracking bound syntax pattern variables with
- @racketmodname[syntax/parse]}
+@title{stxparse-info : Tracking bound syntax pattern variables with
+ @racket[syntax-parse] and @racket[syntax-case]}
@author[@author+email["Georges Dupéron" "georges.duperon@gmail.com"]]
Source code: @url{https://github.com/jsmaniac/stxparse-info}
@defmodule[stxparse-info]
-This library provides some patched versions of @racketmodname[syntax/parse]
+This library provides some patched versions of @racket[syntax-parse]
and the @racket[syntax-case] family. These patched versions track which syntax
pattern variables are bound. This allows some libraries to change the way
syntax pattern variables work.
@@ -40,7 +40,7 @@ The module @racketmodname[stxparse-info/parse] provides patched versions of
@racketmodname[syntax/parse] @racketmodname[define/syntax-parse] which track
which syntax pattern variables are bound.
-@section{Tracking currently-bound pattern variables with @racket[syntax-parse]}
+@section{Tracking currently-bound pattern variables with @racket[syntax-case]}
@defmodule[stxparse-info/case]
diff --git a/test/test-compatibility1.rkt b/test/test-compatibility1.rkt
@@ -0,0 +1,11 @@
+#lang racket
+(require ;syntax/parse
+ ;syntax/parse/experimental/template
+ stxparse-info/parse
+ stxparse-info/parse/experimental/template)
+(provide mf original-template)
+(define-template-metafunction (mf stx)
+ #'ok-metafunction-official-1)
+(define-syntax-rule (original-template t)
+ (template t))
+
+\ No newline at end of file
diff --git a/test/test-compatibility2.rkt b/test/test-compatibility2.rkt
@@ -0,0 +1,23 @@
+#lang racket
+(require ;syntax/parse
+ ;syntax/parse/experimental/template
+ stxparse-info/parse
+ stxparse-info/parse/experimental/template
+ rackunit
+ #;"test-compatibility1.rkt")
+(define-template-metafunction (mf stx)
+ #'ok-metafunction-official-1)
+
+#;(check-equal? (syntax-parse #'(1 (2 3))
+ [(x {~optional y} ({~optional z} t))
+ (list #;(syntax->datum
+ (original-template (x (?? y no-y) (?? z no-z) t (mf))))
+ (syntax->datum
+ (template (x (?? y no-y) (?? z no-z) t (mf)))))])
+ '(#;(1 no-y 2 3 ok-metafunction-official-1)
+ (1 no-y 2 3 ok-metafunction-official-1)))
+
+(syntax-parse #'(1 (2 3))
+ [(x {~optional y} ({~optional z} t))
+ (syntax->datum
+ (template (x (?? y no-y) (?? z no-z) t (mf))))])
+\ No newline at end of file
