commit de8508f3cef3c9170671e912c919e4b528b084b5
parent dc11b3014e4a8e464c5d37a57443e3e4a68449cd
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Sat, 8 Oct 2016 03:10:04 +0200
Added support for type-to-replaceᵢ directly within a union.
Diffstat:
4 files changed, 316 insertions(+), 22 deletions(-)
diff --git 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
@@ -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
@@ -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
@@ -171,12 +171,10 @@ way up, so that a simple identity function can be applied in these cases.
@chunk[<type-cases>
[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
