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.

1 files changed, 34 insertions, 24 deletions

diff --git a/src/letsqlite.ml b/src/letsqlite.ml
index a74097c..83bf0c6 100644
--- a/src/letsqlite.ml
+++ b/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