move over stuff from old project

5 files changed, 311 insertions, 0 deletions

diff --git a/src/dune b/src/dune
new file mode 100644
index 0000000..c31f479
--- /dev/null
+++ b/src/dune
@@ -0,0 +1,7 @@
+(library
+ (name libunderwriter)
+ (inline_tests)
+ (preprocess (pps ppx_inline_test))
+ (flags -rectypes)
+ (libraries sqlite3 letsqlite)
+)
diff --git a/src/dune-project b/src/dune-project
new file mode 100644
index 0000000..b51f172
--- /dev/null
+++ b/src/dune-project
@@ -0,0 +1,18 @@
+(lang dune 2.9)
+(name letsqlite)
+(generate_opam_files true)
+(license CC0-1.0)
+(authors "Peter McGoron")
+(maintainers "code@mcgoron.com")
+(package
+ (name letsqlite)
+ (synopsis "Simple monadic Sqlite3 wrapper")
+ (description "Simple monadic Sqlite3 wrapper")
+ (homepage "https://software.mcgoron.com/peter/letsqlite")
+ (bug_reports "code@mcgoron.com")
+ (depends
+  (dune (>= 2.9))
+  (sqlite3 (>= 5.0.3))
+  (ppx_inline_test (>= 0.14.1))
+ )
+)
diff --git a/src/letsqlite.ml b/src/letsqlite.ml
new file mode 100644
index 0000000..81ee72c
--- /dev/null
+++ b/src/letsqlite.ml
@@ -0,0 +1,114 @@
+module S = Sqlite3
+module Rc = S.Rc
+
+type 'a stmt_m =
+| Failed of Rc.t
+| Norm of ('a * S.stmt)
+
+type ('a,'b) monad_fun = ('a * Sqlite3.stmt) -> 'b stmt_m
+type rowdata = (string, Sqlite3.Data.t) Hashtbl.t
+(* Monad definitions *)
+let (>>$) s f = match s with
+| Failed r -> Failed r
+| 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
+	| Failed r -> Failed r
+	| Norm (_,s) -> Norm (x,s)
+	)
+let (@>$) s f = fun x -> s x >>$ f
+
+(* Helper definitions *)
+let transform f (v,s) = Norm ((f v),s)
+let inject v (_,s) = Norm (v,s)
+let fail er (_,s) =
+	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
+	else fail e tp
+
+(* Helper functions *)
+let arr_to_tbl tbl keys vals =
+	assert (Array.length keys = Array.length vals);
+	Array.iteri (fun i x -> Hashtbl.add tbl x vals.(i)) keys
+
+(* Monadic functions *)
+let prepare db stmt v =
+	try Norm (v,(S.prepare db stmt)) with
+	_ -> Failed Rc.ERROR
+let reprepare db stmt (v,s) =
+	let x = S.finalize s
+	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 rec fold f l (v,s) = match l with
+| [] -> Norm (v,s)
+| h::t -> f h (v,s) >>$ fold f t
+
+let getrow (_,s) =
+	let r = S.step s
+	in match r with
+	| Rc.ROW -> if S.data_count s = 0 then stmtfail Rc.NOTFOUND s
+		else let keys = S.row_names s
+		in let tbl = Hashtbl.create (Array.length keys)
+		in arr_to_tbl tbl keys (S.row_data s);
+		Norm (((),tbl),s)
+	| x -> stmtfail x s
+
+let exec_extract extrfun convfun ((_,arg),s) =
+	match extrfun arg with
+	| None -> stmtfail Rc.NOTFOUND s
+	| Some x -> (match convfun x with
+		| None -> stmtfail Rc.NOTFOUND s
+		| Some x -> Norm ((x,arg), s)
+	)
+
+let get_exactly_one_row tr =
+	let$ (v,s) = getrow tr
+	in let r = S.step s
+	in if Rc.is_success r then reset (v,s)
+	else Failed r
+
+let extract name conv tu =
+	exec_extract (fun tbl -> Hashtbl.find_opt tbl name) conv tu
+
+let finalize = function
+| Failed e -> raise (S.SqliteError (Rc.to_string e))
+| Norm (v,s) -> Rc.check (S.finalize s); v
+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 exec db s = prepare db s () >>$ step
+let reexec db s = reprepare db s @>$ step
+let bsrc l = bind_values l @>$ step @>$ reset @>$ clear_bindings
+
+let%test "simple usage" = 
+	let db = S.db_open ":memory:"
+	in let s1 = ref []
+	in let fin = (
+		let m = exec db "CREATE TABLE tbl (x,y);"
+		>>$ reprepare db "INSERT INTO tbl VALUES(?,?);"
+		>>$ bsrc [S.Data.INT 1L; S.Data.INT 2L]
+		>>$ bsrc [S.Data.INT 2L; S.Data.INT 3L]
+		>>$ reprepare db "SELECT y FROM tbl WHERE x = ?;"
+		>>$ bind_values [S.Data.INT 1L]
+		>>$ get_exactly_one_row
+		>>$ extract "y" S.Data.to_int64
+		in let$ ((v,r),s) = m
+		in s1 := [v];
+		let$ ((v,r),s) = bind_values [S.Data.INT 2L] ((v,r),s)
+		>>$ get_exactly_one_row
+		>>$ extract "y" S.Data.to_int64
+		in s1 := v::!s1;
+		Norm ((),s)
+	)
+	in finalize fin; S.db_close db && !s1 = [3L; 2L]
diff --git a/src/letsqlite.mli b/src/letsqlite.mli
new file mode 100644
index 0000000..001b228
--- /dev/null
+++ b/src/letsqlite.mli
@@ -0,0 +1,141 @@
+(** {1 Type definitions}
+
+Types used for monad composition.
+*)
+type 'a stmt_m =
+| Failed of Sqlite3.Rc.t
+| Norm of ('a * Sqlite3.stmt)
+(** 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],
+    or it may "return a value", in which it returns [Norm v s].
+    They are collectively refered to as the monad's values.
+
+    The bundled {Sqlite.stmt} value is refered to as [S], and the
+    value bundled is refered to as [V].
+
+    {i Never directly use [Failed].} You run the likelihood of leaking
+    memory.
+*)
+
+type ('a,'b) monad_fun = ('a * Sqlite3.stmt) -> 'b stmt_m
+
+type rowdata = (string, Sqlite3.Data.t) Hashtbl.t
+
+(** {1 Primary Functions} *)
+
+val (>>$) : 'a stmt_m -> ('a,'b) monad_fun -> 'b stmt_m
+(** [>>$] is the monadic composition function.
+
+    [s >>$ f] return [s] if [s] is [Failed] and [f V S] otherwise.
+*)
+
+val (let$) : 'a stmt_m -> ('a,'b) monad_fun -> 'b stmt_m
+(** [let$ (v,s) = f (V,S) in ...] is equivalent to
+    [f (V,S) >>$ (fun (v,s) -> ...)]. *)
+
+val (>-$) : 'a stmt_m -> ('a,'b) monad_fun -> 'a stmt_m
+(** [>-$] is the passthrough function.
+
+    [s >-$ f] is equivalent to [s >>$ f] except that the bundled
+    value from [f (V,S)] is discarded and replaced with [V]. This function
+    passes the original [V] through.
+*)
+
+(** {1 Non-Execution Functions}
+
+These functions do not execute any SQL queries. They exist to make dealing
+with the monad easier.
+*)
+
+val inject : 'a -> ('b,'a) monad_fun
+(** [inject x] returns [Norm x S], discarding [V]. *)
+
+val fail : Sqlite3.Rc.t -> ('a,'b) monad_fun
+(** [fail e] finalizes [S] and returns [Failure], where the error
+    code is [e] if [e] is not a success error code, and the return code
+    of {finalize} otherwise.
+*)
+
+val stmtfail : Sqlite3.Rc.t -> Sqlite3.stmt -> unit stmt_m
+(** [stmtfail e s] is equivalent to [fail] except it assembles a statement
+    with unit type. *)
+
+val lift_err : Sqlite3.Rc.t -> ('a,'a) monad_fun
+(** [lift_err e] is equivalent to [fail e] when [e] is not a success
+    value, and otherwise returns the monad's values unchanged.
+
+    {b NOTE}: You may be tempted to define a function like
+    [lift : (Sqlite3.stmt -> Sqlite3.Rc.t) -> ('a,'a) monad_fun]
+    which would take a function and apply [lift_err (f S) V S]
+    to the function. However, the partial application [lift f]
+    would leave you with a {i weak type}, which will force your
+    type to have a fixed type. *)
+
+(** {1 Execution functions}
+
+All of these functions will (effectively) exceute {fail} and return
+[Failed] on failure. All functions will omit error behavior unless
+there is something different across any of them. *)
+
+val prepare : Sqlite3.db -> string -> 'a -> 'a stmt_m
+(** [prepare db stmt v] returns a monad with bundled value [v] and
+    the statement in [s].
+*)
+
+val reprepare : Sqlite3.db -> string -> ('a,'a) monad_fun
+(** [reprepare db stmt] finalizes [S] and prepares [stmt] in
+    its place. *)
+
+val reset : ('a,'a) monad_fun
+(** [reset] resets [S] so that it may be executed again. *)
+
+val step : ('a,'a) monad_fun
+(** [step] is equivalent to the Sqlite3 function {step}.
+
+    {b NOTE}: [step] will fail when the statement returns a row.
+*)
+
+val fold : ('a -> ('b,'b) monad_fun) -> 'a list -> ('b,'b) monad_fun
+(** [fold f l] applies each element of [l] to make a monadic function [f]. *)
+
+val getrow : ('a,(unit * rowdata)) monad_fun
+(** [getrow] steps [S] and stores the returned row. The value in [S] is
+    discarded.
+
+    The function returns a tuple with the unit type to interact with
+    {extract}.
+*)
+
+val exec_extract : ('a -> 'b option) -> ('b -> 'c option)
+                   -> (('d * 'a),('c * 'a)) monad_fun
+(** [exec_extract extr conv] extracts a value from the second element in
+    [V], and then applies [conv] to it. If both were successful, the
+    function replaces the first element of [V] with the converted
+    value. *)
+
+val extract : string -> (Sqlite3.Data.t -> 'b option)
+              -> (('a * rowdata),('b * rowdata)) monad_fun
+(** [extract name f] finds the value in the row with header name [name]
+    and applies [f] to it. If [f] succeeds then its return value is
+    stored in [V]. The rowdata is preserved.
+*)
+
+val finalize : 'a stmt_m -> 'a
+(** [finalize] raises an exception if the execution failed, and [V]
+    otherwise. *)
+
+val bind_values : Sqlite3.Data.t list -> ('a,'a) monad_fun
+(** [bind_values l] binds each index of [l] to a positional parameter
+    in [S]. *)
+
+val clear_bindings : ('a,'a) monad_fun
+(** [clear_bindings] clears any values bound to [S]. *)
+
+val exec : Sqlite3.db -> string -> unit stmt_m
+(** [exec db s] is equivalent to a call to {prepare} followed by {step}. *)
+
+val reexec : Sqlite3.db -> string -> ('a,'a) monad_fun
+(** [reexec db s] is equivalent to [reprepare >>$ step]. *)
+
+val bsrc : Sqlite3.Data.t list -> ('a,'a) monad_fun
+(** [bsrc l] is equivalent to [bind_values >>$ step >>$ reset >>$ clear_bindings]. *)
diff --git a/src/letsqlite.opam b/src/letsqlite.opam
new file mode 100644
index 0000000..729ecb0
--- /dev/null
+++ b/src/letsqlite.opam
@@ -0,0 +1,31 @@
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+synopsis: "Simple monadic Sqlite3 wrapper"
+description: "Simple monadic Sqlite3 wrapper"
+maintainer: ["code@mcgoron.com"]
+authors: ["Peter McGoron"]
+license: "CC0-1.0"
+homepage: "https://software.mcgoron.com/peter/letsqlite"
+bug-reports: "code@mcgoron.com"
+depends: [
+  "dune" {>= "2.9" & >= "2.9"}
+  "sqlite3" {>= "5.0.3"}
+  "ppx_inline_test" {>= "0.14.1"}
+  "odoc" {with-doc}
+]
+build: [
+  ["dune" "subst"] {dev}
+  [
+    "dune"
+    "build"
+    "-p"
+    name
+    "-j"
+    jobs
+    "--promote-install-files=false"
+    "@install"
+    "@runtest" {with-test}
+    "@doc" {with-doc}
+  ]
+  ["dune" "install" "-p" name "--create-install-files" name]
+]