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
|
module T = Tools
module type DATA_SIG = sig
type 'a typ
type 'a returnType
val compare_typ: 'a typ -> 'b typ -> ('a, 'b) T.cmp
val repr: Format.formatter -> 'a typ -> unit
end
(** We cannot update an existing function. Any [registerX] function will raise
[RegisteredFunction] if a function with the same signature already exists in
the catalog. *)
exception RegisteredFunction
(** Catalog for all functions *)
module Make(Data:DATA_SIG) = struct
(** This is the way the function is store in the map.
We just the return type, and the function itself. *)
type _ t_function =
| Fn1: 'b Data.returnType * ('a -> 'b) -> 'a t_function
| Fn2: 'c Data.returnType * ('a -> 'b -> 'c) -> ('a * 'b) t_function
| Fn3: 'd Data.returnType * ('a -> 'b -> 'c -> 'd) -> ('a * 'b * 'c) t_function
(** This is the key for storing functions in the map. *)
type _ sig_typ =
| T1: 'a Data.typ -> 'a t_function sig_typ
| T2: 'a Data.typ * 'b Data.typ -> ('a * 'b) t_function sig_typ
| T3: 'a Data.typ * 'b Data.typ * 'c Data.typ -> ('a * 'b * 'c) t_function sig_typ
let repr: type a. Format.formatter -> a sig_typ -> unit = fun formatter -> function
| T1 t -> Format.fprintf formatter "(%a)" Data.repr t
| T2 (t1, t2) -> Format.fprintf formatter "(%a,%a)" Data.repr t1 Data.repr t2
| T3 (t1, t2, t3) -> Format.fprintf formatter "(%a,%a,%a)" Data.repr t1 Data.repr t2 Data.repr t3
module ComparableSignature = struct
type 'a t = string * 'a sig_typ
(* Type for pure equality *)
type (_, _) eq = Eq : ('a, 'a) eq
(** Compare two signature *)
let comp: type a b. string * a sig_typ -> string * b sig_typ -> (a, b) T.cmp = begin fun (namea, a) (nameb, b) ->
let cmp: type c d. c Data.typ -> d Data.typ -> ((c, d) eq -> (a, b) T.cmp) -> (a, b) T.cmp =
begin fun a b f -> match Data.compare_typ a b with
| T.Eq -> f Eq
| T.Lt -> T.Lt
| T.Gt -> T.Gt
end in
if namea < nameb then
T.Lt
else if namea > nameb then
T.Gt
else match a, b with
| T1(a), T1(b) -> cmp a b (fun Eq -> T.Eq)
| T1(_), _ -> T.Lt
| _, T1(_) -> T.Gt
| T2(a, b), T2(c, d) ->
cmp a c (fun Eq ->
cmp b d (fun Eq -> T.Eq)
)
| T2(_), _ -> T.Lt
| _, T2(_) -> T.Gt
| T3(a, b, c), T3(d, e, f) ->
cmp a d (fun Eq ->
cmp b e (fun Eq ->
cmp c f (fun Eq -> T.Eq)
)
)
end
let repr : type a. Format.formatter -> a t -> unit = begin fun formatter (str, typ) ->
Format.fprintf formatter "%s:%a"
str
repr typ
end
end
module Functions = Splay.Make(ComparableSignature)
(* This is the map which contains all the registered functions.
Each name is binded with another map with contains the function for each
signature.
*)
type t = Functions.t
let empty = Functions.empty
(**
Register a function in the catalog. If the function is already defined,
raise an exception.
*)
let register t name signature f = begin
let name' = String.uppercase_ascii name in
if Functions.member (name', signature) t then
raise RegisteredFunction
else
Functions.add (name', signature) f t
end
(** Look in the catalog for a function with the given name and signature *)
let find_function:
type a. t -> string -> a t_function sig_typ -> a t_function =
begin fun t name signature ->
Functions.find ((String.uppercase_ascii name), signature) t
end
let repr = Functions.repr
end
|
