Sqlexpr_sqlite: add message to Error exn.

sqlexpr_sqlite.ml

@@ -2,7 +2,7 @@
 open Printf
 open ExtList
 
-exception Error of exn
+exception Error of string * exn
 exception Sqlite_error of string * Sqlite3.Rc.t
 
 let curr_thread_id () = Thread.id (Thread.self ())
@@ -17,7 +17,7 @@ let raise_thread_error ?msg expected =
       expected
       actual
       (Option.map_default ((^) " ") "" msg)
-  in raise (Error (Failure s))
+  in raise (Error (s, (Failure s)))
 
 module Stmt =
 struct
@@ -53,9 +53,8 @@ include Types
 let () =
   Printexc.register_printer
     (function
-       | Error exn ->
-           Some (sprintf "Sqlexpr_sqlite.Error %s"
-                   (Printexc.to_string exn))
+       | Error (s, exn) ->
+           Some (sprintf "Sqlexpr_sqlite.Error (%S, %s)" s (Printexc.to_string exn))
        | Sqlite_error (s, rc) ->
            Some (sprintf "Sqlexpr_sqlite.Sqlite_error (%S, %s)"
                    s (Sqlite3.Rc.to_string rc))
@@ -254,8 +253,8 @@ let () =
 
 module Error(M : THREAD) =
 struct
-  let raise_exn exn = M.fail (Error exn)
-  let failwithfmt fmt = Printf.ksprintf (fun s -> M.fail (Error (Failure s))) fmt
+  let raise_exn ?(msg="") exn = M.fail (Error (msg, exn))
+  let failwithfmt fmt = Printf.ksprintf (fun s -> M.fail (Error (s, Failure s))) fmt
 end
 
 module Profile(Lwt : Sqlexpr_concurrency.THREAD) =
@@ -394,7 +393,7 @@ struct
         None | Some [] -> msg
       | Some params ->
           sprintf "%s with params %s" msg (string_of_params (List.rev params))
-    in M.fail (Error (Sqlite_error (msg, errcode)))
+    in M.fail (Error (msg, Sqlite_error (msg, errcode)))
 
   let rec run ?stmt ?sql ?params db f x = match f x with
       Sqlite3.Rc.OK | Sqlite3.Rc.ROW | Sqlite3.Rc.DONE as r -> return r
@@ -437,7 +436,9 @@ struct
                          WT.add db.stmts stmt;
                          return stmt)
       with e ->
-        failwithfmt "Error with SQL statement %S:\n%s" sql (Printexc.to_string e) in
+        let msg =
+          sprintf "Error with SQL statement %S:\n%s" sql (Printexc.to_string e)
+        in raise_exn ~msg e in
     let rec iteri ?(i = 0) f = function
         [] -> return ()
       | hd :: tl -> f i hd >> iteri ~i:(i + 1) f tl
@@ -495,7 +496,7 @@ sig
 
   type db
 
-  exception Error of exn
+  exception Error of string * exn
   exception Sqlite_error of string * Sqlite3.Rc.t
 
   val open_db : ?init:(Sqlite3.db -> unit) -> string -> db

sqlexpr_sqlite.mli

@@ -11,11 +11,11 @@ type st = Types.st
 
 (** All the exceptions raised by the code in {Sqlexpr_sqlite} are wrapped in
     Error except when indicated otherwise. *)
-exception Error of exn
+exception Error of string * exn
 
 (** Errors reported by SQLite are converted into [Sqlite_error _] exceptions,
     so they can be matched with
-    [try ... with Sqlexpr.Error (Sqlexpr.sqlite_error _)] *)
+    [try ... with Sqlexpr.Error (_, Sqlexpr.sqlite_error _)] *)
 exception Sqlite_error of string * Sqlite3.Rc.t
 
 (**  *)
@@ -44,7 +44,7 @@ sig
 
   (** Exception identical to the toplevel [Error], provided for convenience.
       Note that [Sqlexpr_sqlite.Error _] matches this exception. *)
-  exception Error of exn
+  exception Error of string * exn
 
   (** Exception identical to the toplevel [Sqlite_error], provided for
       convenience.  Note that [Sqlexpr_sqlite.Sqlite_error _] matches this

sqlexpr_sqlite_lwt.ml

@@ -53,7 +53,8 @@ struct
   let close_db db =
     db.max_threads <- 0;
     db.db_finished <- true;
-    let e = Error (Failure (sprintf "Handle closed for DB %S" db.file)) in
+    let msg = sprintf "Handle closed for DB %S" db.file in
+    let e = Error (msg, Failure msg) in
       Lwt_sequence.iter_l (fun u -> wakeup_exn u e) db.waiters;
       Queue.iter
         (fun worker ->
@@ -187,7 +188,7 @@ struct
         None | Some [] -> msg
       | Some params ->
           sprintf "%s with params %s" msg (string_of_params (List.rev params))
-    in raise (Error (Sqlite_error (msg, errcode)))
+    in raise (Error (msg, Sqlite_error (msg, errcode)))
 
   let raise_error worker ?sql ?params ?errmsg errcode =
     lwt errmsg = match errmsg with
@@ -241,7 +242,8 @@ struct
                          return stmt)
       with e ->
         add_worker db worker;
-        failwithfmt "Error with SQL statement %S:\n%s" sql (Printexc.to_string e)
+        let s = sprintf "Error with SQL statement %s" sql in
+          raise_lwt (Error (s, e))
     in
       (* the list of params is reversed *)
       detach worker