www

commit 36ae2e8080168e0dbd937be4e82a16d24161f26e
parent a0d682cb6ce9986108cddad36a313e3b4cde92a2
Author: Georges Dupéron <georges.duperon@gmail.com>
Date:   Thu,  6 Apr 2017 10:40:37 +0200

Cleaned up tests

Diffstat:
M
invariants-phantom.hl.rkt
 | 
4
+++-
M
test/invariant-phantom/simple.rkt
 | 
46
++++++++++++++++++++++++++++++++++++++++------
M
test/invariant-phantom/util.rkt
 | 
17
++++++++++++++---

3 files changed, 57 insertions(+), 10 deletions(-)
diff --git a/invariants-phantom.hl.rkt b/invariants-phantom.hl.rkt
@@ -612,7 +612,9 @@ Two sorts of paths inside (in)equality constraints:
                 NonTarget
                 ε
                 witness-value
-                (for-syntax parse-path))
+                (for-syntax parse-path)
+                AnyType
+                AnyField)
 
        <parse>
 
diff --git a/test/invariant-phantom/simple.rkt b/test/invariant-phantom/simple.rkt
@@ -9,13 +9,47 @@
   (syntax-case stx ()
     [(_ . π)
      (parse-path #'π)]))
-(eval #'(#%top-interaction . (:type (Π (λdot a aa) ((λdot b c))* (λdot d e))))
-      (variable-reference->namespace (#%variable-reference)))
+
+(check-same-type
+ (Π (λdot a aa) ((λdot b c))* (λdot d e))
+ (Rec
+  R
+  (U (Pairof Any R)
+     (Pairof
+      (Pairof 'a AnyType)
+      (Pairof
+       (Pairof 'aa AnyType)
+       (Rec
+        R
+        (U (Pairof
+            (Pairof 'b AnyType)
+            (Pairof (Pairof 'c AnyType) R))
+           (List (Pairof 'd AnyType) (Pairof 'e AnyType)))))))))
 (struct a ()); the field.
-(eval #'(#%top-interaction . (:type (Π (dot :a aa) ((λdot b c))* (λdot d e))))
-      (variable-reference->namespace (#%variable-reference)))
-(eval #'(#%top-interaction . (:type (Π (dot :a) ((λdot b c))* (λdot d e))))
-      (variable-reference->namespace (#%variable-reference)))
+(check-same-type
+ (Π (dot :a aa) ((λdot b c))* (λdot d e))
+ (Rec
+  R
+  (U (Pairof Any R)
+     (Pairof
+      (Pairof AnyField a)
+      (Pairof
+       (Pairof 'aa AnyType)
+       (Rec
+        R
+        (U (List (Pairof 'd AnyType) (Pairof 'e AnyType))
+           (Pairof (Pairof 'b AnyType) (Pairof (Pairof 'c AnyType) R)))))))))
+(check-same-type
+ (Π (dot :a) ((λdot b c))* (λdot d e))
+ (Rec
+  R
+  (U (Pairof Any R)
+     (Pairof
+      (Pairof AnyField a)
+      (Rec
+       R
+       (U (List (Pairof 'd AnyType) (Pairof 'e AnyType))
+          (Pairof (Pairof 'b AnyType) (Pairof (Pairof 'c AnyType) R))))))))
 
 #|
 
diff --git a/test/invariant-phantom/util.rkt b/test/invariant-phantom/util.rkt
@@ -1,7 +1,8 @@
 #lang type-expander
 
 (provide check-a-same-as-b
-         check-a-stronger-than-b)
+         check-a-stronger-than-b
+         check-same-type)
 
 (require phc-toolkit
          (lib "phc-graph/invariants-phantom.hl.rkt")
@@ -22,4 +23,14 @@
      (syntax/top-loc stx
        (begin
          (check-ann (ann witness-value a) b)
-         (check-ann (ann witness-value b) a)))]))
-\ No newline at end of file
+         (check-ann (ann witness-value b) a)))]))
+
+(define-syntax (check-same-type stx)
+  (syntax-case stx ()
+    [(_ a b)
+     (syntax/top-loc stx
+       (begin
+         (check-not-exn:
+          (λ () (λ ([x : a]) (check-ann x b))))
+         (check-not-exn:
+          (λ () (λ ([x : b]) (check-ann x a))))))]))
+\ No newline at end of file