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