www

commit 88102c7263afb6c4a020a6468eed953e5c14f286
parent 48625734536e0db8264d85b7356d08e754f1a36d
Author: Georges Dupéron <georges.duperon@gmail.com>
Date:   Tue,  4 Oct 2016 13:23:37 +0200

Union of two tagged structures works

Diffstat:
M
dispatch-union.rkt
 | 
47
++++++++++++++++++++++++++++-------------------
M
test/adt-pre-declarations.rkt
 | 
1
+
M
test/test-traversal-2.rkt
 | 
25
++++++++++++++++++++++++-
M
traversal.hl.rkt
 | 
17
++++++++++++-----

4 files changed, 65 insertions(+), 25 deletions(-)
diff --git a/dispatch-union.rkt b/dispatch-union.rkt
@@ -1,24 +1,33 @@
 #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))
+         phc-adt
+         (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))
+
+(provide dispatch-union)
 
 (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 …)))
-\ No newline at end of file
+  ((λ (x) (local-require racket/pretty) #;(pretty-write (syntax->datum x)) x)
+   #`(cond
+       . #,(stx-map
+            (λ (X v result)
+              (syntax-parse X
+                #:literals (tagged)
+                [(tagged name [fieldᵢ (~optional :colon) typeᵢ] …)
+                 #`[((tagged? name fieldᵢ …) #,v) #,result]]
+                [other (raise-syntax-error 'graph
+                                           "Unhandled union type"
+                                           #'other)]))
+            #'(X …)
+            #'(v …)
+            #'(result …)))))
+\ No newline at end of file
diff --git a/test/adt-pre-declarations.rkt b/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))
diff --git a/test/test-traversal-2.rkt b/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)
+\ No newline at end of file
diff --git a/traversal.hl.rkt b/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