Preliminary support for tagged structures, early draft for unions

dispatch-union.rkt

@@ -0,0 +1,24 @@
+#lang typed/racket
+
+(require phc-toolkit
+                (for-syntax racket/base
+                            phc-toolkit/untyped
+                            racket/syntax
+                            syntax/parse
+                            syntax/parse/experimental/template
+                            type-expander/expander
+                            "free-identifier-tree-equal.rkt")
+                (for-meta 2 racket/base)
+                (for-meta 2 phc-toolkit/untyped)
+                (for-meta 2 syntax/parse))
+
+(define-syntax/parse (dispatch-union ([type-to-replaceᵢ Aᵢ predicateᵢ] …)
+                                     [X v result] …)
+  (stx-map
+   (λ (X v result)
+     (cond
+       [(meta-struct? X) #`[((struct-predicate #,X) #,v) #,result]]
+       [else (raise-syntax-error 'graph "Unhandled union type" #'X)]))
+   #'(X …)
+   #'(v …)
+   #'(result …)))

test/adt-pre-declarations.rkt

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

test/ck.rkt

@@ -10,11 +10,11 @@
 
 (define-syntax check-equal?-values:
   (syntax-parser
-    [(_ actual {~maybe :colon type} expected ...)
+    [(_ actual {~maybe :colon type:type-expand!} expected ...)
      (quasisyntax/top-loc this-syntax
        (check-equal?: (call-with-values (ann (λ () actual)
                                              (-> #,(if (attribute type)
-                                                       #'type
+                                                       #'type.expanded
                                                        #'AnyValues)))
                                         (λ l l))
                       (list expected ...)))]))

test/test-traversal-2.rkt

@@ -0,0 +1,21 @@
+#lang typed/racket
+
+(require "../traversal.hl.rkt"
+         type-expander
+         phc-adt
+         "ck.rkt")
+(adt-init)
+
+#;(define-type Foo (Listof String))
+
+(define-fold f₁ t₁ (tagged tg [a String] [b Boolean]) String)
+
+(define (string->symbol+acc [x : String] [acc : Integer])
+  (values (string->symbol x) (add1 acc)))
+
+(check-equal?-values:
+ ((f₁ string? string->symbol+acc) (tagged tg [a "abc"] [b #f]) 0)
+ : (Values (tagged tg [a Symbol] [b Boolean]) Integer)
+ (tagged tg [a 'abc] [b #f]) 1)
+
+

traversal.hl.rkt

@@ -145,8 +145,10 @@ way up, so that a simple identity function can be applied in these cases.
 
 @chunk[<define-fold-prepare>
        (type-cases
-        (whole-type => _the-type _the-code the-defs …)
-        #:literals (Null Pairof Listof List Vectorof Vector)
+        (whole-type #:to _the-type
+                    #:using _the-code
+                    #:with-defintitions the-defs …)
+        #:literals (Null Pairof Listof List Vectorof Vector U tagged)
         <type-cases>)]
 
 @chunk[<type-cases>
@@ -155,49 +157,120 @@ way up, so that a simple identity function can be applied in these cases.
                            (syntax->list #'([type-to-replaceᵢ updateᵢ _Tᵢ] …)))
         #:when (attribute info)
         #:with (_ update T) #'info
-        => T
+
+        #:to
+        T
+
+        #:using
         (update v acc)]]
 
 @chunk[<type-cases>
        [(~or Null (List))
-        => Null
+
+        #:to
+        Null
+
+        #:using
         (values v acc)]]
 
 @chunk[<type-cases>
        [(Pairof X Y)
-        => (Pairof (tx _Tᵢ …) (ty _Tᵢ …))
+
+        #:to
+        (Pairof (tx _Tᵢ …) (ty _Tᵢ …))
+
+        #:using
         (let*-values ([(result-x acc-x) ((fx . _args) (car v) acc)]
                       [(result-y acc-y) ((fy . _args) (cdr v) acc-x)])
           (values (cons result-x result-y) acc-y))
+
+        #:with-defintitions
         (define-fold fx tx X type-to-replaceᵢ …)
         (define-fold fy ty Y type-to-replaceᵢ …)]]
 
 @chunk[<type-cases>
        [(Listof X)
-        => (Listof (te _Tᵢ …))
+
+        #:to
+        (Listof (te _Tᵢ …))
+
+        #:using
         (foldl-map (fe . _args) acc v)
+
+        #:with-defintitions
         (define-fold fe te X type-to-replaceᵢ …)]]
 
 @chunk[<type-cases>
        [(Vectorof X)
-        => (Vectorof (te _Tᵢ …))
+
+        #:to
+        (Vectorof (te _Tᵢ …))
+
+        #:using
         (vector->immutable-vector
          (list->vector
           (foldl-map (fe . _args) acc (vector->list v))))
+
+        #:with-defintitions
         (define-fold fe te X type-to-replaceᵢ …)]]
 
 @chunk[<type-cases>
-       [(List X Y ...)
-        => (Pairof (tx _Tᵢ …) (ty* _Tᵢ …))
+       [(List X Y …)
+
+        #:to
+        (Pairof (tx _Tᵢ …) (ty* _Tᵢ …))
+
+        #:using
         (let*-values ([(result-x acc-x) ((fx . _args) (car v) acc)]
                       [(result-y* acc-y*) ((fy* . _args) (cdr v) acc-x)])
           (values (cons result-x result-y*) acc-y*))
+
+        #:with-defintitions
         (define-fold fx tx X type-to-replaceᵢ …)
-        (define-fold fy* ty* (List Y ...) type-to-replaceᵢ …)]]
+        (define-fold fy* ty* (List Y …) type-to-replaceᵢ …)]]
+
+@chunk[<type-cases>
+       [(U X …)
+
+        #:to
+        (U (tx _Tᵢ …))
+
+        #:using
+        (dispatch-union ([type-to-replaceᵢ Aᵢ predicateᵢ]
+                         …)
+                        [X v ((fx . _args) v acc)]
+                        …)
+
+        #:with-defintitions
+        (define-fold fx tx X type-to-replaceᵢ …)
+        …]]
+
+@chunk[<type-cases>
+       [(tagged _name [_field (~optional :colon) _X] …
+                {~do (define-temp-ids "_fx" (_X …))}
+                {~do (define-temp-ids "_tx" (_X …))}
+                {~do (define-temp-ids "_result" (_X …))})
+
+        #:to
+        (tagged _name [_field : (_tx _Tᵢ …)] …)
+
+        #:using
+        (let*-values ([(_result acc) ((_fx . _args) (uniform-get v _field) acc)]
+                      …)
+          (values (tagged _name [_field _result] …)
+                  acc))
+
+        #:with-defintitions
+        (define-fold _fx _tx _X type-to-replaceᵢ …)
+        …]]
 
 @chunk[<type-cases>
        [else-T
-        => else-T
+
+        #:to
+        else-T
+
+        #:using
         (values v acc)]]
 
 where @racket[foldl-map] is defined as:
@@ -219,10 +292,15 @@ where @racket[foldl-map] is defined as:
 @chunk[<type-cases-macro>
        (define-syntax type-cases
          (syntax-parser
-           #:literals (=>)
-           [(_ (whole-type => the-type the-code the-defs (~literal …))
+           [(_ (whole-type #:to the-type
+                           #:using the-code
+                           #:with-defintitions the-defs (~literal …))
                #:literals (lit …)
-               (Pat opts … => transform-type transform-code transform-defs …)
+               (Pat opts …
+                    #:to transform-type
+                    #:using transform-code
+                    (~optional (~seq #:with-defintitions transform-defs …)
+                               #:defaults ([(transform-defs 1) (list)])))
                …)
             #'(define/with-syntax (the-type the-code the-defs (… …))
                 (syntax-parse #'whole-type
@@ -252,6 +330,8 @@ where @racket[foldl-map] is defined as:
 
 @chunk[<*>
        (require phc-toolkit
+                type-expander
+                phc-adt
                 (for-syntax racket/base
                             phc-toolkit/untyped
                             racket/syntax