commit 38c9c7b7d6d03e9928c0019f7607cea1510d8d63
parent d4167fe4e4a4596bbdd3ef35440238679e6c1af5
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Sat, 5 Nov 2016 02:46:09 +0100
First metafunction works, with a bit of a hack to remove the annoying scope.
Diffstat:
3 files changed, 81 insertions(+), 54 deletions(-)
diff --git a/subtemplate.rkt b/subtemplate.rkt
@@ -4,6 +4,7 @@
racket/stxparam
syntax/parse
syntax/parse/experimental/template
+ syntax/parse/experimental/private/substitute
syntax/id-table
racket/syntax
(for-syntax "patch-arrows.rkt"
@@ -22,6 +23,7 @@
(provide (rename-out [new-syntax-parse syntax-parse]
[new-syntax-parser syntax-parser]
[new-syntax-case syntax-case])
+ define-unhygienic-template-metafunction
subtemplate
quasisubtemplate)
@@ -314,4 +316,36 @@
#'tmp-ddd))
(define/with-syntax bound-ddd cached)
(define-syntax #,(format-id #'bound " is-derived-~a " #'bound)
- (derived)))))
-\ No newline at end of file
+ (derived)))))
+
+
+(require syntax/parse/experimental/private/substitute)
+;; Not very clean, but syntax/parse/experimental/template should export it :-(
+(define (stolen-current-template-metafunction-introducer)
+ ((eval #'current-template-metafunction-introducer
+ (module->namespace 'syntax/parse/experimental/private/substitute))))
+
+;; Note: define-unhygienic-template-metafunction probably only works correctly
+;; when the metafunction is defined in the same file as it is used. The macro
+;; which is built using that or other metafunctions can be used anywhere,
+;; though. This is because we use a hack to guess what the old-mark from
+;; syntax/parse/experimental/private/substitute is.
+(define-syntax (define-unhygienic-template-metafunction xxx)
+ (syntax-case xxx ()
+ [(mee (name stx) . code)
+ (datum->syntax
+ #'mee
+ `(define-template-metafunction (,#'name ,#'tmp-stx)
+ (syntax-case ,#'tmp-stx ()
+ [(self . _)
+ (let* ([zero (datum->syntax #f 'zero)]
+ [normal ((,#'stolen-current-template-metafunction-introducer) (quote-syntax here))
+ #;(syntax-local-introduce
+ (syntax-local-get-shadower
+ (datum->syntax #f 'shadower)))]
+ [+self (make-syntax-delta-introducer normal zero)]
+ [+normal (make-syntax-delta-introducer normal zero)]
+ [mark (make-syntax-delta-introducer (+normal #'self 'flip)
+ zero)]
+ [,#'stx (syntax-local-introduce (mark ,#'tmp-stx 'flip))])
+ (mark (syntax-local-introduce (let () . ,#'code))))])))]))
+\ No newline at end of file
diff --git a/test/test-traversal-1.rkt b/test/test-traversal-1.rkt
@@ -17,6 +17,12 @@
(define-fold f₁₀ t₁₀ (List String Foo (Listof String)) (Listof String))
(define-fold f₁₁ t₁₁ (List (Listof String) (Listof Number)) (Listof String))
(define-fold f₁₂ t₁₂ (List (Listof String) (Listof String)) (Listof String))
+(define-fold f₁₃ t₁₃
+ (List Null
+ (Pairof (List (List Null))
+ (List (List Null)))
+ Null)
+ String)
(define (string->symbol+acc [x : String] [acc : Integer])
(values (string->symbol x) (add1 acc)))
diff --git a/traversal.hl.rkt b/traversal.hl.rkt
@@ -146,17 +146,18 @@ not expressed syntactically using the @racket[Foo] identifier.
@;@subsection{…}
-* free-id-tree=?
-* cache of already-seen types
-* recursively go down the tree. If there are no replacements, return #f all the
-way up, so that a simple identity function can be applied in these cases.
+@; TODO: recursively go down the tree. If there are no replacements, return #f
+@; all the way up, so that a simple identity function can be applied in these
+@; cases.
@CHUNK[<define-fold>
- (define-for-syntax (replace-in-type stx)
- (syntax-case stx ()
- [(_whole-type [_type-to-replaceᵢ _Tᵢ] …)
- #`(#,(fold-type #'(_whole-type _type-to-replaceᵢ …)) _Tᵢ …)]))]
+ (begin-for-syntax
+ (define-unhygienic-template-metafunction (replace-in-type stx)
+ (syntax-case stx ()
+ [(_ _whole-type [_type-to-replaceᵢ _Tᵢ] …)
+ #`(#,(syntax-local-introduce
+ (fold-type #'(_whole-type _type-to-replaceᵢ …))) _Tᵢ …)])))]
@CHUNK[<define-fold>
(define-for-syntax fold-type
@@ -171,12 +172,10 @@ way up, so that a simple identity function can be applied in these cases.
(map syntax-e
(syntax->list
#'([_type-to-replaceᵢ . _Tᵢ] …)))))
- (printf "Start ~a ~a =>\n" (syntax->datum τ-) #'_whole-type)
- ((λ (x) (printf "~a ~a =>\n" (syntax->datum τ-) #'_whole-type) (pretty-write (syntax->datum x)) x)
- #`(∀ (_Tᵢ …)
- #,(syntax-parse #'_whole-type
- #:literals (Null Pairof Listof List Vectorof Vector U tagged)
- <type-cases>))))]))]
+ #`(∀ (_Tᵢ …)
+ #,(syntax-parse #'_whole-type
+ #:literals (Null Pairof Listof List Vectorof Vector U tagged)
+ <type-cases>)))]))]
@CHUNK[<cached>
(begin-for-syntax
@@ -197,7 +196,6 @@ way up, so that a simple identity function can be applied in these cases.
(syntax-case stx ()
[(_whole-type
[_type-to-replaceᵢ _predicateᵢ _updateᵢ] …)
- ;+ cache
#`(#,(fold-f #'(_whole-type _type-to-replaceᵢ …))
{?@ _predicateᵢ _updateᵢ} …)]))]
@@ -215,22 +213,21 @@ way up, so that a simple identity function can be applied in these cases.
(get-f-cache)
(get-f-defs)
#'(_whole-type _type-to-replaceᵢ …)]
- ((λ (x) (printf "~a ~a =>\n" (syntax->datum f-) #'_whole-type) (pretty-write (syntax->datum x)) x)
- #`[(λ ({?@ _predicateᵢ _updateᵢ} …)
- (λ (v acc)
- #,(syntax-parse #'_whole-type
- #:literals (Null Pairof Listof List Vectorof Vector U tagged)
- <f-cases>)))
- (∀ (_Aᵢ … _Bᵢ … Acc)
- (→ (?@ (→ Any Boolean : _Aᵢ)
- (→ _Aᵢ Acc (Values _Bᵢ Acc)))
- …
- (→ #,(replace-in-type #'(_whole-type
- [_type-to-replaceᵢ _Aᵢ] …))
- Acc
- (Values #,(replace-in-type #'(_whole-type
- [_type-to-replaceᵢ _Bᵢ] …))
- Acc))))]))]))]
+ #`[(λ ({?@ _predicateᵢ _updateᵢ} …)
+ (λ (v acc)
+ #,(syntax-parse #'_whole-type
+ #:literals (Null Pairof Listof List Vectorof Vector U tagged)
+ <f-cases>)))
+ (∀ (_Aᵢ … _Bᵢ … Acc)
+ (→ (?@ (→ Any Boolean : _Aᵢ)
+ (→ _Aᵢ Acc (Values _Bᵢ Acc)))
+ …
+ (→ (replace-in-type _whole-type
+ [_type-to-replaceᵢ _Aᵢ] …)
+ Acc
+ (Values (replace-in-type _whole-type
+ [_type-to-replaceᵢ _Bᵢ] …)
+ Acc))))])]))]
@chunk[<f-cases>
[t
@@ -255,8 +252,8 @@ way up, so that a simple identity function can be applied in these cases.
@CHUNK[<type-cases>
[(Pairof X Y)
- #`(Pairof #,(replace-in-type #'(X . rec-args))
- #,(replace-in-type #'(Y . rec-args)))]]
+ #`(Pairof (replace-in-type X . rec-args)
+ (replace-in-type Y . rec-args))]]
@CHUNK[<f-cases>
[(Pairof X Y)
@@ -268,7 +265,7 @@ way up, so that a simple identity function can be applied in these cases.
@CHUNK[<type-cases>
[(Listof X)
- #`(Listof #,(replace-in-type #'(X . rec-args)))]]
+ #`(Listof (replace-in-type X . rec-args))]]
@CHUNK[<f-cases>
[(Listof X)
@@ -277,8 +274,7 @@ way up, so that a simple identity function can be applied in these cases.
@CHUNK[<type-cases>
[(Vectorof X)
- ;; TODO: turn replace-in-type & co into rec-replace via metafunctions
- #`(Vectorof #,(replace-in-type #'(X . rec-args)))]]
+ #`(Vectorof (replace-in-type X . rec-args))]]
@CHUNK[<ftype-cases>
[(Vectorof X)
@@ -291,8 +287,8 @@ way up, so that a simple identity function can be applied in these cases.
@CHUNK[<type-cases>
[(List X Y …)
- #`(Pairof #,(replace-in-type #'(X . rec-args))
- #,(replace-in-type #'((List Y …) . rec-args)))]]
+ #`(Pairof (replace-in-type X . rec-args)
+ (replace-in-type (List Y …) . rec-args))]]
@CHUNK[<f-cases>
[(List X Y …)
@@ -306,8 +302,7 @@ way up, so that a simple identity function can be applied in these cases.
@CHUNK[<type-cases>
[(U _Xⱼ …)
- #`(U #,@(stx-map (λ (_x) (replace-in-type #`(#,_x . rec-args)))
- #'(_Xⱼ …)))]]
+ #`(U (replace-in-type _Xⱼ . rec-args) …)]]
@CHUNK[<f-cases>
[(U _Xⱼ …)
@@ -320,10 +315,7 @@ way up, so that a simple identity function can be applied in these cases.
@CHUNK[<type-cases>
[(tagged _name [_fieldⱼ (~optional :colon) _Xⱼ] …)
- #`(tagged _name #,@(stx-map (λ (_field _x)
- #`[#,_field : #,(replace-in-type #`(#,_x . rec-args))])
- #'(_fieldⱼ …)
- #'(_Xⱼ …)))]]
+ #`(tagged _name [_fieldⱼ : (replace-in-type _Xⱼ . rec-args)] …)]]
@CHUNK[<f-cases>
[(tagged _name [_fieldⱼ (~optional :colon) _Xⱼ] …)
@@ -347,10 +339,6 @@ way up, so that a simple identity function can be applied in these cases.
-------
-
-
-
@CHUNK[<define-fold>
(define-syntax define-fold
(syntax-parser
@@ -392,13 +380,12 @@ where @racket[foldl-map] is defined as:
phc-adt
"dispatch-union.rkt"
(for-syntax "subtemplate-override.rkt"
- (subtract-in racket/base
+ (subtract-in (combine-in racket/base
+ syntax/parse)
"subtemplate-override.rkt")
+ syntax/parse/experimental/template
phc-toolkit/untyped
racket/syntax
- (subtract-in syntax/parse
- "subtemplate-override.rkt")
- syntax/parse/experimental/template
type-expander/expander
"free-identifier-tree-equal.rkt"
racket/dict
