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

Partial rewrite of traversal.hl.rkt, ready to add the caching mechanism.

Browse Source
This commit is contained in:
Georges Dupéron 2016-11-04 02:30:51 +01:00
parent 3b33c3676a
commit cf23417f1f
7 changed files with 337 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
dispatch-union.rkt
View File

@ -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]))

44
free-identifier-tree-equal.rkt
View File

@ -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
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 (free-id-tree=? a b)
(define rec=? free-identifier-tree=?) (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))]
@ -26,4 +36,30 @@
(let ([b-key (prefab-struct-key b)]) (let ([b-key (prefab-struct-key b)])
(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
View File

@ -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"

27
subtemplate.rkt
View File

@ -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 ()
;; HERE insert a hash table, to cache the uses of derived pvars. #,(patch-arrows
;; Lifting the define-temp-ids is not likely to work, as they ;; HERE insert a hash table, to cache the uses of derived pvars.
;; need to define syntax pattern variables so that other macros ;; Lifting the define-temp-ids is not likely to work, as they
;; can recognize them. Instead, we only lift the values, but still ;; need to define syntax pattern variables so that other macros
;; do the bindings around the subtemplate. ;; can recognize them. Instead, we only lift the values, but still
(let ([the-pvar-values (cons (make-hash) pvar-values-id)]) ;; do the bindings around the subtemplate.
(syntax-parameterize ([maybe-syntax-pattern-variable-ids #`(let ([the-pvar-values (cons (make-hash) pvar-values-id)])
#,(new-scope rest lctx)] (syntax-parameterize ([maybe-syntax-pattern-variable-ids
[pvar-values-id (make-rename-transformer #,(new-scope rest lctx)]
#'the-pvar-values)]) [pvar-values-id (make-rename-transformer
#,new-whole-form)))))) #'the-pvar-values)])
#,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)

2
test/test-traversal-1.rkt
View File

@ -1,4 +1,4 @@
#lang typed/racket #lang type-expander
(require "../traversal.hl.rkt" (require "../traversal.hl.rkt"
"ck.rkt") "ck.rkt")

2
test/test-traversal-2.rkt
View File

@ -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])

327
traversal.hl.rkt
View File

@ -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,30 +118,256 @@ 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 …)
<define-fold-prepare> #'(begin
((λ (x) (define-type _type-name
(local-require racket/pretty) (fold-type whole-type _type-to-replaceᵢ …))
#;(pretty-write (syntax->datum x)) (define _function-name
x) (fold-f whole-type _type-to-replaceᵢ …)))]))
(subtemplate #;(define-syntax define-fold
(begin (syntax-parser
<define-fold-result>)))]))] [(_ _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> @chunk[<define-fold-result>
the-defs … the-defs …
@ -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
@ -319,11 +547,11 @@ where @racket[foldl-map] is defined as:
…) …)
#'(define/with-syntax (the-type the-code the-defs (… …)) #'(define/with-syntax (the-type the-code the-defs (… …))
(sp #'whole-type (sp #'whole-type
#:literals (lit …) #:literals (lit …)
[pat opts … [pat opts …
(subtemplate (subtemplate
(transform-type transform-code transform-defs …))] (transform-type transform-code transform-defs …))]
…))]))] …))]))]
@section{Putting it all together} @section{Putting it all together}
@ -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>]