[TESTS][LAMBDA] Add union types; fix on subtyping

tests/lambda/GRAMMAR

@@ -30,7 +30,6 @@ branches = (* empty *)
 
 id = [a-z_][A-Za-z0-9_]*
 
-(* TODO: Add union types *)
 type_id = [A-Z][A-Za-z0-9_]*
 | "'"[A-Z][A-Za-z0-9_]*
 | "[" complex_type_id "]"
@@ -38,7 +37,10 @@ type_id = [A-Z][A-Za-z0-9_]*
 
 complex_type_id = [A-Z][A-Za-z0-9_]*
 | "'"[A-Z][A-Za-z0-9_]*
-| complex_type_id * complex_type_id
+| complex_type_id "*" complex_type_id
+| complex_type_id "|" complex_type_id
+| complex_type_id "&" complex_type_id
+| "!" complex_type_id
 | complex_type_id -> complex_type_id
 | "[" complex_type_id "]"
 | "(" complex_type_id ")"

tests/lambda/src/compute.ml

@@ -21,6 +21,9 @@ let rec type_of_ptype arg = match arg with
   | Type(t) -> type_of_string t
   | PType(t) -> any (* TODO: Check this solution *)
   | TPair(t1, t2) -> times (cons (type_of_ptype t1)) (cons (type_of_ptype t2))
+  | TUnion(t1, t2) -> cup (type_of_ptype t1) (type_of_ptype t2)
+  | TInter(t1, t2) -> cap (type_of_ptype t1) (type_of_ptype t2)
+  | TNot(t) -> neg (type_of_ptype t)
   | TArrow(t1, t2) -> arrow (cons (type_of_ptype t1)) (cons (type_of_ptype t2))
   | TSeq(t) -> Sequence.star (type_of_ptype t)
 
@@ -169,16 +172,16 @@ and parse_match_value env l list p toptype = match p with
     let d1 = any, list, Patterns.Capture(lsize, mname) in
     let t2 = type_of_ptype mtype in
     let d2 = t2, [], Patterns.Constr(t2) in
-    t2, Patterns.Cap(d1, d2), list, l, Types.subtype (type_of_ptype toptype) t2
+    t2, Patterns.Cap(d1, d2), list, l, Types.subtype t2 (type_of_ptype toptype)
   | MInt (_, i) ->
     let t = constant (Integer(big_int_of_int i)) in
-    t, Patterns.Constr(t), list, l, Types.subtype (type_of_ptype toptype)
-      (type_of_string "Int")
+    t, Patterns.Constr(t), list, l, Types.subtype (type_of_string "Int")
+      (type_of_ptype toptype)
   | MString (_, s) ->
     let t = constant (String(0, String.length s - 1, s,
 			     Integer(big_int_of_int 0))) in
-    t, Patterns.Constr(t), list, l, Types.subtype (type_of_ptype toptype)
-      (type_of_string "String")
+    t, Patterns.Constr(t), list, l, Types.subtype (type_of_string "String")
+      (type_of_ptype toptype)
 
 let to_typed expr =
   let env, l, expr = _to_typed empty_toplevel Locals.empty expr in

tests/lambda/src/main.ml

@@ -118,6 +118,30 @@ let tests = "CDuce runtime tests" >:::
                      | el : [Int] -> el).[1; 2; 5; 4; 8; 7]");
     );
 
+    "union" >:: ( fun test_ctxt ->
+      assert_equal ~msg:"Test CDuce.runtime.union.identity failed"
+	~printer:(fun x -> x) "Abstraction(([ Char* ] | Int, [ Char* ] | Int))"
+	(run_test "fun f x : (Int | String) : (Int | String) -> x");
+      assert_equal ~msg:"Test CDuce.runtime.union.match failed"
+	~printer:(fun x -> x) "Abstraction(([ Char* ] | Int, [ Char* ] | Int))"
+	(run_test "fun f x : (Int | String) : (Int | String) ->
+                     match x : (Int | String) with
+                       | x : Int -> 2
+                       | x : String -> \"Piece of cake\"");
+      assert_equal ~msg:"Test CDuce.runtime.union.match_applied failed"
+	~printer:(fun x -> x) "2"
+	(run_test "(fun f x : (Int | String) : (Int | String) ->
+                      match x : (Int | String) with
+                        | x : Int -> 2
+                        | x : String -> \"Piece of cake\").5");
+      assert_equal ~msg:"Test CDuce.runtime.union.match_applied2 failed"
+	~printer:(fun x -> x) "\"Piece of cake\""
+	(run_test "(fun f x : (Int | String) : (Int | String) ->
+                      match x : (Int | String) with
+                        | x : Int -> 2
+                        | x : String -> \"Piece of cake\").\"test\"");
+    );
+
   ]
 
 let _ = run_test_tt_main tests

tests/lambda/src/parse.ml

@@ -21,6 +21,9 @@ and ptype =
   | Type of string
   | PType of string
   | TPair of ptype * ptype
+  | TUnion of ptype * ptype
+  | TInter of ptype * ptype
+  | TNot of ptype
   | TArrow of ptype * ptype
   | TSeq of ptype
 
@@ -78,6 +81,9 @@ module ExprParser = struct
 		     | [ "'"; t = UIDENT -> PType(t) ]
 		     | [ t1 = SELF; "*"; t2 = SELF -> TPair(t1, t2)
 		       | t1 = SELF; "->"; t2 = SELF -> TArrow(t1, t2) ]
+		     | [ t1 = SELF; "|"; t2 = SELF -> TUnion(t1, t2)
+		       | t1 = SELF; "&"; t2 = SELF -> TInter(t1, t2) ]
+		     | [ "!"; t = SELF -> TNot(t) ]
 		     | [ "["; t = complex_type_id; "]" -> TSeq(t) ]];
 
     END;;

tests/lambda/src/parse.mli

@@ -20,6 +20,9 @@ and ptype =
   | Type of string
   | PType of string
   | TPair of ptype * ptype
+  | TUnion of ptype * ptype
+  | TInter of ptype * ptype
+  | TNot of ptype
   | TArrow of ptype * ptype
   | TSeq of ptype