commit 8c8496da46660f3d0e45171a3cc3d8d3159dfa2f Author: Peter McGoron Date: Sat Oct 9 21:45:43 2021 -0400 move over stuff from old project 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] +]