commit a486dc81f7ecc8dab3712c0e906ef3aed13e3bf2
parent 897c4ed99db3f920980176ea2b23ab2f08c99a75
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Fri, 7 Oct 2016 13:42:00 +0200
Ported traversal code to use subtemplate, fixed scope issue with subtemplate
Diffstat:
3 files changed, 30 insertions(+), 31 deletions(-)
diff --git a/subtemplate.rkt b/subtemplate.rkt
@@ -219,11 +219,14 @@
(set! acc (cons binders+info acc)))
#'id)]
[other (rec #'other)]))
+ ;; process the syntax, extract the derived bindings into acc
+ (fold-syntax fold-process #'tmpl)
+ ;; define the result, which looks like (template . tmpl) or
+ ;; like (quasitemplate . tmpl)
(define result
(quasisyntax/top-loc #'self
(#,tmpl-form
- . #,(fold-syntax fold-process
- #'tmpl))))
+ . tmpl)))
;; Make sure that we remove duplicates, otherwise we'll get errors if we
;; define the same derived id twice.
(define/with-syntax ([bound binders
diff --git a/test/test-traversal-1.rkt b/test/test-traversal-1.rkt
@@ -91,4 +91,4 @@
(Listof String)
(Listof Symbol))
Integer)
- '("abc" ("def" "ghi") (jkl mno)) 1)
-\ No newline at end of file
+ '("abc" ("def" "ghi") (jkl mno)) 1)
diff --git a/traversal.hl.rkt b/traversal.hl.rkt
@@ -123,6 +123,9 @@ not expressed syntactically using the @racket[Foo] identifier.
way up, so that a simple identity function can be applied in these cases.
@chunk[<define-fold>
+ (begin-for-syntax
+ (define-syntax-rule (barr body)
+ body))
(define-syntax define-fold
(syntax-parser
[(_ _function-name:id
@@ -134,10 +137,9 @@ way up, so that a simple identity function can be applied in these cases.
(local-require racket/pretty)
#;(pretty-write (syntax->datum x))
x)
- (subtemplate
- (begin
- <define-fold-result>)))]))]
-
+ (subtemplate
+ (begin
+ <define-fold-result>)))]))]
@chunk[<define-fold-result>
the-defs …
@@ -156,16 +158,11 @@ way up, so that a simple identity function can be applied in these cases.
_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/with-syntax _args (subtemplate ({?@ predicateᵢ updateᵢ} …)))]
@chunk[<define-fold-prepare>
(type-cases
+ syntax-parse
(whole-type #:to _the-type
#:using _the-code
#:with-defintitions the-defs …)
@@ -175,7 +172,8 @@ way up, so that a simple identity function can be applied in these cases.
@chunk[<type-cases>
[t
#:with info (findf (λ (r) (free-identifier-tree=? #'t (stx-car r)))
- (syntax->list #'([type-to-replaceᵢ updateᵢ _Tᵢ] …)))
+ (syntax->list
+ (subtemplate ([type-to-replaceᵢ updateᵢ _Tᵢ] …))))
#:when (attribute info)
#:with (_ update T) #'info
@@ -251,40 +249,38 @@ way up, so that a simple identity function can be applied in these cases.
(define-fold fy* ty* (List Y …) type-to-replaceᵢ …)]]
@chunk[<type-cases>
- [(U X …)
- (define-temp-ids "_fx" (X …))
- (define-temp-ids "_tx" (X …))
+ [(U _Xⱼ …)
+ (define-temp-ids "_fx" (_Xⱼ …))
+ (define-temp-ids "_tx" (_Xⱼ …))
#:to
- (U (_tx _Tᵢ …) …)
+ (U (_txⱼ _Tᵢ …) …)
#:using
(dispatch-union ([type-to-replaceᵢ Aᵢ predicateᵢ]
…)
- [X v ((_fx . _args) v acc)]
+ [_Xⱼ v ((_fxⱼ . _args) v acc)]
…)
#:with-defintitions
- (define-fold _fx _tx X type-to-replaceᵢ …)
+ (define-fold _fxⱼ _txⱼ _Xⱼ type-to-replaceᵢ …)
…]]
@chunk[<type-cases>
- [(tagged _name [_field (~optional :colon) _X] …
- {~do (define-temp-ids "_fx" (_X …))}
- {~do (define-temp-ids "_tx" (_X …))}
- {~do (define-temp-ids "_result" (_X …))})
+ [(tagged _name [_fieldⱼ (~optional :colon) _Xⱼ] …)
#:to
- (tagged _name [_field : (_tx _Tᵢ …)] …)
+ (tagged _name [_fieldⱼ : (_txⱼ _Tᵢ …)] …)
#:using
- (let*-values ([(_result acc) ((_fx . _args) (uniform-get v _field) acc)]
+ (let*-values ([(_resultⱼ acc) ((_fxⱼ . _args) (uniform-get v _fieldⱼ)
+ acc)]
…)
- (values (tagged _name [_field _result] …)
+ (values (tagged _name [_fieldⱼ _resultⱼ] …)
acc))
#:with-defintitions
- (define-fold _fx _tx _X type-to-replaceᵢ …)
+ (define-fold _fxⱼ _txⱼ _Xⱼ type-to-replaceᵢ …)
…]]
@chunk[<type-cases>
@@ -315,7 +311,8 @@ where @racket[foldl-map] is defined as:
@chunk[<type-cases-macro>
(define-syntax type-cases
(syntax-parser
- [(_ (whole-type #:to the-type
+ [(_ sp
+ (whole-type #:to the-type
#:using the-code
#:with-defintitions the-defs (~literal …))
#:literals (lit …)
@@ -326,7 +323,7 @@ where @racket[foldl-map] is defined as:
#:defaults ([(transform-defs 1) (list)])))
…)
#'(define/with-syntax (the-type the-code the-defs (… …))
- (syntax-parse #'whole-type
+ (sp #'whole-type
#:literals (lit …)
[pat opts …
(subtemplate
