Add the red-black tree test case (works until deletion which does not type).

lang/typing/patterns.ml

@@ -1154,13 +1154,7 @@ module Compile = struct
             aux success (Types.diff t ty) rem
     in
     aux [] t tests;
-    List.map
-      (fun (t, a) ->
-        let ct = (* TODO CHECK THAT THIS IS CORRECT W.R.T static semantics. *)
-          Types.Subst.clean_type ~pos:Types.any ~neg:Types.empty Var.Set.empty t
-        in
-        (ct, a))
-      !accu
+    !accu
 
   let get_tests facto pl f t d post =
     let pl = Array.map (List.map f) pl in

tests/full/good/dune.auto

@@ -54,6 +54,14 @@
 (rule (alias poly-ok) (action (diff poly-ok.exp poly-ok.out)))
 ; end: poly-ok.cd
 
+; begin: red-black.cd
+(rule (deps red-black.cd) (target red-black.cdo)
+   (action (ignore-outputs (with-accepted-exit-codes 0 (run cduce --compile  %{deps})))))
+(rule (deps red-black.cdo) (target red-black.out)
+   (action (ignore-stderr (with-stdout-to %{target} (with-accepted-exit-codes 0 (run cduce --run  %{deps}))))))
+(rule (alias red-black) (action (diff red-black.exp red-black.out)))
+; end: red-black.cd
+
 ; begin: web_site.cd
 (rule (deps web_site.cd) (target web_site.cdo)
    (action (ignore-outputs (with-accepted-exit-codes 0 (run cduce --compile  %{deps})))))
@@ -72,5 +80,6 @@
     (alias overloading)
     (alias patricia)
     (alias poly-ok)
+    (alias red-black)
     (alias web_site)
 ))

old/tests/poly/red-black.cd → tests/full/good/red-black.cd

@@ -20,7 +20,7 @@ type Unbalanced('a) = <black elem='a>( [ Wrongtree ('a) RBtree('a) ]
 
 ************)
 
-let balance ( Unbalanced('a) -> Rtree('a) ; 'b \Unbalanced('a) -> 'b\Unbalanced('a) )
+let balance ( Unbalanced('a) -> Rtree('a) ; ('b \Unbalanced(Any)) -> ('b\Unbalanced(Any)) )
   | <black (z)>[ <red (y)>[ <red (x)>[ a b ] c ] d ]
   | <black (z)>[ <red (x)>[ a <red (y)>[ b c ] ] d ]
   | <black (x)>[ a <red (z)>[ <red (y)>[ b c ] d ] ]
