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

Renamed subtemplate and quasisubtemplate as #' and #` for conciseness

Browse Source
This commit is contained in:
Georges Dupéron 2016-11-04 23:48:16 +01:00
parent 37d6ba92ea
commit d4167fe4e4
1 changed files with 90 additions and 108 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

122
traversal.hl.rkt
View File

@ -162,8 +162,7 @@ way up, so that a simple identity function can be applied in these cases.
(define-for-syntax fold-type (define-for-syntax fold-type
(syntax-parser (syntax-parser
[(_whole-type:type _type-to-replaceᵢ:type …) [(_whole-type:type _type-to-replaceᵢ:type …)
#:with rec-args (subtemplate #:with rec-args #'([_type-to-replaceᵢ _Tᵢ] …)
([_type-to-replaceᵢ _Tᵢ] …))
(cached [τ- (cached [τ-
(get-τ-cache) (get-τ-cache)
(get-τ-defs) (get-τ-defs)
@ -171,15 +170,13 @@ way up, so that a simple identity function can be applied in these cases.
(define replacements (make-immutable-free-id-tree-table (define replacements (make-immutable-free-id-tree-table
(map syntax-e (map syntax-e
(syntax->list (syntax->list
(subtemplate #'([_type-to-replaceᵢ . _Tᵢ] …)))))
([_type-to-replaceᵢ . _Tᵢ] …))))))
(printf "Start ~a ~a =>\n" (syntax->datum τ-) #'_whole-type) (printf "Start ~a ~a =>\n" (syntax->datum τ-) #'_whole-type)
((λ (x) (printf "~a ~a =>\n" (syntax->datum τ-) #'_whole-type) (pretty-write (syntax->datum x)) x) ((λ (x) (printf "~a ~a =>\n" (syntax->datum τ-) #'_whole-type) (pretty-write (syntax->datum x)) x)
(quasisubtemplate #`(∀ (_Tᵢ …)
(∀ (_Tᵢ …)
#,(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)
<type-cases>)))))]))] <type-cases>))))]))]
@CHUNK[<cached> @CHUNK[<cached>
(begin-for-syntax (begin-for-syntax
@ -201,29 +198,25 @@ way up, so that a simple identity function can be applied in these cases.
[(_whole-type [(_whole-type
[_type-to-replaceᵢ _predicateᵢ _updateᵢ] …) [_type-to-replaceᵢ _predicateᵢ _updateᵢ] …)
;+ cache ;+ cache
(quasisubtemplate #`(#,(fold-f #'(_whole-type _type-to-replaceᵢ …))
(#,(fold-f #'(_whole-type _type-to-replaceᵢ …)) {?@ _predicateᵢ _updateᵢ} …)]))]
{?@ _predicateᵢ _updateᵢ} …))]))]
@CHUNK[<define-fold> @CHUNK[<define-fold>
(define-for-syntax fold-f (define-for-syntax fold-f
(syntax-parser (syntax-parser
[(_whole-type:type _type-to-replaceᵢ:type …) [(_whole-type:type _type-to-replaceᵢ:type …)
#:with rec-args (subtemplate #:with rec-args #'([_type-to-replaceᵢ _predicateᵢ _updateᵢ] …)
([_type-to-replaceᵢ _predicateᵢ _updateᵢ] …))
(define replacements (make-immutable-free-id-tree-table (define replacements (make-immutable-free-id-tree-table
(map syntax-e (map syntax-e
(syntax->list (syntax->list
(subtemplate #'([_type-to-replaceᵢ . _updateᵢ] …)))))
([_type-to-replaceᵢ . _updateᵢ] …)))))) (define/with-syntax _args #'({?@ _predicateᵢ _updateᵢ} …))
(define/with-syntax _args (subtemplate ({?@ _predicateᵢ _updateᵢ} …)))
(cached [f- (cached [f-
(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) ((λ (x) (printf "~a ~a =>\n" (syntax->datum f-) #'_whole-type) (pretty-write (syntax->datum x)) x)
(quasisubtemplate #`[(λ ({?@ _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)
@ -232,138 +225,125 @@ way up, so that a simple identity function can be applied in these cases.
(→ (?@ (→ Any Boolean : _Aᵢ) (→ (?@ (→ Any Boolean : _Aᵢ)
(→ _Aᵢ Acc (Values _Bᵢ Acc))) (→ _Aᵢ Acc (Values _Bᵢ Acc)))
… …
(→ #,(replace-in-type (subtemplate (_whole-type (→ #,(replace-in-type #'(_whole-type
[_type-to-replaceᵢ _Aᵢ] …))) [_type-to-replaceᵢ _Aᵢ] …))
Acc Acc
(Values #,(replace-in-type (subtemplate (_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
#:when (dict-has-key? replacements #'t) #:when (dict-has-key? replacements #'t)
#:with _update (dict-ref replacements #'t) #:with _update (dict-ref replacements #'t)
(subtemplate (_update v acc))]] #'(_update v acc)]]
@chunk[<type-cases> @chunk[<type-cases>
[t [t
#:when (dict-has-key? replacements #'t) #:when (dict-has-key? replacements #'t)
#:with _T (dict-ref replacements #'t) #:with _T (dict-ref replacements #'t)
(subtemplate _T)]] #'_T]]
@chunk[<type-cases> @chunk[<type-cases>
[(~or Null (List)) [(~or Null (List))
(subtemplate Null)]] #'Null]]
@chunk[<f-cases> @chunk[<f-cases>
[(~or Null (List)) [(~or Null (List))
(subtemplate (values v acc))]] #'(values v acc)]]
@CHUNK[<type-cases> @CHUNK[<type-cases>
[(Pairof X Y) [(Pairof X Y)
(quasisubtemplate (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)
(quasisubtemplate #`(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)
(quasisubtemplate #`(Listof #,(replace-in-type #'(X . rec-args)))]]
(Listof #,(replace-in-type #'(X . rec-args))))]]
@CHUNK[<f-cases> @CHUNK[<f-cases>
[(Listof X) [(Listof X)
(quasisubtemplate #`(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)
(quasisubtemplate
;; TODO: turn replace-in-type & co into rec-replace via metafunctions ;; 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)
(quasisubtemplate #`(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 …)
(quasisubtemplate #`(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 …)
(quasisubtemplate #`(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ⱼ …)
(quasisubtemplate #`(U #,@(stx-map (λ (_x) (replace-in-type #`(#,_x . rec-args)))
(U #,@(stx-map (λ (_x) (replace-in-type #`(#,_x . rec-args))) #'(_Xⱼ …)))]]
(subtemplate (_Xⱼ …)))))]]
@CHUNK[<f-cases> @CHUNK[<f-cases>
[(U _Xⱼ …) [(U _Xⱼ …)
((λ (x) (displayln x) x) ((λ (x) (displayln x) x)
(quasisubtemplate #`(dispatch-union v
(dispatch-union v
([_type-to-replaceᵢ Aᵢ _predicateᵢ] …) ([_type-to-replaceᵢ Aᵢ _predicateᵢ] …)
#,@(stx-map (λ (_x) #,@(stx-map (λ (_x)
#`[#,_x (#,(replace-in-instance #`(#,_x . rec-args)) v acc)]) #`[#,_x (#,(replace-in-instance #`(#,_x . rec-args)) v acc)])
(subtemplate (_Xⱼ …))))))]] #'(_Xⱼ …))))]]
@CHUNK[<type-cases> @CHUNK[<type-cases>
[(tagged _name [_fieldⱼ (~optional :colon) _Xⱼ] …) [(tagged _name [_fieldⱼ (~optional :colon) _Xⱼ] …)
(quasisubtemplate #`(tagged _name #,@(stx-map (λ (_field _x)
(tagged _name #,@(stx-map (λ (_field _x)
#`[#,_field : #,(replace-in-type #`(#,_x . rec-args))]) #`[#,_field : #,(replace-in-type #`(#,_x . rec-args))])
(subtemplate (_fieldⱼ …)) #'(_fieldⱼ …)
(subtemplate (_Xⱼ …)))))]] #'(_Xⱼ …)))]]
@CHUNK[<f-cases> @CHUNK[<f-cases>
[(tagged _name [_fieldⱼ (~optional :colon) _Xⱼ] …) [(tagged _name [_fieldⱼ (~optional :colon) _Xⱼ] …)
(quasisubtemplate #`(let*-values (#,@(stx-map (λ ( _result _field _x)
(let*-values (#,@(stx-map (λ ( _result _field _x)
#`[(#,_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)])
(subtemplate (_resultⱼ …)) #'(_resultⱼ …)
(subtemplate (_fieldⱼ …)) #'(_fieldⱼ …)
(subtemplate (_Xⱼ …)))) #'(_Xⱼ …)))
(values (tagged _name #:instance [_fieldⱼ _resultⱼ] …) (values (tagged _name #:instance [_fieldⱼ _resultⱼ] …)
acc)))]] acc))]]
@chunk[<type-cases> @chunk[<type-cases>
[else-T [else-T
(subtemplate #'else-T]]
else-T)]]
@chunk[<f-cases> @chunk[<f-cases>
[else-T [else-T
(subtemplate #'(values v acc)]]
(values v acc))]]
@ -411,11 +391,13 @@ where @racket[foldl-map] is defined as:
type-expander type-expander
phc-adt phc-adt
"dispatch-union.rkt" "dispatch-union.rkt"
(for-syntax "subtemplate.rkt" (for-syntax "subtemplate-override.rkt"
(subtract-in racket/base "subtemplate.rkt") (subtract-in racket/base
"subtemplate-override.rkt")
phc-toolkit/untyped phc-toolkit/untyped
racket/syntax racket/syntax
(subtract-in syntax/parse "subtemplate.rkt") (subtract-in syntax/parse
"subtemplate-override.rkt")
syntax/parse/experimental/template syntax/parse/experimental/template
type-expander/expander type-expander/expander
"free-identifier-tree-equal.rkt" "free-identifier-tree-equal.rkt"