1(* Encoding generics using GADTs *) 2(* (c) Alain Frisch / Lexifi *) 3(* cf. http://www.lexifi.com/blog/dynamic-types *) 4 5(* Basic tag *) 6 7type 'a ty = 8 | Int: int ty 9 | String: string ty 10 | List: 'a ty -> 'a list ty 11 | Pair: ('a ty * 'b ty) -> ('a * 'b) ty 12;; 13 14(* Tagging data *) 15 16type variant = 17 | VInt of int 18 | VString of string 19 | VList of variant list 20 | VPair of variant * variant 21;; 22 23let rec variantize: type t. t ty -> t -> variant = 24 fun ty x -> 25 (* type t is abstract here *) 26 match ty with 27 | Int -> VInt x (* in this branch: t = int *) 28 | String -> VString x (* t = string *) 29 | List ty1 -> 30 VList (List.map (variantize ty1) x) 31 (* t = 'a list for some 'a *) 32 | Pair (ty1, ty2) -> 33 VPair (variantize ty1 (fst x), variantize ty2 (snd x)) 34 (* t = ('a, 'b) for some 'a and 'b *) 35;; 36[%%expect{| 37type 'a ty = 38 Int : int ty 39 | String : string ty 40 | List : 'a ty -> 'a list ty 41 | Pair : ('a ty * 'b ty) -> ('a * 'b) ty 42type variant = 43 VInt of int 44 | VString of string 45 | VList of variant list 46 | VPair of variant * variant 47val variantize : 't ty -> 't -> variant = <fun> 48|}];; 49 50exception VariantMismatch 51;; 52 53let rec devariantize: type t. t ty -> variant -> t = 54 fun ty v -> 55 match ty, v with 56 | Int, VInt x -> x 57 | String, VString x -> x 58 | List ty1, VList vl -> 59 List.map (devariantize ty1) vl 60 | Pair (ty1, ty2), VPair (x1, x2) -> 61 (devariantize ty1 x1, devariantize ty2 x2) 62 | _ -> raise VariantMismatch 63;; 64[%%expect{| 65exception VariantMismatch 66val devariantize : 't ty -> variant -> 't = <fun> 67|}];; 68 69(* Handling records *) 70 71type 'a ty = 72 | Int: int ty 73 | String: string ty 74 | List: 'a ty -> 'a list ty 75 | Pair: ('a ty * 'b ty) -> ('a * 'b) ty 76 | Record: 'a record -> 'a ty 77 78and 'a record = 79 { 80 path: string; 81 fields: 'a field_ list; 82 } 83 84and 'a field_ = 85 | Field: ('a, 'b) field -> 'a field_ 86 87and ('a, 'b) field = 88 { 89 label: string; 90 field_type: 'b ty; 91 get: ('a -> 'b); 92 } 93;; 94 95(* Again *) 96 97type variant = 98 | VInt of int 99 | VString of string 100 | VList of variant list 101 | VPair of variant * variant 102 | VRecord of (string * variant) list 103;; 104 105let rec variantize: type t. t ty -> t -> variant = 106 fun ty x -> 107 (* type t is abstract here *) 108 match ty with 109 | Int -> VInt x (* in this branch: t = int *) 110 | String -> VString x (* t = string *) 111 | List ty1 -> 112 VList (List.map (variantize ty1) x) 113 (* t = 'a list for some 'a *) 114 | Pair (ty1, ty2) -> 115 VPair (variantize ty1 (fst x), variantize ty2 (snd x)) 116 (* t = ('a, 'b) for some 'a and 'b *) 117 | Record {fields} -> 118 VRecord 119 (List.map (fun (Field{field_type; label; get}) -> 120 (label, variantize field_type (get x))) fields) 121;; 122[%%expect{| 123type 'a ty = 124 Int : int ty 125 | String : string ty 126 | List : 'a ty -> 'a list ty 127 | Pair : ('a ty * 'b ty) -> ('a * 'b) ty 128 | Record : 'a record -> 'a ty 129and 'a record = { path : string; fields : 'a field_ list; } 130and 'a field_ = Field : ('a, 'b) field -> 'a field_ 131and ('a, 'b) field = { label : string; field_type : 'b ty; get : 'a -> 'b; } 132type variant = 133 VInt of int 134 | VString of string 135 | VList of variant list 136 | VPair of variant * variant 137 | VRecord of (string * variant) list 138val variantize : 't ty -> 't -> variant = <fun> 139|}];; 140 141(* Extraction *) 142 143type 'a ty = 144 | Int: int ty 145 | String: string ty 146 | List: 'a ty -> 'a list ty 147 | Pair: ('a ty * 'b ty) -> ('a * 'b) ty 148 | Record: ('a, 'builder) record -> 'a ty 149 150and ('a, 'builder) record = 151 { 152 path: string; 153 fields: ('a, 'builder) field list; 154 create_builder: (unit -> 'builder); 155 of_builder: ('builder -> 'a); 156 } 157 158and ('a, 'builder) field = 159 | Field: ('a, 'builder, 'b) field_ -> ('a, 'builder) field 160 161and ('a, 'builder, 'b) field_ = 162 { 163 label: string; 164 field_type: 'b ty; 165 get: ('a -> 'b); 166 set: ('builder -> 'b -> unit); 167 } 168;; 169 170let rec devariantize: type t. t ty -> variant -> t = 171 fun ty v -> 172 match ty, v with 173 | Int, VInt x -> x 174 | String, VString x -> x 175 | List ty1, VList vl -> 176 List.map (devariantize ty1) vl 177 | Pair (ty1, ty2), VPair (x1, x2) -> 178 (devariantize ty1 x1, devariantize ty2 x2) 179 | Record {fields; create_builder; of_builder}, VRecord fl -> 180 if List.length fields <> List.length fl then raise VariantMismatch; 181 let builder = create_builder () in 182 List.iter2 183 (fun (Field {label; field_type; set}) (lab, v) -> 184 if label <> lab then raise VariantMismatch; 185 set builder (devariantize field_type v) 186 ) 187 fields fl; 188 of_builder builder 189 | _ -> raise VariantMismatch 190;; 191[%%expect{| 192type 'a ty = 193 Int : int ty 194 | String : string ty 195 | List : 'a ty -> 'a list ty 196 | Pair : ('a ty * 'b ty) -> ('a * 'b) ty 197 | Record : ('a, 'builder) record -> 'a ty 198and ('a, 'builder) record = { 199 path : string; 200 fields : ('a, 'builder) field list; 201 create_builder : unit -> 'builder; 202 of_builder : 'builder -> 'a; 203} 204and ('a, 'builder) field = 205 Field : ('a, 'builder, 'b) field_ -> ('a, 'builder) field 206and ('a, 'builder, 'b) field_ = { 207 label : string; 208 field_type : 'b ty; 209 get : 'a -> 'b; 210 set : 'builder -> 'b -> unit; 211} 212val devariantize : 't ty -> variant -> 't = <fun> 213|}];; 214 215type my_record = 216 { 217 a: int; 218 b: string list; 219 } 220;; 221 222let my_record = 223 let fields = 224 [ 225 Field {label = "a"; field_type = Int; 226 get = (fun {a} -> a); 227 set = (fun (r, _) x -> r := Some x)}; 228 Field {label = "b"; field_type = List String; 229 get = (fun {b} -> b); 230 set = (fun (_, r) x -> r := Some x)}; 231 ] 232 in 233 let create_builder () = (ref None, ref None) in 234 let of_builder (a, b) = 235 match !a, !b with 236 | Some a, Some b -> {a; b} 237 | _ -> failwith "Some fields are missing in record of type my_record" 238 in 239 Record {path = "My_module.my_record"; fields; create_builder; of_builder} 240;; 241[%%expect{| 242type my_record = { a : int; b : string list; } 243val my_record : my_record ty = 244 Record 245 {path = "My_module.my_record"; 246 fields = 247 [Field {label = "a"; field_type = Int; get = <fun>; set = <fun>}; 248 Field {label = "b"; field_type = List String; get = <fun>; set = <fun>}]; 249 create_builder = <fun>; of_builder = <fun>} 250|}];; 251 252(* Extension to recursive types and polymorphic variants *) 253(* by Jacques Garrigue *) 254 255type noarg = Noarg 256 257type (_,_) ty = 258 | Int: (int,_) ty 259 | String: (string,_) ty 260 | List: ('a,'e) ty -> ('a list, 'e) ty 261 | Option: ('a,'e) ty -> ('a option, 'e) ty 262 | Pair: (('a,'e) ty * ('b,'e) ty) -> ('a * 'b,'e) ty 263 (* Support for type variables and recursive types *) 264 | Var: ('a, 'a -> 'e) ty 265 | Rec: ('a, 'a -> 'e) ty -> ('a,'e) ty 266 | Pop: ('a, 'e) ty -> ('a, 'b -> 'e) ty 267 (* Change the representation of a type *) 268 | Conv: string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty 269 (* Sum types (both normal sums and polymorphic variants) *) 270 | Sum: ('a, 'e, 'b) ty_sum -> ('a, 'e) ty 271 272and ('a, 'e, 'b) ty_sum = 273 { sum_proj: 'a -> string * 'e ty_dyn option; 274 sum_cases: (string * ('e,'b) ty_case) list; 275 sum_inj: 'c. ('b,'c) ty_sel * 'c -> 'a; } 276 277and 'e ty_dyn = (* dynamic type *) 278 | Tdyn : ('a,'e) ty * 'a -> 'e ty_dyn 279 280and (_,_) ty_sel = (* selector from a list of types *) 281 | Thd : ('a -> 'b, 'a) ty_sel 282 | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel 283 284and (_,_) ty_case = (* type a sum case *) 285 | TCarg : ('b,'a) ty_sel * ('a,'e) ty -> ('e,'b) ty_case 286 | TCnoarg : ('b,noarg) ty_sel -> ('e,'b) ty_case 287;; 288 289type _ ty_env = (* type variable substitution *) 290 | Enil : unit ty_env 291 | Econs : ('a,'e) ty * 'e ty_env -> ('a -> 'e) ty_env 292;; 293 294(* Comparing selectors *) 295type (_,_) eq = Eq: ('a,'a) eq 296;; 297 298let rec eq_sel : type a b c. (a,b) ty_sel -> (a,c) ty_sel -> (b,c) eq option = 299 fun s1 s2 -> 300 match s1, s2 with 301 | Thd, Thd -> Some Eq 302 | Ttl s1, Ttl s2 -> 303 (match eq_sel s1 s2 with None -> None | Some Eq -> Some Eq) 304 | _ -> None 305;; 306[%%expect{| 307type noarg = Noarg 308type (_, _) ty = 309 Int : (int, 'c) ty 310 | String : (string, 'd) ty 311 | List : ('a, 'e) ty -> ('a list, 'e) ty 312 | Option : ('a, 'e) ty -> ('a option, 'e) ty 313 | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty 314 | Var : ('a, 'a -> 'e) ty 315 | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty 316 | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty 317 | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty 318 | Sum : ('a, 'e, 'b) ty_sum -> ('a, 'e) ty 319and ('a, 'e, 'b) ty_sum = { 320 sum_proj : 'a -> string * 'e ty_dyn option; 321 sum_cases : (string * ('e, 'b) ty_case) list; 322 sum_inj : 'c. ('b, 'c) ty_sel * 'c -> 'a; 323} 324and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn 325and (_, _) ty_sel = 326 Thd : ('a -> 'b, 'a) ty_sel 327 | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel 328and (_, _) ty_case = 329 TCarg : ('b, 'a) ty_sel * ('a, 'e) ty -> ('e, 'b) ty_case 330 | TCnoarg : ('b, noarg) ty_sel -> ('e, 'b) ty_case 331type _ ty_env = 332 Enil : unit ty_env 333 | Econs : ('a, 'e) ty * 'e ty_env -> ('a -> 'e) ty_env 334type (_, _) eq = Eq : ('a, 'a) eq 335val eq_sel : ('a, 'b) ty_sel -> ('a, 'c) ty_sel -> ('b, 'c) eq option = <fun> 336|}];; 337 338(* Auxiliary function to get the type of a case from its selector *) 339let rec get_case : type a b e. 340 (b, a) ty_sel -> (string * (e,b) ty_case) list -> string * (a, e) ty option = 341 fun sel cases -> 342 match cases with 343 | (name, TCnoarg sel') :: rem -> 344 begin match eq_sel sel sel' with 345 | None -> get_case sel rem 346 | Some Eq -> name, None 347 end 348 | (name, TCarg (sel', ty)) :: rem -> 349 begin match eq_sel sel sel' with 350 | None -> get_case sel rem 351 | Some Eq -> name, Some ty 352 end 353 | [] -> raise Not_found 354;; 355[%%expect{| 356val get_case : 357 ('b, 'a) ty_sel -> 358 (string * ('e, 'b) ty_case) list -> string * ('a, 'e) ty option = <fun> 359|}];; 360 361(* Untyped representation of values *) 362type variant = 363 | VInt of int 364 | VString of string 365 | VList of variant list 366 | VOption of variant option 367 | VPair of variant * variant 368 | VConv of string * variant 369 | VSum of string * variant option 370;; 371 372let may_map f = function Some x -> Some (f x) | None -> None ;; 373 374let rec variantize : type a e. e ty_env -> (a,e) ty -> a -> variant = 375 fun e ty v -> 376 match ty with 377 | Int -> VInt v 378 | String -> VString v 379 | List t -> VList (List.map (variantize e t) v) 380 | Option t -> VOption (may_map (variantize e t) v) 381 | Pair (t1, t2) -> VPair (variantize e t1 (fst v), variantize e t2 (snd v)) 382 | Rec t -> variantize (Econs (ty, e)) t v 383 | Pop t -> (match e with Econs (_, e') -> variantize e' t v) 384 | Var -> (match e with Econs (t, e') -> variantize e' t v) 385 | Conv (s, proj, inj, t) -> VConv (s, variantize e t (proj v)) 386 | Sum ops -> 387 let tag, arg = ops.sum_proj v in 388 VSum (tag, may_map (function Tdyn (ty,arg) -> variantize e ty arg) arg) 389;; 390[%%expect{| 391type variant = 392 VInt of int 393 | VString of string 394 | VList of variant list 395 | VOption of variant option 396 | VPair of variant * variant 397 | VConv of string * variant 398 | VSum of string * variant option 399val may_map : ('a -> 'b) -> 'a option -> 'b option = <fun> 400val variantize : 'e ty_env -> ('a, 'e) ty -> 'a -> variant = <fun> 401|}];; 402 403let rec devariantize : type t e. e ty_env -> (t, e) ty -> variant -> t = 404 fun e ty v -> 405 match ty, v with 406 | Int, VInt x -> x 407 | String, VString x -> x 408 | List ty1, VList vl -> 409 List.map (devariantize e ty1) vl 410 | Pair (ty1, ty2), VPair (x1, x2) -> 411 (devariantize e ty1 x1, devariantize e ty2 x2) 412 | Rec t, _ -> devariantize (Econs (ty, e)) t v 413 | Pop t, _ -> (match e with Econs (_, e') -> devariantize e' t v) 414 | Var, _ -> (match e with Econs (t, e') -> devariantize e' t v) 415 | Conv (s, proj, inj, t), VConv (s', v) when s = s' -> 416 inj (devariantize e t v) 417 | Sum ops, VSum (tag, a) -> 418 begin try match List.assoc tag ops.sum_cases, a with 419 | TCarg (sel, t), Some a -> ops.sum_inj (sel, devariantize e t a) 420 | TCnoarg sel, None -> ops.sum_inj (sel, Noarg) 421 | _ -> raise VariantMismatch 422 with Not_found -> raise VariantMismatch 423 end 424 | _ -> raise VariantMismatch 425;; 426[%%expect{| 427val devariantize : 'e ty_env -> ('t, 'e) ty -> variant -> 't = <fun> 428|}];; 429 430(* First attempt: represent 1-constructor variants using Conv *) 431let wrap_A t = Conv ("`A", (fun (`A x) -> x), (fun x -> `A x), t);; 432[%%expect{| 433val wrap_A : ('a, 'b) ty -> ([ `A of 'a ], 'b) ty = <fun> 434|}];; 435 436let ty a = Rec (wrap_A (Option (Pair (a, Var)))) ;; 437[%%expect{| 438val ty : ('a, ([ `A of ('a * 'b) option ] as 'b) -> 'c) ty -> ('b, 'c) ty = 439 <fun> 440|}];; 441let v = variantize Enil (ty Int);; 442[%%expect{| 443val v : ([ `A of (int * 'a) option ] as 'a) -> variant = <fun> 444|}];; 445let x = v (`A (Some (1, `A (Some (2, `A None))))) ;; 446[%%expect{| 447val x : variant = 448 VConv ("`A", 449 VOption 450 (Some 451 (VPair (VInt 1, 452 VConv ("`A", 453 VOption (Some (VPair (VInt 2, VConv ("`A", VOption None))))))))) 454|}];; 455 456(* Can also use it to decompose a tuple *) 457 458let triple t1 t2 t3 = 459 Conv ("Triple", (fun (a,b,c) -> (a,(b,c))), 460 (fun (a,(b,c)) -> (a,b,c)), Pair (t1, Pair (t2, t3)));; 461[%%expect{| 462val triple : 463 ('a, 'b) ty -> ('c, 'b) ty -> ('d, 'b) ty -> ('a * 'c * 'd, 'b) ty = <fun> 464|}];; 465 466let v = variantize Enil (triple String Int Int) ("A", 2, 3) ;; 467[%%expect{| 468val v : variant = 469 VConv ("Triple", VPair (VString "A", VPair (VInt 2, VInt 3))) 470|}];; 471 472(* Second attempt: introduce a real sum construct *) 473let ty_abc = 474 (* Could also use [get_case] for proj, but direct definition is shorter *) 475 let proj = function 476 `A n -> "A", Some (Tdyn (Int, n)) 477 | `B s -> "B", Some (Tdyn (String, s)) 478 | `C -> "C", None 479 (* Define inj in advance to be able to write the type annotation easily *) 480 and inj : type c. (int -> string -> noarg -> unit, c) ty_sel * c -> 481 [`A of int | `B of string | `C] = function 482 Thd, v -> `A v 483 | Ttl Thd, v -> `B v 484 | Ttl (Ttl Thd), Noarg -> `C 485 in 486 (* Coherence of sum_inj and sum_cases is checked by the typing *) 487 Sum { sum_proj = proj; sum_inj = inj; sum_cases = 488 [ "A", TCarg (Thd, Int); "B", TCarg (Ttl Thd, String); 489 "C", TCnoarg (Ttl (Ttl Thd)) ] } 490;; 491[%%expect{| 492val ty_abc : ([ `A of int | `B of string | `C ], 'a) ty = 493 Sum 494 {sum_proj = <fun>; 495 sum_cases = 496 [("A", TCarg (Thd, Int)); ("B", TCarg (Ttl Thd, String)); 497 ("C", TCnoarg (Ttl (Ttl Thd)))]; 498 sum_inj = <fun>} 499|}];; 500 501let v = variantize Enil ty_abc (`A 3);; 502[%%expect{| 503val v : variant = VSum ("A", Some (VInt 3)) 504|}];; 505let a = devariantize Enil ty_abc v;; 506[%%expect{| 507val a : [ `A of int | `B of string | `C ] = `A 3 508|}];; 509 510(* And an example with recursion... *) 511type 'a vlist = [`Nil | `Cons of 'a * 'a vlist] 512;; 513 514let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t -> 515 let tcons = Pair (Pop t, Var) in 516 Rec (Sum { 517 sum_proj = (function 518 `Nil -> "Nil", None 519 | `Cons p -> "Cons", Some (Tdyn (tcons, p))); 520 sum_cases = ["Nil", TCnoarg Thd; "Cons", TCarg (Ttl Thd, tcons)]; 521 sum_inj = fun (type c) -> 522 (function 523 | Thd, Noarg -> `Nil 524 | Ttl Thd, v -> `Cons v 525 : (noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist) 526 (* One can also write the type annotation directly *) 527 }) 528;; 529[%%expect{| 530type 'a vlist = [ `Cons of 'a * 'a vlist | `Nil ] 531val ty_list : ('a, 'e) ty -> ('a vlist, 'e) ty = <fun> 532|}];; 533 534let v = variantize Enil (ty_list Int) (`Cons (1, `Cons (2, `Nil))) ;; 535[%%expect{| 536val v : variant = 537 VSum ("Cons", 538 Some 539 (VPair (VInt 1, VSum ("Cons", Some (VPair (VInt 2, VSum ("Nil", None))))))) 540|}];; 541 542(* Simpler but weaker approach *) 543 544type (_,_) ty = 545 | Int: (int,_) ty 546 | String: (string,_) ty 547 | List: ('a,'e) ty -> ('a list, 'e) ty 548 | Option: ('a,'e) ty -> ('a option, 'e) ty 549 | Pair: (('a,'e) ty * ('b,'e) ty) -> ('a * 'b,'e) ty 550 | Var: ('a, 'a -> 'e) ty 551 | Rec: ('a, 'a -> 'e) ty -> ('a,'e) ty 552 | Pop: ('a, 'e) ty -> ('a, 'b -> 'e) ty 553 | Conv: string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty 554 | Sum: ('a -> string * 'e ty_dyn option) * (string * 'e ty_dyn option -> 'a) 555 -> ('a, 'e) ty 556and 'e ty_dyn = 557 | Tdyn : ('a,'e) ty * 'a -> 'e ty_dyn 558;; 559 560let ty_abc : ([`A of int | `B of string | `C],'e) ty = 561 (* Could also use [get_case] for proj, but direct definition is shorter *) 562 Sum ( 563 (function 564 `A n -> "A", Some (Tdyn (Int, n)) 565 | `B s -> "B", Some (Tdyn (String, s)) 566 | `C -> "C", None), 567 (function 568 "A", Some (Tdyn (Int, n)) -> `A n 569 | "B", Some (Tdyn (String, s)) -> `B s 570 | "C", None -> `C 571 | _ -> invalid_arg "ty_abc")) 572;; 573[%%expect{| 574type (_, _) ty = 575 Int : (int, 'c) ty 576 | String : (string, 'd) ty 577 | List : ('a, 'e) ty -> ('a list, 'e) ty 578 | Option : ('a, 'e) ty -> ('a option, 'e) ty 579 | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty 580 | Var : ('a, 'a -> 'e) ty 581 | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty 582 | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty 583 | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty 584 | Sum : ('a -> string * 'e ty_dyn option) * 585 (string * 'e ty_dyn option -> 'a) -> ('a, 'e) ty 586and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn 587val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum (<fun>, <fun>) 588|}];; 589 590(* Breaks: no way to pattern-match on a full recursive type *) 591let ty_list : type a e. (a,e) ty -> (a vlist,e) ty = fun t -> 592 let targ = Pair (Pop t, Var) in 593 Rec (Sum ( 594 (function `Nil -> "Nil", None 595 | `Cons p -> "Cons", Some (Tdyn (targ, p))), 596 (function "Nil", None -> `Nil 597 | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p))) 598;; 599[%%expect{| 600Line _, characters 41-58: 601Error: This pattern matches values of type a * a vlist 602 but a pattern was expected which matches values of type 603 $Tdyn_'a = $0 * $1 604 Type a is not compatible with type $0 605|}];; 606 607(* Define Sum using object instead of record for first-class polymorphism *) 608 609type (_,_) ty = 610 | Int: (int,_) ty 611 | String: (string,_) ty 612 | List: ('a,'e) ty -> ('a list, 'e) ty 613 | Option: ('a,'e) ty -> ('a option, 'e) ty 614 | Pair: (('a,'e) ty * ('b,'e) ty) -> ('a * 'b,'e) ty 615 | Var: ('a, 'a -> 'e) ty 616 | Rec: ('a, 'a -> 'e) ty -> ('a,'e) ty 617 | Pop: ('a, 'e) ty -> ('a, 'b -> 'e) ty 618 | Conv: string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty 619 | Sum: < proj: 'a -> string * 'e ty_dyn option; 620 cases: (string * ('e,'b) ty_case) list; 621 inj: 'c. ('b,'c) ty_sel * 'c -> 'a > 622 -> ('a, 'e) ty 623 624and 'e ty_dyn = 625 | Tdyn : ('a,'e) ty * 'a -> 'e ty_dyn 626 627and (_,_) ty_sel = 628 | Thd : ('a -> 'b, 'a) ty_sel 629 | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel 630 631and (_,_) ty_case = 632 | TCarg : ('b,'a) ty_sel * ('a,'e) ty -> ('e,'b) ty_case 633 | TCnoarg : ('b,noarg) ty_sel -> ('e,'b) ty_case 634;; 635 636let ty_abc : ([`A of int | `B of string | `C] as 'a, 'e) ty = 637 Sum (object 638 method proj = function 639 `A n -> "A", Some (Tdyn (Int, n)) 640 | `B s -> "B", Some (Tdyn (String, s)) 641 | `C -> "C", None 642 method cases = 643 [ "A", TCarg (Thd, Int); "B", TCarg (Ttl Thd, String); 644 "C", TCnoarg (Ttl (Ttl Thd)) ]; 645 method inj : type c. 646 (int -> string -> noarg -> unit, c) ty_sel * c -> 647 [`A of int | `B of string | `C] = 648 function 649 Thd, v -> `A v 650 | Ttl Thd, v -> `B v 651 | Ttl (Ttl Thd), Noarg -> `C 652 end) 653;; 654[%%expect{| 655type (_, _) ty = 656 Int : (int, 'd) ty 657 | String : (string, 'f) ty 658 | List : ('a, 'e) ty -> ('a list, 'e) ty 659 | Option : ('a, 'e) ty -> ('a option, 'e) ty 660 | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty 661 | Var : ('a, 'a -> 'e) ty 662 | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty 663 | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty 664 | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty 665 | Sum : 666 < cases : (string * ('e, 'b) ty_case) list; 667 inj : 'c. ('b, 'c) ty_sel * 'c -> 'a; 668 proj : 'a -> string * 'e ty_dyn option > -> ('a, 'e) ty 669and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn 670and (_, _) ty_sel = 671 Thd : ('a -> 'b, 'a) ty_sel 672 | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel 673and (_, _) ty_case = 674 TCarg : ('b, 'a) ty_sel * ('a, 'e) ty -> ('e, 'b) ty_case 675 | TCnoarg : ('b, noarg) ty_sel -> ('e, 'b) ty_case 676val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum <obj> 677|}];; 678 679type 'a vlist = [`Nil | `Cons of 'a * 'a vlist] 680;; 681 682let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t -> 683 let tcons = Pair (Pop t, Var) in 684 Rec (Sum (object 685 method proj = function 686 `Nil -> "Nil", None 687 | `Cons p -> "Cons", Some (Tdyn (tcons, p)) 688 method cases = ["Nil", TCnoarg Thd; "Cons", TCarg (Ttl Thd, tcons)] 689 method inj : type c.(noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist 690 = function 691 | Thd, Noarg -> `Nil 692 | Ttl Thd, v -> `Cons v 693 end)) 694;; 695[%%expect{| 696type 'a vlist = [ `Cons of 'a * 'a vlist | `Nil ] 697val ty_list : ('a, 'e) ty -> ('a vlist, 'e) ty = <fun> 698|}];; 699 700(* 701type (_,_) ty_assoc = 702 | Anil : (unit,'e) ty_assoc 703 | Acons : string * ('a,'e) ty * ('b,'e) ty_assoc -> ('a -> 'b, 'e) ty_assoc 704 705and (_,_) ty_pvar = 706 | Pnil : ('a,'e) ty_pvar 707 | Pconst : 't * ('b,'e) ty_pvar -> ('t -> 'b, 'e) ty_pvar 708 | Parg : 't * ('a,'e) ty * ('b,'e) ty_pvar -> ('t * 'a -> 'b, 'e) ty_pvar 709*) 710