Pattern matching order error

4 files changed, 49 insertions, 20 deletions

diff --git a/src/catalog.ml b/src/catalog.ml
index cd217b3..526a3ed 100644
--- a/src/catalog.ml
+++ b/src/catalog.ml
@@ -15,6 +15,8 @@ You should have received a copy of the GNU General Public License
 along with licht.  If not, see <http://www.gnu.org/licenses/>.

 *)

 

+let u = UTF8.from_utf8string

+

 module T = Tools

 module type DATA_SIG = sig

 

@@ -89,12 +91,31 @@ module Make(Data:DATA_SIG) = struct
   type 'a argument = 'a Data.t

   type 'a returnType = 'a Data.returnType

 

-  type result =

-    | R : 'a returnType * 'a -> result

+  type result = R : 'a returnType * 'a -> result

+  type ex_argument = ExArg : 'a argument -> ex_argument

 

   type _ lift =

     | Z : result lift (* No more parameter in the function *)

-    | S : 'c argument * 't1 lift -> ('c -> 't1) lift

+    | S : 'a argument * 't1 lift -> ('a -> 't1) lift (* Add an argument to the function *)

+

+  (** Build a reversed list with each argument mapped *)

+  let rev_map: type a. (ex_argument -> 'c) -> a lift -> 'c list = begin fun f lift ->

+    let rec map': type a. 'c list -> a lift -> 'c list = fun acc -> function

+    | Z -> acc

+    | S (l, tl) -> map' ((f (ExArg l))::acc) tl in

+    map' [] lift

+  end

+

+  (** Get the name for argument *)

+  let show_args lift = begin

+    let formatter = Format.str_formatter in

+    let print (ExArg arg) = begin

+      Data.repr formatter arg;

+      Format.flush_str_formatter ()

+    end in

+    List.rev @@ rev_map print lift

+  end

+

 

   module ComparableSignature = struct

 

@@ -106,10 +127,8 @@ module Make(Data:DATA_SIG) = struct
     (** Compare two signature *)

     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

+      | 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

         | T.Eq -> begin match comp s1 s2 with

@@ -117,10 +136,12 @@ module Make(Data:DATA_SIG) = struct
           | T.Lt -> T.Lt

           | T.Gt -> T.Gt

           end

-      end

+        end

+      | _  , Z   -> T.Lt

+      | Z  , _   -> T.Gt

     end

 

-    let rec repr : type a b. Format.formatter -> a t -> unit = begin fun formatter t -> match t with

+    let rec repr : type a. 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

@@ -161,26 +182,30 @@ module Make(Data:DATA_SIG) = struct
   end

 

   let register1 name typ1 result f catalog =

-    let f' arg1 = R(result, f arg1) in

+    let f' arg1 = R (result, f arg1) in

     register catalog name (S (typ1, Z)) f'

 

   let register2 name (typ1, typ2) result f catalog =

-    let f' arg1 arg2 = R(result, f arg1 arg2) in

+    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 =

-    let f' arg1 arg2 arg3 = R(result, f arg1 arg2 arg3) in

+    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 b. t -> string -> a ComparableSignature.t  -> a =

   begin fun t name signature ->

-       String_dict.find_exn t (String.uppercase_ascii name)

+    try String_dict.find_exn t (String.uppercase_ascii name)

     |> Functions.find signature

+    with Not_found ->

+        (* None found, build an error message *)

+        raise (Errors.Undefined (u name, show_args signature))

   end

 

   let compile t =

+

     (* Use efficient String_dict.

        The requirement to have a unique key is garantee by the Map structure.

     *)

@@ -202,6 +227,4 @@ module Make(Data:DATA_SIG) = struct
     f arg1 arg2 arg3

   end

 

-

-

 end

diff --git a/src/errors.ml b/src/errors.ml
index f4b3425..e5abe10 100644
--- a/src/errors.ml
+++ b/src/errors.ml
@@ -20,12 +20,16 @@ along with licht.  If not, see <http://www.gnu.org/licenses/>.
 exception Undefined of UTF8.t * string list

 

 exception TypeError

-

 exception Cycle

 

 let printf formatter = function

-  | Undefined (name, args) -> Format.fprintf formatter

-      "There is no function '%s' with signature %a"

+  | Undefined (name, args) ->

+    let pp_sep f () = Format.pp_print_string f ", " in

+    Format.fprintf formatter

+      "There is no function '%s' with signature (%a)"

       (UTF8.to_utf8string name)

-      (Format.pp_print_list Format.pp_print_text) args

-  | _ -> Format.fprintf formatter "#Error"

+      (Format.pp_print_list ~pp_sep Format.pp_print_text) args

+  | Cycle -> Format.fprintf formatter "Cycle"

+  | TypeError -> Format.fprintf formatter "TypeError"

+  | Not_found -> Format.fprintf formatter "Not_found"

+  | _ -> Format.fprintf formatter "?"

diff --git a/src/expressions/evaluate.ml b/src/expressions/evaluate.ml
index 4cf98da..308a824 100644
--- a/src/expressions/evaluate.ml
+++ b/src/expressions/evaluate.ml
@@ -60,6 +60,7 @@ let get_argument: type a. a value -> a Functions.typ * a = function
   | List (t, l)   -> Functions.t_list (Functions.typ_of_format t), l

   | Matrix (t, l) -> Functions.t_list (Functions.t_list (Functions.typ_of_format t)), l

 

+(** Convert the evaluation result in a type depending of the function parameters *)

 let wrap_call (Functions.C.R(ret, res)) type_builder = begin

   let returnType = ScTypes.ReturnType.guess_format_result ret type_builder in

   begin match returnType with

diff --git a/src/scTypes.ml b/src/scTypes.ml
index 46886a9..a8aa198 100644
--- a/src/scTypes.ml
+++ b/src/scTypes.ml
@@ -200,6 +200,7 @@ module Result = struct
     | Error x ->
         (*
         let buffer = Buffer.create 16 in
+        Buffer.add_string buffer "#Error :";
         let b = Format.formatter_of_buffer buffer in
         Errors.printf b x;
         Format.pp_print_flush b ();