1(* Ignore OCAMLRUNPARAM=b to be reproducible *) 2Printexc.record_backtrace false;; 3 4type foo = .. 5;; 6 7type foo += 8 A 9 | B of int 10;; 11 12let is_a x = 13 match x with 14 A -> true 15 | _ -> false 16;; 17 18(* The type must be open to create extension *) 19 20type foo 21;; 22 23type foo += A of int (* Error type is not open *) 24;; 25 26(* The type parameters must match *) 27 28type 'a foo = .. 29;; 30 31type ('a, 'b) foo += A of int (* Error: type parameter mismatch *) 32;; 33 34(* In a signature the type does not have to be open *) 35 36module type S = 37sig 38 type foo 39 type foo += A of float 40end 41;; 42 43(* But it must still be extensible *) 44 45module type S = 46sig 47 type foo = A of int 48 type foo += B of float (* Error foo does not have an extensible type *) 49end 50;; 51 52(* Signatures can change the grouping of extensions *) 53 54type foo = .. 55;; 56 57module M = struct 58 type foo += 59 A of int 60 | B of string 61 62 type foo += 63 C of int 64 | D of float 65end 66;; 67 68module type S = sig 69 type foo += 70 B of string 71 | C of int 72 73 type foo += D of float 74 75 type foo += A of int 76end 77;; 78 79module M_S = (M : S) 80;; 81 82(* Extensions can be GADTs *) 83 84type 'a foo = .. 85;; 86 87type _ foo += 88 A : int -> int foo 89 | B : int foo 90;; 91 92let get_num : type a. a foo -> a -> a option = fun f i1 -> 93 match f with 94 A i2 -> Some (i1 + i2) 95 | _ -> None 96;; 97 98(* Extensions must obey constraints *) 99 100type 'a foo = .. constraint 'a = [> `Var ] 101;; 102 103type 'a foo += A of 'a 104;; 105 106let a = A 9 (* ERROR: Constraints not met *) 107;; 108 109type 'a foo += B : int foo (* ERROR: Constraints not met *) 110;; 111 112(* Signatures can make an extension private *) 113 114type foo = .. 115;; 116 117module M = struct type foo += A of int end 118;; 119 120let a1 = M.A 10 121;; 122 123module type S = sig type foo += private A of int end 124;; 125 126module M_S = (M : S) 127;; 128 129let is_s x = 130 match x with 131 M_S.A _ -> true 132 | _ -> false 133;; 134 135let a2 = M_S.A 20 (* ERROR: Cannot create a value using a private constructor *) 136;; 137 138(* Extensions can be rebound *) 139 140type foo = .. 141;; 142 143module M = struct type foo += A1 of int end 144;; 145 146type foo += A2 = M.A1 147;; 148 149type bar = .. 150;; 151 152type bar += A3 = M.A1 (* Error: rebind wrong type *) 153;; 154 155module M = struct type foo += private B1 of int end 156;; 157 158type foo += private B2 = M.B1 159;; 160 161type foo += B3 = M.B1 (* Error: rebind private extension *) 162;; 163 164type foo += C = Unknown (* Error: unbound extension *) 165;; 166 167(* Extensions can be rebound even if type is closed *) 168 169module M : sig type foo type foo += A1 of int end 170 = struct type foo = .. type foo += A1 of int end 171 172type M.foo += A2 = M.A1 173 174(* Rebinding handles abbreviations *) 175 176type 'a foo = .. 177;; 178 179type 'a foo1 = 'a foo = .. 180;; 181 182type 'a foo2 = 'a foo = .. 183;; 184 185type 'a foo1 += 186 A of int 187 | B of 'a 188 | C : int foo1 189;; 190 191type 'a foo2 += 192 D = A 193 | E = B 194 | F = C 195;; 196 197(* Extensions must obey variances *) 198 199type +'a foo = .. 200;; 201 202type 'a foo += A of (int -> 'a) 203;; 204 205type 'a foo += B of ('a -> int) 206 (* ERROR: Parameter variances are not satisfied *) 207;; 208 209type _ foo += C : ('a -> int) -> 'a foo 210 (* ERROR: Parameter variances are not satisfied *) 211;; 212 213type 'a bar = .. 214;; 215 216type +'a bar += D of (int -> 'a) (* ERROR: type variances do not match *) 217;; 218 219(* Exceptions are compatible with extensions *) 220 221module M : sig 222 type exn += 223 Foo of int * float 224 | Bar : 'a list -> exn 225end = struct 226 exception Bar : 'a list -> exn 227 exception Foo of int * float 228end 229;; 230 231module M : sig 232 exception Bar : 'a list -> exn 233 exception Foo of int * float 234end = struct 235 type exn += 236 Foo of int * float 237 | Bar : 'a list -> exn 238end 239;; 240 241exception Foo of int * float 242;; 243 244exception Bar : 'a list -> exn 245;; 246 247module M : sig 248 type exn += 249 Foo of int * float 250 | Bar : 'a list -> exn 251end = struct 252 exception Bar = Bar 253 exception Foo = Foo 254end 255;; 256 257(* Test toplevel printing *) 258 259type foo = .. 260;; 261 262type foo += 263 Foo of int * int option 264 | Bar of int option 265;; 266 267let x = Foo(3, Some 4), Bar(Some 5) (* Prints Foo and Bar successfully *) 268;; 269 270type foo += Foo of string 271;; 272 273let y = x (* Prints Bar but not Foo (which has been shadowed) *) 274;; 275 276exception Foo of int * int option 277;; 278 279exception Bar of int option 280;; 281 282let x = Foo(3, Some 4), Bar(Some 5) (* Prints Foo and Bar successfully *) 283;; 284 285type foo += Foo of string 286;; 287 288let y = x (* Prints Bar and part of Foo (which has been shadowed) *) 289;; 290 291(* Test Obj functions *) 292 293type foo = .. 294;; 295 296type foo += 297 Foo 298 | Bar of int 299;; 300 301let extension_name e = Obj.extension_name (Obj.extension_constructor e);; 302let extension_id e = Obj.extension_id (Obj.extension_constructor e);; 303 304let n1 = extension_name Foo 305;; 306 307let n2 = extension_name (Bar 1) 308;; 309 310let t = (extension_id (Bar 2)) = (extension_id (Bar 3)) (* true *) 311;; 312 313let f = (extension_id (Bar 2)) = (extension_id Foo) (* false *) 314;; 315 316let is_foo x = (extension_id Foo) = (extension_id x) 317 318type foo += Foo 319;; 320 321let f = is_foo Foo 322;; 323 324let _ = Obj.extension_constructor 7 (* Invald_arg *) 325;; 326 327let _ = Obj.extension_constructor (object method m = 3 end) (* Invald_arg *) 328;; 329