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

Cleanup of traversal.hl.rkt (still needs a lot of prose)

Browse Source
This commit is contained in:
Georges Dupéron 2017-02-05 21:20:07 +01:00
parent 22f3d97185
commit 72261decc4
1 changed files with 33 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
traversal.hl.rkt
View File

@ -8,10 +8,12 @@
(for-label racket/format (for-label racket/format
racket/promise racket/promise
racket/list racket/list
syntax/parse (except-in subtemplate/override begin let)
syntax/parse/experimental/template
type-expander type-expander
(except-in (subtract-in typed/racket/base type-expander) phc-adt
(except-in (subtract-in typed/racket/base
type-expander
subtemplate/override)
values) values)
(only-in racket/base values) (only-in racket/base values)
(subtract-in racket/contract typed/racket/base) (subtract-in racket/contract typed/racket/base)
@ -173,13 +175,13 @@ not expressed syntactically using the @racket[Foo] identifier.
(get-τ-cache) (get-τ-cache)
(get-τ-defs) (get-τ-defs)
#'(_whole-type _type-to-replaceᵢ …)] #'(_whole-type _type-to-replaceᵢ …)]
(define replacements (make-immutable-free-id-tree-table (define replacements
(map syntax-e (make-immutable-free-id-tree-table
(syntax->list (list [cons #'_type-to-replaceᵢ #'_Tᵢ] …)))
#'([_type-to-replaceᵢ . _Tᵢ] …)))))
#`(∀ (_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>
@ -216,31 +218,34 @@ not expressed syntactically using the @racket[Foo] identifier.
(syntax-parser (syntax-parser
[(_whole-type:type _type-to-replaceᵢ:type …) [(_whole-type:type _type-to-replaceᵢ:type …)
#:with rec-args #'([_type-to-replaceᵢ _predicateᵢ _updateᵢ] …) #:with rec-args #'([_type-to-replaceᵢ _predicateᵢ _updateᵢ] …)
(define replacements (make-immutable-free-id-tree-table (define replacements
(map syntax-e (make-immutable-free-id-tree-table
(syntax->list (list [cons #'_type-to-replaceᵢ #'_updateᵢ] …)))
#'([_type-to-replaceᵢ . _updateᵢ] …)))))
(define/with-syntax _args #'({?@ _predicateᵢ _updateᵢ} …)) (define/with-syntax _args #'({?@ _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ᵢ …)]
#`[(λ ({?@ _predicateᵢ _updateᵢ} …) #`[<fold-f-proc>
<fold-f-type>])]))]
@CHUNK[<fold-f-proc>
(λ ({?@ _predicateᵢ _updateᵢ} …)
(λ (v acc) (λ (v acc)
#,(syntax-parse #'_whole-type #,(syntax-parse #'_whole-type
#:literals (Null Pairof Listof List #:literals (Null Pairof Listof List
Vectorof Vector U tagged) Vectorof Vector U tagged)
<f-cases>))) <f-cases>)))]
@chunk[<fold-f-type>
(∀ (_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 _whole-type (→ (!replace-in-type _whole-type [_type-to-replaceᵢ _Aᵢ] …)
[_type-to-replaceᵢ _Aᵢ] …)
Acc Acc
(Values (!replace-in-type _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