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

Second template metafunction works too. The scopes issue is a bit fishy, but it will do until I tackle the task of having a propper, powerfull and expressive templating library.

Browse Source
This commit is contained in:
Georges Dupéron 2016-11-05 02:53:18 +01:00
parent 38c9c7b7d6
commit f36c90a27b
2 changed files with 34 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
subtemplate-override.rkt Normal file
View File

@ -0,0 +1,5 @@
#lang racket
(require (rename-in "subtemplate.rkt"
[subtemplate syntax]
[quasisubtemplate quasisyntax]))
(provide (all-from-out "subtemplate.rkt"))

60
traversal.hl.rkt
View File

@ -192,12 +192,13 @@ not expressed syntactically using the @racket[Foo] identifier.
base))))))] base))))))]
@CHUNK[<define-fold> @CHUNK[<define-fold>
(define-for-syntax (replace-in-instance stx) (begin-for-syntax
(syntax-case stx () (define-unhygienic-template-metafunction (replace-in-instance stx)
[(_whole-type (syntax-case stx ()
[_type-to-replaceᵢ _predicateᵢ _updateᵢ] …) [(_ _whole-type [_type-to-replaceᵢ _predicateᵢ _updateᵢ] …)
#`(#,(fold-f #'(_whole-type _type-to-replaceᵢ …)) #`(#,(syntax-local-introduce
{?@ _predicateᵢ _updateᵢ} …)]))] (fold-f #'(_whole-type _type-to-replaceᵢ …)))
{?@ _predicateᵢ _updateᵢ} …)])))]
@CHUNK[<define-fold> @CHUNK[<define-fold>
(define-for-syntax fold-f (define-for-syntax fold-f
@ -252,80 +253,77 @@ not expressed syntactically using the @racket[Foo] identifier.
@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)
#`(let*-values ([(result-x acc-x) #'(let*-values ([(result-x acc-x)
(#,(replace-in-instance #'(X . rec-args)) (car v) acc)] ((replace-in-instance X . rec-args) (car v) acc)]
[(result-y acc-y) [(result-y acc-y)
(#,(replace-in-instance #'(Y . rec-args)) (cdr v) acc-x)]) ((replace-in-instance Y . rec-args) (cdr v) acc-x)])
(values (cons result-x result-y) acc-y))]] (values (cons result-x result-y) acc-y))]]
@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)
#`(foldl-map #,(replace-in-instance #'(X . rec-args)) #'(foldl-map (replace-in-instance X . rec-args)
acc v)]] acc v)]]
@CHUNK[<type-cases> @CHUNK[<type-cases>
[(Vectorof X) [(Vectorof X)
#`(Vectorof (replace-in-type X . rec-args))]] #'(Vectorof (replace-in-type X . rec-args))]]
@CHUNK[<ftype-cases> @CHUNK[<ftype-cases>
[(Vectorof X) [(Vectorof X)
#`(vector->immutable-vector #'(vector->immutable-vector
(list->vector (list->vector
(foldl-map #,(replace-in-instance #'(X . rec-args)) (foldl-map (replace-in-instance X . rec-args)
acc acc
(vector->list v))))]] (vector->list v))))]]
@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 …)
#`(let*-values ([(result-x acc-x) (#,(replace-in-instance #'(X . rec-args)) #'(let*-values ([(result-x acc-x) ((replace-in-instance X . rec-args)
(car v) (car v)
acc)] acc)]
[(result-y* acc-y*) (#,(replace-in-instance #'((List Y …) . rec-args)) [(result-y* acc-y*) ((replace-in-instance (List Y …) . rec-args)
(cdr v) (cdr v)
acc-x)]) acc-x)])
(values (cons result-x result-y*) acc-y*))]] (values (cons result-x result-y*) acc-y*))]]
@CHUNK[<type-cases> @CHUNK[<type-cases>
[(U _Xⱼ …) [(U _Xⱼ …)
#`(U (replace-in-type _Xⱼ . rec-args) …)]] #'(U (replace-in-type _Xⱼ . rec-args) …)]]
@CHUNK[<f-cases> @CHUNK[<f-cases>
[(U _Xⱼ …) [(U _Xⱼ …)
((λ (x) (displayln x) x) ((λ (x) (displayln x) x)
#`(dispatch-union v #'(dispatch-union v
([_type-to-replaceᵢ Aᵢ _predicateᵢ] …) ([_type-to-replaceᵢ Aᵢ _predicateᵢ] …)
#,@(stx-map (λ (_x) [_Xⱼ ((replace-in-instance _Xⱼ . rec-args) v acc)]
#`[#,_x (#,(replace-in-instance #`(#,_x . rec-args)) v acc)]) …))]]
#'(_Xⱼ …))))]]
@CHUNK[<type-cases> @CHUNK[<type-cases>
[(tagged _name [_fieldⱼ (~optional :colon) _Xⱼ] …) [(tagged _name [_fieldⱼ (~optional :colon) _Xⱼ] …)
#`(tagged _name [_fieldⱼ : (replace-in-type _Xⱼ . rec-args)] …)]] #'(tagged _name [_fieldⱼ : (replace-in-type _Xⱼ . rec-args)] …)]]
@CHUNK[<f-cases> @CHUNK[<f-cases>
[(tagged _name [_fieldⱼ (~optional :colon) _Xⱼ] …) [(tagged _name [_fieldⱼ (~optional :colon) _Xⱼ] …)
#`(let*-values (#,@(stx-map (λ ( _result _field _x) #'(let*-values
#`[(#,_result acc) ([(_resultⱼ acc)
(#,(replace-in-instance #`(#,_x . rec-args)) (uniform-get v #,_field) ((replace-in-instance _Xⱼ . rec-args) (uniform-get v _fieldⱼ)
acc)]) acc)]
#'(_resultⱼ …) …)
#'(_fieldⱼ …)
#'(_Xⱼ …)))
(values (tagged _name #:instance [_fieldⱼ _resultⱼ] …) (values (tagged _name #:instance [_fieldⱼ _resultⱼ] …)
acc))]] acc))]]