1 files changed, 125 insertions, 0 deletions
diff --git a/src/catalog.ml b/src/catalog.ml
new file mode 100755
index 0000000..e4cd34b
--- /dev/null
+++ b/src/catalog.ml
@@ -0,0 +1,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