From de038270f72214b169d056642eb7144a79e6f126 Mon Sep 17 00:00:00 2001
From: Emilio Jesus Gallego Arias
Date: Thu, 7 Jul 2016 04:56:24 +0200
Subject: Unify location handling of error functions.

In some cases prior to this patch, there were two cases for the same
error function, one taking a location, the other not.

We unify them by using an option parameter, in the line with recent
changes in warnings and feedback.

This implies a bit of clean up in some places, but more importantly, is
the preparation for subsequent patches making `Loc.location` opaque,
change that could be use to improve modularity and allow a more
functional implementation strategy --- for example --- of the
beautifier.
---
 lib/cErrors.ml   | 9 ++++-----
 lib/cErrors.mli  | 5 +++--
 lib/cWarnings.ml | 2 +-
 lib/loc.ml       | 9 ++++++---
 lib/loc.mli      | 2 +-
 5 files changed, 15 insertions(+), 12 deletions(-)

(limited to 'lib')

diff --git a/lib/cErrors.ml b/lib/cErrors.ml
index 1459141d1e..c5f262373e 100644
--- a/lib/cErrors.ml
+++ b/lib/cErrors.ml
@@ -26,9 +26,8 @@ let _ =
 let make_anomaly ?label pp =
   Anomaly (label, pp)
 
-let anomaly ?loc ?label pp = match loc with
-  | None -> raise (Anomaly (label, pp))
-  | Some loc -> Loc.raise loc (Anomaly (label, pp))
+let anomaly ?loc ?label pp =
+  Loc.raise ?loc (Anomaly (label, pp))
 
 let is_anomaly = function
 | Anomaly _ -> true
@@ -43,8 +42,8 @@ let alreadydeclared pps = raise (AlreadyDeclared(pps))
 
 let todo s = prerr_string ("TODO: "^s^"\n")
 
-let user_err_loc (loc,s,strm) = Loc.raise loc (UserError (s,strm))
-let invalid_arg_loc (loc,s) = Loc.raise loc (Invalid_argument s)
+let user_err    ?loc s strm = Loc.raise ?loc (UserError (s,strm))
+let invalid_arg ?loc s   = Loc.raise ?loc (Invalid_argument s)
 
 exception Timeout
 exception Drop
diff --git a/lib/cErrors.mli b/lib/cErrors.mli
index e5dad93fd0..291c39b84f 100644
--- a/lib/cErrors.mli
+++ b/lib/cErrors.mli
@@ -36,12 +36,13 @@ val is_anomaly : exn -> bool
 exception UserError of string * std_ppcmds
 val error : string -> 'a
 val errorlabstrm : string -> std_ppcmds -> 'a
-val user_err_loc : Loc.t * string * std_ppcmds -> 'a
+
+val user_err     : ?loc:Loc.t -> string -> std_ppcmds -> 'a
 
 exception AlreadyDeclared of std_ppcmds
 val alreadydeclared : std_ppcmds -> 'a
 
