commit cf23417f1fcdd94899eddc6e66c271999057db57
parent 3b33c3676a7577eb2a5238e3fe469c23fb6e69e3
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Fri, 4 Nov 2016 02:30:51 +0100
Partial rewrite of traversal.hl.rkt, ready to add the caching mechanism.
Diffstat:
7 files changed, 337 insertions(+), 70 deletions(-)
diff --git a/dispatch-union.rkt b/dispatch-union.rkt
@@ -23,7 +23,7 @@
(define-syntax-class to-replace
(pattern [t result]
#:with (_ predicate)
- (findf (λ (r) (free-identifier-tree=? #'t (stx-car r)))
+ (findf (λ (r) (free-id-tree=? #'t (stx-car r)))
(syntax->list
#'([type-to-replaceᵢ predicateᵢ] …)))
#:with clause #`[(predicate v) result]))
diff --git a/free-identifier-tree-equal.rkt b/free-identifier-tree-equal.rkt
@@ -2,10 +2,20 @@
(require racket/struct)
-(provide free-identifier-tree=?)
+(provide free-id-tree=?
+ free-id-tree-hash-code
+ free-id-tree-secondary-hash-code
+
+ free-id-tree-table?
+ 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-identifier-tree=? a b)
- (define rec=? free-identifier-tree=?)
+(define (free-id-tree=? a b)
+ (define rec=? free-id-tree=?)
(cond
[(identifier? a) (and (identifier? b)
(free-identifier=? a b))]
@@ -26,4 +36,30 @@
(let ([b-key (prefab-struct-key b)])
(and (equal? a-key b-key)
(rec=? (struct->list a)
- (struct->list b)))))]))
-\ No newline at end of file
+ (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)
diff --git a/info.rkt b/info.rkt
@@ -4,7 +4,7 @@
"rackunit-lib"
"https://github.com/jsmaniac/phc-toolkit.git#dev"
"https://github.com/jsmaniac/phc-adt.git?path=phc-adt#dev"
- "type-expander"
+ "https://github.com/jsmaniac/type-expander.git#Let-Λ"
"hyper-literate"
"scribble-enhanced"
"typed-racket-lib"
diff --git a/subtemplate.rkt b/subtemplate.rkt
@@ -57,19 +57,20 @@
(begin-for-syntax
(define/contract (wrap-with-parameterize lctx new-whole-form rest)
(-> identifier? syntax? syntax? syntax?)
- (patch-arrows
- (quasisyntax/top-loc lctx
- ;; HERE insert a hash table, to cache the uses of derived pvars.
- ;; Lifting the define-temp-ids is not likely to work, as they
- ;; need to define syntax pattern variables so that other macros
- ;; can recognize them. Instead, we only lift the values, but still
- ;; do the bindings around the subtemplate.
- (let ([the-pvar-values (cons (make-hash) pvar-values-id)])
- (syntax-parameterize ([maybe-syntax-pattern-variable-ids
- #,(new-scope rest lctx)]
- [pvar-values-id (make-rename-transformer
- #'the-pvar-values)])
- #,new-whole-form))))))
+ (quasisyntax/top-loc lctx
+ (let ()
+ #,(patch-arrows
+ ;; HERE insert a hash table, to cache the uses of derived pvars.
+ ;; Lifting the define-temp-ids is not likely to work, as they
+ ;; need to define syntax pattern variables so that other macros
+ ;; can recognize them. Instead, we only lift the values, but still
+ ;; do the bindings around the subtemplate.
+ #`(let ([the-pvar-values (cons (make-hash) pvar-values-id)])
+ (syntax-parameterize ([maybe-syntax-pattern-variable-ids
+ #,(new-scope rest lctx)]
+ [pvar-values-id (make-rename-transformer
+ #'the-pvar-values)])
+ #,new-whole-form)))))))
(begin-for-syntax
(define/contract (simple-wrap-with-parameterize new-form-id)
diff --git a/test/test-traversal-1.rkt b/test/test-traversal-1.rkt
@@ -1,4 +1,4 @@
-#lang typed/racket
+#lang type-expander
(require "../traversal.hl.rkt"
"ck.rkt")
diff --git a/test/test-traversal-2.rkt b/test/test-traversal-2.rkt
@@ -7,8 +7,6 @@
"../dispatch-union.rkt") ;; DEBUG
(adt-init)
-#;(define-type Foo (Listof 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])
diff --git a/traversal.hl.rkt b/traversal.hl.rkt
@@ -8,6 +8,8 @@
(for-label racket/format
racket/promise
racket/list
+ syntax/parse
+ syntax/parse/experimental/template
type-expander
(except-in (subtract-in typed/racket/base type-expander)
values)
@@ -86,10 +88,10 @@ not expressed syntactically using the @racket[Foo] identifier.
Acc))))]
We use the @racket[?@] notation from
- @racket[syntax/parse/experimental/template] to indicate that the function
- accepts a predicate, followed by an update function, followed by another
- predicate, and so on. For example, the function type when there are three
- @racket[type-to-replaceᵢ] would be:
+ @racketmodname[syntax/parse/experimental/template] to indicate that the
+ function accepts a predicate, followed by an update function, followed by
+ another predicate, and so on. For example, the function type when there are
+ three @racket[type-to-replaceᵢ] would be:
@racketblock[(∀ (A₁ A₂ A₃ B₁ B₂ B₃ Acc)
(→ (→ Any Boolean : A₁)
@@ -116,30 +118,256 @@ not expressed syntactically using the @racket[Foo] identifier.
calls to all update functions, so that the update functions can communicate
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
* 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.
+
+@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>
- (begin-for-syntax
- (define-syntax-rule (barr body)
- body))
(define-syntax define-fold
(syntax-parser
[(_ _function-name:id
_type-name:id
whole-type:type
- type-to-replaceᵢ:type …)
- <define-fold-prepare>
- ((λ (x)
- (local-require racket/pretty)
- #;(pretty-write (syntax->datum x))
- x)
- (subtemplate
- (begin
- <define-fold-result>)))]))]
+ _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>
+ ((λ (x)
+ (local-require racket/pretty)
+ #;(pretty-write (syntax->datum x))
+ x)
+ (subtemplate
+ (begin
+ <define-fold-result>)))]))]
@chunk[<define-fold-result>
the-defs …
@@ -158,7 +386,7 @@ way up, so that a simple identity function can be applied in these cases.
_the-code)]
@chunk[<define-fold-prepare>
- (define/with-syntax _args (subtemplate ({?@ predicateᵢ updateᵢ} …)))]
+ (define/with-syntax _args (subtemplate ({?@ _predicateᵢ _updateᵢ} …)))]
@chunk[<define-fold-prepare>
(type-cases
@@ -167,13 +395,13 @@ way up, so that a simple identity function can be applied in these cases.
#:using _the-code
#:with-defintitions the-defs …)
#:literals (Null Pairof Listof List Vectorof Vector U tagged)
- <type-cases>)]
+ <old-type-cases>)]
-@chunk[<type-cases>
+@chunk[<old-type-cases>
[t
#:with (_ update T)
- (findf (λ (r) (free-identifier-tree=? #'t (stx-car r)))
- (syntax->list (subtemplate ([type-to-replaceᵢ updateᵢ _Tᵢ] …))))
+ (findf (λ (r) (free-id-tree=? #'t (stx-car r)))
+ (syntax->list (subtemplate ([_type-to-replaceᵢ _updateᵢ _Tᵢ] …))))
#:to
T
@@ -181,7 +409,7 @@ way up, so that a simple identity function can be applied in these cases.
#:using
(update v acc)]]
-@chunk[<type-cases>
+@chunk[<old-type-cases>
[(~or Null (List))
#:to
@@ -190,7 +418,7 @@ way up, so that a simple identity function can be applied in these cases.
#:using
(values v acc)]]
-@chunk[<type-cases>
+@chunk[<old-type-cases>
[(Pairof X Y)
#: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))
#:with-defintitions
- (define-fold fx tx X type-to-replaceᵢ …)
- (define-fold fy ty Y type-to-replaceᵢ …)]]
+ (define-fold fx tx X _type-to-replaceᵢ …)
+ (define-fold fy ty Y _type-to-replaceᵢ …)]]
-@chunk[<type-cases>
+@chunk[<old-type-cases>
[(Listof X)
#: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)
#: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)
#: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))))
#: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 …)
#: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*))
#:with-defintitions
- (define-fold fx tx X type-to-replaceᵢ …)
- (define-fold fy* ty* (List Y …) type-to-replaceᵢ …)]]
+ (define-fold fx tx X _type-to-replaceᵢ …)
+ (define-fold fy* ty* (List Y …) _type-to-replaceᵢ …)]]
-@chunk[<type-cases>
+@chunk[<old-type-cases>
[(U _Xⱼ …)
#:to
@@ -254,14 +482,14 @@ way up, so that a simple identity function can be applied in these cases.
#:using
(dispatch-union v
- ([type-to-replaceᵢ Aᵢ predicateᵢ] …)
+ ([_type-to-replaceᵢ Aᵢ _predicateᵢ] …)
[_Xⱼ ((_fxⱼ . _args) v acc)] …)
#: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ⱼ] …)
#:to
@@ -275,10 +503,10 @@ way up, so that a simple identity function can be applied in these cases.
acc))
#: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
#:to
@@ -319,11 +547,11 @@ where @racket[foldl-map] is defined as:
…)
#'(define/with-syntax (the-type the-code the-defs (… …))
(sp #'whole-type
- #:literals (lit …)
- [pat opts …
- (subtemplate
- (transform-type transform-code transform-defs …))]
- …))]))]
+ #:literals (lit …)
+ [pat opts …
+ (subtemplate
+ (transform-type transform-code transform-defs …))]
+ …))]))]
@section{Putting it all together}
@@ -341,12 +569,17 @@ where @racket[foldl-map] is defined as:
(subtract-in syntax/parse "subtemplate.rkt")
syntax/parse/experimental/template
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 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>)
<foldl-map>
<define-fold>]
\ No newline at end of file
