move over stuff from old project
This commit is contained in:
commit
8c8496da46
|
|
@ -0,0 +1,7 @@
|
||||||
|
(library
|
||||||
|
(name libunderwriter)
|
||||||
|
(inline_tests)
|
||||||
|
(preprocess (pps ppx_inline_test))
|
||||||
|
(flags -rectypes)
|
||||||
|
(libraries sqlite3 letsqlite)
|
||||||
|
)
|
||||||
|
|
@ -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))
|
||||||
|
)
|
||||||
|
)
|
||||||
|
|
@ -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]
|
||||||
|
|
@ -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]. *)
|
||||||
|
|
@ -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]
|
||||||
|
]
|
||||||
Loading…
Reference in New Issue