Fix a subtle bug in Positive.decompose (for some complex recursive types,

Positive.solve(Positive.decompose t) was not the identity but added spurious types at toplevel.

Added more test cases in poly-ok.cd to cover such regressions

tests/poly/poly-ok.cd

@@ -37,7 +37,8 @@ max 42;;
 
 let f (_ : ('a | 'b | 'c)) (_ : (Int&'d&'e \1--3 )) : Any = raise "123";;
 
-let x = id even (even mmap) even;; (* same type as map_even *)
+let e = (even mmap) ;;
+let x = id (even (e even));; (* same type as map_even *)
 
 let twisted = id even (even mmap) even (mmap max [1 2 3 4 5 6]);;
 
@@ -62,4 +63,5 @@ let f ( x : B('a) ) : 'a =
 ;;
 
 let v = f <b>[<b>[<a>32]]
-;;
\ No newline at end of file
+;;
+

types/types.ml

@@ -2688,8 +2688,13 @@ module Positive = struct
   let ty d = cons (`Type d)
   let var d = cons (`Variable d)
   let neg v = cons (`Neg v)
-  let cup = function [ v ] -> v | vl -> cons (`Cup vl)
-  let cap vl = cons (`Cap vl)
+  let cup vl =
+    match vl with
+      [ v ] -> v
+    | _ -> cons (`Cup vl)
+  let cap vl = match vl with
+      [ v ] -> v
+    | _ -> cons (`Cap vl)
   let times v1 v2 = cons (`Times (v1,v2))
   let arrow v1 v2 = cons (`Arrow (v1,v2))
   let xml v1 v2 = cons (`Xml (v1,v2))
@@ -2702,7 +2707,7 @@ module Positive = struct
 
   let decompose t =
     let memo = DescrHash.create 17 in
-    let decompose_conj acc f_atom sign ilist acc =
+    let decompose_conj f_atom sign ilist acc =
       List.fold_left (fun acc e ->
         let ne = f_atom e in
         (sign ne) :: acc
@@ -2710,11 +2715,16 @@ module Positive = struct
     in
     let decompose_dnf t_any f_atom dnf acc =
       List.fold_left (fun acc (ipos, ineg) ->
-        let lacc = decompose_conj [] f_atom neg ineg in
-        let lacc = decompose_conj lacc f_atom (fun x -> x) ipos [t_any] in
-        match lacc with
-        | [v] -> v::acc
-        | l -> (cap l) :: acc) acc dnf
+          let lacc = match ipos,ineg with
+              [],[] -> [t_any]
+            |  _ -> []
+          in
+          let lacc = decompose_conj f_atom neg ineg lacc in
+          let lacc = decompose_conj f_atom (fun x -> x) ipos lacc in
+          match lacc with
+          | [] -> t_any::acc
+          | [v] -> v::acc
+          | l -> (cap l) :: acc) acc dnf
     in
     let or_var f = function
       |`Var x -> var x
@@ -2745,20 +2755,25 @@ module Positive = struct
         let node_t = forward () in
         if no_var t then ty t
         else
-          let () = DescrHash.add memo t node_t in
-          let descr_t =
-            decompose_kind Atom.any atom (BoolAtoms.get t.atoms)
-            @@ decompose_kind Int.any interval (BoolIntervals.get t.ints)
-            @@ decompose_kind Char.any char (BoolChars.get t.chars)
-            @@ decompose_bdd Product.any times (BoolPair.get t.times)
-            @@ decompose_bdd Product.any_xml xml (BoolPair.get t.xml)
-            @@ decompose_bdd Arrow.any arrow (BoolPair.get t.arrow)
-            @@ decompose_rec Record.any record (BoolRec.get t.record)
-            @@ decompose_kind Abstract.any abstract (BoolAbstracts.get t.abstract) []
-          in
-          node_t.def <- (cup descr_t).def; node_t
-    in
-    decompose_type t
+          match check_var t with
+            `Pos v -> var v
+          | `Neg v -> neg (var v)
+          | `NotVar ->
+            let () = DescrHash.add memo t node_t in
+            let descr_t =
+              decompose_kind Atom.any atom (BoolAtoms.get t.atoms)
+              @@ decompose_kind Int.any interval (BoolIntervals.get t.ints)
+              @@ decompose_kind Char.any char (BoolChars.get t.chars)
+              @@ decompose_bdd Product.any times (BoolPair.get t.times)
+              @@ decompose_bdd Product.any_xml xml (BoolPair.get t.xml)
+              @@ decompose_bdd Arrow.any arrow (BoolPair.get t.arrow)
+              @@ decompose_rec Record.any record (BoolRec.get t.record)
+              @@ decompose_kind Abstract.any abstract (BoolAbstracts.get t.abstract) []
+            in
+            node_t.def <- (cup descr_t).def; node_t
+
+      in
+      decompose_type t
 
   let solve v = internalize (make_node v)