From 73864d938f557dee345d849c270825b647b6acab Mon Sep 17 00:00:00 2001 From: James Brechtel Date: Fri, 29 May 2026 23:07:49 -0400 Subject: [PATCH] Add OrvilleM monad and RawSql modules --- orville-sqlite.cabal | 8 +----- src/Orville/SQLite/Monad.hs | 41 +++++++++++++++++++++++++++++ src/Orville/SQLite/RawSql.hs | 50 ++++++++++++++++++++++++++++++++++++ 3 files changed, 92 insertions(+), 7 deletions(-) create mode 100644 src/Orville/SQLite/Monad.hs create mode 100644 src/Orville/SQLite/RawSql.hs diff --git a/orville-sqlite.cabal b/orville-sqlite.cabal index a584d46..05dd766 100644 --- a/orville-sqlite.cabal +++ b/orville-sqlite.cabal @@ -15,19 +15,13 @@ build-type: Simple library exposed-modules: - Orville.SQLite - Orville.SQLite.AutoMigration - Orville.SQLite.Execution - Orville.SQLite.FieldDefinition Orville.SQLite.Monad Orville.SQLite.RawSql - Orville.SQLite.SqlMarshaller - Orville.SQLite.SqlType - Orville.SQLite.TableDefinition hs-source-dirs: src build-depends: base >=4.17 && <5 , direct-sqlite + , mtl , text , bytestring default-language: Haskell2010 diff --git a/src/Orville/SQLite/Monad.hs b/src/Orville/SQLite/Monad.hs new file mode 100644 index 0000000..2b44c1c --- /dev/null +++ b/src/Orville/SQLite/Monad.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +module Orville.SQLite.Monad + ( OrvilleM + , withConnection + , openConnection + , closeConnection + , runOrvilleM + , withTransaction + ) where + +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Reader (ReaderT, runReaderT, ask, MonadReader) +import qualified Data.Text as T +import qualified Database.SQLite3 as SQLite3 + +newtype OrvilleM a = OrvilleM + { unOrvilleM :: ReaderT SQLite3.Database IO a + } + deriving (Functor, Applicative, Monad, MonadIO, MonadReader SQLite3.Database) + +runOrvilleM :: SQLite3.Database -> OrvilleM a -> IO a +runOrvilleM db action = runReaderT (unOrvilleM action) db + +withConnection :: SQLite3.Database -> OrvilleM a -> IO a +withConnection = runOrvilleM + +openConnection :: String -> IO SQLite3.Database +openConnection path = SQLite3.open (T.pack path) + +closeConnection :: SQLite3.Database -> IO () +closeConnection = SQLite3.close + +withTransaction :: OrvilleM a -> OrvilleM a +withTransaction action = do + db <- ask + liftIO $ SQLite3.exec db "BEGIN TRANSACTION" + result <- action + liftIO $ SQLite3.exec db "COMMIT" + pure result diff --git a/src/Orville/SQLite/RawSql.hs b/src/Orville/SQLite/RawSql.hs new file mode 100644 index 0000000..b0b45e6 --- /dev/null +++ b/src/Orville/SQLite/RawSql.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Orville.SQLite.RawSql + ( RawSql (..) + , fromString + , toRawSql + , intercalate + , fromText + , space + , comma + , leftParen + , rightParen + , equals + ) where + +import qualified Data.Text as T + +newtype RawSql = RawSql {unRawSql :: String} + deriving (Show, Eq, Semigroup, Monoid) + +fromString :: String -> RawSql +fromString = RawSql + +toRawSql :: RawSql -> RawSql +toRawSql = id + +fromText :: T.Text -> RawSql +fromText = RawSql . T.unpack + +intercalate :: RawSql -> [RawSql] -> RawSql +intercalate sep parts = RawSql . intercalateStr (unRawSql sep) $ map unRawSql parts + where + intercalateStr _ [] = "" + intercalateStr _ [x] = x + intercalateStr s (x : xs) = x <> s <> intercalateStr s xs + +space :: RawSql +space = RawSql " " + +comma :: RawSql +comma = RawSql ", " + +leftParen :: RawSql +leftParen = RawSql "(" + +rightParen :: RawSql +rightParen = RawSql ")" + +equals :: RawSql +equals = RawSql " = "