From cf23417f1fcdd94899eddc6e66c271999057db57 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Fri, 4 Nov 2016 02:30:51 +0100 Subject: [PATCH] Partial rewrite of traversal.hl.rkt, ready to add the caching mechanism. --- dispatch-union.rkt | 2 +- free-identifier-tree-equal.rkt | 44 ++++- info.rkt | 2 +- subtemplate.rkt | 27 +-- test/test-traversal-1.rkt | 2 +- test/test-traversal-2.rkt | 2 - traversal.hl.rkt | 327 ++++++++++++++++++++++++++++----- 7 files changed, 337 insertions(+), 69 deletions(-) diff --git a/dispatch-union.rkt b/dispatch-union.rkt index 9f2758a..371cc75 100644 --- 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 index b9a16ee..9268f97 100644 --- 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 index b7770f2..a4c7058 100644 --- 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 index 915ec00..eba46dc 100644 --- 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 index 448f8ca..46f7d6b 100644 --- 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 index c8ee6f0..f9d921d 100644 --- 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 index aab9c69..205f0d1 100644 --- 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[ + (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-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) + ))))]))] + +@CHUNK[ + (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) + ))) + (∀ (_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[ + [t + #:when (dict-has-key? replacements #'t) + #:with _update (dict-ref replacements #'t) + (subtemplate (_update v acc))]] + +@chunk[ + [t + #:when (dict-has-key? replacements #'t) + #:with _T (dict-ref replacements #'t) + (subtemplate _T)]] + +@chunk[ + [(~or Null (List)) + (subtemplate Null)]] + +@chunk[ + [(~or Null (List)) + (subtemplate (values v acc))]] + + +@chunk[ + [(Pairof X Y) + (subtemplate (Pairof (replace-in-type X . rec-args) + (replace-in-type Y . rec-args)))]] + +@chunk[ + [(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[ + [(Listof X) + (subtemplate + (Listof (replace-in-type X . rec-args)))]] + +@chunk[ + [(Listof X) + (subtemplate + (foldl-map (replace-in-instance X . rec-args) + acc v))]] + +@chunk[ + [(Vectorof X) + (subtemplate + ;; TODO: turn replace-in-type & co into rec-replace via metafunctions + (Vectorof (replace-in-type X . rec-args)))]] + +@chunk[ + [(Vectorof X) + (subtemplate + (vector->immutable-vector + (list->vector + (foldl-map (replace-in-instance X . rec-args) acc (vector->list v)))))]] + + +@chunk[ + [(List X Y …) + (subtemplate + (Pairof (replace-in-type X . rec-args) + (replace-in-type (List Y …) . rec-args)))]] + +@chunk[ + [(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[ + [(U _Xⱼ …) + (subtemplate + (U (replace-in-type _Xⱼ . rec-args) …))]] + +@chunk[ + [(U _Xⱼ …) + (subtemplate + (dispatch-union v + ([_type-to-replaceᵢ Aᵢ _predicateᵢ] …) + [_Xⱼ ((replace-in-instance _Xⱼ . rec-args) v acc)] …))]] + +@chunk[ + [(tagged _name [_fieldⱼ (~optional :colon) _Xⱼ] …) + (subtemplate + (tagged _name [_fieldⱼ : (replace-in-type _Xⱼ . rec-args)] …))]] + +@chunk[ + [(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[ + [else-T + (subtemplate + else-T)]] + +@chunk[ + [else-T + (subtemplate + (values v acc))]] + + + +------ + + + @chunk[ - (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 …) - - ((λ (x) - (local-require racket/pretty) - #;(pretty-write (syntax->datum x)) - x) - (subtemplate - (begin - )))]))] + _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 …) + + ((λ (x) + (local-require racket/pretty) + #;(pretty-write (syntax->datum x)) + x) + (subtemplate + (begin + )))]))] @chunk[ the-defs … @@ -158,7 +386,7 @@ way up, so that a simple identity function can be applied in these cases. _the-code)] @chunk[ - (define/with-syntax _args (subtemplate ({?@ predicateᵢ updateᵢ} …)))] + (define/with-syntax _args (subtemplate ({?@ _predicateᵢ _updateᵢ} …)))] @chunk[ (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) - )] + )] -@chunk[ +@chunk[ [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[ +@chunk[ [(~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[ +@chunk[ [(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[ +@chunk[ [(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[ +@chunk[ [(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[ +@chunk[ [(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[ +@chunk[ [(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[ +@chunk[ [(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[ +@chunk[ [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 ) ] \ No newline at end of file