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

61
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>
(λ (v acc) <fold-f-type>])]))]
#,(syntax-parse #'_whole-type
#:literals (Null Pairof Listof List @CHUNK[<fold-f-proc>
Vectorof Vector U tagged) (λ ({?@ _predicateᵢ _updateᵢ} …)
<f-cases>))) (λ (v acc)
(∀ (_Aᵢ … _Bᵢ … Acc) #,(syntax-parse #'_whole-type
(→ (?@ (→ Any Boolean : _Aᵢ) #:literals (Null Pairof Listof List
(→ _Aᵢ Acc (Values _Bᵢ Acc))) Vectorof Vector U tagged)
… <f-cases>)))]
(→ (!replace-in-type _whole-type
[_type-to-replaceᵢ _Aᵢ] …) @chunk[<fold-f-type>
Acc (∀ (_Aᵢ … _Bᵢ … Acc)
(Values (!replace-in-type _whole-type (→ (?@ (→ Any Boolean : _Aᵢ)
[_type-to-replaceᵢ _Bᵢ] …) (→ _Aᵢ Acc (Values _Bᵢ Acc)))
Acc))))])]))] …
(→ (!replace-in-type _whole-type [_type-to-replaceᵢ _Aᵢ] …)
Acc
(Values (!replace-in-type _whole-type [_type-to-replaceᵢ _Bᵢ] …)
Acc))))]
@chunk[<f-cases> @chunk[<f-cases>
[t [t