blob: 7e155f5368789ec54bfa25ddf8f61df5381a10d9 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
|
(* TEST
* toplevel
*)
(* Ignore OCAMLRUNPARAM=b to be reproducible *)
Printexc.record_backtrace false;;
(* By using two types we can have a recursive constraint *)
type 'a class_name = .. constraint 'a = < cast: 'a. 'a name -> 'a; ..>
and 'a name =
Class : 'a class_name -> (< cast: 'a. 'a name -> 'a; ..> as 'a) name
;;
exception Bad_cast
;;
class type castable =
object
method cast: 'a.'a name -> 'a
end
;;
(* Lets create a castable class with a name*)
class type foo_t =
object
inherit castable
method foo: string
end
;;
type 'a class_name += Foo: foo_t class_name
;;
class foo: foo_t =
object(self)
method cast: type a. a name -> a =
function
Class Foo -> (self :> foo_t)
| _ -> ((raise Bad_cast) : a)
method foo = "foo"
end
;;
(* Now we can create a subclass of foo *)
class type bar_t =
object
inherit foo
method bar: string
end
;;
type 'a class_name += Bar: bar_t class_name
;;
class bar: bar_t =
object(self)
inherit foo as super
method cast: type a. a name -> a =
function
Class Bar -> (self :> bar_t)
| other -> super#cast other
method bar = "bar"
end
;;
(* Now lets create a mutable list of castable objects *)
let clist :castable list ref = ref []
;;
let push_castable (c: #castable) =
clist := (c :> castable) :: !clist
;;
let pop_castable () =
match !clist with
c :: rest ->
clist := rest;
c
| [] -> raise Not_found
;;
(* We can add foos and bars to this list, and retrieve them *)
push_castable (new foo);;
push_castable (new bar);;
push_castable (new foo);;
let c1: castable = pop_castable ();;
let c2: castable = pop_castable ();;
let c3: castable = pop_castable ();;
(* We can also downcast these values to foos and bars *)
let f1: foo = c1#cast (Class Foo);; (* Ok *)
let f2: foo = c2#cast (Class Foo);; (* Ok *)
let f3: foo = c3#cast (Class Foo);; (* Ok *)
let b1: bar = c1#cast (Class Bar);; (* Exception Bad_cast *)
let b2: bar = c2#cast (Class Bar);; (* Ok *)
let b3: bar = c3#cast (Class Bar);; (* Exception Bad_cast *)
|