-val invalid_arg_loc : Loc.t * string -> 'a
+val invalid_arg : ?loc:Loc.t -> string -> 'a
 
 (** [todo] is for running of an incomplete code its implementation is
    "do nothing" (or print a message), but this function should not be
diff --git a/lib/cWarnings.ml b/lib/cWarnings.ml
index 78fa84f333..f36c7ad80d 100644
--- a/lib/cWarnings.ml
+++ b/lib/cWarnings.ml
@@ -45,7 +45,7 @@ let create ~name ~category ?(default=Enabled) pp =
            | Disabled -> ()
            | AsError ->
               let loc = Option.default !current_loc loc in
-              CErrors.user_err_loc (loc,"_",pp x)
+              CErrors.user_err ~loc "_" (pp x)
            | Enabled ->
               let msg =
                 pp x ++ spc () ++ str "[" ++ str name ++ str "," ++
diff --git a/lib/loc.ml b/lib/loc.ml
index 0f9864a9ac..e373a760cb 100644
--- a/lib/loc.ml
+++ b/lib/loc.ml
@@ -71,6 +71,9 @@ let add_loc e loc = Exninfo.add e location loc
 
 let get_loc e = Exninfo.get e location
 
-let raise loc e =
-  let info = Exninfo.add Exninfo.null location loc in
-  Exninfo.iraise (e, info)
+let raise ?loc e =
+  match loc with
+  | None     -> raise e
+  | Some loc ->
+    let info = Exninfo.add Exninfo.null location loc in
+    Exninfo.iraise (e, info)
diff --git a/lib/loc.mli b/lib/loc.mli
index c08e097a87..bb88f86428 100644
--- a/lib/loc.mli
+++ b/lib/loc.mli
@@ -51,7 +51,7 @@ val add_loc : Exninfo.info -> t -> Exninfo.info
 val get_loc : Exninfo.info -> t option
 (** Retrieving the optional location of an exception *)
 
-val raise : t -> exn -> 'a
+val raise : ?loc:t -> exn -> 'a
 (** [raise loc e] is the same as [Pervasives.raise (add_loc e loc)]. *)
 
 (** {5 Location utilities} *)
-- 
cgit v1.2.3


From 543ee0c7ad43874c577416af9f2e5a94d7d1e4d3 Mon Sep 17 00:00:00 2001
From: Emilio Jesus Gallego Arias
Date: Fri, 19 Aug 2016 01:58:04 +0200
Subject: Remove errorlabstrm in favor of user_err

As noted by @ppedrot, the first is redundant. The patch is basically a renaming.

We didn't make the component optional yet, but this could happen in a
future patch.
---
 lib/cErrors.ml  | 10 +++++-----
 lib/cErrors.mli |  7 +++++--
 lib/system.ml   | 14 +++++++-------
 3 files changed, 17 insertions(+), 14 deletions(-)

(limited to 'lib')

diff --git a/lib/cErrors.ml b/lib/cErrors.ml
index c5f262373e..830a9e3cea 100644
--- a/lib/cErrors.ml
+++ b/lib/cErrors.ml
@@ -34,17 +34,17 @@ let is_anomaly = function
 | _ -> false
 
 exception UserError of string * std_ppcmds (* User errors *)
-let error string = raise (UserError("_", str string))
-let errorlabstrm l pps = raise (UserError(l,pps))
-
-exception AlreadyDeclared of std_ppcmds (* for already declared Schemes *)
-let alreadydeclared pps = raise (AlreadyDeclared(pps))
 
 let todo s = prerr_string ("TODO: "^s^"\n")
 
 let user_err    ?loc s strm = Loc.raise ?loc (UserError (s,strm))
+let error            string = user_err "_" (str string)
+
 let invalid_arg ?loc s   = Loc.raise ?loc (Invalid_argument s)
 
+exception AlreadyDeclared of std_ppcmds (* for already declared Schemes *)
+let alreadydeclared pps = raise (AlreadyDeclared(pps))
+
 exception Timeout
 exception Drop
 exception Quit
diff --git a/lib/cErrors.mli b/lib/cErrors.mli
index 291c39b84f..ad17be393f 100644
--- a/lib/cErrors.mli
+++ b/lib/cErrors.mli
@@ -34,10 +34,13 @@ val is_anomaly : exn -> bool
     tricks with anomalies thanks to it. See rather [noncritical] below. *)
 
 exception UserError of string * std_ppcmds
-val error : string -> 'a
-val errorlabstrm : string -> std_ppcmds -> 'a
 
 val user_err     : ?loc:Loc.t -> string -> std_ppcmds -> 'a
+(** Main error raising primitive. [user_err ?loc c pp] signals an
+    error [pp] in component [c], with optional location [loc] *)
+
+val error : string -> 'a
+(** [error s] just calls [user_error "_" (str s)] *)
 
 exception AlreadyDeclared of std_ppcmds
 val alreadydeclared : std_ppcmds -> 'a
diff --git a/lib/system.ml b/lib/system.ml
index af9aa5c074..916c087959 100644
--- a/lib/system.ml
+++ b/lib/system.ml
@@ -132,7 +132,7 @@ let find_file_in_path ?(warn=true) paths filename =
       let root = Filename.dirname filename in
       root, filename
     else
-      CErrors.errorlabstrm "System.find_file_in_path"
+      CErrors.user_err "System.find_file_in_path"
 	(hov 0 (str "Can't find file" ++ spc () ++ str filename))
   else
     (* the name is considered to be the transcription as a relative
@@ -140,7 +140,7 @@ let find_file_in_path ?(warn=true) paths filename =
        to be locate respecting case *)
     try where_in_path ~warn paths filename
     with Not_found ->
-      CErrors.errorlabstrm "System.find_file_in_path"
+      CErrors.user_err "System.find_file_in_path"
 	(hov 0 (str "Can't find file" ++ spc () ++ str filename ++ spc () ++
 		str "on loadpath"))
 
