1 files changed, 44 insertions, 60 deletions
diff --git a/src/catalog.ml b/src/catalog.ml
index 71f953f..cd217b3 100755..100644
--- a/src/catalog.ml
+++ b/src/catalog.ml
@@ -62,7 +62,6 @@ module type CATALOG = sig
     ( 'a -> 'b -> 'c -> 'd) ->    (* The function to call*)
     catalog_builder -> catalog_builder
 
-
   (** Compile the catalog *)
   val compile: catalog_builder -> t
 
@@ -78,6 +77,7 @@ module type CATALOG = sig
 
 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. *)
@@ -89,65 +89,44 @@ module Make(Data:DATA_SIG) = struct
   type 'a argument = 'a Data.t
   type 'a returnType = 'a Data.returnType
 
-  (** 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.t -> 'a t_function sig_typ
-    | T2: 'a Data.t * 'b Data.t -> ('a * 'b) t_function sig_typ
-    | T3: 'a Data.t * 'b Data.t * 'c Data.t -> ('a * 'b * 'c) t_function sig_typ
+  type result =
+    | R : 'a returnType * 'a -> result
 
+  type _ lift =
+    | Z : result lift (* No more parameter in the function *)
+    | S : 'c argument * 't1 lift -> ('c -> 't1) lift
 
   module ComparableSignature = struct
 
-    type 'a t = 'a sig_typ
+    type 'a t = 'a lift
 
     (* Type for pure equality *)
     type (_, _) eq = Eq : ('a, 'a) eq
 
     (** Compare two signature *)
-    let comp: type a b. a sig_typ -> b sig_typ -> (a, b) T.cmp = begin fun a b ->
-
-      let cmp: type c d. c Data.t -> d Data.t -> ((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
+    let rec comp: type a1 a2. a1 lift -> a2 lift -> (a1, a2) T.cmp = fun a b ->
+      begin match (a, b) with
+      | (S _, Z) -> T.Lt
+      | (Z, S _) -> T.Gt
+      | (Z, Z) -> T.Eq
+      | (S (arg1, s1), S (arg2, s2)) -> begin match Data.compare_typ arg1 arg2 with
         | T.Lt -> T.Lt
         | T.Gt -> T.Gt
-      end in
-
-      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 -> 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
+        | T.Eq -> begin match comp s1 s2 with
+          | T.Eq -> T.Eq
+          | T.Lt -> T.Lt
+          | T.Gt -> T.Gt
+          end
       end
+    end
 
+    let rec repr : type a b. Format.formatter -> a t -> unit = begin fun formatter t -> match t with
+      | Z -> Format.fprintf formatter "->"
+      | S (t1, f) -> Format.fprintf formatter "(%a,%a)" Data.repr t1 repr f
+    end
   end
 
+
   module Catalog = Map.Make(String)
   module Functions = Splay.Make(ComparableSignature)
 
@@ -160,9 +139,11 @@ module Make(Data:DATA_SIG) = struct
 
   let empty = Catalog.empty
 
-  (**
+  (** Generic register function in the catalog.
+
      Register a function in the catalog. If the function is already defined,
      raise an exception.
+
    *)
   let register t name signature f = begin
 
@@ -179,18 +160,21 @@ module Make(Data:DATA_SIG) = struct
     Catalog.add name' map t
   end
 
-  let register1 name typ1 returnType f catalog =
-    register catalog name (T1(typ1)) (Fn1 (returnType, f))
+  let register1 name typ1 result f catalog =
+    let f' arg1 = R(result, f arg1) in
+    register catalog name (S (typ1, Z)) f'
 
   let register2 name (typ1, typ2) result f catalog =
-    register catalog name (T2(typ1, typ2)) (Fn2 (result, f))
+    let f' arg1 arg2 = R(result, f arg1 arg2) in
+    register catalog name (S (typ1, S (typ2, Z))) f'
 
   let register3 name (typ1, typ2, typ3) result f catalog =
-    register catalog name (T3(typ1, typ2, typ3)) (Fn3 (result, f))
+    let f' arg1 arg2 arg3 = R(result, f arg1 arg2 arg3) in
+    register catalog name (S (typ1, S (typ2, S (typ3, Z)))) f'
 
   (** 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 =
+  type a b. t -> string -> a ComparableSignature.t  -> a =
   begin fun t name signature ->
        String_dict.find_exn t (String.uppercase_ascii name)
     |> Functions.find signature
@@ -203,21 +187,21 @@ module Make(Data:DATA_SIG) = struct
     String_dict.of_alist_exn (Catalog.bindings t)
 
 
-  type result =
-    | R : 'a returnType * 'a -> result
-
   let eval1 catalog name (t1, arg1) = begin
-    let Fn1(ret, f) = find_function catalog name (T1 t1) in
-    R (ret, f arg1)
+    let f = find_function catalog name (S (t1, Z)) in
+    f arg1
   end
 
   let eval2 catalog name (t1, arg1) (t2, arg2) = begin
-    let Fn2(ret, f) = find_function catalog name (T2 (t1, t2)) in
-    R (ret, f arg1 arg2)
+    let f = find_function catalog name (S (t1, S (t2, Z))) in
+    f arg1 arg2
   end
 
   let eval3 catalog name (t1, arg1) (t2, arg2) (t3, arg3) = begin
-    let Fn3(ret, f) = find_function catalog name (T3 (t1, t2, t3)) in
-    R (ret, f arg1 arg2 arg3)
+    let f = find_function catalog name (S (t1, S (t2, S (t3, Z)))) in
+    f arg1 arg2 arg3
   end
+
+
+
 end