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
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
|
(* Simple example *)
let f x =
(multimatch x with `A -> 1 | `B -> true),
(multimatch x with `A -> 1. | `B -> "1");;
(* OK *)
module M : sig
val f :
[< `A & 'a = int & 'b = float | `B & 'b =string & 'a = bool] -> 'a * 'b
end = struct let f = f end;;
(* Bad *)
module M : sig
val f :
[< `A & 'a = int & 'b = float | `B & 'b =string & 'a = int] -> 'a * 'b
end = struct let f = f end;;
(* Should be good! *)
module M : sig
val f :
[< `A & 'a = int * float | `B & 'a = bool * string] -> 'a
end = struct let f = f end;;
let f = multifun `A|`B as x -> f x;;
(* Two-level example *)
let f = multifun
`A -> (multifun `C -> 1 | `D -> 1.)
| `B -> (multifun `C -> true | `D -> "1");;
(* OK *)
module M : sig
val f :
[< `A & 'b = [< `C & 'a = int | `D & 'a = float & 'c = bool] -> 'a
| `B & 'b = [< `C & 'c = bool | `D & 'c = string] -> 'c] -> 'b
end = struct let f = f end;;
(* Bad *)
module M : sig
val f :
[< `A & 'b = [< `C & 'a = int | `D & 'a = bool] -> 'a
| `B & 'b = [< `C & 'c = bool | `D & 'c = string] -> 'c] -> 'b
end = struct let f = f end;;
module M : sig
val f :
[< `A & 'b = [< `C & 'a = int | `D] -> 'a
| `B & 'b = [< `C & 'c = bool | `D & 'c = string] -> 'c] -> 'b
end = struct let f = f end;;
(* Examples with hidden sharing *)
let r = ref []
let f = multifun `A -> 1 | `B -> true
let g x = r := [f x];;
(* Bad! *)
module M : sig
val g : [< `A & 'a = int | `B & 'a = bool] -> unit
end = struct let g = g end;;
let r = ref []
let f = multifun `A -> r | `B -> ref [];;
(* Now OK *)
module M : sig
val f : [< `A & 'b = int list ref | `B & 'b = 'c list ref] -> 'b
end = struct let f = f end;;
(* Still OK *)
let l : int list ref = r;;
module M : sig
val f : [< `A & 'b = int list ref | `B & 'b = 'c list ref] -> 'b
end = struct let f = f end;;
(* Examples that would need unification *)
let f = multifun `A -> (1, []) | `B -> (true, [])
let g x = fst (f x);;
(* Didn't work, now Ok *)
module M : sig
val g : [< `A & 'a * 'b = int * bool | `B & 'a * 'b = bool * int] -> 'a
end = struct let g = g end;;
let g = multifun (`A|`B) as x -> g x;;
(* Other examples *)
let f x =
let a = multimatch x with `A -> 1 | `B -> "1" in
(multifun `A -> print_int | `B -> print_string) x a
;;
let f = multifun (`A|`B) as x -> f x;;
type unit_op = [`Set of int | `Move of int]
type int_op = [`Get]
let op r =
multifun
`Get -> !r
| `Set x -> r := x
| `Move dx -> r := !r + dx
;;
let rec trace r = function
[] -> []
| op1 :: ops ->
multimatch op1 with
#int_op as op1 ->
let x = op r op1 in
x :: trace r ops
| #unit_op as op1 ->
op r op1;
trace r ops
;;
class point x = object
val mutable x : int = x
method get = x
method set y = x <- y
method move dx = x <- x + dx
end;;
let poly sort coeffs x =
let add, mul, zero =
multimatch sort with
`Int -> (+), ( * ), 0
| `Float -> (+.), ( *. ), 0.
in
let rec compute = function
[] -> zero
| c :: cs -> add c (mul x (compute cs))
in
compute coeffs
;;
module M : sig
val poly : [< `Int & 'a = int | `Float & 'a = float] -> 'a list -> 'a -> 'a
end = struct let poly = poly end;;
type ('a,'b) num_sort =
'b constraint 'b = [< `Int & 'a = int | `Float & 'a = float]
module M : sig
val poly : ('a,_) num_sort -> 'a list -> 'a -> 'a
end = struct let poly = poly end;;
(* type dispatch *)
type num = [ `Int | `Float ]
let print0 = multifun
`Int -> print_int
| `Float -> print_float
;;
let print1 = multifun
#num as x -> print0 x
| `List t -> List.iter (print0 t)
| `Pair(t1,t2) -> (fun (x,y) -> print0 t1 x; print0 t2 y)
;;
print1 (`Pair(`Int,`Float)) (1,1.0);;
|
