add a boolean to the monad to be more flexible with error management

To optimize Sqlite3 queries, prepared statements are typically
kept instead of re-prepared so that they may be executed multiple
times. This allows for prepared statements to not be finalized on
destruction, allowing for reuse even when an error has occured.

src/letsqlite.ml

@@ -1,11 +1,12 @@
 module S = Sqlite3
 module Rc = S.Rc
 
+type stmt_wrap = bool * S.stmt
 type 'a stmt_m =
 | Failed of Rc.t
-| Norm of ('a * S.stmt)
+| Norm of ('a * stmt_wrap)
 
-type ('a,'b) monad_fun = ('a * Sqlite3.stmt) -> 'b stmt_m
+type ('a,'b) monad_fun = ('a * stmt_wrap) -> 'b stmt_m
 type rowdata = (string, Sqlite3.Data.t) Hashtbl.t
 (* Monad definitions *)
 let (>>$) s f = match s with
@@ -13,6 +14,7 @@ let (>>$) s f = match s with
 | Norm (x,s) -> f (x,s)
 
 let (let$) = (>>$)
+
 let (>-$) s f = match s with
 | Failed r -> Failed r
 | Norm (x,s) -> (match f (x,s) with
@@ -21,13 +23,17 @@ let (>-$) s f = match s with
 	)
 let (@>$) s f = fun x -> s x >>$ f
 
+let gs (_,s) = s
+
 (* Helper definitions *)
 let transform f (v,s) = Norm ((f v),s)
 let inject v = transform (fun _ -> v)
-let fail er (_,s) =
-	let er2 = S.finalize s
-	in if Rc.is_success er then Failed er2
-	else Failed er
+let fail er (_,(b,s)) =
+	if b then Failed er else (
+		let er2 = S.finalize s
+		in if Rc.is_success er then Failed er2
+		else Failed er
+	)
 let stmtfail er s = fail er ((),s)
 let lift_err e tp =
 	if Rc.is_success e then Norm tp
@@ -39,32 +45,34 @@ let arr_to_tbl tbl keys vals =
 	Array.iteri (fun i x -> Hashtbl.add tbl x vals.(i)) keys
 
 let create_rowtbl s rowdata =
-	let keys = S.row_names s
+	let keys = S.row_names (gs s)
 	in let tbl = Hashtbl.create (Array.length keys)
 	in arr_to_tbl tbl keys rowdata;
 	tbl
 
 (* Monadic functions *)
-let prepare db stmt v =
-	try Norm (v,(S.prepare db stmt)) with
+let prepare_keep keep db stmt v =
+	try Norm (v,(keep, S.prepare db stmt)) with
 	_ -> Failed Rc.ERROR
-let reprepare db stmt (v,s) =
-	let x = S.finalize s
+let prepare db s v = prepare_keep false db s v
+let reprepare db stmt (v,(b,s)) =
+	let x = if not b then S.finalize s
+		else Rc.OK
 	in if Rc.is_success x then prepare db stmt v
 	else Failed x
 
-let reset (v,s) = lift_err (S.reset s) (v,s)
-let step (v,s) = lift_err (S.step s) (v,s)
-let bind_values l (v,s) = lift_err (S.bind_values s l) (v,s)
-let clear_bindings (v,s) = lift_err (S.clear_bindings s) (v,s)
+let reset (v,s) = lift_err (S.reset (gs s)) (v,s)
+let step (v,s) = lift_err (S.step (gs s)) (v,s)
+let bind_values l (v,s) = lift_err (S.bind_values (gs s) l) (v,s)
+let clear_bindings (v,s) = lift_err (S.clear_bindings (gs s)) (v,s)
 
-let execif r v = if Rc.is_success r then Norm v else Failed r
+let execif r v = if Rc.is_success r then Norm v else fail r v
 
 let rowfold f (init,s) =
 	let rec fold acc ((),s) =
-		let r = S.step s
+		let r = S.step (gs s)
 		in if r = Rc.ROW then
-		match f acc (create_rowtbl s (S.row_data s)) with
+		match f acc (create_rowtbl s (S.row_data (gs s))) with
 			| Error r -> stmtfail r s
 			| Ok x -> fold x ((),s)
 		else execif r (acc,s)
@@ -81,7 +89,7 @@ let map f l (ival,s) =
 	| [] -> Norm (b,s)
 	| h::t ->
 		let$ v,s = f h (ival,s)
-		in map t (v::b,s)
+		in map t (v::b, s)
 	in let$ (v,s) = map l ([],s)
 	in Norm (List.rev v, s)
 
@@ -90,11 +98,11 @@ let rec fold f l (v,s) = match l with
 | h::t -> f h (v,s) >>$ fold f t
 
 let get_exactly_one_row (_,s) =
-	let r = S.step s
+	let r = S.step (gs s)
 	in match r with
-	| Rc.ROW -> if S.data_count s = 0 then stmtfail Rc.NOTFOUND s
-		else let tbl = create_rowtbl s (S.row_data s)
-		in let r = S.step s
+	| Rc.ROW -> if S.data_count (gs s) = 0 then stmtfail Rc.NOTFOUND s
+		else let tbl = create_rowtbl s (S.row_data (gs s))
+		in let r = S.step (gs s)
 		in if Rc.is_success r then
 			reset (((),tbl),s)
 		else stmtfail r s
@@ -113,7 +121,9 @@ let extract name conv tu =
 
 let finalize = function
 | Failed e -> raise (S.SqliteError (Rc.to_string e))
-| Norm (v,s) -> Rc.check (S.finalize s); v
+| Norm (v,(b,s)) -> if b then v else (
+                    Rc.check (S.finalize s); v
+                    )
 
 let exec db s = prepare db s () >>$ step
 let reexec db s = reprepare db s @>$ step

src/letsqlite.mli

@@ -5,9 +5,11 @@
 Types used for monad composition.
 *)
 
+type stmt_wrap = bool * Sqlite3.stmt
+
 type 'a stmt_m =
 | Failed of Sqlite3.Rc.t
-| Norm of ('a * Sqlite3.stmt)
+| Norm of ('a * stmt_wrap)
 
 (** The ['a] value in the [stmt_m] is referred to as the bundled value.
     A function may "fail with [e]", in which it returns [Failed e],
@@ -17,11 +19,15 @@ type 'a stmt_m =
     The bundled {!Sqlite.stmt} value is refered to as [S], and the
     value bundled is refered to as [V].
 
+    The boolean value is the {i preserve on failure} flag. When true,
+    monadic functions will not call {!Sqlite3.finalize} on the contained
+    statement. {b This will cause a memory leak if not handled correctly.}
+
     {i Never directly use [Failed].} You run the likelihood of leaking
-    memory.
+    memory or causing a crash.
 *)
 
-type ('a,'b) monad_fun = ('a * Sqlite3.stmt) -> 'b stmt_m
+type ('a,'b) monad_fun = ('a * stmt_wrap) -> 'b stmt_m
 
 type rowdata = (string, Sqlite3.Data.t) Hashtbl.t
 
@@ -49,6 +55,9 @@ val (>-$) : 'a stmt_m -> ('a,'b) monad_fun -> 'a stmt_m
     passes the original [V] through.
 *)
 
+val gs : stmt_wrap -> Sqlite3.stmt
+(** [gs s] returns the statment in an instance of [stmt_wrap]. *)
+
 (** {1 Non-Execution Functions}
 
 These functions do not execute any SQL queries. They exist to make dealing
@@ -67,7 +76,7 @@ val fail : Sqlite3.Rc.t -> ('a,'b) monad_fun
     of {!Sqlite3.finalize} otherwise.
 *)
 
-val stmtfail : Sqlite3.Rc.t -> Sqlite3.stmt -> unit stmt_m
+val stmtfail : Sqlite3.Rc.t -> stmt_wrap -> unit stmt_m
 (** [stmtfail e s] is equivalent to [fail] except it assembles a statement
     with unit type. *)
 
@@ -93,6 +102,11 @@ val prepare : Sqlite3.db -> string -> 'a -> 'a stmt_m
     the statement in [s].
 *)
 
+val prepare_keep : bool -> Sqlite3.db -> string -> 'a -> 'a stmt_m
+(** [prepare_keep b] is like [prepare], but [b] is the preserve-on-failure
+    file.
+*)
+
 val reprepare : Sqlite3.db -> string -> ('a,'a) monad_fun
 (** [reprepare db stmt] finalizes [S] and prepares [stmt] in
     its place. *)