From 38c9c7b7d6d03e9928c0019f7607cea1510d8d63 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Sat, 5 Nov 2016 02:46:09 +0100 Subject: [PATCH] First metafunction works, with a bit of a hack to remove the annoying scope. --- subtemplate.rkt | 36 ++++++++++++++- test/test-traversal-1.rkt | 6 +++ traversal.hl.rkt | 93 +++++++++++++++++---------------------- 3 files changed, 81 insertions(+), 54 deletions(-) diff --git a/subtemplate.rkt b/subtemplate.rkt index eba46dc..88e3b4a 100644 --- 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 index 0dbbfb4..7284760 100644 --- 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 index cfdbaf9..4de7a6a 100644 --- 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-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-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) - ))))]))] + #`(∀ (_Tᵢ …) + #,(syntax-parse #'_whole-type + #:literals (Null Pairof Listof List Vectorof Vector U tagged) + )))]))] @CHUNK[ (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) - ))) - (∀ (_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) + ))) + (∀ (_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[ [t @@ -255,8 +252,8 @@ way up, so that a simple identity function can be applied in these cases. @CHUNK[ [(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[ [(Pairof X Y) @@ -268,7 +265,7 @@ way up, so that a simple identity function can be applied in these cases. @CHUNK[ [(Listof X) - #`(Listof #,(replace-in-type #'(X . rec-args)))]] + #`(Listof (replace-in-type X . rec-args))]] @CHUNK[ [(Listof X) @@ -277,8 +274,7 @@ way up, so that a simple identity function can be applied in these cases. @CHUNK[ [(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[ [(Vectorof X) @@ -291,8 +287,8 @@ way up, so that a simple identity function can be applied in these cases. @CHUNK[ [(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[ [(List X Y …) @@ -306,8 +302,7 @@ way up, so that a simple identity function can be applied in these cases. @CHUNK[ [(U _Xⱼ …) - #`(U #,@(stx-map (λ (_x) (replace-in-type #`(#,_x . rec-args))) - #'(_Xⱼ …)))]] + #`(U (replace-in-type _Xⱼ . rec-args) …)]] @CHUNK[ [(U _Xⱼ …) @@ -320,10 +315,7 @@ way up, so that a simple identity function can be applied in these cases. @CHUNK[ [(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[ [(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-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