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

TR-bug

Browse Source
This commit is contained in:
Georges Dupéron 2016-11-04 19:19:35 +01:00
parent 88b31299fb
commit b083acd41a
1 changed files with 108 additions and 108 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

160
traversal.hl.rkt
View File

@ -127,23 +127,19 @@ not expressed syntactically using the @racket[Foo] identifier.
(define-for-syntax get-τ-cache (make-parameter #f)) (define-for-syntax get-τ-cache (make-parameter #f))
(define-for-syntax get-f-defs (make-parameter #f)) (define-for-syntax get-f-defs (make-parameter #f))
(define-for-syntax get-τ-defs (make-parameter #f)) (define-for-syntax get-τ-defs (make-parameter #f))
(define-syntax (with-folds stx) (define-for-syntax (with-folds thunk)
(syntax-case stx ()
[(_ . body*)
;; TODO: should probably use bound-id instead. ;; TODO: should probably use bound-id instead.
(parameterize ([get-f-cache (make-mutable-free-id-tree-table)] (parameterize ([get-f-cache (make-mutable-free-id-tree-table)]
[get-τ-cache (make-mutable-free-id-tree-table)] [get-τ-cache (make-mutable-free-id-tree-table)]
[get-f-defs (box '())] [get-f-defs (box '())]
[get-τ-defs (box '())]) [get-τ-defs (box '())])
(displayln (list 'context= (syntax-local-context))) (displayln (list 'context= (syntax-local-context)))
(define expanded-body (local-expand #'(begin . body*) (define/with-syntax thunk-result (thunk))
(syntax-local-context); 'top-level
'()))
(with-syntax ([([f-id . f-body] …) (unbox (get-f-defs))] (with-syntax ([([f-id . f-body] …) (unbox (get-f-defs))]
[([τ-id . τ-body] …) (unbox (get-τ-defs))]) [([τ-id . τ-body] …) (unbox (get-τ-defs))])
#`(begin (define-type τ-id τ-body) … #`(begin (define-type τ-id τ-body) …
(define f-id f-body) … (define f-id f-body) …
expanded-body)))]))] thunk-result))))]
@;@subsection{…} @;@subsection{…}
@ -155,15 +151,15 @@ way up, so that a simple identity function can be applied in these cases.
@CHUNK[<define-fold> @CHUNK[<define-fold>
(define-type-expander (replace-in-type stx) (define-for-syntax (replace-in-type stx)
(syntax-case stx () (syntax-case stx ()
[(_ _whole-type [_type-to-replaceᵢ _Tᵢ] …) [(_whole-type [_type-to-replaceᵢ _Tᵢ] …)
#'((fold-type _whole-type _type-to-replaceᵢ …) _Tᵢ …)]))] #`(#,(fold-type #'(_whole-type _type-to-replaceᵢ …)) _Tᵢ …)]))]
@CHUNK[<define-fold> @CHUNK[<define-fold>
(define-type-expander 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 (subtemplate
([_type-to-replaceᵢ _Tᵢ] …)) ([_type-to-replaceᵢ _Tᵢ] …))
(cached [τ- (cached [τ-
@ -197,19 +193,19 @@ way up, so that a simple identity function can be applied in these cases.
new-def))))))] new-def))))))]
@CHUNK[<define-fold> @CHUNK[<define-fold>
(define-syntax (replace-in-instance stx) (define-for-syntax (replace-in-instance stx)
(syntax-case stx () (syntax-case stx ()
[(_ _whole-type [(_whole-type
[_type-to-replaceᵢ _predicateᵢ _updateᵢ] …) [_type-to-replaceᵢ _predicateᵢ _updateᵢ] …)
;+ cache ;+ cache
(subtemplate (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-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 (subtemplate
([_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
@ -217,16 +213,7 @@ way up, so that a simple identity function can be applied in these cases.
(syntax->list (syntax->list
(subtemplate (subtemplate
([_type-to-replaceᵢ . _updateᵢ] …)))))) ([_type-to-replaceᵢ . _updateᵢ] …))))))
#;(define-template-metafunction (λrec-replace stx)
(syntax-case stx ()
[(_ τ)
#'(replace-in-instance τ . rec-args)]))
#;(define-template-metafunction (rec-replace stx)
(syntax-case stx ()
[(_ τ v acc)
#'((replace-in-instance τ . rec-args) v acc)]))
(define/with-syntax _args (subtemplate ({?@ _predicateᵢ _updateᵢ} …))) (define/with-syntax _args (subtemplate ({?@ _predicateᵢ _updateᵢ} …)))
((λ (x) (displayln "f=") (pretty-write (syntax->datum x)) x)
(quasisubtemplate (quasisubtemplate
(ann (λ ({?@ _predicateᵢ _updateᵢ} …) (ann (λ ({?@ _predicateᵢ _updateᵢ} …)
(λ (v acc) (λ (v acc)
@ -237,12 +224,12 @@ 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 _whole-type (→ #,(replace-in-type (subtemplate (_whole-type
[_type-to-replaceᵢ _Aᵢ] …) [_type-to-replaceᵢ _Aᵢ] …)))
Acc Acc
(Values (replace-in-type _whole-type (Values #,(replace-in-type (subtemplate (_whole-type
[_type-to-replaceᵢ _Bᵢ] …) [_type-to-replaceᵢ _Bᵢ] …)))
Acc)))))))]))] Acc))))))]))]
@chunk[<f-cases> @chunk[<f-cases>
[t [t
@ -265,86 +252,97 @@ way up, so that a simple identity function can be applied in these cases.
(subtemplate (values v acc))]] (subtemplate (values v acc))]]
@chunk[<type-cases> @CHUNK[<type-cases>
[(Pairof X Y) [(Pairof X Y)
(subtemplate (Pairof (replace-in-type X . rec-args) (quasisubtemplate (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)
(subtemplate (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)
(subtemplate (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)
(subtemplate (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)
(subtemplate (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)
(subtemplate (quasisubtemplate
(vector->immutable-vector (vector->immutable-vector
(list->vector (list->vector
(foldl-map (replace-in-instance X . rec-args) acc (vector->list v)))))]] (foldl-map #,(replace-in-instance #'(X . rec-args))
acc
(vector->list v)))))]]
@chunk[<type-cases> @CHUNK[<type-cases>
[(List X Y …) [(List X Y …)
(subtemplate (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 …)
(subtemplate (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ⱼ …)
(subtemplate (quasisubtemplate
(U (replace-in-type _Xⱼ . rec-args) …))]] (U #,@(stx-map (λ (_x) (replace-in-type #'(_x . rec-args)))
(subtemplate (_Xⱼ …)))))]]
@chunk[<f-cases> @CHUNK[<f-cases>
[(U _Xⱼ …) [(U _Xⱼ …)
(subtemplate (quasisubtemplate
(dispatch-union v (dispatch-union v
([_type-to-replaceᵢ Aᵢ _predicateᵢ] …) ([_type-to-replaceᵢ Aᵢ _predicateᵢ] …)
[_Xⱼ ((replace-in-instance _Xⱼ . rec-args) v acc)] …))]] #,@(stx-map (λ (_x)
#`[_x (#,(replace-in-instance #'(_x . rec-args)) v acc)])
(subtemplate (_Xⱼ …)))))]]
@chunk[<type-cases> @CHUNK[<type-cases>
[(tagged _name [_fieldⱼ (~optional :colon) _Xⱼ] …) [(tagged _name [_fieldⱼ (~optional :colon) _Xⱼ] …)
(subtemplate (quasisubtemplate
(tagged _name [_fieldⱼ : (replace-in-type _Xⱼ . rec-args)] …))]] (tagged _name #,@(stx-map (λ (_field _x)
#`[_field : #,(replace-in-type #'(_x . rec-args))])
(subtemplate (_fieldⱼ …))
(subtemplate (_Xⱼ …)))))]]
@chunk[<f-cases> @CHUNK[<f-cases>
[(tagged _name [_fieldⱼ (~optional :colon) _Xⱼ] …) [(tagged _name [_fieldⱼ (~optional :colon) _Xⱼ] …)
(subtemplate (quasisubtemplate
(let*-values ([(_resultⱼ acc) (let*-values (#,@(stx-map (λ ( _result _field _x)
((replace-in-instance _Xⱼ . rec-args) (uniform-get v _fieldⱼ) #`[(_result acc)
acc)] (#,(replace-in-instance #'(_x . rec-args)) (uniform-get v _field)
…) acc)])
(subtemplate (_fieldⱼ …))
(subtemplate (_resultⱼ …))
(subtemplate (_Xⱼ …))))
(values (tagged _name #:instance [_fieldⱼ _resultⱼ] …) (values (tagged _name #:instance [_fieldⱼ _resultⱼ] …)
acc)))]] acc)))]]
@ -364,18 +362,20 @@ 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
[(_ _function-name:id [(_ _function-name:id
_type-name:id _type-name:id
whole-type:type whole-type:type
_type-to-replaceᵢ:type …) _type-to-replaceᵢ:type …)
#'(with-folds (with-folds
(λ ()
#`(begin
(define-type _type-name (define-type _type-name
(fold-type whole-type _type-to-replaceᵢ …)) #,(fold-type #'(whole-type _type-to-replaceᵢ …)))
(define _function-name (define _function-name
(fold-f whole-type _type-to-replaceᵢ …)))]))] #,(fold-f #'(whole-type _type-to-replaceᵢ …))))))]))]
where @racket[foldl-map] is defined as: where @racket[foldl-map] is defined as:
@ -418,8 +418,8 @@ where @racket[foldl-map] is defined as:
racket/pretty) racket/pretty)
(provide define-fold (provide define-fold
replace-in-instance (for-syntax replace-in-instance)
replace-in-type) (for-syntax replace-in-type))
<foldl-map> <foldl-map>
<with-folds> <with-folds>
<cached> <cached>