suzanne.soy/phc-graph
1
0
Fork 0
Code Issues 24 Pull Requests Actions Packages Projects Releases Wiki Activity

First metafunction works, with a bit of a hack to remove the annoying scope.

Browse Source
This commit is contained in:
Georges Dupéron 2016-11-05 02:46:09 +01:00
parent d4167fe4e4
commit 38c9c7b7d6
3 changed files with 81 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
subtemplate.rkt
View File

@ -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)))))
(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))))])))]))

6
test/test-traversal-1.rkt
View File

@ -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)))

93
traversal.hl.rkt
View File

@ -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
"subtemplate-override.rkt")
phc-toolkit/untyped
racket/syntax
(subtract-in syntax/parse
(subtract-in (combine-in racket/base
syntax/parse)
"subtemplate-override.rkt")
syntax/parse/experimental/template
phc-toolkit/untyped
racket/syntax
type-expander/expander
"free-identifier-tree-equal.rkt"
racket/dict