From de8508f3cef3c9170671e912c919e4b528b084b5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Sat, 8 Oct 2016 03:10:04 +0200 Subject: [PATCH] =?UTF-8?q?Added=20support=20for=20type-to-replace?= =?UTF-8?q?=E1=B5=A2=20directly=20within=20a=20union.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- dispatch-union.rkt | 28 ++-- test/adt-pre-declarations.rkt | 1 + test/test-traversal-2.rkt | 293 +++++++++++++++++++++++++++++++++- traversal.hl.rkt | 12 +- 4 files changed, 314 insertions(+), 20 deletions(-) diff --git a/dispatch-union.rkt b/dispatch-union.rkt index 525f85f..8ea1681 100644 --- a/dispatch-union.rkt +++ b/dispatch-union.rkt @@ -1,14 +1,16 @@ -#lang typed/racket +#lang typed/racket/base -(require phc-toolkit +(require racket/require + phc-toolkit phc-adt - (for-syntax racket/base + (for-syntax (subtract-in racket/base "subtemplate.rkt") phc-toolkit/untyped racket/syntax - syntax/parse + (subtract-in syntax/parse "subtemplate.rkt") syntax/parse/experimental/template type-expander/expander - "free-identifier-tree-equal.rkt") + "free-identifier-tree-equal.rkt" + "subtemplate.rkt") (for-meta 2 racket/base) (for-meta 2 phc-toolkit/untyped) (for-meta 2 syntax/parse)) @@ -19,15 +21,23 @@ ([type-to-replaceᵢ Aᵢ predicateᵢ] …) [Xⱼ result] …) ((λ (x) (local-require racket/pretty) #;(pretty-write (syntax->datum x)) x) - #`(cond + (quasisyntax/top-loc stx + (cond + ;; TODO: put first the type-to-replaceᵢ, then afterwards the other Xⱼ, otherwise it can fail to typecheck. . #,(stx-map - (λ (X result) - (syntax-parse X + (λ (Xⱼ result) + (syntax-parse Xⱼ #:literals (tagged) + [t + #:with (_ predicate) + (findf (λ (r) (free-identifier-tree=? #'t (stx-car r))) + (syntax->list + (subtemplate ([type-to-replaceᵢ predicateᵢ] …)))) + #`[(predicate v) #,result]] [(tagged name [fieldₖ (~optional :colon) typeₖ] …) #`[((tagged? name fieldₖ …) v) #,result]] [other (raise-syntax-error 'graph "Unhandled union type" #'other)])) #'(Xⱼ …) - #'(result …))))) \ No newline at end of file + #'(result …)))))) \ No newline at end of file diff --git a/test/adt-pre-declarations.rkt b/test/adt-pre-declarations.rkt index e3c7660..e2d73e5 100644 --- a/test/adt-pre-declarations.rkt +++ b/test/adt-pre-declarations.rkt @@ -1,3 +1,4 @@ #lang s-exp phc-adt/declarations (remembered! tagged-structure (tg a b)) (remembered! tagged-structure (tg a c)) +(remembered! tagged-structure (t0)) diff --git a/test/test-traversal-2.rkt b/test/test-traversal-2.rkt index d3daee0..a061082 100644 --- a/test/test-traversal-2.rkt +++ b/test/test-traversal-2.rkt @@ -3,17 +3,28 @@ (require "../traversal.hl.rkt" type-expander phc-adt - "ck.rkt") + "ck.rkt" + "../dispatch-union.rkt") ;; DEBUG (adt-init) -(define-type Foo (Listof String)) +#;(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]) (tagged tg [a Boolean] [c String])) String) - +#;(define-fold f₄ t₄ (U (tagged tg [a String] [b Boolean]) + String + (tagged tg [a Boolean] [c String])) + String) +#;(define-fold f₄ t₄ (U (tagged t0) + String + (tagged tg [a Boolean] [c String])) + String) +(define-fold f₆ t₆ (U String + (tagged tg [a String] [b Boolean])) + String) (define (string->symbol+acc [x : String] [acc : Integer]) (values (string->symbol x) (add1 acc))) @@ -40,4 +51,278 @@ : (Values (U (tagged tg [a Symbol] [b Boolean]) (tagged tg [a Boolean] [c Symbol])) Integer) - (tagged tg [a #t] [c 'def]) 1) \ No newline at end of file + (tagged tg [a #t] [c 'def]) 1) + +#;(check-equal?-values: + ((f₄ string? string->symbol+acc) (tagged tg [a #t] [c "def"]) 0) + : (Values (U (tagged tg [a Symbol] [b Boolean]) + Symbol + (tagged tg [a Boolean] [c Symbol])) + Integer) + (tagged tg [a #t] [c 'def]) 1) + +#;(check-equal?-values: + ((f₄ string? string->symbol+acc) "ghi" 0) + : (Values (U (tagged tg [a Symbol] [b Boolean]) + Symbol + (tagged tg [a Boolean] [c Symbol])) + Integer) + 'ghi 1) + +(check-equal?-values: + ((f₆ string? string->symbol+acc) (tagged tg [a "abc"] [b #f]) 0) + : (Values (U (tagged tg [a Symbol] [b Boolean]) + Symbol) + Integer) + (tagged tg [a 'abc] [b #f]) 1) + +(check-equal?-values: + ((f₆ string? string->symbol+acc) "ghi" 0) + : (Values (U (tagged tg [a Symbol] [b Boolean]) + Symbol) + Integer) + 'ghi 1) + + + + + + + + + + +#| + + + +(begin + #;(define-fold + _Xⱼ/_fxⱼ-test-traversal-2279088 + _Xⱼ/_txⱼ-test-traversal-2279086 + (tagged tg (a String) (b Boolean)) + String) + #;(define-fold + _Xⱼ/_fxⱼ-test-traversal-2279089 + _Xⱼ/_txⱼ-test-traversal-2279087 + String + String) + (define-type + (t₄ type-to-replaceᵢ/_Tᵢ-test-traversal-2279083) + (U + (_Xⱼ/_txⱼ-test-traversal-2279086 + type-to-replaceᵢ/_Tᵢ-test-traversal-2279083) + (_Xⱼ/_txⱼ-test-traversal-2279087 + type-to-replaceᵢ/_Tᵢ-test-traversal-2279083))) + (: + f₄ + (∀ + (type-to-replaceᵢ/_Aᵢ-test-traversal-2279094 + type-to-replaceᵢ/_Bᵢ-test-traversal-2279093 + Acc) + (→ + (→ Any Boolean : type-to-replaceᵢ/_Aᵢ-test-traversal-2279094) + (→ + type-to-replaceᵢ/_Aᵢ-test-traversal-2279094 + Acc + (Values type-to-replaceᵢ/_Bᵢ-test-traversal-2279093 Acc)) + (→ + (t₄ type-to-replaceᵢ/_Aᵢ-test-traversal-2279094) + Acc + (Values (t₄ type-to-replaceᵢ/_Bᵢ-test-traversal-2279093) Acc))))) + (define ((f₄ + type-to-replaceᵢ/predicateᵢ-test-traversal-2279082 + type-to-replaceᵢ/updateᵢ-test-traversal-2279081) + v + acc) + (cond + ((type-to-replaceᵢ/predicateᵢ-test-traversal-2279082 v) + ((_Xⱼ/_fxⱼ-test-traversal-2279089 + type-to-replaceᵢ/predicateᵢ-test-traversal-2279082 + type-to-replaceᵢ/updateᵢ-test-traversal-2279081) + v + acc)) + (((tagged? tg a b) v) + ((_Xⱼ/_fxⱼ-test-traversal-2279088 + type-to-replaceᵢ/predicateᵢ-test-traversal-2279082 + type-to-replaceᵢ/updateᵢ-test-traversal-2279081) + v + acc))) + #;(dispatch-union + v + ((String + type-to-replaceᵢ/Aᵢ-test-traversal-2279091 + type-to-replaceᵢ/predicateᵢ-test-traversal-2279082)) + ((tagged tg (a String) (b Boolean)) + ((_Xⱼ/_fxⱼ-test-traversal-2279088 + type-to-replaceᵢ/predicateᵢ-test-traversal-2279082 + type-to-replaceᵢ/updateᵢ-test-traversal-2279081) + v + acc)) + (String + ((_Xⱼ/_fxⱼ-test-traversal-2279089 + type-to-replaceᵢ/predicateᵢ-test-traversal-2279082 + type-to-replaceᵢ/updateᵢ-test-traversal-2279081) + v + acc))))) +(begin + #;(define-fold + _Xⱼ/_fxⱼ-test-traversal-2279102 + _Xⱼ/_txⱼ-test-traversal-2279100 + String + String) + #;(define-fold + _Xⱼ/_fxⱼ-test-traversal-2279103 + _Xⱼ/_txⱼ-test-traversal-2279101 + Boolean + String) + (define-type + (_Xⱼ/_txⱼ-test-traversal-2279086 + type-to-replaceᵢ/_Tᵢ-test-traversal-2279098) + (tagged + tg + (a + : + (_Xⱼ/_txⱼ-test-traversal-2279100 + type-to-replaceᵢ/_Tᵢ-test-traversal-2279098)) + (b + : + (_Xⱼ/_txⱼ-test-traversal-2279101 + type-to-replaceᵢ/_Tᵢ-test-traversal-2279098)))) + (: + _Xⱼ/_fxⱼ-test-traversal-2279088 + (∀ + (type-to-replaceᵢ/_Aᵢ-test-traversal-2279108 + type-to-replaceᵢ/_Bᵢ-test-traversal-2279107 + Acc) + (→ + (→ Any Boolean : type-to-replaceᵢ/_Aᵢ-test-traversal-2279108) + (→ + type-to-replaceᵢ/_Aᵢ-test-traversal-2279108 + Acc + (Values type-to-replaceᵢ/_Bᵢ-test-traversal-2279107 Acc)) + (→ + (_Xⱼ/_txⱼ-test-traversal-2279086 + type-to-replaceᵢ/_Aᵢ-test-traversal-2279108) + Acc + (Values + (_Xⱼ/_txⱼ-test-traversal-2279086 + type-to-replaceᵢ/_Bᵢ-test-traversal-2279107) + Acc))))) + (define ((_Xⱼ/_fxⱼ-test-traversal-2279088 + type-to-replaceᵢ/predicateᵢ-test-traversal-2279097 + type-to-replaceᵢ/updateᵢ-test-traversal-2279096) + v + acc) + (let*-values (((_Xⱼ/_resultⱼ-test-traversal-2279104 acc) + ((_Xⱼ/_fxⱼ-test-traversal-2279102 + type-to-replaceᵢ/predicateᵢ-test-traversal-2279097 + type-to-replaceᵢ/updateᵢ-test-traversal-2279096) + (uniform-get v a) + acc)) + ((_Xⱼ/_resultⱼ-test-traversal-2279105 acc) + ((_Xⱼ/_fxⱼ-test-traversal-2279103 + type-to-replaceᵢ/predicateᵢ-test-traversal-2279097 + type-to-replaceᵢ/updateᵢ-test-traversal-2279096) + (uniform-get v b) + acc))) + (values + (tagged + tg + #:instance + (a _Xⱼ/_resultⱼ-test-traversal-2279104) + (b _Xⱼ/_resultⱼ-test-traversal-2279105)) + acc)))) +(begin + (define-type + (_Xⱼ/_txⱼ-test-traversal-2279100 + type-to-replaceᵢ/_Tᵢ-test-traversal-2279112) + type-to-replaceᵢ/_Tᵢ-test-traversal-2279112) + (: + _Xⱼ/_fxⱼ-test-traversal-2279102 + (∀ + (type-to-replaceᵢ/_Aᵢ-test-traversal-2279115 + type-to-replaceᵢ/_Bᵢ-test-traversal-2279114 + Acc) + (→ + (→ Any Boolean : type-to-replaceᵢ/_Aᵢ-test-traversal-2279115) + (→ + type-to-replaceᵢ/_Aᵢ-test-traversal-2279115 + Acc + (Values type-to-replaceᵢ/_Bᵢ-test-traversal-2279114 Acc)) + (→ + (_Xⱼ/_txⱼ-test-traversal-2279100 + type-to-replaceᵢ/_Aᵢ-test-traversal-2279115) + Acc + (Values + (_Xⱼ/_txⱼ-test-traversal-2279100 + type-to-replaceᵢ/_Bᵢ-test-traversal-2279114) + Acc))))) + (define ((_Xⱼ/_fxⱼ-test-traversal-2279102 + type-to-replaceᵢ/predicateᵢ-test-traversal-2279111 + type-to-replaceᵢ/updateᵢ-test-traversal-2279110) + v + acc) + (type-to-replaceᵢ/updateᵢ-test-traversal-2279110 v acc))) +(begin + (define-type + (_Xⱼ/_txⱼ-test-traversal-2279101 + type-to-replaceᵢ/_Tᵢ-test-traversal-2279119) + Boolean) + (: + _Xⱼ/_fxⱼ-test-traversal-2279103 + (∀ + (type-to-replaceᵢ/_Aᵢ-test-traversal-2279122 + type-to-replaceᵢ/_Bᵢ-test-traversal-2279121 + Acc) + (→ + (→ Any Boolean : type-to-replaceᵢ/_Aᵢ-test-traversal-2279122) + (→ + type-to-replaceᵢ/_Aᵢ-test-traversal-2279122 + Acc + (Values type-to-replaceᵢ/_Bᵢ-test-traversal-2279121 Acc)) + (→ + (_Xⱼ/_txⱼ-test-traversal-2279101 + type-to-replaceᵢ/_Aᵢ-test-traversal-2279122) + Acc + (Values + (_Xⱼ/_txⱼ-test-traversal-2279101 + type-to-replaceᵢ/_Bᵢ-test-traversal-2279121) + Acc))))) + (define ((_Xⱼ/_fxⱼ-test-traversal-2279103 + type-to-replaceᵢ/predicateᵢ-test-traversal-2279118 + type-to-replaceᵢ/updateᵢ-test-traversal-2279117) + v + acc) + (values v acc))) +(begin + (define-type + (_Xⱼ/_txⱼ-test-traversal-2279087 + type-to-replaceᵢ/_Tᵢ-test-traversal-2279128) + type-to-replaceᵢ/_Tᵢ-test-traversal-2279128) + (: + _Xⱼ/_fxⱼ-test-traversal-2279089 + (∀ + (type-to-replaceᵢ/_Aᵢ-test-traversal-2279131 + type-to-replaceᵢ/_Bᵢ-test-traversal-2279130 + Acc) + (→ + (→ Any Boolean : type-to-replaceᵢ/_Aᵢ-test-traversal-2279131) + (→ + type-to-replaceᵢ/_Aᵢ-test-traversal-2279131 + Acc + (Values type-to-replaceᵢ/_Bᵢ-test-traversal-2279130 Acc)) + (→ + (_Xⱼ/_txⱼ-test-traversal-2279087 + type-to-replaceᵢ/_Aᵢ-test-traversal-2279131) + Acc + (Values + (_Xⱼ/_txⱼ-test-traversal-2279087 + type-to-replaceᵢ/_Bᵢ-test-traversal-2279130) + Acc))))) + (define ((_Xⱼ/_fxⱼ-test-traversal-2279089 + type-to-replaceᵢ/predicateᵢ-test-traversal-2279127 + type-to-replaceᵢ/updateᵢ-test-traversal-2279126) + v + acc) + (type-to-replaceᵢ/updateᵢ-test-traversal-2279126 v acc)))|# \ No newline at end of file diff --git a/traversal.hl.rkt b/traversal.hl.rkt index c659ac7..aab9c69 100644 --- a/traversal.hl.rkt +++ b/traversal.hl.rkt @@ -171,12 +171,10 @@ way up, so that a simple identity function can be applied in these cases. @chunk[ [t - #:with info (findf (λ (r) (free-identifier-tree=? #'t (stx-car r))) - (syntax->list - (subtemplate ([type-to-replaceᵢ updateᵢ _Tᵢ] …)))) - #:when (attribute info) - #:with (_ update T) #'info - + #:with (_ update T) + (findf (λ (r) (free-identifier-tree=? #'t (stx-car r))) + (syntax->list (subtemplate ([type-to-replaceᵢ updateᵢ _Tᵢ] …)))) + #:to T @@ -273,7 +271,7 @@ way up, so that a simple identity function can be applied in these cases. (let*-values ([(_resultⱼ acc) ((_fxⱼ . _args) (uniform-get v _fieldⱼ) acc)] …) - (values (tagged _name [_fieldⱼ _resultⱼ] …) + (values (tagged _name #:instance [_fieldⱼ _resultⱼ] …) acc)) #:with-defintitions