testlabl/varunion.ml

   1 (* cvs update -r varunion parsing typing bytecomp toplevel *)
   2
   3 type t = private [> ];;
   4 type u = private [> ] ~ [t];;
   5 type v = [t | u];;
   6 let f x = (x : t :> v);;
   7
   8 (* bad *)
   9 module Mix(X: sig type t = private [> ] end)
  10     (Y: sig type t = private [> ] end) =
  11   struct type t = [X.t | Y.t] end;;
  12
  13 (* bad *)
  14 module Mix(X: sig type t = private [> `A of int ] end)
  15     (Y: sig type t = private [> `A of bool] ~ [X.t] end) =
  16   struct type t = [X.t | Y.t] end;;
  17
  18 (* ok *)
  19 module Mix(X: sig type t = private [> `A of int ] end)
  20     (Y: sig type t = private [> `A of int] ~ [X.t] end) =
  21   struct type t = [X.t | Y.t] end;;
  22
  23 (* bad *)
  24 module Mix(X: sig type t = private [> `A of int ] end)
  25     (Y: sig type t = private [> `B of bool] ~ [X.t] end) =
  26   struct type t = [X.t | Y.t] end;;
  27
  28 type 'a t = private [> `L of 'a] ~ [`L];;
  29
  30 (* ok *)
  31 module Mix(X: sig type t = private [> `A of int ] ~ [`B] end)
  32     (Y: sig type t = private [> `B of bool] ~ [X.t] end) =
  33   struct type t = [X.t | Y.t] let is_t = function #t -> true | _ -> false end;;
  34
  35 module Mix(X: sig type t = private [> `A of int ] ~ [`B] end)
  36     (Y: sig type t = private [> `B of bool] ~ [X.t] end) =
  37   struct
  38     type t = [X.t | Y.t]
  39     let which = function #X.t -> `X | #Y.t -> `Y
  40   end;;
  41
  42 module Mix(I: sig type t = private [> ] ~ [`A;`B] end)
  43     (X: sig type t = private [> I.t | `A of int ] ~ [`B] end)
  44     (Y: sig type t = private [> I.t | `B of bool] ~ [X.t] end) =
  45   struct
  46     type t = [X.t | Y.t]
  47     let which = function #X.t -> `X | #Y.t -> `Y
  48   end;;
  49
  50 (* ok *)
  51 module M =
  52   Mix(struct type t = [`C of char] end)
  53     (struct type t = [`A of int | `C of char] end)
  54     (struct type t = [`B of bool | `C of char] end);;
  55
  56 (* bad *)
  57 module M =
  58   Mix(struct type t = [`B of bool] end)
  59     (struct type t = [`A of int | `B of bool] end)
  60     (struct type t = [`B of bool | `C of char] end);;
  61
  62 (* ok *)
  63 module M1 = struct type t = [`A of int | `C of char] end
  64 module M2 = struct type t = [`B of bool | `C of char] end
  65 module I = struct type t = [`C of char] end
  66 module M = Mix(I)(M1)(M2) ;;
  67
  68 let c = (`C 'c' : M.t) ;;
  69
  70 module M(X : sig type t = private [> `A] end) =
  71   struct let f (#X.t as x) = x end;;
  72
  73 (* code generation *)
  74 type t = private [> `A ] ~ [`B];;
  75 match `B with #t -> 1 | `B -> 2;;
  76
  77 module M : sig type t = private [> `A of int | `B] ~ [`C] end =
  78   struct type t = [`A of int | `B | `D of bool] end;;
  79 let f = function (`C | #M.t) -> 1+1 ;;
  80 let f = function (`A _ | `B #M.t) -> 1+1 ;;
  81
  82 (* expression *)
  83 module Mix(X:sig type t = private [> ] val show: t -> string end)
  84     (Y:sig type t = private [> ] ~ [X.t] val show: t -> string end) =
  85   struct
  86     type t = [X.t | Y.t]
  87     let show : t -> string = function
  88         #X.t as x -> X.show x
  89       | #Y.t as y -> Y.show y
  90   end;;
  91
  92 module EStr = struct
  93   type t = [`Str of string]
  94   let show (`Str s) = s
  95 end
  96 module EInt = struct
  97   type t = [`Int of int]
  98   let show (`Int i) = string_of_int i
  99 end
 100 module M = Mix(EStr)(EInt);;
 101
 102 module type T = sig type t = private [> ] val show: t -> string end
 103 module Mix(X:T)(Y:T with type t = private [> ] ~ [X.t]) :
 104     T with type t = [X.t | Y.t] =
 105   struct
 106     type t = [X.t | Y.t]
 107     let show = function
 108         #X.t as x -> X.show x
 109       | #Y.t as y -> Y.show y
 110   end;;
 111 module M = Mix(EStr)(EInt);;
 112
 113 (* deep *)
 114 module M : sig type t = private [> `A] end = struct type t = [`A] end
 115 module M' : sig type t = private [> ] end = struct type t = [M.t | `A] end;;
 116
 117 (* bad *)
 118 type t = private [> ]
 119 type u = private [> `A of int] ~ [t] ;;
 120
 121 (* ok *)
 122 type t = private [> `A of int]
 123 type u = private [> `A of int] ~ [t] ;;
 124
 125 module F(X: sig
 126   type t = private [> ] ~ [`A;`B;`C;`D]
 127   type u = private [> `A|`B|`C] ~ [t; `D]
 128 end) : sig type v = private [< X.t | X.u | `D] end = struct
 129   open X
 130   let f = function #u -> 1 | #t -> 2 | `D -> 3
 131   let g = function #u|#t|`D -> 2
 132   type v = [t|u|`D]
 133 end
 134
 135 (* ok *)
 136 module M = struct type t = private [> `A] end;;
 137 module M' : sig type t = private [> ] ~ [`A] end = M;;
 138
 139 (* ok *)
 140 module type T = sig type t = private [> ] ~ [`A] end;;
 141 module type T' = T with type t = private [> `A];;
 142
 143 (* ok *)
 144 type t = private [> ] ~ [`A]
 145 let f = function `A x -> x | #t -> 0
 146 type t' = private [< `A of int | t];;
 147
 148 (* should be ok *)
 149 module F(X:sig end) :
 150     sig type t = private [> ] type u = private [> ] ~ [t] end =
 151   struct type t = [ `A] type u = [`B] end
 152 module M = F(String)
 153 let f = function #M.t -> 1 | #M.u -> 2
 154 let f = function #M.t -> 1 | _ -> 2
 155 type t = [M.t | M.u]
 156 let f = function #t -> 1 | _ -> 2;;
 157 module G(X : sig type t = private [> ] type u = private [> ] ~ [t] end) =
 158   struct let f = function #X.t -> 1 | _ -> 2 end;;
 159 module M1 = G(struct module N = F(String) type t = N.t type u = N.u end) ;;
 160 module M1 = G(struct type t = M.t type u = M.u end) ;;
 161 (* bad *)
 162 let f = function #F(String).t -> 1 | _ -> 2;;
 163 type t = [F(String).t | M.u]
 164 let f = function #t -> 1 | _ -> 2;;
 165 module N : sig type t = private [> ] end =
 166   struct type t = [F(String).t | M.u] end;;
 167
 168 (* compatibility improvement *)
 169 type a = [`A of int | `B]
 170 type b = [`A of bool | `B]
 171 type c = private [> ] ~ [a;b]
 172 let f = function #c -> 1 | `A x -> truncate x
 173 type d = private [> ] ~ [a]
 174 let g = function #d -> 1 | `A x -> truncate x;;
 175
 176
 177 (* Expression Problem: functorial form *)
 178
 179 type num = [ `Num of int ]
 180
 181 module type Exp = sig
 182   type t = private [> num]
 183   val eval : t -> t
 184   val show : t -> string
 185 end
 186
 187 module Num(X : Exp) = struct
 188   type t = num
 189   let eval (`Num _ as x) : X.t = x
 190   let show (`Num n) = string_of_int n
 191 end
 192
 193 type 'a add = [ `Add of 'a * 'a ]
 194
 195 module Add(X : Exp with type t = private [> num | 'a add] as 'a) = struct
 196   type t = X.t add
 197   let show (`Add(e1, e2) : t) = "("^ X.show e1 ^"+"^ X.show e2 ^")"
 198   let eval (`Add(e1, e2) : t) =
 199     let e1 = X.eval e1 and e2 = X.eval e2 in
 200     match e1, e2 with
 201       `Num n1, `Num n2 -> `Num (n1+n2)
 202     | `Num 0, e | e, `Num 0 -> e
 203     | e12 -> `Add e12
 204 end
 205
 206 type 'a mul = [`Mul of 'a * 'a]
 207
 208 module Mul(X : Exp with type t = private [> num | 'a mul] as 'a) = struct
 209   type t = X.t mul
 210   let show (`Mul(e1, e2) : t) = "("^ X.show e1 ^"*"^ X.show e2 ^")"
 211   let eval (`Mul(e1, e2) : t) =
 212     let e1 = X.eval e1 and e2 = X.eval e2 in
 213     match e1, e2 with
 214       `Num n1, `Num n2 -> `Num (n1*n2)
 215     | `Num 0, e | e, `Num 0 -> `Num 0
 216     | `Num 1, e | e, `Num 1 -> e
 217     | e12 -> `Mul e12
 218 end
 219
 220 module Ext(X : sig type t = private [> ] end)(Y : sig type t end) = struct
 221   module type S =
 222     sig
 223       type t = private [> ] ~ [ X.t ]
 224       val eval : t -> Y.t
 225       val show : t -> string
 226     end
 227 end
 228
 229 module Dummy = struct type t = [`Dummy] end
 230
 231 module Mix(E : Exp)(E1 : Ext(Dummy)(E).S)(E2 : Ext(E1)(E).S) =
 232   struct
 233     type t = [E1.t | E2.t]
 234     let eval = function
 235         #E1.t as x -> E1.eval x
 236       | #E2.t as x -> E2.eval x
 237     let show = function
 238         #E1.t as x -> E1.show x
 239       | #E2.t as x -> E2.show x
 240   end
 241
 242 module rec EAdd : (Exp with type t = [num | EAdd.t add]) =
 243     Mix(EAdd)(Num(EAdd))(Add(EAdd))
 244
 245 (* A bit heavy: one must pass E to everybody *)
 246 module rec E : Exp with type t = [num | E.t add | E.t mul] =
 247     Mix(E)(Mix(E)(Num(E))(Add(E)))(Mul(E))
 248
 249 let e = E.eval (`Add(`Mul(`Num 2,`Num 3),`Num 1))
 250
 251 (* Alternatives *)
 252 (* Direct approach, no need of Mix *)
 253 module rec E : (Exp with type t = [num | E.t add | E.t mul]) =
 254   struct
 255     module E1 = Num(E)
 256     module E2 = Add(E)
 257     module E3 = Mul(E)
 258     type t = E.t
 259     let show = function
 260       | #num as x -> E1.show x
 261       | #add as x -> E2.show x
 262       | #mul as x -> E3.show x
 263     let eval = function
 264       | #num as x -> E1.eval x
 265       | #add as x -> E2.eval x
 266       | #mul as x -> E3.eval x
 267   end
 268
 269 (* Do functor applications in Mix *)
 270 module type T = sig type t = private [> ] end
 271 module type Tnum = sig type t = private [> num] end
 272
 273 module Ext(E : Tnum) = struct
 274   module type S = functor (Y : Exp with type t = E.t) ->
 275     sig
 276       type t = private [> num]
 277       val eval : t -> Y.t
 278       val show : t -> string
 279     end
 280 end
 281
 282 module Ext'(E : Tnum)(X : T) = struct
 283   module type S = functor (Y : Exp with type t = E.t) ->
 284     sig
 285       type t = private [> ] ~ [ X.t ]
 286       val eval : t -> Y.t
 287       val show : t -> string
 288     end
 289 end
 290
 291 module Mix(E : Exp)(F1 : Ext(E).S)(F2 : Ext'(E)(F1(E)).S) =
 292   struct
 293     module E1 = F1(E)
 294     module E2 = F2(E)
 295     type t = [E1.t | E2.t]
 296     let eval = function
 297         #E1.t as x -> E1.eval x
 298       | #E2.t as x -> E2.eval x
 299     let show = function
 300         #E1.t as x -> E1.show x
 301       | #E2.t as x -> E2.show x
 302   end
 303
 304 module Join(E : Exp)(F1 : Ext(E).S)(F2 : Ext'(E)(F1(E)).S)
 305     (E' : Exp with type t = E.t) =
 306   Mix(E)(F1)(F2)
 307
 308 module rec EAdd : (Exp with type t = [num | EAdd.t add]) =
 309   Mix(EAdd)(Num)(Add)
 310
 311 module rec EMul : (Exp with type t = [num | EMul.t mul]) =
 312   Mix(EMul)(Num)(Mul)
 313
 314 module rec E : (Exp with type t = [num | E.t add | E.t mul]) =
 315   Mix(E)(Join(E)(Num)(Add))(Mul)
 316
 317 (* Linear extension by the end: not so nice *)
 318 module LExt(X : T) = struct
 319   module type S =
 320     sig
 321       type t
 322       val eval : t -> X.t
 323       val show : t -> string
 324     end
 325 end
 326 module LNum(E: Exp)(X : LExt(E).S with type t = private [> ] ~ [num]) =
 327   struct
 328     type t = [num | X.t]
 329     let show = function
 330         `Num n -> string_of_int n
 331       | #X.t as x -> X.show x
 332     let eval = function
 333         #num as x -> x
 334       | #X.t as x -> X.eval x
 335   end
 336 module LAdd(E : Exp with type t = private [> num | 'a add] as 'a)
 337     (X : LExt(E).S with type t = private [> ] ~ [add]) =
 338   struct
 339     type t = [E.t add | X.t]
 340     let show = function
 341         `Add(e1,e2) -> "("^ E.show e1 ^"+"^ E.show e2 ^")"
 342       | #X.t as x -> X.show x
 343     let eval = function
 344         `Add(e1,e2) ->
 345           let e1 = E.eval e1 and e2 = E.eval e2 in
 346           begin match e1, e2 with
 347             `Num n1, `Num n2 -> `Num (n1+n2)
 348           | `Num 0, e | e, `Num 0 -> e
 349           | e12 -> `Add e12
 350           end
 351       | #X.t as x -> X.eval x
 352   end
 353 module LEnd = struct
 354   type t = [`Dummy]
 355   let show `Dummy = ""
 356   let eval `Dummy = `Dummy
 357 end
 358 module rec L : Exp with type t = [num | L.t add | `Dummy] =
 359     LAdd(L)(LNum(L)(LEnd))
 360
 361 (* Back to first form, but add map *)
 362
 363 module Num(X : Exp) = struct
 364   type t = num
 365   let map f x = x
 366   let eval1 (`Num _ as x) : X.t = x
 367   let show (`Num n) = string_of_int n
 368 end
 369
 370 module Add(X : Exp with type t = private [> num | 'a add] as 'a) = struct
 371   type t = X.t add
 372   let show (`Add(e1, e2) : t) = "("^ X.show e1 ^"+"^ X.show e2 ^")"
 373   let map f (`Add(e1, e2) : t) = `Add(f e1, f e2)
 374   let eval1 (`Add(e1, e2) as e : t) =
 375     match e1, e2 with
 376       `Num n1, `Num n2 -> `Num (n1+n2)
 377     | `Num 0, e | e, `Num 0 -> e
 378     | _ -> e
 379 end
 380
 381 module Mul(X : Exp with type t = private [> num | 'a mul] as 'a) = struct
 382   type t = X.t mul
 383   let show (`Mul(e1, e2) : t) = "("^ X.show e1 ^"*"^ X.show e2 ^")"
 384   let map f (`Mul(e1, e2) : t) = `Mul(f e1, f e2)
 385   let eval1 (`Mul(e1, e2) as e : t) =
 386     match e1, e2 with
 387       `Num n1, `Num n2 -> `Num (n1*n2)
 388     | `Num 0, e | e, `Num 0 -> `Num 0
 389     | `Num 1, e | e, `Num 1 -> e
 390     | _ -> e
 391 end
 392
 393 module Ext(X : sig type t = private [> ] end)(Y : sig type t end) = struct
 394   module type S =
 395     sig
 396       type t = private [> ] ~ [ X.t ]
 397       val map  : (Y.t -> Y.t) -> t -> t
 398       val eval1 : t -> Y.t
 399       val show : t -> string
 400     end
 401 end
 402
 403 module Mix(E : Exp)(E1 : Ext(Dummy)(E).S)(E2 : Ext(E1)(E).S) =
 404   struct
 405     type t = [E1.t | E2.t]
 406     let map f = function
 407         #E1.t as x -> (E1.map f x : E1.t :> t)
 408       | #E2.t as x -> (E2.map f x : E2.t :> t)
 409     let eval1 = function
 410         #E1.t as x -> E1.eval1 x
 411       | #E2.t as x -> E2.eval1 x
 412     let show = function
 413         #E1.t as x -> E1.show x
 414       | #E2.t as x -> E2.show x
 415   end
 416
 417 module type ET = sig
 418   type t
 419   val map  : (t -> t) -> t -> t
 420   val eval1 : t -> t
 421   val show : t -> string
 422 end
 423
 424 module Fin(E : ET) = struct
 425   include E
 426   let rec eval e = eval1 (map eval e)
 427 end
 428
 429 module rec EAdd : (Exp with type t = [num | EAdd.t add]) =
 430     Fin(Mix(EAdd)(Num(EAdd))(Add(EAdd)))
 431
 432 module rec E : Exp with type t = [num | E.t add | E.t mul] =
 433     Fin(Mix(E)(Mix(E)(Num(E))(Add(E)))(Mul(E)))
 434
 435 let e = E.eval (`Add(`Mul(`Num 2,`Num 3),`Num 1))