commit 9f738e12e5c3185dce34e87374b06c296129c646
parent 60e567af3bcbff9887093eae204668f83889d518
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Fri, 7 Oct 2016 04:46:06 +0200
Arrows for subtemplate derived ids work in DrRacket
Diffstat:
6 files changed, 636 insertions(+), 257 deletions(-)
diff --git a/fully-expanded-grammar-extract-bindings.rkt b/fully-expanded-grammar-extract-bindings.rkt
@@ -0,0 +1,109 @@
+#lang racket/base
+
+;; This file is based on the file fully-expanded-grammar.rkt in the same folder.
+
+(require syntax/parse
+ phc-toolkit/untyped
+ racket/contract
+ racket/list
+ (for-template '#%kernel))
+
+(provide extract-bindings)
+
+(define acc (make-parameter #f))
+
+(define/contract (acc! v)
+ (-> identifier? void?)
+ (set-box! (acc) (cons v (unbox (acc)))))
+
+(define-syntax-class acc-id
+ #:attributes ()
+ (pattern {~and id:id
+ {~do (acc! #'id)}}))
+
+(define/contract (extract-bindings e)
+ (-> syntax? (listof identifier?))
+ (parameterize ([acc (box '())])
+ (syntax-parse e
+ [:expr 'ok])
+ (fold-syntax (λ (stx rec)
+ (let ([d (syntax-property stx 'disappeared-binding)])
+ (for-each acc! (filter identifier? (flatten d))))
+ (rec stx))
+ e)
+ (unbox (acc))))
+
+(define-syntax-class top-level-form
+ #:literals (#%expression module #%plain-module-begin begin begin-for-syntax)
+ (pattern :general-top-level-form)
+ (pattern (#%expression :expr))
+ (pattern (module :id _module-path
+ (#%plain-module-begin
+ :module-level-form …)))
+ (pattern (begin :top-level-form …))
+ (pattern (begin-for-syntax :top-level-form …)))
+
+(define-syntax-class module-level-form
+ #:literals (#%provide begin-for-syntax #%declare)
+ (pattern :general-top-level-form)
+ (pattern (#%provide _raw-provide-spec …))
+ (pattern (begin-for-syntax :module-level-form …))
+ (pattern :submodule-form)
+ (pattern (#%declare _declaration-keyword …)))
+
+(define-syntax-class submodule-form
+ #:literals (module #%plain-module-begin module* )
+ (pattern (module :id _module-path
+ (#%plain-module-begin
+ :module-level-form …)))
+ (pattern (module* :id _module-path
+ (#%plain-module-begin
+ :module-level-form …)))
+ (pattern (module* :id #f
+ (#%plain-module-begin
+ :module-level-form …))))
+
+(define-syntax-class general-top-level-form
+ #:literals (define-values define-syntaxes #%require)
+ (pattern :expr)
+ (pattern (define-values (:id …) :expr))
+ (pattern (define-syntaxes (:id …) :expr))
+ (pattern (#%require _raw-require-spec …)))
+
+(define-syntax-class expr
+ #:literals (lambda case-lambda if begin begin0
+ let-values letrec-values letrec-syntaxes+values
+ set! quote quote-syntax
+ with-continuation-mark
+ #%app #%top #%expression #%variable-reference
+ define-values)
+ (pattern :id)
+ (pattern (lambda :formals :expr …+))
+ (pattern (case-lambda (:formals :expr …+) …))
+ (pattern (if :expr :expr :expr))
+ (pattern (begin :expr …+))
+ (pattern (begin0 :expr :expr …))
+ (pattern (let-values ([(:acc-id …) :expr] …)
+ :expr …+))
+ (pattern (letrec-values ([(:acc-id …) :expr] …)
+ :expr …+))
+ (pattern (letrec-syntaxes+values ([(:acc-id …) :expr] …)
+ ([(:acc-id …) :expr] …)
+ :expr …+))
+ (pattern (set! :id :expr))
+ (pattern (quote _datum))
+ (pattern (quote-syntax _datum))
+ (pattern (quote-syntax _datum #:local))
+ (pattern (with-continuation-mark :expr :expr :expr))
+ (pattern (#%app :expr …+))
+ (pattern (#%top . :id))
+ (pattern (#%expression :expr))
+ (pattern (#%variable-reference :id))
+ (pattern (#%variable-reference (#%top . :id)))
+ (pattern (#%variable-reference))
+ (pattern (define-values (lifted-id:acc-id …) _lifted-expr)))
+
+(define-syntax-class formals
+ (pattern (:acc-id …))
+ (pattern (:acc-id …+ . :acc-id))
+ (pattern :acc-id))
diff --git a/fully-expanded-grammar.rkt b/fully-expanded-grammar.rkt
@@ -0,0 +1,90 @@
+#lang racket/base
+
+;; This file is not used by the project, but can be used as a base for macros
+;; which need to parse the result of local-expand. For example, the file
+;; fully-expanded-grammar-extract-bindings.rkt is based on this one.
+
+(require syntax/parse
+ phc-toolkit/untyped
+ (for-template '#%kernel))
+
+(provide top-level-form
+ module-level-form
+ submodule-form
+ general-top-level-form
+ expr
+ formals)
+
+(define-syntax-class top-level-form
+ #:literals (#%expression module #%plain-module-begin begin begin-for-syntax)
+ (pattern :general-top-level-form)
+ (pattern (#%expression :expr))
+ (pattern (module :id _module-path
+ (#%plain-module-begin
+ :module-level-form …)))
+ (pattern (begin :top-level-form …))
+ (pattern (begin-for-syntax :top-level-form …)))
+
+(define-syntax-class module-level-form
+ #:literals (#%provide begin-for-syntax #%declare)
+ (pattern :general-top-level-form)
+ (pattern (#%provide _raw-provide-spec …))
+ (pattern (begin-for-syntax :module-level-form …))
+ (pattern :submodule-form)
+ (pattern (#%declare _declaration-keyword …)))
+
+(define-syntax-class submodule-form
+ #:literals (module #%plain-module-begin module* )
+ (pattern (module :id _module-path
+ (#%plain-module-begin
+ :module-level-form …)))
+ (pattern (module* :id _module-path
+ (#%plain-module-begin
+ :module-level-form …)))
+ (pattern (module* :id #f
+ (#%plain-module-begin
+ :module-level-form …))))
+
+(define-syntax-class general-top-level-form
+ #:literals (define-values define-syntaxes #%require)
+ (pattern :expr)
+ (pattern (define-values (:id …) :expr))
+ (pattern (define-syntaxes (:id …) :expr))
+ (pattern (#%require _raw-require-spec …)))
+
+(define-syntax-class expr
+ #:literals (lambda case-lambda if begin begin0
+ let-values letrec-values letrec-syntaxes+values
+ set! quote quote-syntax
+ with-continuation-mark
+ #%app #%top #%expression #%variable-reference)
+ (pattern :id)
+ (pattern (#%plain-lambda :formals :expr …+))
+ (pattern (case-lambda (:formals :expr …+) …))
+ (pattern (if :expr :expr :expr))
+ (pattern (begin :expr …+))
+ (pattern (begin0 :expr :expr …))
+
+ (pattern (let-values ([(:id …) :expr] …)
+ :expr …+))
+ (pattern (letrec-values ([(:id …) :expr] …)
+ :expr …+))
+ (pattern (letrec-syntaxes+values ([(:id …) :expr] …)
+ ([(:id …) :expr] …)
+ :expr …+))
+ (pattern (set! :id :expr))
+ (pattern (quote _datum))
+ (pattern (quote-syntax _datum))
+ (pattern (quote-syntax _datum #:local))
+ (pattern (with-continuation-mark :expr :expr :expr))
+ (pattern (#%plain-app :expr …+))
+ (pattern (#%top . :id))
+ (pattern (#%expression :expr))
+ (pattern (#%variable-reference :id))
+ (pattern (#%variable-reference (#%top . :id)))
+ (pattern (#%variable-reference)))
+
+(define-syntax-class formals
+ (pattern (:id …))
+ (pattern (:id …+ . :id))
+ (pattern :id))
+\ No newline at end of file
diff --git a/patch-arrows.rkt b/patch-arrows.rkt
@@ -0,0 +1,115 @@
+#lang racket
+
+(require (for-template (only-in '#%kernel [module* k:module*])
+ '#%kernel)
+ phc-toolkit/untyped
+ syntax/parse
+ racket/syntax
+ racket/list
+ racket/contract
+ syntax/id-table
+ syntax/strip-context
+ "fully-expanded-grammar-extract-bindings.rkt")
+
+(provide patch-arrows)
+
+
+(define/contract (patch-arrows stx)
+ (-> syntax? syntax?)
+ (define fully-expanded
+ ;; TODO: local-expand/capture-lifts is probably not what we want here,
+ ;; instead we should just let the lifted expressions pass through.
+ (local-expand/capture-lifts stx 'expression (list #'k:module*))
+ #;(local-expand stx 'expression (list #'k:module*)))
+ (define extracted-list (extract-bindings fully-expanded))
+ (define bindings-table (make-immutable-free-id-table (map cons
+ extracted-list
+ extracted-list)))
+ (define patched-acc '())
+
+ (define/contract (patch-srcloc id)
+ (-> identifier? (or/c #f identifier?))
+ (define table-ref (free-id-table-ref bindings-table id #f))
+ (if (and table-ref
+ ;; all info missing, i.e. (datum->syntax #'lctx 'sym #f) was used
+ (not (or (syntax-source id)
+ (syntax-position id)
+ (syntax-line id)
+ (syntax-column id))))
+ (datum->syntax id (syntax-e id) table-ref id)
+ #f))
+
+ (fold-syntax
+ (λ (stx rec)
+ (define maybe-patched-binders
+ (for*/list ([p* (in-value (syntax-property stx 'sub-range-binders))]
+ #:when p*
+ [p (in-list (flatten p*))])
+ (match p
+ [(vector (? identifier? d) d-start d-len
+ (? identifier? s) s-start s-len)
+ (let ([patched-d (patch-srcloc d)]
+ [patched-s (patch-srcloc s)])
+ (and (or patched-d patched-s)
+ (vector (or patched-d d) d-start d-len
+ (or patched-s s) s-start s-len)))]
+ [(vector (? identifier? d) d-start d-len d-x d-y
+ (? identifier? s) s-start s-len s-x s-y)
+ (let ([patched-d (patch-srcloc d)]
+ [patched-s (patch-srcloc s)])
+ (and (or patched-d patched-s)
+ (vector (or patched-d d) d-start d-len d-x d-y
+ (or patched-s s) s-start s-len s-x s-y)))]
+ [other #| not a sub-range-binder |# #f])))
+ (define patched-binders (filter identity maybe-patched-binders))
+ (when (not (null? patched-binders))
+ (set! patched-acc (cons patched-binders patched-acc)))
+
+ (rec stx))
+ fully-expanded)
+
+ (define existing-property (or (syntax-property fully-expanded
+ 'sub-range-binders)
+ '()))
+ (syntax-property fully-expanded
+ 'sub-range-binders
+ (cons patched-acc existing-property)))
+
+;Example usage:
+#;(module* test racket
+ (require phc-toolkit/untyped)
+ (require (for-syntax (submod "..")))
+ (require (for-syntax phc-toolkit/untyped
+ racket/syntax))
+
+ (define-for-syntax saved (box #f))
+
+ (define-syntax/case (foo y) ()
+ (with-arrows
+ (record-sub-range-binders! (vector #'y
+ 1 1
+ (datum->syntax #'y
+ (unbox saved)
+ #f)
+ 1 1))
+ (record-disappeared-uses #'y)
+ #'(define y 1)))
+
+ (define-syntax/case (bar body) ()
+ (set-box! saved 'aa)
+ (patch-arrows #'body))
+
+
+ (bar
+ (begin
+ 'aa
+ (let ([aa 1])
+ (let ([aa 1])
+ ;; The arrow is drawn from bb to the binding of aa above, thanks to
+ ;; the fact that the srcloc is #f for the arrow's origin id. The
+ ;; patch-arrows function detects that, and substitutes the
+ ;; corresponding definition.
+ ;;
+ ;; Note that it correctly binds to the nearest let, not the outer aa.
+ (foo bb)
+ aa)))))
diff --git a/subtemplate.rkt b/subtemplate.rkt
@@ -1,11 +1,13 @@
#lang racket
-(require phc-toolkit/untyped
+(require racket/require
+ phc-toolkit/untyped
racket/stxparam
syntax/parse
syntax/parse/experimental/template
syntax/id-table
racket/syntax
- (for-syntax syntax/parse
+ (for-syntax "patch-arrows.rkt"
+ syntax/parse
racket/private/sc
racket/syntax
racket/list
@@ -13,10 +15,12 @@
phc-toolkit/untyped
syntax/strip-context
srfi/13
+ (subtract-in racket/string srfi/13)
syntax/contract
racket/contract))
(provide (rename-out [new-syntax-parse syntax-parse]
+ [new-syntax-parser syntax-parser]
[new-syntax-case syntax-case])
subtemplate
quasisubtemplate)
@@ -27,6 +31,14 @@
(define-syntax-parameter pvar-values-id (make-rename-transformer
#'empty-pvar-values))
+(begin-for-syntax
+ (define/contract (split-colon sym)
+ (-> symbol? (cons/c symbol? (listof symbol?)))
+ (cons sym
+ (map string->symbol
+ (string-split (symbol->string sym)
+ ":")))))
+
(define-for-syntax (new-scope rest lctx)
;(wrap-expr/c
;#'(listof (cons/c identifier? (listof symbol?)))
@@ -37,38 +49,48 @@
'#,(~> (syntax->datum rest)
flatten
(filter symbol? _)
+ (append-map split-colon _)
(remove-duplicates)))
(syntax-parameter-value
#'maybe-syntax-pattern-variable-ids)));)
-(define-syntax/parse (new-syntax-parse . rest)
- (quasisyntax/top-loc (stx-car stx)
- ;; HERE insert a hash table, to cache the uses of derived pvars.
- ;; Lifting the define-temp-ids is not likely to work, as they
- ;; need to define syntax pattern variables so that other macros
- ;; can recognize them. Instead, we only lift the values, but still
- ;; do the bindings around the subtemplate.
- (let ([the-pvar-values (cons (make-hash) pvar-values-id)])
- (syntax-parameterize ([maybe-syntax-pattern-variable-ids
- #,(new-scope #'rest (stx-car stx))]
- [pvar-values-id (make-rename-transformer
- #'the-pvar-values)])
- (syntax-parse . rest)))))
+(begin-for-syntax
+ (define/contract (wrap-with-parameterize lctx new-whole-form rest)
+ (-> identifier? syntax? syntax? syntax?)
+ (patch-arrows
+ (quasisyntax/top-loc lctx
+ ;; HERE insert a hash table, to cache the uses of derived pvars.
+ ;; Lifting the define-temp-ids is not likely to work, as they
+ ;; need to define syntax pattern variables so that other macros
+ ;; can recognize them. Instead, we only lift the values, but still
+ ;; do the bindings around the subtemplate.
+ (let ([the-pvar-values (cons (make-hash) pvar-values-id)])
+ (syntax-parameterize ([maybe-syntax-pattern-variable-ids
+ #,(new-scope rest lctx)]
+ [pvar-values-id (make-rename-transformer
+ #'the-pvar-values)])
+ #,new-whole-form))))))
+
+(begin-for-syntax
+ (define/contract (simple-wrap-with-parameterize new-form-id)
+ (-> identifier? (-> syntax? syntax?))
+ (λ/syntax-case (self . rest) ()
+ (wrap-with-parameterize #'self #`(#,new-form-id . rest) #'rest))))
+
+(define-syntax new-syntax-parse
+ (simple-wrap-with-parameterize #'syntax-parse))
+
+(define-syntax new-syntax-case
+ (simple-wrap-with-parameterize #'syntax-case))
-(define-syntax/case (new-syntax-case . rest) ()
- (error "new-syntax-case not implemented yet")
- #;(quasisyntax/top-loc (stx-car stx)
- (let ([the-pvar-values (or pvar-values-id (make-free-id-table))])
- (syntax-parameterize ([maybe-syntax-pattern-variable-ids
- (cons '#,(remove-duplicates
- (filter symbol?
- (flatten
- (syntax->datum #'rest))))
- (syntax-parameter-value
- #'maybe-syntax-pattern-variable-ids))]
- [pvar-values-id (make-rename-transformer
- #'the-pvar-values)])
- (syntax-case . rest)))))
+(define-syntax (new-syntax-parser stx)
+ (syntax-case stx ()
+ [(self . rest)
+ (quasisyntax/top-loc #'self
+ (λ (stx2)
+ #,(wrap-with-parameterize #'self
+ #'((syntax-parser . rest) stx2)
+ #'rest)))]))
(begin-for-syntax
(define/contract (string-suffix a b)
@@ -118,18 +140,7 @@
(add1 scope-depth)))
(define found-here
(for*/list ([binder-sym (in-list syms)]
- [binder (in-value (datum->syntax lctx binder-sym))]
- #;#:when #;(displayln (list bound binder
- 'pvar?= (syntax-pattern-variable?
- (syntax-local-value binder (thunk #f)))
- 'derived?= (derived?
- (syntax-local-value
- (format-id binder
- " is-derived-~a "
- binder)
- (thunk #f)))
- (subscript-equal? bound
- binder)))
+ [binder (in-value (datum->syntax lctx binder-sym #f))]
#:when (syntax-pattern-variable?
(syntax-local-value binder (thunk #f)))
#:when (not (derived?
@@ -141,9 +152,7 @@
[subscripts (in-value (subscript-equal? bound
binder))]
#:when subscripts)
- ;(displayln (list binder scope-depth))
(list binder scope-depth)))
- ;(displayln (list* 'found-here= bound '→ found-here))
(if (null? found-here)
recur-found
(append found-here recur-found)))))
@@ -151,7 +160,8 @@
(define/contract (find-subscript-binder2 bound)
(-> identifier?
(or/c #f (list/c identifier? ;; bound
- (syntax/c (listof identifier?)) ;; bindings
+ (syntax/c (listof identifier?)) ;; binders
+ (syntax/c (listof identifier?)) ;; max-binders
exact-nonnegative-integer? ;; ellipsis-depth
exact-nonnegative-integer? ;; scope-depth
syntax?))) ;; check-ellipsis-count
@@ -161,7 +171,6 @@
scopes
bound
0))
- ;(displayln (syntax->datum #`(2 bound= #,bound 2a-result= [binder scope-depth] …)))
(if (stx-null? #'(binder …))
#f
(let ()
@@ -176,10 +185,18 @@
;; ellipsis count
(define/with-syntax check-ellipsis-count-ddd
(nest-ellipses #'(binder …) (car depths)))
+ (define max-scope-depth (apply max (syntax->datum #'(scope-depth …))))
+ (define max-binders
+ (sort (map car
+ (filter (λ (bs) (= (syntax-e (cdr bs)) max-scope-depth))
+ (stx-map syntax-e #'([binder . scope-depth] …))))
+ symbol<?
+ #:key syntax-e))
(list bound
#'(binder …)
+ #`#,max-binders
(car depths)
- (apply max (syntax->datum #'(scope-depth …)))
+ max-scope-depth
#'check-ellipsis-count-ddd))))
(define/contract (nest-ellipses stx n)
@@ -197,10 +214,9 @@
(free-identifier=? #'id #'unsyntax))
stx]
[id (identifier? #'id)
- (let ([binders (find-subscript-binder2 #'id)])
- (when binders
- ;(displayln (syntax->datum (datum->syntax #f binders)))
- (set! acc (cons binders acc)))
+ (let ([binders+info (find-subscript-binder2 #'id)])
+ (when binders+info
+ (set! acc (cons binders+info acc)))
#'id)]
[other (rec #'other)]))
(define result
@@ -210,17 +226,15 @@
#'tmpl))))
;; Make sure that we remove duplicates, otherwise we'll get errors if we
;; define the same derived id twice.
- (define/with-syntax ([bound (binder0 . binders)
+ (define/with-syntax ([bound binders
+ max-binders
depth
scope-depth
check-ellipsis-count] …)
(remove-duplicates acc #:key car))
- #;(displayln (syntax->datum #'((derive2 bound binder0 (binder0 . binders) depth scope-depth)
- …)))
-
#`(let ()
- (derive2 bound binder0 (binder0 . binders) depth scope-depth)
+ (derive bound binders max-binders depth scope-depth)
…
(let ()
;; no-op, just to raise an error when they are incompatible
@@ -233,42 +247,67 @@
+(define-syntax/case (derive bound binders max-binders stx-depth stx-scope-depth)
+ ()
+ ;; TODO: shouldn't it be called in the first place?
+ (if (syntax-pattern-variable? (syntax-local-value #'bound (thunk #f)))
+ #'(begin)
+ #'(derive2 bound binders max-binders stx-depth stx-scope-depth)))
-
-(define-syntax/case (derive2 bound binder0 binders stx-depth stx-scope-depth) ()
- (define/with-syntax bound-def #'bound #;(replace-context #'binder0 #'bound))
+(define-syntax/case (derive2 bound
+ binders
+ (max-binder0 . max-binders)
+ stx-depth
+ stx-scope-depth) ()
(define depth (syntax-e #'stx-depth))
- (define/with-syntax bound-ddd (nest-ellipses #'bound-def depth))
- (define/with-syntax tmp-id (format-id #'here "~a/~a" #'binder0 #'bound-def))
+ (define/with-syntax bound-ddd (nest-ellipses #'bound depth))
+ (define/with-syntax tmp-id (format-id #'here "~a/~a" #'max-binder0 #'bound))
(define/with-syntax tmp-str (datum->syntax #'tmp-id (symbol->string
(syntax-e #'tmp-id))))
(define/with-syntax tmp-ddd (nest-ellipses #'tmp-id depth))
- (define/with-syntax binder-ddd (nest-ellipses (replace-context #'bound #'binder0) ;; why oh why do I need replace-context here???
- depth))
- ;; HERE: cache the define-temp-ids in the free-id-table, and make sure
- ;; that we retrieve the cached ones, so that two subtemplate within the same
- ;; syntax-case or syntax-parse clause use the same derived ids.
- ;; TODO: mark specially those bindings bound by (derive …) so that they are
- ;; not seen as original bindings in nested subtemplates (e.g. with an
- ;; "unsyntax"), otherwise that rule may not hold anymore, e.g.
- ;; (syntax-parse #'(a b c)
- ;; [(xᵢ …)
- ;; (quasisubtemplate (yᵢ …
- ;; #,(quasisubtemplate zᵢ …) ;; must be from xᵢ, not yᵢ
- ;; zᵢ …))])
- ;; the test above is not exactly right (zᵢ will still have the correct
- ;; binding), but it gives the general idea.
+ (define/with-syntax binder-ddd (nest-ellipses #'max-binder0 depth))
- ;; TODO: shouldn't be called in the first place? ;; TODO: remove?
- (if (syntax-pattern-variable? (syntax-local-value #'bound (thunk #f)))
- #'(begin)
- #`(begin (define-temp-ids tmp-str binder-ddd)
- (define cached (hash-ref! (list-ref pvar-values-id
- stx-scope-depth)
- 'bound-def
- #'tmp-ddd))
- (define/with-syntax bound-ddd cached)
- (define-syntax #,(format-id #'bound
- " is-derived-~a "
- #'bound)
- (derived)))))
-\ No newline at end of file
+ ;; Draw arrows in DrRacket.
+ (with-arrows
+ (define subscripts (subscript-equal? #'bound #'max-binder0))
+ (define bound-id-str (identifier->string #'bound))
+ (for ([max-binder (in-list (syntax->list #'(max-binder0 . max-binders)))])
+ (define binder-id-str (identifier->string max-binder))
+ (record-sub-range-binders! (vector #'bound
+ (- (string-length bound-id-str)
+ (string-length subscripts))
+ (string-length subscripts)
+ max-binder
+ (- (string-length binder-id-str)
+ (string-length subscripts))
+ (string-length subscripts))))
+ #;(define binder0-id-str (identifier->string #'max-binder0))
+ #;(record-sub-range-binders! (vector #'bound
+ (- (string-length bound-id-str)
+ (string-length subscripts))
+ (string-length subscripts)
+ #'max-binder0
+ (- (string-length binder0-id-str)
+ (string-length subscripts))
+ (string-length subscripts)))
+ ;; HERE: cache the define-temp-ids in the free-id-table, and make sure
+ ;; that we retrieve the cached ones, so that two subtemplate within the same
+ ;; syntax-case or syntax-parse clause use the same derived ids.
+ ;; TODO: mark specially those bindings bound by (derive …) so that they are
+ ;; not seen as original bindings in nested subtemplates (e.g. with an
+ ;; "unsyntax"), otherwise that rule may not hold anymore, e.g.
+ ;; (syntax-parse #'(a b c)
+ ;; [(xᵢ …)
+ ;; (quasisubtemplate (yᵢ …
+ ;; #,(quasisubtemplate zᵢ …) ;; must be from xᵢ, not yᵢ
+ ;; zᵢ …))])
+ ;; the test above is not exactly right (zᵢ will still have the correct
+ ;; binding), but it gives the general idea.
+ #`(begin (define-temp-ids tmp-str binder-ddd)
+ (define cached (hash-ref! (list-ref pvar-values-id
+ stx-scope-depth)
+ 'bound
+ #'tmp-ddd))
+ (define/with-syntax bound-ddd cached)
+ (define-syntax #,(format-id #'bound " is-derived-~a " #'bound)
+ (derived)))))
+\ No newline at end of file
diff --git a/test/test-subtemplate.rkt b/test/test-subtemplate.rkt
@@ -27,141 +27,150 @@
(subtemplate foo)]))
'foo)
-(syntax-parse (syntax-parse #'(a b c d)
- [(_ xⱼ zᵢ …)
- (list (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …))
- (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …)))])
- [(([x1 w1] foo1 [z1 p1] [zz1 pp1])
- ([x2 w2] foo2 [z2 p2] [zz2 pp2]))
- (check free-identifier=? #'x1 #'x2)
- (check free-identifier=? #'w1 #'w2)
- (check free-identifier=? #'foo1 #'foo2)
- (check free-identifier=? #'z1 #'z2)
- (check free-identifier=? #'p1 #'p2)
- (check free-identifier=? #'zz1 #'zz2)
- (check free-identifier=? #'pp1 #'pp2)
+#;(let ()
+ (syntax-parse #'a #;(syntax-parse #'(a b c d)
+ [(_ xⱼ zᵢ …)
+ (list (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …))
+ (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …)))])
+ [_ #;(([x1 w1] foo1 [z1 p1] [zz1 pp1])
+ ([x2 w2] foo2 [z2 p2] [zz2 pp2]))
+ (check free-identifier=? #'x1 #'x2)]))
- (check free-identifier=? #'x1 #'b)
- (check free-identifier=? #'z1 #'c)
- (check free-identifier=? #'zz1 #'d)
+(syntax-parse (syntax-parse #'(a b c d)
+ [(_ xⱼ zᵢ …)
+ (list (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …))
+ (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …)))])
+ [(([x1 w1] foo1 [z1 p1] [zz1 pp1])
+ ([x2 w2] foo2 [z2 p2] [zz2 pp2]))
+ (check free-identifier=? #'x1 #'x2)
+ (check free-identifier=? #'w1 #'w2)
+ (check free-identifier=? #'foo1 #'foo2)
+ (check free-identifier=? #'z1 #'z2)
+ (check free-identifier=? #'p1 #'p2)
+ (check free-identifier=? #'zz1 #'zz2)
+ (check free-identifier=? #'pp1 #'pp2)
+
+ (check free-identifier=? #'x1 #'b)
+ (check free-identifier=? #'z1 #'c)
+ (check free-identifier=? #'zz1 #'d)
- (check free-identifier=? #'x2 #'b)
- (check free-identifier=? #'z2 #'c)
- (check free-identifier=? #'zz2 #'d)
-
- ;; The *1 are all different:
- (check free-identifier=? #'x1 #'x1)
- (check (∘ not free-identifier=?) #'x1 #'w1)
- (check (∘ not free-identifier=?) #'x1 #'foo1)
- (check (∘ not free-identifier=?) #'x1 #'z1)
- (check (∘ not free-identifier=?) #'x1 #'p1)
- (check (∘ not free-identifier=?) #'x1 #'zz1)
- (check (∘ not free-identifier=?) #'x1 #'pp1)
+ (check free-identifier=? #'x2 #'b)
+ (check free-identifier=? #'z2 #'c)
+ (check free-identifier=? #'zz2 #'d)
+
+ ;; The *1 are all different:
+ (check free-identifier=? #'x1 #'x1)
+ (check (∘ not free-identifier=?) #'x1 #'w1)
+ (check (∘ not free-identifier=?) #'x1 #'foo1)
+ (check (∘ not free-identifier=?) #'x1 #'z1)
+ (check (∘ not free-identifier=?) #'x1 #'p1)
+ (check (∘ not free-identifier=?) #'x1 #'zz1)
+ (check (∘ not free-identifier=?) #'x1 #'pp1)
- (check (∘ not free-identifier=?) #'w1 #'x1)
- (check free-identifier=? #'w1 #'w1)
- (check (∘ not free-identifier=?) #'w1 #'foo1)
- (check (∘ not free-identifier=?) #'w1 #'z1)
- (check (∘ not free-identifier=?) #'w1 #'p1)
- (check (∘ not free-identifier=?) #'w1 #'zz1)
- (check (∘ not free-identifier=?) #'w1 #'pp1)
-
- (check (∘ not free-identifier=?) #'foo1 #'x1)
- (check (∘ not free-identifier=?) #'foo1 #'w1)
- (check free-identifier=? #'foo1 #'foo1)
- (check (∘ not free-identifier=?) #'foo1 #'z1)
- (check (∘ not free-identifier=?) #'foo1 #'p1)
- (check (∘ not free-identifier=?) #'foo1 #'zz1)
- (check (∘ not free-identifier=?) #'foo1 #'pp1)
-
- (check (∘ not free-identifier=?) #'z1 #'x1)
- (check (∘ not free-identifier=?) #'z1 #'w1)
- (check (∘ not free-identifier=?) #'z1 #'foo1)
- (check free-identifier=? #'z1 #'z1)
- (check (∘ not free-identifier=?) #'z1 #'p1)
- (check (∘ not free-identifier=?) #'z1 #'zz1)
- (check (∘ not free-identifier=?) #'z1 #'pp1)
-
- (check (∘ not free-identifier=?) #'p1 #'x1)
- (check (∘ not free-identifier=?) #'p1 #'w1)
- (check (∘ not free-identifier=?) #'p1 #'foo1)
- (check (∘ not free-identifier=?) #'p1 #'z1)
- (check free-identifier=? #'p1 #'p1)
- (check (∘ not free-identifier=?) #'p1 #'zz1)
- (check (∘ not free-identifier=?) #'p1 #'pp1)
-
- (check (∘ not free-identifier=?) #'zz1 #'x1)
- (check (∘ not free-identifier=?) #'zz1 #'w1)
- (check (∘ not free-identifier=?) #'zz1 #'foo1)
- (check (∘ not free-identifier=?) #'zz1 #'z1)
- (check (∘ not free-identifier=?) #'zz1 #'p1)
- (check free-identifier=? #'zz1 #'zz1)
- (check (∘ not free-identifier=?) #'zz1 #'pp1)
-
- (check (∘ not free-identifier=?) #'pp1 #'x1)
- (check (∘ not free-identifier=?) #'pp1 #'w1)
- (check (∘ not free-identifier=?) #'pp1 #'foo1)
- (check (∘ not free-identifier=?) #'pp1 #'z1)
- (check (∘ not free-identifier=?) #'pp1 #'p1)
- (check (∘ not free-identifier=?) #'pp1 #'zz1)
- (check free-identifier=? #'pp1 #'pp1)
-
- ;; The *2 are all different:
- (check free-identifier=? #'x2 #'x2)
- (check (∘ not free-identifier=?) #'x2 #'w2)
- (check (∘ not free-identifier=?) #'x2 #'foo2)
- (check (∘ not free-identifier=?) #'x2 #'z2)
- (check (∘ not free-identifier=?) #'x2 #'p2)
- (check (∘ not free-identifier=?) #'x2 #'zz2)
- (check (∘ not free-identifier=?) #'x2 #'pp2)
+ (check (∘ not free-identifier=?) #'w1 #'x1)
+ (check free-identifier=? #'w1 #'w1)
+ (check (∘ not free-identifier=?) #'w1 #'foo1)
+ (check (∘ not free-identifier=?) #'w1 #'z1)
+ (check (∘ not free-identifier=?) #'w1 #'p1)
+ (check (∘ not free-identifier=?) #'w1 #'zz1)
+ (check (∘ not free-identifier=?) #'w1 #'pp1)
+
+ (check (∘ not free-identifier=?) #'foo1 #'x1)
+ (check (∘ not free-identifier=?) #'foo1 #'w1)
+ (check free-identifier=? #'foo1 #'foo1)
+ (check (∘ not free-identifier=?) #'foo1 #'z1)
+ (check (∘ not free-identifier=?) #'foo1 #'p1)
+ (check (∘ not free-identifier=?) #'foo1 #'zz1)
+ (check (∘ not free-identifier=?) #'foo1 #'pp1)
+
+ (check (∘ not free-identifier=?) #'z1 #'x1)
+ (check (∘ not free-identifier=?) #'z1 #'w1)
+ (check (∘ not free-identifier=?) #'z1 #'foo1)
+ (check free-identifier=? #'z1 #'z1)
+ (check (∘ not free-identifier=?) #'z1 #'p1)
+ (check (∘ not free-identifier=?) #'z1 #'zz1)
+ (check (∘ not free-identifier=?) #'z1 #'pp1)
+
+ (check (∘ not free-identifier=?) #'p1 #'x1)
+ (check (∘ not free-identifier=?) #'p1 #'w1)
+ (check (∘ not free-identifier=?) #'p1 #'foo1)
+ (check (∘ not free-identifier=?) #'p1 #'z1)
+ (check free-identifier=? #'p1 #'p1)
+ (check (∘ not free-identifier=?) #'p1 #'zz1)
+ (check (∘ not free-identifier=?) #'p1 #'pp1)
+
+ (check (∘ not free-identifier=?) #'zz1 #'x1)
+ (check (∘ not free-identifier=?) #'zz1 #'w1)
+ (check (∘ not free-identifier=?) #'zz1 #'foo1)
+ (check (∘ not free-identifier=?) #'zz1 #'z1)
+ (check (∘ not free-identifier=?) #'zz1 #'p1)
+ (check free-identifier=? #'zz1 #'zz1)
+ (check (∘ not free-identifier=?) #'zz1 #'pp1)
+
+ (check (∘ not free-identifier=?) #'pp1 #'x1)
+ (check (∘ not free-identifier=?) #'pp1 #'w1)
+ (check (∘ not free-identifier=?) #'pp1 #'foo1)
+ (check (∘ not free-identifier=?) #'pp1 #'z1)
+ (check (∘ not free-identifier=?) #'pp1 #'p1)
+ (check (∘ not free-identifier=?) #'pp1 #'zz1)
+ (check free-identifier=? #'pp1 #'pp1)
+
+ ;; The *2 are all different:
+ (check free-identifier=? #'x2 #'x2)
+ (check (∘ not free-identifier=?) #'x2 #'w2)
+ (check (∘ not free-identifier=?) #'x2 #'foo2)
+ (check (∘ not free-identifier=?) #'x2 #'z2)
+ (check (∘ not free-identifier=?) #'x2 #'p2)
+ (check (∘ not free-identifier=?) #'x2 #'zz2)
+ (check (∘ not free-identifier=?) #'x2 #'pp2)
- (check (∘ not free-identifier=?) #'w2 #'x2)
- (check free-identifier=? #'w2 #'w2)
- (check (∘ not free-identifier=?) #'w2 #'foo2)
- (check (∘ not free-identifier=?) #'w2 #'z2)
- (check (∘ not free-identifier=?) #'w2 #'p2)
- (check (∘ not free-identifier=?) #'w2 #'zz2)
- (check (∘ not free-identifier=?) #'w2 #'pp2)
-
- (check (∘ not free-identifier=?) #'foo2 #'x2)
- (check (∘ not free-identifier=?) #'foo2 #'w2)
- (check free-identifier=? #'foo2 #'foo2)
- (check (∘ not free-identifier=?) #'foo2 #'z2)
- (check (∘ not free-identifier=?) #'foo2 #'p2)
- (check (∘ not free-identifier=?) #'foo2 #'zz2)
- (check (∘ not free-identifier=?) #'foo2 #'pp2)
-
- (check (∘ not free-identifier=?) #'z2 #'x2)
- (check (∘ not free-identifier=?) #'z2 #'w2)
- (check (∘ not free-identifier=?) #'z2 #'foo2)
- (check free-identifier=? #'z2 #'z2)
- (check (∘ not free-identifier=?) #'z2 #'p2)
- (check (∘ not free-identifier=?) #'z2 #'zz2)
- (check (∘ not free-identifier=?) #'z2 #'pp2)
-
- (check (∘ not free-identifier=?) #'p2 #'x2)
- (check (∘ not free-identifier=?) #'p2 #'w2)
- (check (∘ not free-identifier=?) #'p2 #'foo2)
- (check (∘ not free-identifier=?) #'p2 #'z2)
- (check free-identifier=? #'p2 #'p2)
- (check (∘ not free-identifier=?) #'p2 #'zz2)
- (check (∘ not free-identifier=?) #'p2 #'pp2)
-
- (check (∘ not free-identifier=?) #'zz2 #'x2)
- (check (∘ not free-identifier=?) #'zz2 #'w2)
- (check (∘ not free-identifier=?) #'zz2 #'foo2)
- (check (∘ not free-identifier=?) #'zz2 #'z2)
- (check (∘ not free-identifier=?) #'zz2 #'p2)
- (check free-identifier=? #'zz2 #'zz2)
- (check (∘ not free-identifier=?) #'zz2 #'pp2)
-
- (check (∘ not free-identifier=?) #'pp2 #'x2)
- (check (∘ not free-identifier=?) #'pp2 #'w2)
- (check (∘ not free-identifier=?) #'pp2 #'foo2)
- (check (∘ not free-identifier=?) #'pp2 #'z2)
- (check (∘ not free-identifier=?) #'pp2 #'p2)
- (check (∘ not free-identifier=?) #'pp2 #'zz2)
- (check free-identifier=? #'pp2 #'pp2)])
+ (check (∘ not free-identifier=?) #'w2 #'x2)
+ (check free-identifier=? #'w2 #'w2)
+ (check (∘ not free-identifier=?) #'w2 #'foo2)
+ (check (∘ not free-identifier=?) #'w2 #'z2)
+ (check (∘ not free-identifier=?) #'w2 #'p2)
+ (check (∘ not free-identifier=?) #'w2 #'zz2)
+ (check (∘ not free-identifier=?) #'w2 #'pp2)
+
+ (check (∘ not free-identifier=?) #'foo2 #'x2)
+ (check (∘ not free-identifier=?) #'foo2 #'w2)
+ (check free-identifier=? #'foo2 #'foo2)
+ (check (∘ not free-identifier=?) #'foo2 #'z2)
+ (check (∘ not free-identifier=?) #'foo2 #'p2)
+ (check (∘ not free-identifier=?) #'foo2 #'zz2)
+ (check (∘ not free-identifier=?) #'foo2 #'pp2)
+
+ (check (∘ not free-identifier=?) #'z2 #'x2)
+ (check (∘ not free-identifier=?) #'z2 #'w2)
+ (check (∘ not free-identifier=?) #'z2 #'foo2)
+ (check free-identifier=? #'z2 #'z2)
+ (check (∘ not free-identifier=?) #'z2 #'p2)
+ (check (∘ not free-identifier=?) #'z2 #'zz2)
+ (check (∘ not free-identifier=?) #'z2 #'pp2)
+
+ (check (∘ not free-identifier=?) #'p2 #'x2)
+ (check (∘ not free-identifier=?) #'p2 #'w2)
+ (check (∘ not free-identifier=?) #'p2 #'foo2)
+ (check (∘ not free-identifier=?) #'p2 #'z2)
+ (check free-identifier=? #'p2 #'p2)
+ (check (∘ not free-identifier=?) #'p2 #'zz2)
+ (check (∘ not free-identifier=?) #'p2 #'pp2)
+
+ (check (∘ not free-identifier=?) #'zz2 #'x2)
+ (check (∘ not free-identifier=?) #'zz2 #'w2)
+ (check (∘ not free-identifier=?) #'zz2 #'foo2)
+ (check (∘ not free-identifier=?) #'zz2 #'z2)
+ (check (∘ not free-identifier=?) #'zz2 #'p2)
+ (check free-identifier=? #'zz2 #'zz2)
+ (check (∘ not free-identifier=?) #'zz2 #'pp2)
+
+ (check (∘ not free-identifier=?) #'pp2 #'x2)
+ (check (∘ not free-identifier=?) #'pp2 #'w2)
+ (check (∘ not free-identifier=?) #'pp2 #'foo2)
+ (check (∘ not free-identifier=?) #'pp2 #'z2)
+ (check (∘ not free-identifier=?) #'pp2 #'p2)
+ (check (∘ not free-identifier=?) #'pp2 #'zz2)
+ (check free-identifier=? #'pp2 #'pp2)])
(syntax-parse (syntax-parse #'(a b c)
[(xᵢ …)
@@ -289,13 +298,13 @@
wᵢ …))]))
(syntax-parse (syntax-parse #'(a b c)
- [(xᵢ …)
- (quasisubtemplate (yᵢ …
- #,(syntax-parse #'d
- [zᵢ (quasisubtemplate (zᵢ))])
- #,(syntax-parse #'d
- [zᵢ (quasisubtemplate (zᵢ))])
- zᵢ …))])
+ [(xᵢ …)
+ (quasisubtemplate (yᵢ …
+ #,(syntax-parse #'d
+ [zᵢ (quasisubtemplate (zᵢ))])
+ #,(syntax-parse #'d
+ [zᵢ (quasisubtemplate (zᵢ))])
+ zᵢ …))])
[(y yy yyy (d1) (d2) z zz zzz)
(check free-identifier=? #'d1 #'d2)
@@ -535,4 +544,17 @@
(subtemplate ([xᵢ wᵢ] … foo [zᵢ pᵢ] …))])
(syntax-parse #'(cc dd)
[(xᵢ …)
- (subtemplate ([xᵢ wᵢ] … foo [zᵢ pᵢ] …))]))])])))
-\ No newline at end of file
+ (subtemplate ([xᵢ wᵢ] … foo [zᵢ pᵢ] …))]))])])))
+
+;; Test for arrows, with two maximal candidates tᵢ and zᵢ :
+(syntax-parse (syntax-parse #'()
+ [()
+ (syntax-parse #'([a b] [aa bb])
+ [([tᵢ …] [zᵢ …])
+ (list (syntax-parse #'(c d)
+ [(xᵢ …)
+ (subtemplate ([xᵢ wᵢ] … tᵢ … foo [zᵢ pᵢ] …))])
+ (syntax-parse #'(cc dd)
+ [(xᵢ …)
+ (subtemplate ([xᵢ wᵢ] … tᵢ … foo [zᵢ pᵢ] …))]))])])
+ [_ 'TODO])
diff --git a/traversal.hl.rkt b/traversal.hl.rkt
@@ -134,18 +134,35 @@ way up, so that a simple identity function can be applied in these cases.
(local-require racket/pretty)
#;(pretty-write (syntax->datum x))
x)
- (template
+ (subtemplate
(begin
<define-fold-result>)))]))]
+
+@chunk[<define-fold-result>
+ the-defs …
+
+ (define-type (_type-name _Tᵢ …) _the-type)
+
+ (: _function-name (∀ (_Aᵢ … _Bᵢ … Acc)
+ (→ (?@ (→ Any Boolean : _Aᵢ)
+ (→ _Aᵢ Acc (Values _Bᵢ Acc)))
+ …
+ (→ (_type-name _Aᵢ …)
+ Acc
+ (Values (_type-name _Bᵢ …)
+ Acc)))))
+ (define ((_function-name . _args) v acc)
+ _the-code)]
+
@chunk[<define-fold-prepare>
- (define-temp-ids "_Tᵢ" (type-to-replaceᵢ …))
- (define-temp-ids "_Aᵢ" (type-to-replaceᵢ …))
- (define-temp-ids "_Bᵢ" (type-to-replaceᵢ …))
- (define-temp-ids "predicateᵢ" (type-to-replaceᵢ …))
- (define-temp-ids "updateᵢ" (type-to-replaceᵢ …))
+ ;(define-temp-ids "_Tᵢ" (type-to-replaceᵢ …))
+ ;(define-temp-ids "_Aᵢ" (type-to-replaceᵢ …))
+ ;(define-temp-ids "_Bᵢ" (type-to-replaceᵢ …))
+ ;(define-temp-ids "predicateᵢ" (type-to-replaceᵢ …))
+ ;(define-temp-ids "updateᵢ" (type-to-replaceᵢ …))
- (define/with-syntax _args (template ({?@ predicateᵢ updateᵢ} …)))]
+ (define/with-syntax _args (subtemplate ({?@ predicateᵢ updateᵢ} …)))]
@chunk[<define-fold-prepare>
(type-cases
@@ -302,7 +319,7 @@ where @racket[foldl-map] is defined as:
#:using the-code
#:with-defintitions the-defs (~literal …))
#:literals (lit …)
- (Pat opts …
+ (pat opts …
#:to transform-type
#:using transform-code
(~optional (~seq #:with-defintitions transform-defs …)
@@ -311,38 +328,25 @@ where @racket[foldl-map] is defined as:
#'(define/with-syntax (the-type the-code the-defs (… …))
(syntax-parse #'whole-type
#:literals (lit …)
- [Pat opts …
- (template
+ [pat opts …
+ (subtemplate
(transform-type transform-code transform-defs …))]
…))]))]
-@chunk[<define-fold-result>
- the-defs …
-
- (define-type (_type-name _Tᵢ …) _the-type)
-
- (: _function-name (∀ (_Aᵢ … _Bᵢ … Acc)
- (→ (?@ (→ Any Boolean : _Aᵢ)
- (→ _Aᵢ Acc (Values _Bᵢ Acc)))
- …
- (→ (_type-name _Aᵢ …)
- Acc
- (Values (_type-name _Bᵢ …)
- Acc)))))
- (define ((_function-name . _args) v acc)
- _the-code)]
@section{Putting it all together}
@chunk[<*>
- (require phc-toolkit
+ (require racket/require
+ phc-toolkit
type-expander
phc-adt
"dispatch-union.rkt"
- (for-syntax racket/base
+ (for-syntax "subtemplate.rkt"
+ (subtract-in racket/base "subtemplate.rkt")
phc-toolkit/untyped
racket/syntax
- syntax/parse
+ (subtract-in syntax/parse "subtemplate.rkt")
syntax/parse/experimental/template
type-expander/expander
"free-identifier-tree-equal.rkt")
