aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSébastien Dailly <sebastien@chimrod.com>2019-09-02 14:03:39 +0200
committerSébastien Dailly <sebastien@chimrod.com>2019-09-02 14:03:39 +0200
commit9518311d758b42663bfd2e0d84e9a06824f38152 (patch)
tree25c9722a498d643d426fd0cf4222c2944a939c8d
parentbd19e0f8d0616526fec25031124b3a33bbe3c8a3 (diff)
Pattern matching order error
-rw-r--r--src/catalog.ml53
-rw-r--r--src/errors.ml14
-rw-r--r--src/expressions/evaluate.ml1
-rw-r--r--src/scTypes.ml1
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 ();