First draft for define-fold, all tests pass.

free-identifier-tree-equal.rkt

@@ -0,0 +1,29 @@
+#lang racket
+
+(require racket/struct)
+
+(provide free-identifier-tree=?)
+
+(define (free-identifier-tree=? a b)
+  (define rec=? free-identifier-tree=?)
+  (cond
+    [(identifier? a) (and (identifier? b)
+                          (free-identifier=? a b))]
+    [(syntax? a) (and (syntax? b)
+                      (rec=? (syntax-e a)
+                             (syntax-e b)))]
+    [(pair? a) (and (pair? b)
+                    (rec=? (car a) (car b))
+                    (rec=? (cdr a) (cdr b)))]
+    [(vector? a) (and (vector? b)
+                      (rec=? (vector->list a)
+                             (vector->list b)))]
+    [(box? a) (and (box? b)
+                   (rec=? (unbox a)
+                          (unbox b)))]
+    [(prefab-struct-key a)
+     => (λ (a-key)
+          (let ([b-key (prefab-struct-key b)])
+            (and (equal? a-key b-key)
+                 (rec=? (struct->list a)
+                        (struct->list b)))))]))

test/test-traversal-1.rkt

@@ -3,20 +3,62 @@
 (require "../traversal.hl.rkt"
          "ck.rkt")
 
-(define-fold f₁ t₁ Null String)
+(define-type Foo (Listof String))
-;(define-fold f₂ t₂ (Pairof Null Null) String)
-;(define-fold f₃ t₃ String String)
-;(define-fold f₄ t₄ (Pairof Null String) String)
 
