Partial rewrite of traversal.hl.rkt, ready to add the caching mechanism.
This commit is contained in:
parent
3b33c3676a
commit
cf23417f1f
|
@ -23,7 +23,7 @@
|
||||||
(define-syntax-class to-replace
|
(define-syntax-class to-replace
|
||||||
(pattern [t result]
|
(pattern [t result]
|
||||||
#:with (_ predicate)
|
#:with (_ predicate)
|
||||||
(findf (λ (r) (free-identifier-tree=? #'t (stx-car r)))
|
(findf (λ (r) (free-id-tree=? #'t (stx-car r)))
|
||||||
(syntax->list
|
(syntax->list
|
||||||
#'([type-to-replaceᵢ predicateᵢ] …)))
|
#'([type-to-replaceᵢ predicateᵢ] …)))
|
||||||
#:with clause #`[(predicate v) result]))
|
#:with clause #`[(predicate v) result]))
|
||||||
|
|
|
@ -2,10 +2,20 @@
|
||||||
|
|
||||||
(require racket/struct)
|
(require racket/struct)
|
||||||
|
|
||||||
(provide free-identifier-tree=?)
|
(provide free-id-tree=?
|
||||||
|
free-id-tree-hash-code
|
||||||
|
free-id-tree-secondary-hash-code
|
||||||
|
|
||||||
(define (free-identifier-tree=? a b)
|
free-id-tree-table?
|
||||||
(define rec=? free-identifier-tree=?)
|
immutable-free-id-tree-table?
|
||||||
|
mutable-free-id-tree-table?
|
||||||
|
weak-free-id-tree-table?
|
||||||
|
make-immutable-free-id-tree-table
|
||||||
|
make-mutable-free-id-tree-table
|
||||||
|
make-weak-free-id-tree-table)
|
||||||
|
|
||||||
|
(define (free-id-tree=? a b)
|
||||||
|
(define rec=? free-id-tree=?)
|
||||||
(cond
|
(cond
|
||||||
[(identifier? a) (and (identifier? b)
|
[(identifier? a) (and (identifier? b)
|
||||||
(free-identifier=? a b))]
|
(free-identifier=? a b))]
|
||||||
|
@ -27,3 +37,29 @@
|
||||||
(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)))))]))
|
||||||
|
|
||||||
|
(define ((free-id-tree-hash hc) a)
|
||||||
|
(define rec-hash (free-id-tree-hash hc))
|
||||||
|
(cond
|
||||||
|
[(identifier? a) (hc (syntax-e #'a))]
|
||||||
|
[(syntax? a) (rec-hash (syntax-e a))]
|
||||||
|
[(pair? a) (hc (cons (rec-hash (car a))
|
||||||
|
(rec-hash (cdr a))))]
|
||||||
|
[(vector? a) (hc (list->vector (rec-hash (vector->list a))))]
|
||||||
|
[(box? a) (hc (box (rec-hash (unbox a))))]
|
||||||
|
[(prefab-struct-key a)
|
||||||
|
=> (λ (a-key)
|
||||||
|
(hc (apply make-prefab-struct a-key
|
||||||
|
(rec-hash (struct->list a)))))]
|
||||||
|
[else (hc a)]))
|
||||||
|
|
||||||
|
(define free-id-tree-hash-code
|
||||||
|
(free-id-tree-hash equal-hash-code))
|
||||||
|
(define free-id-tree-secondary-hash-code
|
||||||
|
(free-id-tree-hash equal-secondary-hash-code))
|
||||||
|
|
||||||
|
(define-custom-hash-types free-id-tree-table
|
||||||
|
#:key? syntax?
|
||||||
|
free-id-tree=?
|
||||||
|
free-id-tree-hash-code
|
||||||
|
free-id-tree-secondary-hash-code)
|
||||||
|
|
2
info.rkt
2
info.rkt
|
@ -4,7 +4,7 @@
|
||||||
"rackunit-lib"
|
"rackunit-lib"
|
||||||
"https://github.com/jsmaniac/phc-toolkit.git#dev"
|
"https://github.com/jsmaniac/phc-toolkit.git#dev"
|
||||||
"https://github.com/jsmaniac/phc-adt.git?path=phc-adt#dev"
|
"https://github.com/jsmaniac/phc-adt.git?path=phc-adt#dev"
|
||||||
"type-expander"
|
"https://github.com/jsmaniac/type-expander.git#Let-Λ"
|
||||||
"hyper-literate"
|
"hyper-literate"
|
||||||
"scribble-enhanced"
|
"scribble-enhanced"
|
||||||
"typed-racket-lib"
|
"typed-racket-lib"
|
||||||
|
|
|
@ -57,19 +57,20 @@
|
||||||
(begin-for-syntax
|
(begin-for-syntax
|
||||||
(define/contract (wrap-with-parameterize lctx new-whole-form rest)
|
(define/contract (wrap-with-parameterize lctx new-whole-form rest)
|
||||||
(-> identifier? syntax? syntax? syntax?)
|
(-> identifier? syntax? syntax? syntax?)
|
||||||
(patch-arrows
|
|
||||||
(quasisyntax/top-loc lctx
|
(quasisyntax/top-loc lctx
|
||||||
|
(let ()
|
||||||
|
#,(patch-arrows
|
||||||
;; HERE insert a hash table, to cache the uses of derived pvars.
|
;; HERE insert a hash table, to cache the uses of derived pvars.
|
||||||
;; Lifting the define-temp-ids is not likely to work, as they
|
;; Lifting the define-temp-ids is not likely to work, as they
|
||||||
;; need to define syntax pattern variables so that other macros
|
;; need to define syntax pattern variables so that other macros
|
||||||
;; can recognize them. Instead, we only lift the values, but still
|
;; can recognize them. Instead, we only lift the values, but still
|
||||||
;; do the bindings around the subtemplate.
|
;; do the bindings around the subtemplate.
|
||||||
(let ([the-pvar-values (cons (make-hash) pvar-values-id)])
|
#`(let ([the-pvar-values (cons (make-hash) pvar-values-id)])
|
||||||
(syntax-parameterize ([maybe-syntax-pattern-variable-ids
|
(syntax-parameterize ([maybe-syntax-pattern-variable-ids
|
||||||
#,(new-scope rest lctx)]
|
#,(new-scope rest lctx)]
|
||||||
[pvar-values-id (make-rename-transformer
|
[pvar-values-id (make-rename-transformer
|
||||||
#'the-pvar-values)])
|
#'the-pvar-values)])
|
||||||
#,new-whole-form))))))
|
#,new-whole-form)))))))
|
||||||
|
|
||||||
(begin-for-syntax
|
(begin-for-syntax
|
||||||
(define/contract (simple-wrap-with-parameterize new-form-id)
|
(define/contract (simple-wrap-with-parameterize new-form-id)
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
#lang typed/racket
|
#lang type-expander
|
||||||
|
|
||||||
(require "../traversal.hl.rkt"
|
(require "../traversal.hl.rkt"
|
||||||
"ck.rkt")
|
"ck.rkt")
|
||||||
|
|
|
@ -7,8 +7,6 @@
|
||||||
"../dispatch-union.rkt") ;; DEBUG
|
"../dispatch-union.rkt") ;; DEBUG
|
||||||
(adt-init)
|
(adt-init)
|
||||||
|
|
||||||
#;(define-type Foo (Listof String))
|
|
||||||
|
|
||||||
(define-fold f₁ t₁ (tagged tg [a String] [b Boolean]) String)
|
(define-fold f₁ t₁ (tagged tg [a String] [b Boolean]) String)
|
||||||
(define-fold f₂ t₂ (U (tagged tg [a String] [b Boolean])) String)
|
(define-fold f₂ t₂ (U (tagged tg [a String] [b Boolean])) String)
|
||||||
(define-fold f₃ t₃ (U (tagged tg [a String] [b Boolean])
|
(define-fold f₃ t₃ (U (tagged tg [a String] [b Boolean])
|
||||||
|
|
301
traversal.hl.rkt
301
traversal.hl.rkt
|
@ -8,6 +8,8 @@
|
||||||
(for-label racket/format
|
(for-label racket/format
|
||||||
racket/promise
|
racket/promise
|
||||||
racket/list
|
racket/list
|
||||||
|
syntax/parse
|
||||||
|
syntax/parse/experimental/template
|
||||||
type-expander
|
type-expander
|
||||||
(except-in (subtract-in typed/racket/base type-expander)
|
(except-in (subtract-in typed/racket/base type-expander)
|
||||||
values)
|
values)
|
||||||
|
@ -86,10 +88,10 @@ not expressed syntactically using the @racket[Foo] identifier.
|
||||||
Acc))))]
|
Acc))))]
|
||||||
|
|
||||||
We use the @racket[?@] notation from
|
We use the @racket[?@] notation from
|
||||||
@racket[syntax/parse/experimental/template] to indicate that the function
|
@racketmodname[syntax/parse/experimental/template] to indicate that the
|
||||||
accepts a predicate, followed by an update function, followed by another
|
function accepts a predicate, followed by an update function, followed by
|
||||||
predicate, and so on. For example, the function type when there are three
|
another predicate, and so on. For example, the function type when there are
|
||||||
@racket[type-to-replaceᵢ] would be:
|
three @racket[type-to-replaceᵢ] would be:
|
||||||
|
|
||||||
@racketblock[(∀ (A₁ A₂ A₃ B₁ B₂ B₃ Acc)
|
@racketblock[(∀ (A₁ A₂ A₃ B₁ B₂ B₃ Acc)
|
||||||
(→ (→ Any Boolean : A₁)
|
(→ (→ Any Boolean : A₁)
|
||||||
|
@ -116,22 +118,248 @@ not expressed syntactically using the @racket[Foo] identifier.
|
||||||
calls to all update functions, so that the update functions can communicate
|
calls to all update functions, so that the update functions can communicate
|
||||||
state in a functional way.}
|
state in a functional way.}
|
||||||
|
|
||||||
|
@section{Implementation}
|
||||||
|
|
||||||
* free-identifier-tree=?
|
@subsection{Caching the results of @racket[define-fold]}
|
||||||
|
|
||||||
|
@chunk[<with-folds>
|
||||||
|
(define-for-syntax get-with-folds-cache (make-parameter #f))
|
||||||
|
(define-syntax (with-folds stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(_ . body*)
|
||||||
|
(parameterize ([get-with-folds-cache (mutable-hash)])
|
||||||
|
(define expanded-body (local-expand #'(begin . body*)
|
||||||
|
(syntax-local-context)
|
||||||
|
'()))
|
||||||
|
(define/with-syntax (cached-definition …)
|
||||||
|
(append-map (λ (key cached)
|
||||||
|
(with-syntax ([(f-id τ-id f-body τ-body) def-ids])
|
||||||
|
(list #'(define-type τ-id τ-body)
|
||||||
|
#'(define f-id f-body))))
|
||||||
|
(hash->list (get-with-folds-cache))))
|
||||||
|
#`(begin cached-definition …
|
||||||
|
expanded-body))]))]
|
||||||
|
|
||||||
|
@;@subsection{…}
|
||||||
|
|
||||||
|
|
||||||
|
* free-id-tree=?
|
||||||
* cache of already-seen types
|
* cache of already-seen types
|
||||||
* recursively go down the tree. If there are no replacements, return #f all the
|
* recursively go down the tree. If there are no replacements, return #f all the
|
||||||
way up, so that a simple identity function can be applied in these cases.
|
way up, so that a simple identity function can be applied in these cases.
|
||||||
|
|
||||||
|
|
||||||
|
@CHUNK[<define-fold>
|
||||||
|
(define-type-expander (replace-in-type stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(_ _whole-type [_type-to-replaceᵢ _Tᵢ] …)
|
||||||
|
;+ cache
|
||||||
|
#'((fold-type _whole-type _type-to-replaceᵢ …) _Tᵢ …)]))
|
||||||
|
(define-type-expander fold-type
|
||||||
|
(syntax-parser
|
||||||
|
[(_ _whole-type:type _type-to-replaceᵢ:type …)
|
||||||
|
#:with rec-args (subtemplate
|
||||||
|
([_type-to-replaceᵢ _Tᵢ] …))
|
||||||
|
(define replacements (make-immutable-free-id-tree-table
|
||||||
|
(map syntax-e
|
||||||
|
(syntax->list
|
||||||
|
(subtemplate
|
||||||
|
([_type-to-replaceᵢ . _Tᵢ] …))))))
|
||||||
|
#;(define-template-metafunction (rec-replace stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(_ τ) #'(replace-in-type τ . rec-args)]))
|
||||||
|
((λ (x) (displayln "τ=") (pretty-write (syntax->datum x)) x)
|
||||||
|
(quasisubtemplate
|
||||||
|
(∀ (_Tᵢ …)
|
||||||
|
#,(syntax-parse #'_whole-type
|
||||||
|
#:literals (Null Pairof Listof List Vectorof Vector U tagged)
|
||||||
|
<type-cases>))))]))]
|
||||||
|
|
||||||
|
@CHUNK[<define-fold>
|
||||||
|
(define-syntax (replace-in-instance stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(_ _whole-type
|
||||||
|
[_type-to-replaceᵢ _predicateᵢ _updateᵢ] …)
|
||||||
|
;+ cache
|
||||||
|
(subtemplate
|
||||||
|
((fold-f _whole-type _type-to-replaceᵢ …)
|
||||||
|
{?@ _predicateᵢ _updateᵢ} …))]))
|
||||||
|
|
||||||
|
(define-syntax fold-f
|
||||||
|
(syntax-parser
|
||||||
|
[(_ _whole-type:type _type-to-replaceᵢ:type …)
|
||||||
|
#:with rec-args (subtemplate
|
||||||
|
([_type-to-replaceᵢ _predicateᵢ _updateᵢ] …))
|
||||||
|
(define replacements (make-immutable-free-id-tree-table
|
||||||
|
(map syntax-e
|
||||||
|
(syntax->list
|
||||||
|
(subtemplate
|
||||||
|
([_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ᵢ} …)))
|
||||||
|
((λ (x) (displayln "f=") (pretty-write (syntax->datum x)) x)
|
||||||
|
(quasisubtemplate
|
||||||
|
(ann (λ ({?@ _predicateᵢ _updateᵢ} …)
|
||||||
|
(λ (v acc)
|
||||||
|
#,(syntax-parse #'_whole-type
|
||||||
|
#:literals (Null Pairof Listof List Vectorof Vector U tagged)
|
||||||
|
<f-cases>)))
|
||||||
|
(∀ (_Aᵢ … _Bᵢ … Acc)
|
||||||
|
(→ (?@ (→ Any Boolean : _Aᵢ)
|
||||||
|
(→ _Aᵢ Acc (Values _Bᵢ 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>
|
||||||
|
[t
|
||||||
|
#:when (dict-has-key? replacements #'t)
|
||||||
|
#:with _update (dict-ref replacements #'t)
|
||||||
|
(subtemplate (_update v acc))]]
|
||||||
|
|
||||||
|
@chunk[<type-cases>
|
||||||
|
[t
|
||||||
|
#:when (dict-has-key? replacements #'t)
|
||||||
|
#:with _T (dict-ref replacements #'t)
|
||||||
|
(subtemplate _T)]]
|
||||||
|
|
||||||
|
@chunk[<type-cases>
|
||||||
|
[(~or Null (List))
|
||||||
|
(subtemplate Null)]]
|
||||||
|
|
||||||
|
@chunk[<f-cases>
|
||||||
|
[(~or Null (List))
|
||||||
|
(subtemplate (values v acc))]]
|
||||||
|
|
||||||
|
|
||||||
|
@chunk[<type-cases>
|
||||||
|
[(Pairof X Y)
|
||||||
|
(subtemplate (Pairof (replace-in-type X . rec-args)
|
||||||
|
(replace-in-type Y . rec-args)))]]
|
||||||
|
|
||||||
|
@chunk[<f-cases>
|
||||||
|
[(Pairof X Y)
|
||||||
|
(subtemplate
|
||||||
|
(let*-values ([(result-x acc-x)
|
||||||
|
((replace-in-instance X . rec-args) (car v) acc)]
|
||||||
|
[(result-y acc-y)
|
||||||
|
((replace-in-instance Y . rec-args) (cdr v) acc-x)])
|
||||||
|
(values (cons result-x result-y) acc-y)))]]
|
||||||
|
|
||||||
|
@chunk[<type-cases>
|
||||||
|
[(Listof X)
|
||||||
|
(subtemplate
|
||||||
|
(Listof (replace-in-type X . rec-args)))]]
|
||||||
|
|
||||||
|
@chunk[<f-cases>
|
||||||
|
[(Listof X)
|
||||||
|
(subtemplate
|
||||||
|
(foldl-map (replace-in-instance X . rec-args)
|
||||||
|
acc v))]]
|
||||||
|
|
||||||
|
@chunk[<type-cases>
|
||||||
|
[(Vectorof X)
|
||||||
|
(subtemplate
|
||||||
|
;; TODO: turn replace-in-type & co into rec-replace via metafunctions
|
||||||
|
(Vectorof (replace-in-type X . rec-args)))]]
|
||||||
|
|
||||||
|
@chunk[<ftype-cases>
|
||||||
|
[(Vectorof X)
|
||||||
|
(subtemplate
|
||||||
|
(vector->immutable-vector
|
||||||
|
(list->vector
|
||||||
|
(foldl-map (replace-in-instance X . rec-args) acc (vector->list v)))))]]
|
||||||
|
|
||||||
|
|
||||||
|
@chunk[<type-cases>
|
||||||
|
[(List X Y …)
|
||||||
|
(subtemplate
|
||||||
|
(Pairof (replace-in-type X . rec-args)
|
||||||
|
(replace-in-type (List Y …) . rec-args)))]]
|
||||||
|
|
||||||
|
@chunk[<f-cases>
|
||||||
|
[(List X Y …)
|
||||||
|
(subtemplate
|
||||||
|
(let*-values ([(result-x acc-x) ((replace-in-instance X . rec-args)
|
||||||
|
(car v)
|
||||||
|
acc)]
|
||||||
|
[(result-y* acc-y*) ((replace-in-instance (List Y …) . rec-args)
|
||||||
|
(cdr v)
|
||||||
|
acc-x)])
|
||||||
|
(values (cons result-x result-y*) acc-y*)))]]
|
||||||
|
|
||||||
|
@chunk[<type-cases>
|
||||||
|
[(U _Xⱼ …)
|
||||||
|
(subtemplate
|
||||||
|
(U (replace-in-type _Xⱼ . rec-args) …))]]
|
||||||
|
|
||||||
|
@chunk[<f-cases>
|
||||||
|
[(U _Xⱼ …)
|
||||||
|
(subtemplate
|
||||||
|
(dispatch-union v
|
||||||
|
([_type-to-replaceᵢ Aᵢ _predicateᵢ] …)
|
||||||
|
[_Xⱼ ((replace-in-instance _Xⱼ . rec-args) v acc)] …))]]
|
||||||
|
|
||||||
|
@chunk[<type-cases>
|
||||||
|
[(tagged _name [_fieldⱼ (~optional :colon) _Xⱼ] …)
|
||||||
|
(subtemplate
|
||||||
|
(tagged _name [_fieldⱼ : (replace-in-type _Xⱼ . rec-args)] …))]]
|
||||||
|
|
||||||
|
@chunk[<f-cases>
|
||||||
|
[(tagged _name [_fieldⱼ (~optional :colon) _Xⱼ] …)
|
||||||
|
(subtemplate
|
||||||
|
(let*-values ([(_resultⱼ acc)
|
||||||
|
((replace-in-instance _Xⱼ . rec-args) (uniform-get v _fieldⱼ)
|
||||||
|
acc)]
|
||||||
|
…)
|
||||||
|
(values (tagged _name #:instance [_fieldⱼ _resultⱼ] …)
|
||||||
|
acc)))]]
|
||||||
|
|
||||||
|
@chunk[<type-cases>
|
||||||
|
[else-T
|
||||||
|
(subtemplate
|
||||||
|
else-T)]]
|
||||||
|
|
||||||
|
@chunk[<f-cases>
|
||||||
|
[else-T
|
||||||
|
(subtemplate
|
||||||
|
(values v acc))]]
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
------
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@chunk[<define-fold>
|
@chunk[<define-fold>
|
||||||
(begin-for-syntax
|
|
||||||
(define-syntax-rule (barr body)
|
|
||||||
body))
|
|
||||||
(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 …)
|
||||||
|
#'(begin
|
||||||
|
(define-type _type-name
|
||||||
|
(fold-type whole-type _type-to-replaceᵢ …))
|
||||||
|
(define _function-name
|
||||||
|
(fold-f whole-type _type-to-replaceᵢ …)))]))
|
||||||
|
#;(define-syntax define-fold
|
||||||
|
(syntax-parser
|
||||||
|
[(_ _function-name:id
|
||||||
|
_type-name:id
|
||||||
|
whole-type:type
|
||||||
|
_type-to-replaceᵢ:type …)
|
||||||
<define-fold-prepare>
|
<define-fold-prepare>
|
||||||
((λ (x)
|
((λ (x)
|
||||||
(local-require racket/pretty)
|
(local-require racket/pretty)
|
||||||
|
@ -158,7 +386,7 @@ way up, so that a simple identity function can be applied in these cases.
|
||||||
_the-code)]
|
_the-code)]
|
||||||
|
|
||||||
@chunk[<define-fold-prepare>
|
@chunk[<define-fold-prepare>
|
||||||
(define/with-syntax _args (subtemplate ({?@ predicateᵢ updateᵢ} …)))]
|
(define/with-syntax _args (subtemplate ({?@ _predicateᵢ _updateᵢ} …)))]
|
||||||
|
|
||||||
@chunk[<define-fold-prepare>
|
@chunk[<define-fold-prepare>
|
||||||
(type-cases
|
(type-cases
|
||||||
|
@ -167,13 +395,13 @@ way up, so that a simple identity function can be applied in these cases.
|
||||||
#:using _the-code
|
#:using _the-code
|
||||||
#:with-defintitions the-defs …)
|
#:with-defintitions the-defs …)
|
||||||
#:literals (Null Pairof Listof List Vectorof Vector U tagged)
|
#:literals (Null Pairof Listof List Vectorof Vector U tagged)
|
||||||
<type-cases>)]
|
<old-type-cases>)]
|
||||||
|
|
||||||
@chunk[<type-cases>
|
@chunk[<old-type-cases>
|
||||||
[t
|
[t
|
||||||
#:with (_ update T)
|
#:with (_ update T)
|
||||||
(findf (λ (r) (free-identifier-tree=? #'t (stx-car r)))
|
(findf (λ (r) (free-id-tree=? #'t (stx-car r)))
|
||||||
(syntax->list (subtemplate ([type-to-replaceᵢ updateᵢ _Tᵢ] …))))
|
(syntax->list (subtemplate ([_type-to-replaceᵢ _updateᵢ _Tᵢ] …))))
|
||||||
|
|
||||||
#:to
|
#:to
|
||||||
T
|
T
|
||||||
|
@ -181,7 +409,7 @@ way up, so that a simple identity function can be applied in these cases.
|
||||||
#:using
|
#:using
|
||||||
(update v acc)]]
|
(update v acc)]]
|
||||||
|
|
||||||
@chunk[<type-cases>
|
@chunk[<old-type-cases>
|
||||||
[(~or Null (List))
|
[(~or Null (List))
|
||||||
|
|
||||||
#:to
|
#:to
|
||||||
|
@ -190,7 +418,7 @@ way up, so that a simple identity function can be applied in these cases.
|
||||||
#:using
|
#:using
|
||||||
(values v acc)]]
|
(values v acc)]]
|
||||||
|
|
||||||
@chunk[<type-cases>
|
@chunk[<old-type-cases>
|
||||||
[(Pairof X Y)
|
[(Pairof X Y)
|
||||||
|
|
||||||
#:to
|
#:to
|
||||||
|
@ -202,10 +430,10 @@ way up, so that a simple identity function can be applied in these cases.
|
||||||
(values (cons result-x result-y) acc-y))
|
(values (cons result-x result-y) acc-y))
|
||||||
|
|
||||||
#:with-defintitions
|
#:with-defintitions
|
||||||
(define-fold fx tx X type-to-replaceᵢ …)
|
(define-fold fx tx X _type-to-replaceᵢ …)
|
||||||
(define-fold fy ty Y type-to-replaceᵢ …)]]
|
(define-fold fy ty Y _type-to-replaceᵢ …)]]
|
||||||
|
|
||||||
@chunk[<type-cases>
|
@chunk[<old-type-cases>
|
||||||
[(Listof X)
|
[(Listof X)
|
||||||
|
|
||||||
#:to
|
#:to
|
||||||
|
@ -215,9 +443,9 @@ way up, so that a simple identity function can be applied in these cases.
|
||||||
(foldl-map (fe . _args) acc v)
|
(foldl-map (fe . _args) acc v)
|
||||||
|
|
||||||
#:with-defintitions
|
#:with-defintitions
|
||||||
(define-fold fe te X type-to-replaceᵢ …)]]
|
(define-fold fe te X _type-to-replaceᵢ …)]]
|
||||||
|
|
||||||
@chunk[<type-cases>
|
@chunk[<old-type-cases>
|
||||||
[(Vectorof X)
|
[(Vectorof X)
|
||||||
|
|
||||||
#:to
|
#:to
|
||||||
|
@ -229,9 +457,9 @@ way up, so that a simple identity function can be applied in these cases.
|
||||||
(foldl-map (fe . _args) acc (vector->list v))))
|
(foldl-map (fe . _args) acc (vector->list v))))
|
||||||
|
|
||||||
#:with-defintitions
|
#:with-defintitions
|
||||||
(define-fold fe te X type-to-replaceᵢ …)]]
|
(define-fold fe te X _type-to-replaceᵢ …)]]
|
||||||
|
|
||||||
@chunk[<type-cases>
|
@chunk[<old-type-cases>
|
||||||
[(List X Y …)
|
[(List X Y …)
|
||||||
|
|
||||||
#:to
|
#:to
|
||||||
|
@ -243,10 +471,10 @@ way up, so that a simple identity function can be applied in these cases.
|
||||||
(values (cons result-x result-y*) acc-y*))
|
(values (cons result-x result-y*) acc-y*))
|
||||||
|
|
||||||
#:with-defintitions
|
#:with-defintitions
|
||||||
(define-fold fx tx X type-to-replaceᵢ …)
|
(define-fold fx tx X _type-to-replaceᵢ …)
|
||||||
(define-fold fy* ty* (List Y …) type-to-replaceᵢ …)]]
|
(define-fold fy* ty* (List Y …) _type-to-replaceᵢ …)]]
|
||||||
|
|
||||||
@chunk[<type-cases>
|
@chunk[<old-type-cases>
|
||||||
[(U _Xⱼ …)
|
[(U _Xⱼ …)
|
||||||
|
|
||||||
#:to
|
#:to
|
||||||
|
@ -254,14 +482,14 @@ way up, so that a simple identity function can be applied in these cases.
|
||||||
|
|
||||||
#:using
|
#:using
|
||||||
(dispatch-union v
|
(dispatch-union v
|
||||||
([type-to-replaceᵢ Aᵢ predicateᵢ] …)
|
([_type-to-replaceᵢ Aᵢ _predicateᵢ] …)
|
||||||
[_Xⱼ ((_fxⱼ . _args) v acc)] …)
|
[_Xⱼ ((_fxⱼ . _args) v acc)] …)
|
||||||
|
|
||||||
#:with-defintitions
|
#:with-defintitions
|
||||||
(define-fold _fxⱼ _txⱼ _Xⱼ type-to-replaceᵢ …)
|
(define-fold _fxⱼ _txⱼ _Xⱼ _type-to-replaceᵢ …)
|
||||||
…]]
|
…]]
|
||||||
|
|
||||||
@chunk[<type-cases>
|
@chunk[<old-type-cases>
|
||||||
[(tagged _name [_fieldⱼ (~optional :colon) _Xⱼ] …)
|
[(tagged _name [_fieldⱼ (~optional :colon) _Xⱼ] …)
|
||||||
|
|
||||||
#:to
|
#:to
|
||||||
|
@ -275,10 +503,10 @@ way up, so that a simple identity function can be applied in these cases.
|
||||||
acc))
|
acc))
|
||||||
|
|
||||||
#:with-defintitions
|
#:with-defintitions
|
||||||
(define-fold _fxⱼ _txⱼ _Xⱼ type-to-replaceᵢ …)
|
(define-fold _fxⱼ _txⱼ _Xⱼ _type-to-replaceᵢ …)
|
||||||
…]]
|
…]]
|
||||||
|
|
||||||
@chunk[<type-cases>
|
@chunk[<old-type-cases>
|
||||||
[else-T
|
[else-T
|
||||||
|
|
||||||
#:to
|
#:to
|
||||||
|
@ -341,12 +569,17 @@ where @racket[foldl-map] is defined as:
|
||||||
(subtract-in syntax/parse "subtemplate.rkt")
|
(subtract-in syntax/parse "subtemplate.rkt")
|
||||||
syntax/parse/experimental/template
|
syntax/parse/experimental/template
|
||||||
type-expander/expander
|
type-expander/expander
|
||||||
"free-identifier-tree-equal.rkt")
|
"free-identifier-tree-equal.rkt"
|
||||||
|
racket/dict
|
||||||
|
racket/pretty)
|
||||||
(for-meta 2 racket/base)
|
(for-meta 2 racket/base)
|
||||||
(for-meta 2 phc-toolkit/untyped)
|
(for-meta 2 phc-toolkit/untyped)
|
||||||
(for-meta 2 syntax/parse))
|
(for-meta 2 syntax/parse)
|
||||||
|
racket/pretty)
|
||||||
|
|
||||||
(provide define-fold)
|
(provide define-fold
|
||||||
|
replace-in-instance
|
||||||
|
replace-in-type)
|
||||||
(begin-for-syntax <type-cases-macro>)
|
(begin-for-syntax <type-cases-macro>)
|
||||||
<foldl-map>
|
<foldl-map>
|
||||||
<define-fold>]
|
<define-fold>]
|
Loading…
Reference in New Issue
Block a user