@@ -163,7 +163,7 @@ let is_in_system_path filename =
 let open_trapping_failure name =
   try open_out_bin name
   with e when CErrors.noncritical e ->
-    CErrors.errorlabstrm "System.open" (str "Can't open " ++ str name)
+    CErrors.user_err "System.open" (str "Can't open " ++ str name)
 
 let warn_cannot_remove_file =
   CWarnings.create ~name:"cannot-remove-file" ~category:"filesystem"
@@ -175,7 +175,7 @@ let try_remove filename =
     warn_cannot_remove_file filename
 
 let error_corrupted file s =
-  CErrors.errorlabstrm "System" (str file ++ str ": " ++ str s ++ str ". Try to rebuild it.")
+  CErrors.user_err "System" (str file ++ str ": " ++ str s ++ str ". Try to rebuild it.")
 
 let input_binary_int f ch =
   try input_binary_int ch
@@ -252,7 +252,7 @@ let extern_state magic filename val_0 =
       let () = try_remove filename in
       iraise reraise
   with Sys_error s ->
-    CErrors.errorlabstrm "System.extern_state" (str "System error: " ++ str s)
+    CErrors.user_err "System.extern_state" (str "System error: " ++ str s)
 
 let intern_state magic filename =
   try
@@ -261,12 +261,12 @@ let intern_state magic filename =
     close_in channel;
     v
   with Sys_error s ->
-    CErrors.errorlabstrm "System.intern_state" (str "System error: " ++ str s)
+    CErrors.user_err "System.intern_state" (str "System error: " ++ str s)
 
 let with_magic_number_check f a =
   try f a
   with Bad_magic_number {filename=fname;actual=actual;expected=expected} ->
-    CErrors.errorlabstrm "with_magic_number_check"
+    CErrors.user_err "with_magic_number_check"
     (str"File " ++ str fname ++ strbrk" has bad magic number " ++
     int actual ++ str" (expected " ++ int expected ++ str")." ++
     spc () ++
-- 
cgit v1.2.3


From fc579fdc83b751a44a18d2373e86ab38806e7306 Mon Sep 17 00:00:00 2001
From: Emilio Jesus Gallego Arias
Date: Fri, 19 Aug 2016 02:35:47 +0200
Subject: Make the user_err header an optional parameter.

Suggested by @ppedrot
---
 lib/cErrors.ml   |  8 ++++----
 lib/cErrors.mli  | 10 ++++++----
 lib/cWarnings.ml |  2 +-
 lib/system.ml    | 14 +++++++-------
 4 files changed, 18 insertions(+), 16 deletions(-)

(limited to 'lib')

diff --git a/lib/cErrors.ml b/lib/cErrors.ml
index 830a9e3cea..38ed3f5ba7 100644
--- a/lib/cErrors.ml
+++ b/lib/cErrors.ml
@@ -33,12 +33,12 @@ let is_anomaly = function
 | Anomaly _ -> true
 | _ -> false
 
-exception UserError of string * std_ppcmds (* User errors *)
+exception UserError of string option * std_ppcmds (* User errors *)
 
 let todo s = prerr_string ("TODO: "^s^"\n")
 
-let user_err    ?loc s strm = Loc.raise ?loc (UserError (s,strm))
-let error            string = user_err "_" (str string)
+let user_err ?loc ?hdr strm = Loc.raise ?loc (UserError (hdr, strm))
+let error            string = user_err (str string)
 
 let invalid_arg ?loc s   = Loc.raise ?loc (Invalid_argument s)
 
@@ -112,7 +112,7 @@ let iprint_no_report (e, info) =
 
 let _ = register_handler begin function
   | UserError(s, pps) ->
-    hov 0 (str "Error: " ++ where (Some s) ++ pps)
+    hov 0 (str "Error: " ++ where s ++ pps)
   | _ -> raise Unhandled
 end
 
diff --git a/lib/cErrors.mli b/lib/cErrors.mli
index ad17be393f..5cffc725d9 100644
--- a/lib/cErrors.mli
+++ b/lib/cErrors.mli
@@ -33,11 +33,13 @@ val is_anomaly : exn -> bool
     This is mostly provided for compatibility. Please avoid doing specific
     tricks with anomalies thanks to it. See rather [noncritical] below. *)
 
