Added support for type-to-replaceᵢ directly within a union.

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)
+            (λ (Xⱼ result)
-              (syntax-parse X
+              (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 …)))))
+            #'(result …))))))

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

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)
+ (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)))|#

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)))
+        #:with (_ update T)
-                           (syntax->list
+        (findf (λ (r) (free-identifier-tree=? #'t (stx-car r)))
-                            (subtemplate ([type-to-replaceᵢ updateᵢ _Tᵢ] …))))
+               (syntax->list (subtemplate ([type-to-replaceᵢ updateᵢ _Tᵢ] …))))
-        #:when (attribute info)
+        
-        #:with (_ update T) #'info
-
         #: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