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

WIP: have to separate function definition from its type with :, due to recursive functions.

Browse Source
This commit is contained in:
Georges Dupéron 2016-11-04 22:38:14 +01:00
parent b083acd41a
commit 4eecd1def8
5 changed files with 58 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
dispatch-union.rkt
View File

@ -37,7 +37,6 @@
(pattern [other result] (pattern [other result]
#:with clause #`[else result])) #:with clause #`[else result]))
((λ (x) (local-require racket/pretty) #;(pretty-write (syntax->datum x)) x) ((λ (x) (local-require racket/pretty) #;(pretty-write (syntax->datum x)) x)
(syntax-parse #'([Xⱼ resultⱼ] …) (syntax-parse #'([Xⱼ resultⱼ] …)
[({~or to-replace:to-replace [({~or to-replace:to-replace

5
free-identifier-tree-equal.rkt
View File

@ -36,7 +36,10 @@
(let ([b-key (prefab-struct-key b)]) (let ([b-key (prefab-struct-key b)])
(and (equal? a-key b-key) (and (equal? a-key b-key)
(rec=? (struct->list a) (rec=? (struct->list a)
(struct->list b)))))])) (struct->list b)))))]
[(null? a) (null? b)]
[else (error (format "Unexpected value for free-id-tree=? : ~a"
a))]))
(define ((free-id-tree-hash hc) a) (define ((free-id-tree-hash hc) a)
(define rec-hash (free-id-tree-hash hc)) (define rec-hash (free-id-tree-hash hc))

2
test/test-traversal-1.rkt
View File

@ -15,6 +15,8 @@
(define-fold f₈ t₈ (List String Foo (Listof String)) String) (define-fold f₈ t₈ (List String Foo (Listof String)) String)
(define-fold f₉ t₉ (List (Listof String) Foo (Listof String)) (Listof String)) (define-fold f₉ t₉ (List (Listof String) Foo (Listof String)) (Listof String))
(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 String)) (Listof 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)))

1
test/test-traversal-2.rkt
View File

@ -112,4 +112,3 @@
Symbol) Symbol)
Integer) Integer)
'ghi 1) 'ghi 1)

88
traversal.hl.rkt
View File

