From 9518311d758b42663bfd2e0d84e9a06824f38152 Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Mon, 2 Sep 2019 14:03:39 +0200 Subject: Pattern matching order error --- src/catalog.ml | 53 ++++++++++++++++++++++++++++++++------------- src/errors.ml | 14 +++++++----- src/expressions/evaluate.ml | 1 + src/scTypes.ml | 1 + 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 . *) +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 . 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 (); -- cgit v1.2.3