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
|
module T = Tools
module type DATA_SIG = sig
type 'a typ
type 'a result
val compare_typ: 'a typ -> 'b typ -> ('a, 'b) T.cmp
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.result * ('a -> 'b) -> 'a t_function
| Fn2: 'c Data.result * ('a -> 'b -> 'c) -> ('a * 'b) t_function
| Fn3: 'd Data.result * ('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
module ComparableSignature = struct
type 'a t = 'a sig_typ
(** Compare two signature *)
let eq: type a b. a sig_typ -> b sig_typ -> (a, b) T.cmp = begin fun a b ->
let cmp: type c d. c Data.typ -> d Data.typ -> ((c, d) T.cmp -> (a, b) T.cmp) -> (a, b) T.cmp =
begin fun a b f -> match Data.compare_typ a b with
| T.Eq -> f T.Eq
| T.Lt -> T.Lt
| T.Gt -> T.Gt
end in
match a, b with
| T1(a), T1(b) -> cmp a b (fun T.Eq -> T.Eq)
| T2(a, b), T2(c, d) ->
cmp a c (fun T.Eq ->
cmp b d (fun T.Eq -> T.Eq)
)
| T3(a, b, c), T3(d, e, f) ->
cmp a d (fun T.Eq ->
cmp b e (fun T.Eq ->
cmp c f (fun T.Eq -> T.Eq)
)
)
| x, y -> if (T.Ex x) > (T.Ex y) then T.Gt else T.Lt
end
end
module Catalog = Map.Make(String)
module Functions = Tools.Map(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 Catalog.t
let empty = Catalog.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
let map = begin match Catalog.find name' t with
| exception Not_found ->
Functions.singleton signature f
| x ->
(* We prevent any update to already registered function *)
if (Functions.mem signature x) then
raise RegisteredFunction
else
Functions.add signature f x
end in
Catalog.add name' map 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 ->
Catalog.find (String.uppercase_ascii name) t
|> Functions.find signature
end
end
|