@ -137,9 +137,10 @@ not expressed syntactically using the @racket[Foo] identifier.
(define/with-syntax thunk-result (thunk)) (define/with-syntax thunk-result (thunk))
(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) … ((λ (x) (displayln x) x)
(define f-id f-body) … #`(begin (define-type τ-id τ-body) …
thunk-result))))] (define f-id f-body) …
thunk-result)))))]
@;@subsection{…} @;@subsection{…}
@ -171,7 +172,8 @@ way up, so that a simple identity function can be applied in these cases.
(syntax->list (syntax->list
(subtemplate (subtemplate
([_type-to-replaceᵢ . _Tᵢ] …)))))) ([_type-to-replaceᵢ . _Tᵢ] …))))))
((λ (x) (displayln "τ=") (pretty-write (syntax->datum x)) x) (printf "Start ~a ~a =>\n" (syntax->datum τ-) #'_whole-type)
((λ (x) (printf "~a ~a =>\n" (syntax->datum τ-) #'_whole-type) (pretty-write (syntax->datum x)) x)
(quasisubtemplate (quasisubtemplate
(∀ (_Tᵢ …) (∀ (_Tᵢ …)
#,(syntax-parse #'_whole-type #,(syntax-parse #'_whole-type
@ -186,11 +188,11 @@ way up, so that a simple identity function can be applied in these cases.
(error "fold-type and fold-f must be called within with-folds")) (error "fold-type and fold-f must be called within with-folds"))
(if (dict-has-key? cache key) (if (dict-has-key? cache key)
(dict-ref cache key) (dict-ref cache key)
(let ([new-def #`#,(gensym 'base)]) (let ([base #`#,(gensym 'base)])
(dict-set! cache key new-def) (dict-set! cache key base)
(let ([result (let () . body)]) (let ([result (let () . body)])
(set-box! defs `([,new-def . ,result] . ,(unbox defs))) (set-box! defs `([,base . ,result] . ,(unbox defs)))
new-def))))))] base))))))]
@CHUNK[<define-fold> @CHUNK[<define-fold>
(define-for-syntax (replace-in-instance stx) (define-for-syntax (replace-in-instance stx)
@ -214,22 +216,27 @@ way up, so that a simple identity function can be applied in these cases.
(subtemplate (subtemplate
([_type-to-replaceᵢ . _updateᵢ] …)))))) ([_type-to-replaceᵢ . _updateᵢ] …))))))
(define/with-syntax _args (subtemplate ({?@ _predicateᵢ _updateᵢ} …))) (define/with-syntax _args (subtemplate ({?@ _predicateᵢ _updateᵢ} …)))
(quasisubtemplate (cached [f-
(ann (λ ({?@ _predicateᵢ _updateᵢ} …) (get-f-cache)
(λ (v acc) (get-f-defs)
#,(syntax-parse #'_whole-type #'(_whole-type _type-to-replaceᵢ …)]
#:literals (Null Pairof Listof List Vectorof Vector U tagged) ((λ (x) (printf "f ~a =>\n" #'_whole-type) (pretty-write (syntax->datum x)) x)
<f-cases>))) (quasisubtemplate
(∀ (_Aᵢ … _Bᵢ … Acc) (ann (λ ({?@ _predicateᵢ _updateᵢ} …)
(→ (?@ (→ Any Boolean : _Aᵢ) (λ (v acc)
(→ _Aᵢ Acc (Values _Bᵢ Acc))) #,(syntax-parse #'_whole-type
… #:literals (Null Pairof Listof List Vectorof Vector U tagged)
(→ #,(replace-in-type (subtemplate (_whole-type <f-cases>)))
[_type-to-replaceᵢ _Aᵢ] …))) (∀ (_Aᵢ … _Bᵢ … Acc)
Acc (→ (?@ (→ Any Boolean : _Aᵢ)
(Values #,(replace-in-type (subtemplate (_whole-type (→ _Aᵢ Acc (Values _Bᵢ Acc)))
[_type-to-replaceᵢ _Bᵢ] …))) …
Acc))))))]))] (→ #,(replace-in-type (subtemplate (_whole-type
[_type-to-replaceᵢ _Aᵢ] …)))
Acc
(Values #,(replace-in-type (subtemplate (_whole-type
[_type-to-replaceᵢ _Bᵢ] …)))
Acc))))))))]))]
@chunk[<f-cases> @chunk[<f-cases>
[t [t
@ -245,10 +252,12 @@ way up, so that a simple identity function can be applied in these cases.
@chunk[<type-cases> @chunk[<type-cases>
[(~or Null (List)) [(~or Null (List))
(displayln "Null case")
(subtemplate Null)]] (subtemplate Null)]]
@chunk[<f-cases> @chunk[<f-cases>
[(~or Null (List)) [(~or Null (List))
(displayln "Null case")
(subtemplate (values v acc))]] (subtemplate (values v acc))]]
@ -295,12 +304,18 @@ 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 …)
(newline)
(displayln "(List X Y …) case")
(displayln #'(List Y …))
(displayln (replace-in-type #'((List Y …) . rec-args)))
(quasisubtemplate (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 …)
(newline)
(displayln "(List X Y …) case")
(quasisubtemplate (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)
@ -313,23 +328,24 @@ way up, so that a simple identity function can be applied in these cases.
@CHUNK[<type-cases> @CHUNK[<type-cases>
[(U _Xⱼ …) [(U _Xⱼ …)
(quasisubtemplate (quasisubtemplate
(U #,@(stx-map (λ (_x) (replace-in-type #'(_x . rec-args))) (U #,@(stx-map (λ (_x) (replace-in-type #`(#,_x . rec-args)))
(subtemplate (_Xⱼ …)))))]] (subtemplate (_Xⱼ …)))))]]
@CHUNK[<f-cases> @CHUNK[<f-cases>
[(U _Xⱼ …) [(U _Xⱼ …)
(quasisubtemplate ((λ (x) (displayln x) x)
(dispatch-union v (quasisubtemplate
([_type-to-replaceᵢ Aᵢ _predicateᵢ] …) (dispatch-union v
#,@(stx-map (λ (_x) ([_type-to-replaceᵢ Aᵢ _predicateᵢ] …)
#`[_x (#,(replace-in-instance #'(_x . rec-args)) v acc)]) #,@(stx-map (λ (_x)
(subtemplate (_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ⱼ] …)
(quasisubtemplate (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ⱼ …)) (subtemplate (_fieldⱼ …))
(subtemplate (_Xⱼ …)))))]] (subtemplate (_Xⱼ …)))))]]
@ -337,11 +353,11 @@ way up, so that a simple identity function can be applied in these cases.
[(tagged _name [_fieldⱼ (~optional :colon) _Xⱼ] …) [(tagged _name [_fieldⱼ (~optional :colon) _Xⱼ] …)
(quasisubtemplate (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 (_fieldⱼ …))
(subtemplate (_resultⱼ …)) (subtemplate (_resultⱼ …))
(subtemplate (_fieldⱼ …))
(subtemplate (_Xⱼ …)))) (subtemplate (_Xⱼ …))))
(values (tagged _name #:instance [_fieldⱼ _resultⱼ] …) (values (tagged _name #:instance [_fieldⱼ _resultⱼ] …)
acc)))]] acc)))]]