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 racket/stxparam
syntax/parse syntax/parse
syntax/parse/experimental/template syntax/parse/experimental/template
syntax/parse/experimental/private/substitute
syntax/id-table syntax/id-table
racket/syntax racket/syntax
(for-syntax "patch-arrows.rkt" (for-syntax "patch-arrows.rkt"
@ -22,6 +23,7 @@
(provide (rename-out [new-syntax-parse syntax-parse] (provide (rename-out [new-syntax-parse syntax-parse]
[new-syntax-parser syntax-parser] [new-syntax-parser syntax-parser]
[new-syntax-case syntax-case]) [new-syntax-case syntax-case])
define-unhygienic-template-metafunction
subtemplate subtemplate
quasisubtemplate) quasisubtemplate)
@ -314,4 +316,36 @@
#'tmp-ddd)) #'tmp-ddd))
(define/with-syntax bound-ddd cached) (define/with-syntax bound-ddd cached)
(define-syntax #,(format-id #'bound " is-derived-~a " #'bound) (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 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 Number)) (Listof String))
(define-fold f₁₂ t₁₂ (List (Listof String) (Listof String)) (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]) (define (string->symbol+acc [x : String] [acc : Integer])
(values (string->symbol x) (add1 acc))) (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{…} @;@subsection{…}
* free-id-tree=? @; TODO: recursively go down the tree. If there are no replacements, return #f
* cache of already-seen types @; all the way up, so that a simple identity function can be applied in these
* recursively go down the tree. If there are no replacements, return #f all the @; cases.
way up, so that a simple identity function can be applied in these cases.
@CHUNK[<define-fold> @CHUNK[<define-fold>
(define-for-syntax (replace-in-type stx) (begin-for-syntax
(syntax-case stx () (define-unhygienic-template-metafunction (replace-in-type stx)
[(_whole-type [_type-to-replaceᵢ _Tᵢ] …) (syntax-case stx ()
#`(#,(fold-type #'(_whole-type _type-to-replaceᵢ …)) _Tᵢ …)]))] [(_ _whole-type [_type-to-replaceᵢ _Tᵢ] …)
#`(#,(syntax-local-introduce
(fold-type #'(_whole-type _type-to-replaceᵢ …))) _Tᵢ …)])))]
@CHUNK[<define-fold> @CHUNK[<define-fold>
(define-for-syntax fold-type (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 (map syntax-e
(syntax->list (syntax->list
#'([_type-to-replaceᵢ . _Tᵢ] …))))) #'([_type-to-replaceᵢ . _Tᵢ] …)))))
(printf "Start ~a ~a =>\n" (syntax->datum τ-) #'_whole-type) #`(∀ (_Tᵢ …)
((λ (x) (printf "~a ~a =>\n" (syntax->datum τ-) #'_whole-type) (pretty-write (syntax->datum x)) x) #,(syntax-parse #'_whole-type
#`(∀ (_Tᵢ …) #:literals (Null Pairof Listof List Vectorof Vector U tagged)
#,(syntax-parse #'_whole-type <type-cases>)))]))]
#:literals (Null Pairof Listof List Vectorof Vector U tagged)
<type-cases>))))]))]
@CHUNK[<cached> @CHUNK[<cached>
(begin-for-syntax (begin-for-syntax
@ -197,7 +196,6 @@ way up, so that a simple identity function can be applied in these cases.
(syntax-case stx () (syntax-case stx ()
[(_whole-type [(_whole-type
[_type-to-replaceᵢ _predicateᵢ _updateᵢ] …) [_type-to-replaceᵢ _predicateᵢ _updateᵢ] …)
;+ cache
#`(#,(fold-f #'(_whole-type _type-to-replaceᵢ …)) #`(#,(fold-f #'(_whole-type _type-to-replaceᵢ …))
{?@ _predicateᵢ _updateᵢ} …)]))] {?@ _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-cache)
(get-f-defs) (get-f-defs)
#'(_whole-type _type-to-replaceᵢ …)] #'(_whole-type _type-to-replaceᵢ …)]
((λ (x) (printf "~a ~a =>\n" (syntax->datum f-) #'_whole-type) (pretty-write (syntax->datum x)) x) #`[(λ ({?@ _predicateᵢ _updateᵢ} …)
#`[(λ ({?@ _predicateᵢ _updateᵢ} …) (λ (v acc)
(λ (v acc) #,(syntax-parse #'_whole-type
#,(syntax-parse #'_whole-type #:literals (Null Pairof Listof List Vectorof Vector U tagged)
#:literals (Null Pairof Listof List Vectorof Vector U tagged) <f-cases>)))
<f-cases>))) (∀ (_Aᵢ … _Bᵢ … Acc)
(∀ (_Aᵢ … _Bᵢ … Acc) (→ (?@ (→ Any Boolean : _Aᵢ)
(→ (?@ (→ Any Boolean : _Aᵢ) (→ _Aᵢ Acc (Values _Bᵢ Acc)))
(→ _Aᵢ Acc (Values _Bᵢ Acc))) …
… (→ (replace-in-type _whole-type
(→ #,(replace-in-type #'(_whole-type [_type-to-replaceᵢ _Aᵢ] …)
[_type-to-replaceᵢ _Aᵢ] …)) Acc
Acc (Values (replace-in-type _whole-type
(Values #,(replace-in-type #'(_whole-type [_type-to-replaceᵢ _Bᵢ] …)
[_type-to-replaceᵢ _Bᵢ] …)) Acc))))])]))]
Acc))))]))]))]
@chunk[<f-cases> @chunk[<f-cases>
[t [t
@ -255,8 +252,8 @@ way up, so that a simple identity function can be applied in these cases.
@CHUNK[<type-cases> @CHUNK[<type-cases>
[(Pairof X Y) [(Pairof X Y)
#`(Pairof #,(replace-in-type #'(X . rec-args)) #`(Pairof (replace-in-type X . rec-args)
#,(replace-in-type #'(Y . rec-args)))]] (replace-in-type Y . rec-args))]]
@CHUNK[<f-cases> @CHUNK[<f-cases>
[(Pairof X Y) [(Pairof X Y)
@ -268,7 +265,7 @@ way up, so that a simple identity function can be applied in these cases.
@CHUNK[<type-cases> @CHUNK[<type-cases>
[(Listof X) [(Listof X)
#`(Listof #,(replace-in-type #'(X . rec-args)))]] #`(Listof (replace-in-type X . rec-args))]]
@CHUNK[<f-cases> @CHUNK[<f-cases>
[(Listof X) [(Listof X)
@ -277,8 +274,7 @@ way up, so that a simple identity function can be applied in these cases.
@CHUNK[<type-cases> @CHUNK[<type-cases>
[(Vectorof X) [(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> @CHUNK[<ftype-cases>
[(Vectorof X) [(Vectorof X)
@ -291,8 +287,8 @@ way up, so that a simple identity function can be applied in these cases.
@CHUNK[<type-cases> @CHUNK[<type-cases>
[(List X Y …) [(List X Y …)
#`(Pairof #,(replace-in-type #'(X . rec-args)) #`(Pairof (replace-in-type X . rec-args)
#,(replace-in-type #'((List Y …) . rec-args)))]] (replace-in-type (List Y …) . rec-args))]]
@CHUNK[<f-cases> @CHUNK[<f-cases>
[(List X Y …) [(List X Y …)
@ -306,8 +302,7 @@ way up, so that a simple identity function can be applied in these cases.
@CHUNK[<type-cases> @CHUNK[<type-cases>
[(U _Xⱼ …) [(U _Xⱼ …)
#`(U #,@(stx-map (λ (_x) (replace-in-type #`(#,_x . rec-args))) #`(U (replace-in-type _Xⱼ . rec-args) …)]]
#'(_Xⱼ …)))]]
@CHUNK[<f-cases> @CHUNK[<f-cases>
[(U _Xⱼ …) [(U _Xⱼ …)
@ -320,10 +315,7 @@ way up, so that a simple identity function can be applied in these cases.
@CHUNK[<type-cases> @CHUNK[<type-cases>
[(tagged _name [_fieldⱼ (~optional :colon) _Xⱼ] …) [(tagged _name [_fieldⱼ (~optional :colon) _Xⱼ] …)
#`(tagged _name #,@(stx-map (λ (_field _x) #`(tagged _name [_fieldⱼ : (replace-in-type _Xⱼ . rec-args)] …)]]
#`[#,_field : #,(replace-in-type #`(#,_x . rec-args))])
#'(_fieldⱼ …)
#'(_Xⱼ …)))]]
@CHUNK[<f-cases> @CHUNK[<f-cases>
[(tagged _name [_fieldⱼ (~optional :colon) _Xⱼ] …) [(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> @CHUNK[<define-fold>
(define-syntax define-fold (define-syntax define-fold
(syntax-parser (syntax-parser
@ -392,13 +380,12 @@ where @racket[foldl-map] is defined as:
phc-adt phc-adt
"dispatch-union.rkt" "dispatch-union.rkt"
(for-syntax "subtemplate-override.rkt" (for-syntax "subtemplate-override.rkt"
(subtract-in racket/base (subtract-in (combine-in racket/base
"subtemplate-override.rkt") syntax/parse)
phc-toolkit/untyped
racket/syntax
(subtract-in syntax/parse
"subtemplate-override.rkt") "subtemplate-override.rkt")
syntax/parse/experimental/template syntax/parse/experimental/template
phc-toolkit/untyped
racket/syntax
type-expander/expander type-expander/expander
"free-identifier-tree-equal.rkt" "free-identifier-tree-equal.rkt"
racket/dict racket/dict