@@ -92,69 +92,80 @@ let insert (x : 'a) (t : Btree('a)) : Btree('a)\[]=
                 Rtree('a) -> Rtree('a)|Wrongtree('a) )
     | [] -> <red elem=x>[ [] [] ]
     | (<(color) elem=y>[ a b ]) & z ->
-           if x << y then balance <(color) elem=y>[ (ins_aux a) b ]
+           if x << y then 
+           balance <(color) elem=y>[ (ins_aux a) b ]
 	   else if x >> y then balance <(color) elem=y>[ a (ins_aux b) ]
 	   else z
     in match ins_aux t with
        | <_ (y)>[ a b ] -> <black (y)>[ a b ]
 ;;
-/*
+
 let is_empty ([] -> `true; Any \ [] -> `false)  (*better type (Any\[] -> `false ; [] ->`true ) *)
   | [] -> `true
   | _ -> `false
 
 
-let member (x : 'a) (t : RBtree('a)) : Bool =
-(* better type: 'a -> ([] -> `false) & (RBtree('a) -> Bool) *) 
+
+let iter (f : 'a -> []) (t : RBtree('a)) : [] =
   match t with
-   | [] -> `false
-   | <_ elem=y>[ left right ] ->
-       (y = x) || ( member x (if x<<y then left else right) ) 
+    [] -> []
+  | < _ elem=x>[t1 t2] ->  iter f t1;f x; iter f t2
+;;
+
+let member 
+    ('a -> [] -> `false; 'a -> RBtree ('a) -> Bool) x ->
+    (fun ([] -> `false; RBtree ('a) -> Bool)
+        [] -> `false
+        | <_ elem=y>[ left right ] ->
+       (y = x) || ( member x (if x<<y then left else right))) 
 
 
 let singleton (x : 'a): Btree('a)  = <black elem=x>[ [] [] ]
 
 
-let cardinal ( RBtree('a) -> Int )   (* better type: [] -> 0, Any\[] -> [1--*] *)
+let cardinal ([] -> 0; RBtree('a) \ [] -> 1--*)
   | [] -> 0
   | <_ ..>[ l r ] -> cardinal l + cardinal r + 1
 
+/*
+
 (* The though case: deletion *)
 
 
    (* remove the rightmost leave of the tree and return a flag to state
       whether the resulting tree decreased the the depth of black nodes *)
       
-   let remove_min (RBtree('a)\[] -> [RBtree('a) Bool 'a])
-       (* black leaf: remove it and flag the depth decrease *)
-     | <black elem=x>[ [] [] ] ->                 
-          [ [] `true x ]
-       (* black node with red child: promote the child to black *)
-     | <black elem=x>[ ([] <red elem=y>[ l r ])
-                     | (<red elem=y>[ l r ] [] )] ->
-          [ <black elem=y>[ l r ] `false x ]
-       (* you cannot have a red node with one empty sibling *)  
-     | <black elem=Any>[ ([] <red ..>Any)
-                     | (<red ..>Any []) ] ->
-          raise "impossible"
-       (* red node with at least on empty child : remove it without any flag *)
-     | <red elem=x>[ ([] n) | (n []) ] ->
-          [ n `false x ]
-       (* general case of a node with two non empty childs *)
-     | <(c) elem=x>[ l\[] r\[] ] ->
-         let [ ll d e ] = remove_min l in
-	 let tree = <(c) elem=x>[ ll r ] in
-	 if d then
-            (bubble_left tree)@[e]
-	 else
-	    [ tree `false e ]
-     | _ -> raise "impossible"
-
-   let blackify( (<_ ('a)>'b)  -> <black ('a)>'b )
-     | <_ (x)>y -> <black (x)>y
-
-   let redify( (<_ ('a)>'b)  -> <red ('a)>'b )
-     | <_ (x)>y -> <red (x)>y
+let remove_min (RBtree('a)\[] -> [RBtree('a) Bool 'a])
+      (* black leaf: remove it and flag the depth decrease *)
+    | <black elem=x>[ [] [] ] ->                 
+        [ [] `true x ]
+      (* black node with red child: promote the child to black *)
+    | <black elem=x>[ ([] <red elem=y>[ l r ])
+                    | (<red elem=y>[ l r ] [] )] ->
+        [ <black elem=y>[ l r ] `false x ]
+      (* you cannot have a red node with one empty sibling *)  
+    | <black elem=Any>[ ([] <red ..>Any)
+                    | (<red ..>Any []) ] ->
+        raise "impossible"
+      (* red node with at least on empty child : remove it without any flag *)
+    | <red elem=x>[ ([] n) | (n []) ] ->
+        [ n `false x ]
+      (* general case of a node with two non empty childs *)
+    | <(c) elem=x>[ l\[] r\[] ] ->
+        let [ ll d e ] = remove_min l in
+  let tree = <(c) elem=x>[ ll r ] in
+  if d then
+          (bubble_left tree)@[e]
+  else
+    [ tree `false e ]
+    | _ -> raise "impossible"
+
+
+let blackify( (<_ ('a)>'b)  -> <black ('a)>'b )
+  | <_ (x)>y -> <black (x)>y
+
+let redify( (<_ ('a)>'b)  -> <red ('a)>'b )
+  | <_ (x)>y -> <red (x)>y
 
 
 
@@ -209,4 +220,13 @@ let remove(x : 'a)(t : RBtree('a) ) : RBtree('a) =
 		  if d then bubble_left tree else (tree, `false)
    in
    let (sol,_) = remove_aux t in sol
-   */
+*/
+
+
+let [] = 
+  let t = ref (Btree(Int)) [] in
+  let [] =
+    transform [ 100 10 1 300 4 24424 17 ] with
+             x -> t := insert x !t 
+  in
+  iter (fun (Int -> []) x -> print [ !(string_of x) '\n']) !t

tests/full/good/red-black.exp

+1
+4
+10
+17
+100
+300
+24424