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

Needs cleanup, but works!

Browse Source
This commit is contained in:
Georges Dupéron 2016-11-04 23:30:49 +01:00
parent 4eecd1def8
commit 37d6ba92ea
1 changed files with 18 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
traversal.hl.rkt
View File

@ -135,10 +135,11 @@ not expressed syntactically using the @racket[Foo] identifier.
[get-τ-defs (box '())]) [get-τ-defs (box '())])
(displayln (list 'context= (syntax-local-context))) (displayln (list 'context= (syntax-local-context)))
(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 f-type] …) (unbox (get-f-defs))]
[([τ-id . τ-body] …) (unbox (get-τ-defs))]) [([τ-id . τ-body] …) (unbox (get-τ-defs))])
((λ (x) (displayln x) x) ((λ (x) (displayln x) x)
#`(begin (define-type τ-id τ-body) … #`(begin (define-type τ-id τ-body) …
(: f-id f-type) …
(define f-id f-body) … (define f-id f-body) …
thunk-result)))))] thunk-result)))))]
@ -220,23 +221,23 @@ way up, so that a simple identity function can be applied in these cases.
(get-f-cache) (get-f-cache)
(get-f-defs) (get-f-defs)
#'(_whole-type _type-to-replaceᵢ …)] #'(_whole-type _type-to-replaceᵢ …)]
((λ (x) (printf "f ~a =>\n" #'_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 (quasisubtemplate
(ann (λ ({?@ _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)
<f-cases>))) <f-cases>)))
(∀ (_Aᵢ … _Bᵢ … Acc) (∀ (_Aᵢ … _Bᵢ … Acc)
(→ (?@ (→ 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 (subtemplate (_whole-type
[_type-to-replaceᵢ _Aᵢ] …))) [_type-to-replaceᵢ _Aᵢ] …)))
Acc Acc
(Values #,(replace-in-type (subtemplate (_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
@ -252,12 +253,10 @@ 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))]]
@ -304,18 +303,12 @@ 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)