-(define f₁-string->symbol
+(define-fold f₁ t₁ Null String)
-  (f₁ string?
+(define-fold f₂ t₂ (Pairof Null Null) String)
-      (λ ([x : String] [acc : Integer])
+(define-fold f₃ t₃ String String)
-        (values (string->symbol x) acc))))
+(define-fold f₄ t₄ (Pairof Null String) String)
-(check-equal?-values: (f₁-string->symbol '() 0)
+(define-fold f₅ t₅ (Listof Null) String)
+(define-fold f₆ t₆ (List Null (Pairof Null Null) Null) String)
+(define-fold f₇ t₇ (Listof String) String)
+(define-fold f₈ t₈ (List String Foo (Listof String)) String)
+
+(define (string->symbol+acc [x : String] [acc : Integer])
+  (values (string->symbol x) (add1 acc)))
+
+(check-equal?-values: ((f₁ string? string->symbol+acc) '() 0)
                       '() 0)
 
-(check-equal?-values: (f₁-string->symbol '() 0)
+(check-equal?-values: ((f₁ string? string->symbol+acc) '() 0)
                       : (Values Null Integer)
                       '() 0)
 
+(check-equal?-values: ((f₂ string? string->symbol+acc) '(() . ()) 0)
+                      : (Values (Pairof Null Null) Integer)
+                      '(() . ()) 0)
 
+(check-equal?-values: ((f₃ string? string->symbol+acc) "abc" 0)
+                      : (Values Symbol Integer)
+                      'abc 1)
+
+(check-equal?-values: ((f₄ string? string->symbol+acc) '(() . "def") 0)
+                      : (Values (Pairof Null Symbol) Integer)
+                      '(() . def) 1)
+
+(check-equal?-values: ((f₅ string? string->symbol+acc) '(() () () ()) 0)
+                      : (Values (Listof Null) Integer)
+                      '(() () () ()) 0)
+
+(check-equal?-values: ((f₅ string? string->symbol+acc) '(()) 0)
+                      : (Values (Listof Null) Integer)
+                      '(()) 0)
+
+(check-equal?-values: ((f₅ string? string->symbol+acc) '() 0)
+                      : (Values (Listof Null) Integer)
+                      '() 0)
+
+(check-equal?-values: ((f₆ string? string->symbol+acc) '(() (() . ()) ()) 0)
+                      : (Values (List Null (Pairof Null Null) Null) Integer)
+                      '(() (() . ()) ()) 0)
+
+(check-equal?-values: ((f₇ string? string->symbol+acc) '("abc" "def" "ghi") 0)
+                      : (Values (Listof Symbol) Integer)
+                      '(abc def ghi) 3)
+
+(check-equal?-values: ((f₈ string? string->symbol+acc) '("abc" ("def" "ghi")
+                                                               ("jkl" "mno"))
+                                                       0)
+                      : (Values (List Symbol (Listof String) (Listof Symbol))
+                                Integer)
+                      '(abc ("def" "ghi") (jkl mno)) 3)

traversal.hl.rkt

@@ -139,19 +139,98 @@ way up, so that a simple identity function can be applied in these cases.
        (define-temp-ids "Aᵢ" (type-to-replaceᵢ …))
        (define-temp-ids "Bᵢ" (type-to-replaceᵢ …))
        (define-temp-ids "predicateᵢ" (type-to-replaceᵢ …))
-       (define-temp-ids "updateᵢ" (type-to-replaceᵢ …))]
+       (define-temp-ids "updateᵢ" (type-to-replaceᵢ …))
+
+       (define/with-syntax args (template ({?@ predicateᵢ updateᵢ} …)))]
 
 @chunk[<define-fold-prepare>
-       (define/with-syntax (the-type the-code the-defs …)
+       (type-cases
-         (syntax-parse #'whole-type
+        (whole-type => the-type the-code the-defs …)
-           #:literals (Null Pairof Listof List Vectorof Vector)
+        #:literals (Null Pairof Listof List Vectorof Vector)
-           [Null #'(Null (values v acc))]
+        <type-cases>)]
-           [(Pairof X Y)
+
-            #'(Null
+@chunk[<type-cases>
-               (values v acc)
+       [t
-               (define-fold fx tx X type-to-replaceᵢ …)
+        #:with info (findf (λ (r) (free-identifier-tree=? #'t (stx-car r)))
-               (define-fold fy ty Y type-to-replaceᵢ …))]
+                           (syntax->list #'([type-to-replaceᵢ updateᵢ Tᵢ] …)))
-           [#t #'((Pairof Any Any) (void))]))]
+        #:when (attribute info)
+        #:with (_ update T) #'info
+        => T
+        (update v acc)]]
+
+@chunk[<type-cases>
+       [(~or Null (List))
+        => Null
+        (values v acc)]]
+
+@chunk[<type-cases>
+       [(Pairof X Y)
+        => (Pairof (tx Tᵢ …) (ty Tᵢ …))
+        (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))
+        (define-fold fx tx X type-to-replaceᵢ …)
+        (define-fold fy ty Y type-to-replaceᵢ …)]]
+
+@chunk[<type-cases>
+       [(Listof X)
+        => (Listof (te Tᵢ …))
+        (foldl-map (fe . args) acc v)
+        (define-fold fe te X type-to-replaceᵢ …)]]
+
+@chunk[<type-cases>
+       [(Vectorof X)
+        => (Vectorof (te Tᵢ …))
+        (vector->immutable-vector
+         (list->vector
+          (foldl-map (fe . args) acc (vector->list v))))
+        (define-fold fe te X type-to-replaceᵢ …)]]
+
+@chunk[<type-cases>
+       [(List X Y ...)
+        => (Pairof (tx Tᵢ …) (ty* Tᵢ …))
+        (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*))
+        (define-fold fx tx X type-to-replaceᵢ …)
+        (define-fold fy* ty* (List Y ...) type-to-replaceᵢ …)]]
+
+@chunk[<type-cases>
+       [else-T
+        => else-T
+        (values v acc)]]
+
+where @racket[foldl-map] is defined as:
+
+@chunk[<foldl-map>
+       (: foldl-map (∀ (A B Acc) (→ (→ A Acc (Values B Acc))
+                                    Acc
+                                    (Listof A)
+                                    (Values (Listof B) Acc))))
+       (define (foldl-map f acc l)
+         (if (null? l)
+             (values l
+                     acc)
+             (let*-values ([(v a) (f (car l) acc)]
+                           [(ll aa) (foldl-map f a (cdr l))])
+               (values (cons v ll)
+                       aa))))]
+
+@chunk[<type-cases-macro>
+       (define-syntax type-cases
+         (syntax-parser
+           #:literals (=>)
+           [(_ (whole-type => the-type the-code the-defs (~literal …))
+               #:literals (lit …)
+               (Pat opts … => transform-type transform-code transform-defs …)
+               …)
+            #'(define/with-syntax (the-type the-code the-defs (… …))
+                (syntax-parse #'whole-type
+                  #:literals (lit …)
+                  [Pat opts …
+                   (template
+                        (transform-type transform-code transform-defs …))]
+                  …))]))]
 
 @chunk[<define-fold-result>
        the-defs …
@@ -159,14 +238,14 @@ way up, so that a simple identity function can be applied in these cases.
        (define-type (type-name Tᵢ …) the-type)
 
        (: function-name (∀ (Aᵢ … Bᵢ … Acc)
-                           (→ (?@ (→ Any Boolean : Aᵢ)
+                           (→ {?@ (→ Any Boolean : Aᵢ)
-                                  (→ Aᵢ Acc (Values Bᵢ Acc)))
+        (→ Aᵢ Acc (Values Bᵢ Acc))}
                               …
                               (→ (type-name Aᵢ …)
                                  Acc
                                  (Values (type-name Bᵢ …)
                                          Acc)))))
-       (define ((function-name (?@ predicateᵢ updateᵢ) …) v acc)
+       (define ((function-name . args) v acc)
          the-code)]
 
 @section{Putting it all together}
@@ -178,7 +257,13 @@ way up, so that a simple identity function can be applied in these cases.
                             racket/syntax
                             syntax/parse
                             syntax/parse/experimental/template
-                            type-expander/expander))
+                            type-expander/expander
+                            "free-identifier-tree-equal.rkt")
+                (for-meta 2 racket/base)
+                (for-meta 2 phc-toolkit/untyped)
+                (for-meta 2 syntax/parse))
 
        (provide define-fold)
+       (begin-for-syntax <type-cases-macro>)
+       <foldl-map>
        <define-fold>]