-exception UserError of string * std_ppcmds
+exception UserError of string option * std_ppcmds
+(** Main error signaling exception. It carries a header plus a pretty printing
+    doc *)
 
-val user_err     : ?loc:Loc.t -> string -> std_ppcmds -> 'a
-(** Main error raising primitive. [user_err ?loc c pp] signals an
-    error [pp] in component [c], with optional location [loc] *)
+val user_err : ?loc:Loc.t -> ?hdr:string -> std_ppcmds -> 'a
+(** Main error raising primitive. [user_err ?loc ?hdr pp] signals an
+    error [pp] with optional header and location [hdr] [loc] *)
 
 val error : string -> 'a
 (** [error s] just calls [user_error "_" (str s)] *)
diff --git a/lib/cWarnings.ml b/lib/cWarnings.ml
index f36c7ad80d..18b26254db 100644
--- a/lib/cWarnings.ml
+++ b/lib/cWarnings.ml
@@ -45,7 +45,7 @@ let create ~name ~category ?(default=Enabled) pp =
            | Disabled -> ()
            | AsError ->
               let loc = Option.default !current_loc loc in
-              CErrors.user_err ~loc "_" (pp x)
+              CErrors.user_err ~loc (pp x)
            | Enabled ->
               let msg =
                 pp x ++ spc () ++ str "[" ++ str name ++ str "," ++
diff --git a/lib/system.ml b/lib/system.ml
index 916c087959..0f610b8d53 100644
--- a/lib/system.ml
+++ b/lib/system.ml
@@ -132,7 +132,7 @@ let find_file_in_path ?(warn=true) paths filename =
       let root = Filename.dirname filename in
       root, filename
     else
-      CErrors.user_err "System.find_file_in_path"
+      CErrors.user_err ~hdr:"System.find_file_in_path"
 	(hov 0 (str "Can't find file" ++ spc () ++ str filename))
   else
     (* the name is considered to be the transcription as a relative
@@ -140,7 +140,7 @@ let find_file_in_path ?(warn=true) paths filename =
        to be locate respecting case *)
     try where_in_path ~warn paths filename
     with Not_found ->
-      CErrors.user_err "System.find_file_in_path"
+      CErrors.user_err ~hdr:"System.find_file_in_path"
 	(hov 0 (str "Can't find file" ++ spc () ++ str filename ++ spc () ++
 		str "on loadpath"))
 
@@ -163,7 +163,7 @@ let is_in_system_path filename =
 let open_trapping_failure name =
   try open_out_bin name
   with e when CErrors.noncritical e ->
-    CErrors.user_err "System.open" (str "Can't open " ++ str name)
+    CErrors.user_err ~hdr:"System.open" (str "Can't open " ++ str name)
 
 let warn_cannot_remove_file =
   CWarnings.create ~name:"cannot-remove-file" ~category:"filesystem"
@@ -175,7 +175,7 @@ let try_remove filename =
     warn_cannot_remove_file filename
 
 let error_corrupted file s =
-  CErrors.user_err "System" (str file ++ str ": " ++ str s ++ str ". Try to rebuild it.")
+  CErrors.user_err ~hdr:"System" (str file ++ str ": " ++ str s ++ str ". Try to rebuild it.")
 
 let input_binary_int f ch =
   try input_binary_int ch
@@ -252,7 +252,7 @@ let extern_state magic filename val_0 =
       let () = try_remove filename in
       iraise reraise
   with Sys_error s ->
-    CErrors.user_err "System.extern_state" (str "System error: " ++ str s)
+    CErrors.user_err ~hdr:"System.extern_state" (str "System error: " ++ str s)
 
 let intern_state magic filename =
   try
@@ -261,12 +261,12 @@ let intern_state magic filename =
     close_in channel;
     v
   with Sys_error s ->
-    CErrors.user_err "System.intern_state" (str "System error: " ++ str s)
+    CErrors.user_err ~hdr:"System.intern_state" (str "System error: " ++ str s)
 
 let with_magic_number_check f a =
   try f a
   with Bad_magic_number {filename=fname;actual=actual;expected=expected} ->
-    CErrors.user_err "with_magic_number_check"
+    CErrors.user_err ~hdr:"with_magic_number_check"
     (str"File " ++ str fname ++ strbrk" has bad magic number " ++
     int actual ++ str" (expected " ++ int expected ++ str")." ++
     spc () ++
-- 
cgit v1.2.3