From 4eecd1def812591eb599abb8de2409ff66323954 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Fri, 4 Nov 2016 22:38:14 +0100 Subject: [PATCH] WIP: have to separate function definition from its type with :, due to recursive functions. --- dispatch-union.rkt | 1 - free-identifier-tree-equal.rkt | 5 +- test/test-traversal-1.rkt | 2 + test/test-traversal-2.rkt | 1 - traversal.hl.rkt | 88 ++++++++++++++++++++-------------- 5 files changed, 58 insertions(+), 39 deletions(-) diff --git a/dispatch-union.rkt b/dispatch-union.rkt index 371cc75..aac6416 100644 --- a/dispatch-union.rkt +++ b/dispatch-union.rkt @@ -37,7 +37,6 @@ (pattern [other result] #:with clause #`[else result])) - ((λ (x) (local-require racket/pretty) #;(pretty-write (syntax->datum x)) x) (syntax-parse #'([Xⱼ resultⱼ] …) [({~or to-replace:to-replace diff --git a/free-identifier-tree-equal.rkt b/free-identifier-tree-equal.rkt index 9268f97..1d6e74a 100644 --- a/free-identifier-tree-equal.rkt +++ b/free-identifier-tree-equal.rkt @@ -36,7 +36,10 @@ (let ([b-key (prefab-struct-key b)]) (and (equal? a-key b-key) (rec=? (struct->list a) - (struct->list b)))))])) + (struct->list b)))))] + [(null? a) (null? b)] + [else (error (format "Unexpected value for free-id-tree=? : ~a" + a))])) (define ((free-id-tree-hash hc) a) (define rec-hash (free-id-tree-hash hc)) diff --git a/test/test-traversal-1.rkt b/test/test-traversal-1.rkt index 46f7d6b..0dbbfb4 100644 --- a/test/test-traversal-1.rkt +++ b/test/test-traversal-1.rkt @@ -15,6 +15,8 @@ (define-fold f₈ t₈ (List String Foo (Listof String)) String) (define-fold f₉ t₉ (List (Listof String) Foo (Listof String)) (Listof String)) (define-fold f₁₀ t₁₀ (List String Foo (Listof String)) (Listof String)) +(define-fold f₁₁ t₁₁ (List (Listof String) (Listof Number)) (Listof String)) +(define-fold f₁₂ t₁₂ (List (Listof String) (Listof String)) (Listof String)) (define (string->symbol+acc [x : String] [acc : Integer]) (values (string->symbol x) (add1 acc))) diff --git a/test/test-traversal-2.rkt b/test/test-traversal-2.rkt index f9d921d..1c4c54d 100644 --- a/test/test-traversal-2.rkt +++ b/test/test-traversal-2.rkt @@ -112,4 +112,3 @@ Symbol) Integer) 'ghi 1) - diff --git a/traversal.hl.rkt b/traversal.hl.rkt index 49ef615..2165b26 100644 --- a/traversal.hl.rkt +++ b/traversal.hl.rkt @@ -137,9 +137,10 @@ not expressed syntactically using the @racket[Foo] identifier. (define/with-syntax thunk-result (thunk)) (with-syntax ([([f-id . f-body] …) (unbox (get-f-defs))] [([τ-id . τ-body] …) (unbox (get-τ-defs))]) - #`(begin (define-type τ-id τ-body) … - (define f-id f-body) … - thunk-result))))] + ((λ (x) (displayln x) x) + #`(begin (define-type τ-id τ-body) … + (define f-id f-body) … + thunk-result)))))] @;@subsection{…} @@ -171,7 +172,8 @@ way up, so that a simple identity function can be applied in these cases. (syntax->list (subtemplate ([_type-to-replaceᵢ . _Tᵢ] …)))))) - ((λ (x) (displayln "τ=") (pretty-write (syntax->datum x)) x) + (printf "Start ~a ~a =>\n" (syntax->datum τ-) #'_whole-type) + ((λ (x) (printf "~a ~a =>\n" (syntax->datum τ-) #'_whole-type) (pretty-write (syntax->datum x)) x) (quasisubtemplate (∀ (_Tᵢ …) #,(syntax-parse #'_whole-type @@ -186,11 +188,11 @@ way up, so that a simple identity function can be applied in these cases. (error "fold-type and fold-f must be called within with-folds")) (if (dict-has-key? cache key) (dict-ref cache key) - (let ([new-def #`#,(gensym 'base)]) - (dict-set! cache key new-def) + (let ([base #`#,(gensym 'base)]) + (dict-set! cache key base) (let ([result (let () . body)]) - (set-box! defs `([,new-def . ,result] . ,(unbox defs))) - new-def))))))] + (set-box! defs `([,base . ,result] . ,(unbox defs))) + base))))))] @CHUNK[ (define-for-syntax (replace-in-instance stx) @@ -214,22 +216,27 @@ way up, so that a simple identity function can be applied in these cases. (subtemplate ([_type-to-replaceᵢ . _updateᵢ] …)))))) (define/with-syntax _args (subtemplate ({?@ _predicateᵢ _updateᵢ} …))) - (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 (subtemplate (_whole-type - [_type-to-replaceᵢ _Aᵢ] …))) - Acc - (Values #,(replace-in-type (subtemplate (_whole-type - [_type-to-replaceᵢ _Bᵢ] …))) - Acc))))))]))] + (cached [f- + (get-f-cache) + (get-f-defs) + #'(_whole-type _type-to-replaceᵢ …)] + ((λ (x) (printf "f ~a =>\n" #'_whole-type) (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 (subtemplate (_whole-type + [_type-to-replaceᵢ _Aᵢ] …))) + Acc + (Values #,(replace-in-type (subtemplate (_whole-type + [_type-to-replaceᵢ _Bᵢ] …))) + Acc))))))))]))] @chunk[ [t @@ -245,10 +252,12 @@ way up, so that a simple identity function can be applied in these cases. @chunk[ [(~or Null (List)) + (displayln "Null case") (subtemplate Null)]] @chunk[ [(~or Null (List)) + (displayln "Null case") (subtemplate (values v acc))]] @@ -295,12 +304,18 @@ way up, so that a simple identity function can be applied in these cases. @CHUNK[ [(List X Y …) + (newline) + (displayln "(List X Y …) case") + (displayln #'(List Y …)) + (displayln (replace-in-type #'((List Y …) . rec-args))) (quasisubtemplate (Pairof #,(replace-in-type #'(X . rec-args)) #,(replace-in-type #'((List Y …) . rec-args))))]] @CHUNK[ [(List X Y …) + (newline) + (displayln "(List X Y …) case") (quasisubtemplate (let*-values ([(result-x acc-x) (#,(replace-in-instance #'(X . rec-args)) (car v) @@ -313,23 +328,24 @@ way up, so that a simple identity function can be applied in these cases. @CHUNK[ [(U _Xⱼ …) (quasisubtemplate - (U #,@(stx-map (λ (_x) (replace-in-type #'(_x . rec-args))) + (U #,@(stx-map (λ (_x) (replace-in-type #`(#,_x . rec-args))) (subtemplate (_Xⱼ …)))))]] @CHUNK[ [(U _Xⱼ …) - (quasisubtemplate - (dispatch-union v - ([_type-to-replaceᵢ Aᵢ _predicateᵢ] …) - #,@(stx-map (λ (_x) - #`[_x (#,(replace-in-instance #'(_x . rec-args)) v acc)]) - (subtemplate (_Xⱼ …)))))]] + ((λ (x) (displayln x) x) + (quasisubtemplate + (dispatch-union v + ([_type-to-replaceᵢ Aᵢ _predicateᵢ] …) + #,@(stx-map (λ (_x) + #`[#,_x (#,(replace-in-instance #`(#,_x . rec-args)) v acc)]) + (subtemplate (_Xⱼ …))))))]] @CHUNK[ [(tagged _name [_fieldⱼ (~optional :colon) _Xⱼ] …) (quasisubtemplate (tagged _name #,@(stx-map (λ (_field _x) - #`[_field : #,(replace-in-type #'(_x . rec-args))]) + #`[#,_field : #,(replace-in-type #`(#,_x . rec-args))]) (subtemplate (_fieldⱼ …)) (subtemplate (_Xⱼ …)))))]] @@ -337,11 +353,11 @@ way up, so that a simple identity function can be applied in these cases. [(tagged _name [_fieldⱼ (~optional :colon) _Xⱼ] …) (quasisubtemplate (let*-values (#,@(stx-map (λ ( _result _field _x) - #`[(_result acc) - (#,(replace-in-instance #'(_x . rec-args)) (uniform-get v _field) - acc)]) - (subtemplate (_fieldⱼ …)) + #`[(#,_result acc) + (#,(replace-in-instance #`(#,_x . rec-args)) (uniform-get v #,_field) + acc)]) (subtemplate (_resultⱼ …)) + (subtemplate (_fieldⱼ …)) (subtemplate (_Xⱼ …)))) (values (tagged _name #:instance [_fieldⱼ _resultⱼ] …) acc)))]]