Union of two tagged structures works

dispatch-union.rkt

@@ -1,6 +1,7 @@
 #lang typed/racket
 
 (require phc-toolkit
+         phc-adt
          (for-syntax racket/base
                      phc-toolkit/untyped
                      racket/syntax
@@ -12,13 +13,21 @@
          (for-meta 2 phc-toolkit/untyped)
          (for-meta 2 syntax/parse))
 
+(provide dispatch-union)
+
 (define-syntax/parse (dispatch-union ([type-to-replaceᵢ Aᵢ predicateᵢ] …)
                                      [X v result] …)
-  (stx-map
+  ((λ (x) (local-require racket/pretty) #;(pretty-write (syntax->datum x)) x)
+   #`(cond
+       . #,(stx-map
             (λ (X v result)
-     (cond
+              (syntax-parse X
-       [(meta-struct? X) #`[((struct-predicate #,X) #,v) #,result]]
+                #:literals (tagged)
-       [else (raise-syntax-error 'graph "Unhandled union type" #'X)]))
+                [(tagged name [fieldᵢ (~optional :colon) typeᵢ] …)
+                 #`[((tagged? name fieldᵢ …) #,v) #,result]]
+                [other (raise-syntax-error 'graph
+                                           "Unhandled union type"
+                                           #'other)]))
             #'(X …)
             #'(v …)
-   #'(result …)))
+            #'(result …)))))

test/adt-pre-declarations.rkt

@@ -1,2 +1,3 @@
 #lang s-exp phc-adt/declarations
 (remembered! tagged-structure (tg a b))
+(remembered! tagged-structure (tg a c))

test/test-traversal-2.rkt

@@ -6,9 +6,14 @@
          "ck.rkt")
 (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 (string->symbol+acc [x : String] [acc : Integer])
   (values (string->symbol x) (add1 acc)))
@@ -18,4 +23,21 @@
  : (Values (tagged tg [a Symbol] [b Boolean]) Integer)
  (tagged tg [a 'abc] [b #f]) 1)
 
+(check-equal?-values:
+ ((f₂ string? string->symbol+acc) (tagged tg [a "abc"] [b #f]) 0)
+ : (Values (U (tagged tg [a Symbol] [b Boolean])) Integer)
+ (tagged tg [a 'abc] [b #f]) 1)
 
+#;(check-equal?-values:
+ ((f₃ string? string->symbol+acc) (tagged tg [a "abc"] [b #f]) 0)
+ : (Values (U (tagged tg [a Symbol] [b Boolean])
+              (tagged tg [a Boolean] [c Symbol]))
+           Integer)
+ (tagged tg [a 'abc] [b #f]) 1)
+
+#;(check-equal?-values:
+ ((f₃ string? string->symbol+acc) (tagged tg [a #t] [c "def"]) 0)
+ : (Values (U (tagged tg [a Symbol] [b Boolean])
+              (tagged tg [a Boolean] [c Symbol]))
+           Integer)
+ (tagged tg [a #t] [c 'def]) 1)

traversal.hl.rkt

@@ -130,9 +130,13 @@ way up, so that a simple identity function can be applied in these cases.
                whole-type:type
                type-to-replaceᵢ:type …)
             <define-fold-prepare>
+            ((λ (x)
+               (local-require racket/pretty)
+               #;(pretty-write (syntax->datum x))
+               x)
             (template
              (begin
-               <define-fold-result>))]))]
+               <define-fold-result>)))]))]
 
 @chunk[<define-fold-prepare>
        (define-temp-ids "_Tᵢ" (type-to-replaceᵢ …))
@@ -231,18 +235,20 @@ way up, so that a simple identity function can be applied in these cases.
 
 @chunk[<type-cases>
        [(U X …)
+        (define-temp-ids "_fx" (X …))
+        (define-temp-ids "_tx" (X …))
         
         #:to
-        (U (tx _Tᵢ …))
+        (U (_tx _Tᵢ …) …)
 
         #:using
         (dispatch-union ([type-to-replaceᵢ Aᵢ predicateᵢ]
                          …)
-                        [X v ((fx . _args) v acc)]
+                        [X v ((_fx . _args) v acc)]
                         …)
 
         #:with-defintitions
-        (define-fold fx tx X type-to-replaceᵢ …)
+        (define-fold _fx _tx X type-to-replaceᵢ …)
         …]]
 
 @chunk[<type-cases>
@@ -332,6 +338,7 @@ where @racket[foldl-map] is defined as:
        (require phc-toolkit
                 type-expander
                 phc-adt
+                "dispatch-union.rkt"
                 (for-syntax racket/base
                             phc-toolkit/untyped
                             racket/syntax