From e8ab36d022f214747007d34245074f4b0687a6df Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= <georges.duperon@gmail.com>
Date: Mon, 9 Nov 2015 21:30:51 +0100
Subject: [PATCH] Finished writing rewrite-type.lp2.rkt . Fixes case 24.

---
 graph/graph/_examples_cond-abort.rkt |  60 +++++++++++++++
 graph/graph/rewrite-type.lp2.rkt     | 105 ++++++++++++++++++---------
 graph/lib/lib.rkt                    |  15 +---
 graph/lib/low.rkt                    |  18 +++++
 4 files changed, 152 insertions(+), 46 deletions(-)

diff --git a/graph/graph/_examples_cond-abort.rkt b/graph/graph/_examples_cond-abort.rkt
index 759258e..81acfb1 100644
--- a/graph/graph/_examples_cond-abort.rkt
+++ b/graph/graph/_examples_cond-abort.rkt
@@ -60,6 +60,66 @@
  '(a b c))
 
 
+(begin
+  (:
+   test1a
+   (→
+    (List (Pairof (List Symbol (Listof String)) String))
+    (List (Pairof (List Symbol (Listof Number)) Number))))
+  (define (test1a v)
+    (let-values (((temp2) (apply values v)))
+      (list
+       (let ((val-cache3 temp2))
+         (cons
+          (let-values (((Symbol5 temp6) (apply values (car val-cache3))))
+            (list Symbol5 (map (λ ((String9 : String)) (string-length String9)) temp6)))
+          (string-length (cdr val-cache3))))))))
+
+
+
+(begin
+  (:
+   test1
+   (→
+    (List
+     (Pairof
+      (U
+       (List 'tag1 (List (Vector Symbol) (Listof String)))
+       (List 'tag2 (List (Vector Symbol) (Listof String))))
+      String))
+    (List
+     (Pairof
+      (U
+       (List 'tag1 (List (Vector Symbol) (Listof Number)))
+       (List 'tag2 (List (Vector Symbol) (Listof Number))))
+      Number))))
+  (define (test1 v)
+    (let-values (((temp2) (apply values v)))
+      (list
+       (let ((val-cache3 temp2))
+         (cons
+          (let ((val-cache4 (car val-cache3)))
+            (cond
+             ((and (list? val-cache4) (eq? 'tag1 (car val-cache4)))
+              (let-values (((temp6 temp7) (apply values val-cache4)))
+                (list
+                 temp6
+                 (let-values (((temp10 temp11) (apply values temp7)))
+                   (list
+                    (let ((val-cache12 temp10))
+                      (let ((Symbol13 (vector-ref val-cache12 0))) (vector Symbol13)))
+                    (map (λ ((String16 : String)) (string-length String16)) temp11))))))
+             ((and (list? val-cache4) (eq? 'tag2 (car val-cache4)))
+              (let-values (((temp20 temp21) (apply values val-cache4)))
+                (list
+                 temp20
+                 (let-values (((temp24 temp25) (apply values temp21)))
+                   (list
+                    (let ((val-cache26 temp24))
+                      (let ((Symbol27 (vector-ref val-cache26 0))) (vector Symbol27)))
+                    (map (λ ((String30 : String)) (string-length String30)) temp25))))))))
+          (string-length (cdr val-cache3))))))))
+
 #|
 (define-syntax-rule (map-abort lst v . body)
   #;(let ([l (foldl (λ (v acc)
diff --git a/graph/graph/rewrite-type.lp2.rkt b/graph/graph/rewrite-type.lp2.rkt
index 50c905e..cbfb093 100644
--- a/graph/graph/rewrite-type.lp2.rkt
+++ b/graph/graph/rewrite-type.lp2.rkt
@@ -14,38 +14,31 @@ For example, one could replace all strings in a data structure by their length:
        (define-syntax (make-replace stx)
          (syntax-case stx ()
            [(_ name type . replace)
-            (displayln (syntax->datum #`(begin
-                                          (: name (→ type #,(replace-in-data-structure #'type #'replace)))
-                                          (define (name v)
-                                            #,(replace-in-instance #'v #'type #'replace)))))
-            #'(list)]))
+            #`(begin
+                (: name (→ type #,(replace-in-data-structure #'type #'replace)))
+                (define (name v)
+                  #,(replace-in-instance #'v #'type #'replace)))]))
        
        (make-replace test1
-                     (List (Pairof (List Symbol (Listof String)) String))
+                     (List (Pairof (U (List 'tag1 (List (Vector Symbol)
+                                                        Number
+                                                        (Listof String)))
+                                      (List 'tag2 (List (Vector Symbol)
+                                                        Number
+                                                        (Listof String))))
+                                   String))
                      [String Number string-length])
        
-       ;(test1 '((#(sym ("ab" "abc" "abcd")) . "a")))
-       
-       (begin-for-syntax 
-         #;(displayln
-            (syntax->datum
-             (replace-in-instance #'v
-                                  #'(List (Pairof (Vector Symbol
-                                                          (Vectorof String))
-                                                  String))
-                                  #'([String Number string-length]))))
-         (displayln
-          (syntax->datum
-           (replace-in-instance #'v
-                                #'(List Symbol String)
-                                #'([String Number string-length])))))
-       (define-syntax (string→number stx)
-         #`(define-type new-t
-             #,(replace-in-data-structure
-                #'(List (Pairof (Vector Symbol (Vectorof String)) String))
-                #'([String Number string-length]))))
-       
-       (string→number)]
+       (check-equal?
+        (ann (test1 '(((tag2 (#(sym) 7 ("ab" "abc" "abcd"))) . "a")))
+             (List (Pairof (U (List 'tag1 (List (Vector Symbol)
+                                                Number
+                                                (Listof Number)))
+                              (List 'tag2 (List (Vector Symbol)
+                                                Number
+                                                (Listof Number))))
+                           Number)))
+        '(((tag2 (#(sym) 7 (2 3 4))) . 1)))]
 
 @CHUNK[<replace-in-data-structure>
        (define-for-syntax (replace-in-data-structure t r)
@@ -68,13 +61,18 @@ For example, one could replace all strings in a data structure by their length:
             #`(Vectorof #,(recursive-replace #'a))]
            [((~literal U) a ...)
             #`(U #,@(stx-map recursive-replace #'(a ...)))]
+           [((~literal quote) a)
+            ;; TODO: if the quoted type is a primitive, we should replace it too
+            #`(quote a)]
            [x:id #'x]))]
 
-@CHUNK[<replace-in-instance_new>
+@CHUNK[<replace-in-instance>
        (define-for-syntax (replace-in-instance val t r)
          (define/with-syntax ([from to fun] ...) r)
+         <replace-in-union>
          (define (recursive-replace stx-val type)
            (define/with-syntax val stx-val)
+           (define/with-syntax (v-cache) (generate-temporaries #'(val-cache)))
            (syntax-parse type
              [x:id
               #:attr assoc-from-to (cdr-stx-assoc #'x
@@ -83,16 +81,57 @@ For example, one could replace all strings in a data structure by their length:
               #:with (to-type . to-fun) #'assoc-from-to
               (define/with-syntax (tmp) (generate-temporaries #'(x)))
               ;; TODO: Add predicate for to-type in the pattern.
-              #`(match-abort val [(and tmp) (protected (to-fun tmp))])]
+              #`(to-fun val)]
              [((~literal List) a ...)
               (define/with-syntax (tmp ...) (generate-temporaries #'(a ...)))
               #`(let-values ([(tmp ...) (apply values val)])
                   (list #,@(stx-map recursive-replace #'(tmp ...) #'(a ...))))]
-             ))
-         (recursive-replace val t r))]
+             [((~literal Pairof) a b)
+              #`(let ([v-cache val])
+                  (cons #,(recursive-replace #'(car v-cache) #'a)
+                        #,(recursive-replace #'(cdr v-cache) #'b)))]
+             [((~literal Listof) a)
+              (define/with-syntax (tmp) (generate-temporaries #'(a)))
+              #`(map (λ ([tmp : a]) #,(recursive-replace #'tmp #'a))
+                     val)]
+             [((~literal Vector) a ...)
+              (define/with-syntax (tmp ...) (generate-temporaries #'(a ...)))
+              (define/with-syntax (idx ...) (generate-indices #'(a ...)))
+              #`(let ([v-cache val])
+                  (let ([tmp (vector-ref v-cache idx)]
+                        ...)
+                    (vector #,@(stx-map recursive-replace
+                                        #'(tmp ...)
+                                        #'(a ...)))))]
+             [((~literal Vectorof) a)
+              (define/with-syntax (tmp) (generate-temporaries #'(a)))
+              #`(vector-map (λ ([tmp : a]) #,(recursive-replace #'tmp #'a))
+                            val)]
+             [((~literal U) a ...)
+              #`(let ([v-cache val])
+                  (cond
+                    #,@(stx-map (λ (ta) (replace-in-union #'v-cache ta r))
+                                #'(a ...))))]
+             [((~literal quote) a)
+              #'val]
+             [x:id
+              #'val]))
+         (recursive-replace val t))]
+
+@CHUNK[<replace-in-union>
+       (define (replace-in-union stx-v-cache t r)
+         (define/with-syntax v-cache stx-v-cache)
+         (syntax-parse t
+           [(List ((~literal quote) tag:id) b ...)
+            <replace-in-tagged-union-instance>]
+           [_ (error "Type-replace on untagged Unions isn't supported yet!")]))]
+
+@CHUNK[<replace-in-tagged-union-instance>
+       #`[(and (list? v-cache) (eq? 'tag (car v-cache)))
+          #,(recursive-replace #'v-cache t)]]
 
 
-@CHUNK[<replace-in-instance>
+@CHUNK[<replace-in-instance_old>
        (define-for-syntax (replace-in-instance val t r)
          (define/with-syntax ([from to fun] ...) r)
          (define (recursive-replace stx-val type)
diff --git a/graph/lib/lib.rkt b/graph/lib/lib.rkt
index e382012..2f298c1 100644
--- a/graph/lib/lib.rkt
+++ b/graph/lib/lib.rkt
@@ -6,7 +6,7 @@
 ;; Types
 (provide AnyImmutable)
 ;; Functions
-(provide ∘ eval-get-values generate-indices)
+(provide ∘ eval-get-values)
 ;; Macros
 (provide mapp comment)
 
@@ -139,15 +139,4 @@
                                      body ...)
                                    result))
                        (set! l (cdr l))))))))]))
-(: generate-indices (∀ (T) (case→ (→ Integer (Syntax-Listof T) (Listof Integer))
-                                  (→ (Syntax-Listof T) (Listof Nonnegative-Integer)))))
-(define generate-indices
-  (case-lambda
-    [(start stx)
-     (for/list ([v (my-in-syntax stx)]
-                [i (in-naturals start)])
-       i)]
-    [(stx)
-     (for/list ([v (my-in-syntax stx)]
-                [i : Nonnegative-Integer (ann (in-naturals) (Sequenceof Nonnegative-Integer))])
-       i)]))
\ No newline at end of file
+
diff --git a/graph/lib/low.rkt b/graph/lib/low.rkt
index 96c1688..5abc736 100644
--- a/graph/lib/low.rkt
+++ b/graph/lib/low.rkt
@@ -535,4 +535,22 @@
   (let ((res (stx-assoc id alist)))
     (if res (cdr res) #f)))
 
+;; ==== generate-indices ====
+
+(: generate-indices (∀ (T) (case→ (→ Integer (Syntax-Listof T) (Listof Integer))
+                                  (→ (Syntax-Listof T) (Listof Nonnegative-Integer)))))
+
+(provide generate-indices)
+
+(define generate-indices
+  (case-lambda
+    [(start stx)
+     (for/list ([v (my-in-syntax stx)]
+                [i (in-naturals start)])
+       i)]
+    [(stx)
+     (for/list ([v (my-in-syntax stx)]
+                [i : Nonnegative-Integer (ann (in-naturals) (Sequenceof Nonnegative-Integer))])
+       i)]))
+
 ;; ==== end ====
\ No newline at end of file