1 files changed, 435 insertions, 0 deletions
diff --git a/ocaml-binary-annot/testlabl/varunion.ml b/ocaml-binary-annot/testlabl/varunion.ml
new file mode 100644
index 0000000000..30a410f22a
--- /dev/null
+++ b/ocaml-binary-annot/testlabl/varunion.ml
@@ -0,0 +1,435 @@
+(* cvs update -r varunion parsing typing bytecomp toplevel *)
+
+type t = private [> ];;
+type u = private [> ] ~ [t];;
+type v = [t | u];;
+let f x = (x : t :> v);;
+
+(* bad *)
+module Mix(X: sig type t = private [> ] end)
+    (Y: sig type t = private [> ] end) =
+  struct type t = [X.t | Y.t] end;;
+
+(* bad *)
+module Mix(X: sig type t = private [> `A of int ] end)
+    (Y: sig type t = private [> `A of bool] ~ [X.t] end) =
+  struct type t = [X.t | Y.t] end;;
+
+(* ok *)
+module Mix(X: sig type t = private [> `A of int ] end)
+    (Y: sig type t = private [> `A of int] ~ [X.t] end) =
+  struct type t = [X.t | Y.t] end;;
+
+(* bad *)
+module Mix(X: sig type t = private [> `A of int ] end)
+    (Y: sig type t = private [> `B of bool] ~ [X.t] end) =
+  struct type t = [X.t | Y.t] end;;
+
+type 'a t = private [> `L of 'a] ~ [`L];;
+
+(* ok *)
+module Mix(X: sig type t = private [> `A of int ] ~ [`B] end)
+    (Y: sig type t = private [> `B of bool] ~ [X.t] end) =
+  struct type t = [X.t | Y.t] let is_t = function #t -> true | _ -> false end;;
+
+module Mix(X: sig type t = private [> `A of int ] ~ [`B] end)
+    (Y: sig type t = private [> `B of bool] ~ [X.t] end) =
+  struct
+    type t = [X.t | Y.t]
+    let which = function #X.t -> `X | #Y.t -> `Y
+  end;;
+
+module Mix(I: sig type t = private [> ] ~ [`A;`B] end)
+    (X: sig type t = private [> I.t | `A of int ] ~ [`B] end)
+    (Y: sig type t = private [> I.t | `B of bool] ~ [X.t] end) =
+  struct
+    type t = [X.t | Y.t]
+    let which = function #X.t -> `X | #Y.t -> `Y
+  end;;
+
+(* ok *)
+module M =
+  Mix(struct type t = [`C of char] end)
+    (struct type t = [`A of int | `C of char] end)
+    (struct type t = [`B of bool | `C of char] end);;
+
+(* bad *)
+module M =
+  Mix(struct type t = [`B of bool] end)
+    (struct type t = [`A of int | `B of bool] end)
+    (struct type t = [`B of bool | `C of char] end);;
+
+(* ok *)
+module M1 = struct type t = [`A of int | `C of char] end
+module M2 = struct type t = [`B of bool | `C of char] end
+module I = struct type t = [`C of char] end
+module M = Mix(I)(M1)(M2) ;;
+
+let c = (`C 'c' : M.t) ;;
+
+module M(X : sig type t = private [> `A] end) = 
+  struct let f (#X.t as x) = x end;;
+
+(* code generation *)
+type t = private [> `A ] ~ [`B];;
+match `B with #t -> 1 | `B -> 2;;
+
+module M : sig type t = private [> `A of int | `B] ~ [`C] end =
+  struct type t = [`A of int | `B | `D of bool] end;;
+let f = function (`C | #M.t) -> 1+1 ;;
+let f = function (`A _ | `B #M.t) -> 1+1 ;;
+
+(* expression *)
+module Mix(X:sig type t = private [> ] val show: t -> string end)
+    (Y:sig type t = private [> ] ~ [X.t] val show: t -> string end) =
+  struct
+    type t = [X.t | Y.t]
+    let show : t -> string = function
+        #X.t as x -> X.show x
+      | #Y.t as y -> Y.show y
+  end;;
+
+module EStr = struct
+  type t = [`Str of string]
+  let show (`Str s) = s
+end
+module EInt = struct
+  type t = [`Int of int]
+  let show (`Int i) = string_of_int i
+end
+module M = Mix(EStr)(EInt);;
+
+module type T = sig type t = private [> ] val show: t -> string end
+module Mix(X:T)(Y:T with type t = private [> ] ~ [X.t]) :
+    T with type t = [X.t | Y.t] =
+  struct
+    type t = [X.t | Y.t]
+    let show = function
+        #X.t as x -> X.show x
+      | #Y.t as y -> Y.show y
+  end;;
+module M = Mix(EStr)(EInt);;
+
+(* deep *)
+module M : sig type t = private [> `A] end = struct type t = [`A] end
+module M' : sig type t = private [> ] end = struct type t = [M.t | `A] end;;
+
+(* bad *)
+type t = private [> ]
+type u = private [> `A of int] ~ [t] ;;
+
+(* ok *)
+type t = private [> `A of int]
+type u = private [> `A of int] ~ [t] ;;
+
+module F(X: sig
+  type t = private [> ] ~ [`A;`B;`C;`D]
+  type u = private [> `A|`B|`C] ~ [t; `D]
+end) : sig type v = private [< X.t | X.u | `D] end = struct
+  open X
+  let f = function #u -> 1 | #t -> 2 | `D -> 3
+  let g = function #u|#t|`D -> 2 
+  type v = [t|u|`D]
+end
+
+(* ok *)
+module M = struct type t = private [> `A] end;;
+module M' : sig type t = private [> ] ~ [`A] end = M;;
+
+(* ok *)
+module type T = sig type t = private [> ] ~ [`A] end;;
+module type T' = T with type t = private [> `A];;
+
+(* ok *)
+type t = private [> ] ~ [`A]
+let f = function `A x -> x | #t -> 0
+type t' = private [< `A of int | t];;
+
+(* should be ok *)
+module F(X:sig end) :
+    sig type t = private [> ] type u = private [> ] ~ [t] end =
+  struct type t = [ `A] type u = [`B] end
+module M = F(String)
+let f = function #M.t -> 1 | #M.u -> 2
+let f = function #M.t -> 1 | _ -> 2
+type t = [M.t | M.u]
+let f = function #t -> 1 | _ -> 2;;
+module G(X : sig type t = private [> ] type u = private [> ] ~ [t] end) =
+  struct let f = function #X.t -> 1 | _ -> 2 end;;
+module M1 = G(struct module N = F(String) type t = N.t type u = N.u end) ;;
+module M1 = G(struct type t = M.t type u = M.u end) ;;
+(* bad *)
+let f = function #F(String).t -> 1 | _ -> 2;;
+type t = [F(String).t | M.u]
+let f = function #t -> 1 | _ -> 2;;
+module N : sig type t = private [> ] end =
+  struct type t = [F(String).t | M.u] end;;
+
+(* compatibility improvement *)
+type a = [`A of int | `B]
+type b = [`A of bool | `B]
+type c = private [> ] ~ [a;b]
+let f = function #c -> 1 | `A x -> truncate x
+type d = private [> ] ~ [a]
+let g = function #d -> 1 | `A x -> truncate x;;
+
+
+(* Expression Problem: functorial form *)
+
+type num = [ `Num of int ]
+
+module type Exp = sig
+  type t = private [> num]
+  val eval : t -> t
+  val show : t -> string
+end
+
+module Num(X : Exp) = struct
+  type t = num
+  let eval (`Num _ as x) : X.t = x
+  let show (`Num n) = string_of_int n
+end
+
+type 'a add = [ `Add of 'a * 'a ]
+
+module Add(X : Exp with type t = private [> num | 'a add] as 'a) = struct
+  type t = X.t add
+  let show (`Add(e1, e2) : t) = "("^ X.show e1 ^"+"^ X.show e2 ^")"
+  let eval (`Add(e1, e2) : t) =
+    let e1 = X.eval e1 and e2 = X.eval e2 in
+    match e1, e2 with
+      `Num n1, `Num n2 -> `Num (n1+n2)
+    | `Num 0, e | e, `Num 0 -> e
+    | e12 -> `Add e12
+end 
+
+type 'a mul = [`Mul of 'a * 'a]
+
+module Mul(X : Exp with type t = private [> num | 'a mul] as 'a) = struct
+  type t = X.t mul
+  let show (`Mul(e1, e2) : t) = "("^ X.show e1 ^"*"^ X.show e2 ^")"
+  let eval (`Mul(e1, e2) : t) =
+    let e1 = X.eval e1 and e2 = X.eval e2 in
+    match e1, e2 with
+      `Num n1, `Num n2 -> `Num (n1*n2)
+    | `Num 0, e | e, `Num 0 -> `Num 0
+    | `Num 1, e | e, `Num 1 -> e
+    | e12 -> `Mul e12
+end
+
+module Ext(X : sig type t = private [> ] end)(Y : sig type t end) = struct
+  module type S =
+    sig
+      type t = private [> ] ~ [ X.t ]
+      val eval : t -> Y.t
+      val show : t -> string
+    end
+end
+
+module Dummy = struct type t = [`Dummy] end
+
+module Mix(E : Exp)(E1 : Ext(Dummy)(E).S)(E2 : Ext(E1)(E).S) =
+  struct
+    type t = [E1.t | E2.t]
+    let eval = function
+        #E1.t as x -> E1.eval x
+      | #E2.t as x -> E2.eval x
+    let show = function
+        #E1.t as x -> E1.show x
+      | #E2.t as x -> E2.show x
+  end
+
+module rec EAdd : (Exp with type t = [num | EAdd.t add]) =
+    Mix(EAdd)(Num(EAdd))(Add(EAdd))
+
+(* A bit heavy: one must pass E to everybody *)
+module rec E : Exp with type t = [num | E.t add | E.t mul] =
+    Mix(E)(Mix(E)(Num(E))(Add(E)))(Mul(E))
+
+let e = E.eval (`Add(`Mul(`Num 2,`Num 3),`Num 1))
+
+(* Alternatives *)
+(* Direct approach, no need of Mix *)
+module rec E : (Exp with type t = [num | E.t add | E.t mul]) =
+  struct
+    module E1 = Num(E)
+    module E2 = Add(E)
+    module E3 = Mul(E)
+    type t = E.t
+    let show = function
+      | #num as x -> E1.show x
+      | #add as x -> E2.show x
+      | #mul as x -> E3.show x
+    let eval = function
+      | #num as x -> E1.eval x
+      | #add as x -> E2.eval x
+      | #mul as x -> E3.eval x
+  end
+
+(* Do functor applications in Mix *)
+module type T = sig type t = private [> ] end
+module type Tnum = sig type t = private [> num] end
+
+module Ext(E : Tnum) = struct
+  module type S = functor (Y : Exp with type t = E.t) ->
+    sig
+      type t = private [> num]
+      val eval : t -> Y.t
+      val show : t -> string
+    end
+end
+
+module Ext'(E : Tnum)(X : T) = struct
+  module type S = functor (Y : Exp with type t = E.t) ->
+    sig
+      type t = private [> ] ~ [ X.t ]
+      val eval : t -> Y.t
+      val show : t -> string
+    end
+end
+
+module Mix(E : Exp)(F1 : Ext(E).S)(F2 : Ext'(E)(F1(E)).S) =
+  struct
+    module E1 = F1(E)
+    module E2 = F2(E)
+    type t = [E1.t | E2.t]
+    let eval = function
+        #E1.t as x -> E1.eval x
+      | #E2.t as x -> E2.eval x
+    let show = function
+        #E1.t as x -> E1.show x
+      | #E2.t as x -> E2.show x
+  end
+
+module Join(E : Exp)(F1 : Ext(E).S)(F2 : Ext'(E)(F1(E)).S)
+    (E' : Exp with type t = E.t) =
+  Mix(E)(F1)(F2)
+
+module rec EAdd : (Exp with type t = [num | EAdd.t add]) =
+  Mix(EAdd)(Num)(Add)
+
+module rec EMul : (Exp with type t = [num | EMul.t mul]) =
+  Mix(EMul)(Num)(Mul)
+
+module rec E : (Exp with type t = [num | E.t add | E.t mul]) =
+  Mix(E)(Join(E)(Num)(Add))(Mul)
+
+(* Linear extension by the end: not so nice *)
+module LExt(X : T) = struct
+  module type S =
+    sig
+      type t
+      val eval : t -> X.t
+      val show : t -> string
+    end
+end
+module LNum(E: Exp)(X : LExt(E).S with type t = private [> ] ~ [num]) =
+  struct
+    type t = [num | X.t]
+    let show = function
+        `Num n -> string_of_int n
+      | #X.t as x -> X.show x
+    let eval = function
+        #num as x -> x
+      | #X.t as x -> X.eval x
+  end
+module LAdd(E : Exp with type t = private [> num | 'a add] as 'a)
+    (X : LExt(E).S with type t = private [> ] ~ [add]) =
+  struct
+    type t = [E.t add | X.t]
+    let show = function
+        `Add(e1,e2) -> "("^ E.show e1 ^"+"^ E.show e2 ^")"
+      | #X.t as x -> X.show x
+    let eval = function
+        `Add(e1,e2) ->
+          let e1 = E.eval e1 and e2 = E.eval e2 in
+          begin match e1, e2 with
+            `Num n1, `Num n2 -> `Num (n1+n2)
+          | `Num 0, e | e, `Num 0 -> e
+          | e12 -> `Add e12
+          end
+      | #X.t as x -> X.eval x
+  end
+module LEnd = struct
+  type t = [`Dummy]
+  let show `Dummy = ""
+  let eval `Dummy = `Dummy
+end
+module rec L : Exp with type t = [num | L.t add | `Dummy] =
+    LAdd(L)(LNum(L)(LEnd))
+
+(* Back to first form, but add map *)
+
+module Num(X : Exp) = struct
+  type t = num
+  let map f x = x
+  let eval1 (`Num _ as x) : X.t = x
+  let show (`Num n) = string_of_int n
+end
+
+module Add(X : Exp with type t = private [> num | 'a add] as 'a) = struct
+  type t = X.t add
+  let show (`Add(e1, e2) : t) = "("^ X.show e1 ^"+"^ X.show e2 ^")"
+  let map f (`Add(e1, e2) : t) = `Add(f e1, f e2)
+  let eval1 (`Add(e1, e2) as e : t) =
+    match e1, e2 with
+      `Num n1, `Num n2 -> `Num (n1+n2)
+    | `Num 0, e | e, `Num 0 -> e
+    | _ -> e
+end 
+
+module Mul(X : Exp with type t = private [> num | 'a mul] as 'a) = struct
+  type t = X.t mul
+  let show (`Mul(e1, e2) : t) = "("^ X.show e1 ^"*"^ X.show e2 ^")"
+  let map f (`Mul(e1, e2) : t) = `Mul(f e1, f e2)
+  let eval1 (`Mul(e1, e2) as e : t) =
+    match e1, e2 with
+      `Num n1, `Num n2 -> `Num (n1*n2)
+    | `Num 0, e | e, `Num 0 -> `Num 0
+    | `Num 1, e | e, `Num 1 -> e
+    | _ -> e
+end
+
+module Ext(X : sig type t = private [> ] end)(Y : sig type t end) = struct
+  module type S =
+    sig
+      type t = private [> ] ~ [ X.t ]
+      val map  : (Y.t -> Y.t) -> t -> t
+      val eval1 : t -> Y.t
+      val show : t -> string
+    end
+end
+
+module Mix(E : Exp)(E1 : Ext(Dummy)(E).S)(E2 : Ext(E1)(E).S) =
+  struct
+    type t = [E1.t | E2.t]
+    let map f = function
+        #E1.t as x -> (E1.map f x : E1.t :> t)
+      | #E2.t as x -> (E2.map f x : E2.t :> t)
+    let eval1 = function
+        #E1.t as x -> E1.eval1 x
+      | #E2.t as x -> E2.eval1 x
+    let show = function
+        #E1.t as x -> E1.show x
+      | #E2.t as x -> E2.show x
+  end
+
+module type ET = sig
+  type t
+  val map  : (t -> t) -> t -> t
+  val eval1 : t -> t
+  val show : t -> string
+end
+
+module Fin(E : ET) = struct
+  include E
+  let rec eval e = eval1 (map eval e)
+end
+
+module rec EAdd : (Exp with type t = [num | EAdd.t add]) =
+    Fin(Mix(EAdd)(Num(EAdd))(Add(EAdd)))
+
+module rec E : Exp with type t = [num | E.t add | E.t mul] =
+    Fin(Mix(E)(Mix(E)(Num(E))(Add(E)))(Mul(E)))
+
+let e = E.eval (`Add(`Mul(`Num 2,`Num 3),`Num 1))