selda 0.1.7.0 → 0.1.8.0

raw patch · 19 files changed

+749/−254 lines, 19 filesdep +bytestringPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: bytestring

API changes (from Hackage documentation)

Files

• ChangeLog.md +12/−0
• README.md +42/−1
• selda.cabal +13/−9
• src/Database/Selda.hs +24/−14
• src/Database/Selda/Backend.hs +20/−121
• src/Database/Selda/Backend/Internal.hs +223/−0
• src/Database/Selda/Caching.hs +1/−0
• src/Database/Selda/Compile.hs +14/−13
• src/Database/Selda/Exp.hs +1/−1
• src/Database/Selda/Frontend.hs +17/−18
• src/Database/Selda/Generic.hs +0/−1
• src/Database/Selda/Prepared.hs +191/−0
• src/Database/Selda/Query.hs +5/−3
• src/Database/Selda/SQL.hs +8/−0
• src/Database/Selda/SQL/Print.hs +19/−18
• src/Database/Selda/SQL/Print/Config.hs +52/−0
• src/Database/Selda/SqlType.hs +95/−31
• src/Database/Selda/Table.hs +3/−3
• src/Database/Selda/Table/Compile.hs +9/−21

@@ -1,6 +1,18 @@ # Revision history for Selda  +## 0.1.8.0 -- 2017-06-10++* Move SQL pretty-printing config into a single type.+* Support for binary blobs.+* Support for prepared statements.+* Support for connection reuse across Selda computations.+* Cleaner and more robust backend API.+* Stricter type constraints on comparisons.+* Allow limit on inner queries.+* Allow inspecting row identifiers.++ ## 0.1.7.0 -- 2017-05-17  * Add specialized insertUnless upsert variant.

@@ -26,6 +26,7 @@ * Inserting, updating and deleting rows from tables. * Conditional insert/update. * Transactions, uniqueness constraints and foreign keys.+* Seamless prepared statements. * Configurable, automatic, consistent in-process caching of query results. * Lightweight and modular: non-essential features are optional or split into   add-on packages.@@ -634,8 +635,48 @@   return (map fromRel ps) ``` ++Prepared statements+-------------------++While Selda makes use of prepared statements internally to ensure that any and+all input is safely escaped, it does not reuse those statements by default.+Every query is recompiler and replanned each time it is executed.+To improve the performance of your code, you should make use of the `prepared`+function, to mark performance-critical queries as reusable.++The `prepared` function converts any function `f` in the `Query` monad into an+equivalent function `f'` in some `MonadSelda`, provided that all of `f`'s+arguments are column expressions.+When `f'` is called for the first time during a connection to a database, it+automatically gets compiled, prepared and cached before being executed.+Any subsequent calls to `f'` from the same connection will reuse the prepared+version.++Note that since most database engines don't allow prepared statements to persist+across connections, a previously cached statement will get prepared once more if+called from another connection.++As an example, we modify the `grownupsIn` function we saw earlier to use prepared+statements.++```+preparedGrownupsIn :: Text -> SeldaM [Text]+preparedGrownupsIn = prepared $ \city -> do+  (name :*: age :*: _) <- select people+  restrict (age .> 20)+  (name' :*: home) <- select addresses+  restrict (home .== city .&& name .== name')+  return name+```++Note that the type of the `city` argument is `Col s Text` within the query, but+when *calling* `preparedGrownupsIn`, we instead pass in a value of type `Text`;+for convenience, `prepared` automatically converts all arguments to+prepared functions into their equivalent column types.+ And with that, we conclude this tutorial. Hopefully it has been enough to get-you comfortable started using Selda.+you comfortably started using Selda. For a more detailed API reference, please see Selda's [Haddock documentation](http://hackage.haskell.org/package/selda). 

@@ -1,5 +1,5 @@ name:                selda-version:             0.1.7.0+version:             0.1.8.0 synopsis:            Type-safe, high-level EDSL for interacting with relational databases. description:         This package provides an EDSL for writing portable, type-safe, high-level                      database code. Its feature set includes querying and modifying databases,@@ -49,17 +49,20 @@     Database.Selda.Generic     Database.Selda.Unsafe   other-modules:+    Database.Selda.Backend.Internal     Database.Selda.Caching     Database.Selda.Column     Database.Selda.Compile     Database.Selda.Exp     Database.Selda.Frontend     Database.Selda.Inner+    Database.Selda.Prepared     Database.Selda.Query     Database.Selda.Query.Type     Database.Selda.Selectors     Database.Selda.SQL     Database.Selda.SQL.Print+    Database.Selda.SQL.Print.Config     Database.Selda.SqlType     Database.Selda.Table     Database.Selda.Table.Compile@@ -79,19 +82,20 @@     GeneralizedNewtypeDeriving     FlexibleContexts   build-depends:-      base       >=4.8 && <5-    , exceptions >=0.8 && <0.9-    , mtl        >=2.0 && <2.3-    , text       >=1.0 && <1.3-    , time       >=1.5 && <1.9+      base                 >=4.8   && <5+    , bytestring           >=0.10  && <0.11+    , exceptions           >=0.8   && <0.9+    , hashable             >=1.1   && <1.3+    , mtl                  >=2.0   && <2.3+    , text                 >=1.0   && <1.3+    , time                 >=1.5   && <1.9+    , unordered-containers >=0.2.6 && <0.3   if impl(ghc < 7.11)     build-depends:       transformers  >=0.4 && <0.6   if !flag(haste) && flag(localcache)     build-depends:-        hashable             >=1.1   && <1.3-      , psqueues             >=0.2   && <0.3-      , unordered-containers >=0.2.6 && <0.3+      psqueues >=0.2 && <0.3   else     cpp-options:       -DNO_LOCALCACHE

@@ -63,14 +63,14 @@ --   for a more comprehensive tutorial. module Database.Selda   ( -- * Running queries-    MonadIO (..), MonadSelda+    MonadSelda   , SeldaError (..), ValidationError   , SeldaT, SeldaM, Table, Query, Col, Res, Result   , query, transaction, setLocalCache     -- * Constructing queries   , Selector, (!), Assignment(..), with-  , SqlType-  , Text, Cols, Columns+  , SqlType (..)+  , Cols, Columns   , Order (..)   , (:*:)(..)   , select, selectValues, from@@ -79,7 +79,7 @@   , inner, suchThat     -- * Expressions over columns   , Set (..)-  , RowID, invalidRowId, isInvalidRowId+  , RowID, invalidRowId, isInvalidRowId, fromRowId   , (.==), (./=), (.>), (.<), (.>=), (.<=), like   , (.&&), (.||), not_   , literal, int, float, text, true, false, null_@@ -87,7 +87,7 @@     -- * Converting between column types   , round_, just, fromBool, fromInt, toString     -- * Inner queries-  , Aggr, Aggregates, OuterCols, LeftCols, Inner, MinMax+  , Aggr, Aggregates, OuterCols, LeftCols, Inner, SqlOrd   , innerJoin, leftJoin   , aggregate, groupBy   , count, avg, sum_, max_, min_@@ -96,6 +96,9 @@   , insert, insert_, insertWithPK, tryInsert, def   , update, update_, upsert   , deleteFrom, deleteFrom_+    -- * Prepared statements+  , Preparable, Prepare+  , prepared     -- * Defining schemas   , TableSpec, ColSpecs, ColSpec, TableName, ColName   , NonNull, IsNullable, Nullable, NotNullable@@ -116,12 +119,16 @@     -- * Tuple convenience functions   , Tup, Head   , first, second, third, fourth, fifth, sixth, seventh, eighth, ninth, tenth+    -- * Useful re-exports+  , MonadIO, liftIO+  , Text, Day, TimeOfDay, UTCTime   ) where import Database.Selda.Backend import Database.Selda.Column import Database.Selda.Compile import Database.Selda.Frontend import Database.Selda.Inner+import Database.Selda.Prepared import Database.Selda.Query import Database.Selda.Query.Type import Database.Selda.Selectors@@ -134,14 +141,18 @@ import Database.Selda.Unsafe import Control.Exception (throw) import Data.Text (Text)+import Data.Time (Day, TimeOfDay, UTCTime) import Data.Typeable (eqT, (:~:)(..)) import Unsafe.Coerce  -- | Any column type that can be used with the 'min_' and 'max_' functions.-class SqlType a => MinMax a-instance {-# OVERLAPPABLE #-} (SqlType a, Num a) => MinMax a-instance MinMax Text-instance MinMax a => MinMax (Maybe a)+class SqlType a => SqlOrd a+instance {-# OVERLAPPABLE #-} (SqlType a, Num a) => SqlOrd a+instance SqlOrd Text+instance SqlOrd Day+instance SqlOrd UTCTime+instance SqlOrd TimeOfDay+instance SqlOrd a => SqlOrd (Maybe a)  -- | Convenient shorthand for @fmap (! sel) q@. --   The following two queries are quivalent:@@ -184,7 +195,8 @@   return x infixr 7 `suchThat` -(.==), (./=), (.>), (.<), (.>=), (.<=) :: SqlType a => Col s a -> Col s a -> Col s Bool+(.==), (./=) :: SqlType a => Col s a -> Col s a -> Col s Bool+(.>), (.<), (.>=), (.<=) :: SqlOrd a => Col s a -> Col s a -> Col s Bool (.==) = liftC2 $ BinOp Eq (./=) = liftC2 $ BinOp Neq (.>)  = liftC2 $ BinOp Gt@@ -231,8 +243,6 @@ --   For an auto-incrementing primary key, the default value is the next key. -- --   Using @def@ in any other context than insertion results in a runtime error.---   Likewise, if @def@ is given for a column that does not have a default---   value, the insertion will fail. def :: SqlType a => a def = throw DefaultValueException @@ -287,11 +297,11 @@ avg = aggr "AVG"  -- | The greatest value in the given column. Texts are compared lexically.-max_ :: MinMax a => Col s a -> Aggr s a+max_ :: SqlOrd a => Col s a -> Aggr s a max_ = aggr "MAX"  -- | The smallest value in the given column. Texts are compared lexically.-min_  :: MinMax a => Col s a -> Aggr s a+min_  :: SqlOrd a => Col s a -> Aggr s a min_ = aggr "MIN"  -- | Sum all values in the given column.

@@ -1,126 +1,25 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--- | API for building Selda backends.+-- | API for building Selda backends and adding support for more types+--   in queries. module Database.Selda.Backend-  ( MonadIO (..)-  , QueryRunner, SeldaBackend (..), MonadSelda (..), SeldaT (..), SeldaM-  , SeldaError (..)-  , Param (..), Lit (..), SqlValue (..), ColAttr (..)-  , compileColAttr+  ( MonadSelda (..), SeldaT, SeldaM, SeldaError (..)+  , StmtID, BackendID (..), QueryRunner, SeldaBackend (..), SeldaConnection+  , SqlType (..), SqlValue (..), SqlTypeRep (..)+  , Param (..), Lit (..), ColAttr (..)+  , PPConfig (..), defPPConfig+  , newConnection, allStmts, seldaBackend+  , runSeldaT, seldaClose   , sqlDateTimeFormat, sqlDateFormat, sqlTimeFormat-  , runSeldaT   ) where-import Database.Selda.Caching (invalidate)-import Database.Selda.SQL (Param (..))-import Database.Selda.SqlType-import Database.Selda.Table (Table, ColAttr (..), tableName)-import Database.Selda.Table.Compile (compileColAttr)-import Database.Selda.Types (TableName)-import Control.Exception (throwIO)-import Control.Monad.Catch+import Database.Selda.Backend.Internal+import Control.Monad import Control.Monad.IO.Class-import Control.Monad.State-import Data.Text (Text)-import Data.Typeable---- | Thrown by any function in 'SeldaT' if an error occurs.-data SeldaError-  = DbError String  -- ^ Unable to open or connect to database.-  | SqlError String -- ^ An error occurred while executing query.-  deriving (Show, Eq, Typeable)--instance Exception SeldaError---- | A function which executes a query and gives back a list of extensible---   tuples; one tuple per result row, and one tuple element per column.-type QueryRunner a = Text -> [Param] -> IO a---- | A collection of functions making up a Selda backend.-data SeldaBackend = SeldaBackend-  { -- | Execute an SQL statement.-    runStmt       :: QueryRunner (Int, [[SqlValue]])--    -- | Execute an SQL statement and return the last inserted primary key,-    --   where the primary key is auto-incrementing.-    --   Backends must take special care to make this thread-safe.-  , runStmtWithPK :: QueryRunner Int--    -- | Generate a custom column type for the column having the given Selda-    --   type and list of attributes.-  , customColType :: Text -> [ColAttr] -> Maybe Text--    -- | The keyword that represents the default value for auto-incrementing-    --   primary keys.-  , defaultKeyword :: Text--    -- | A string uniquely identifying the database used by this invocation-    --   of the backend. This could be, for instance, a PostgreSQL connection-    --   string or the absolute path to an SQLite file.-  , dbIdentifier   :: Text-}--data SeldaState = SeldaState-  { -- | Backend in use by the current computation.-    stBackend :: !SeldaBackend--    -- | Tables modified by the current transaction.-    --   Invariant: always @Just xs@ during a transaction, and always-    --   @Nothing@ when not in a transaction.-  , stTouchedTables :: !(Maybe [TableName])-  }---- | Some monad with Selda SQL capabilitites.-class MonadIO m => MonadSelda m where-  -- | Get the backend in use by the computation.-  seldaBackend :: m SeldaBackend--  -- | Invalidate the given table as soon as the current transaction finishes.-  --   Invalidate the table immediately if no transaction is ongoing.-  invalidateTable :: Table a -> m ()--  -- | Indicates the start of a new transaction.-  --   Starts bookkeeping to invalidate all tables modified during-  --   the transaction at the next call to 'endTransaction'.-  beginTransaction :: m ()--  -- | Indicates the end of the current transaction.-  --   Invalidates all tables that were modified since the last call to-  --   'beginTransaction', unless the transaction was rolled back.-  endTransaction :: Bool -- ^ @True@ if the transaction was committed,-                         --   @False@ if it was rolled back.-                 -> m ()---- | Monad transformer adding Selda SQL capabilities.-newtype SeldaT m a = S {unS :: StateT SeldaState m a}-  deriving ( Functor, Applicative, Monad, MonadIO-           , MonadThrow, MonadCatch, MonadMask, MonadTrans-           )--instance MonadIO m => MonadSelda (SeldaT m) where-  seldaBackend = S $ fmap stBackend get--  invalidateTable tbl = S $ do-    st <- get-    case stTouchedTables st of-      Nothing -> liftIO $ invalidate [tableName tbl]-      Just ts -> put $ st {stTouchedTables = Just (tableName tbl : ts)}--  beginTransaction = S $ do-    st <- get-    case stTouchedTables st of-      Nothing -> put $ st {stTouchedTables = Just []}-      Just _  -> liftIO $ throwIO $ SqlError "attempted to nest transactions"--  endTransaction committed = S $ do-    st <- get-    case stTouchedTables st of-      Just ts | committed -> liftIO $ invalidate ts-      _                   -> return ()-    put $ st {stTouchedTables = Nothing}---- | The simplest form of Selda computation; 'SeldaT' specialized to 'IO'.-type SeldaM = SeldaT IO+import Data.IORef --- | Run a Selda transformer. Backends should use this to implement their---   @withX@ functions.-runSeldaT :: MonadIO m => SeldaT m a -> SeldaBackend -> m a-runSeldaT m b = fst <$> runStateT (unS m) (SeldaState b Nothing)+-- | Close a reusable Selda connection.+--   Closing a connection while in use is undefined.+--   Passing a closed connection to 'runSeldaT' results in a 'SeldaError'+--   being thrown. Closing a connection more than once is a no-op.+seldaClose :: MonadIO m => SeldaConnection -> m ()+seldaClose c = liftIO $ do+  closed <- atomicModifyIORef' (connClosed c) $ \closed -> (True, closed)+  unless closed $ closeConnection (connBackend c) c

@@ -0,0 +1,223 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- | Internal backend API.+module Database.Selda.Backend.Internal+  ( StmtID, BackendID (..)+  , QueryRunner, SeldaBackend (..), SeldaConnection (..), SeldaStmt (..)+  , MonadSelda (..), SeldaT (..), SeldaM+  , SeldaError (..)+  , Param (..), Lit (..), ColAttr (..)+  , SqlType (..), SqlValue (..), SqlTypeRep (..)+  , PPConfig (..), defPPConfig+  , sqlDateTimeFormat, sqlDateFormat, sqlTimeFormat+  , freshStmtId+  , newConnection, allStmts+  , runSeldaT, seldaBackend+  ) where+import Database.Selda.Caching (invalidate)+import Database.Selda.SQL (Param (..))+import Database.Selda.SqlType+import Database.Selda.Table (Table, ColAttr (..), tableName)+import Database.Selda.SQL.Print.Config+import Database.Selda.Types (TableName)+import Control.Concurrent+import Control.Monad.Catch+import Control.Monad.IO.Class+import Control.Monad.State+import Data.Dynamic+import Data.Hashable+import qualified Data.HashMap.Strict as M+import Data.IORef+import Data.Text (Text)+import System.IO.Unsafe (unsafePerformIO)++-- | Uniquely identifies some particular backend.+--+--   When publishing a new backend, consider submitting a pull request with a+--   constructor for your backend instead of using the @Other@ constructor.+data BackendID = SQLite | PostgreSQL | Other Text+  deriving (Show, Eq, Ord)++-- | Thrown by any function in 'SeldaT' if an error occurs.+data SeldaError+  = DbError String  -- ^ Unable to open or connect to database.+  | SqlError String -- ^ An error occurred while executing query.+  deriving (Show, Eq, Typeable)++instance Exception SeldaError++-- | A prepared statement identifier. Guaranteed to be unique per application.+newtype StmtID = StmtID Int+  deriving (Show, Eq, Ord, Hashable)++-- | A connection identifier. Guaranteed to be unique per application.+newtype ConnID = ConnID Int+  deriving (Show, Eq, Ord)++{-# NOINLINE nextStmtId #-}+nextStmtId :: IORef Int+nextStmtId = unsafePerformIO $ newIORef 1++-- | Generate a fresh statement identifier, guaranteed to be unique per process.+freshStmtId :: MonadIO m => m StmtID+freshStmtId = liftIO $ atomicModifyIORef' nextStmtId $ \n -> (n+1, StmtID n)++-- | A function which executes a query and gives back a list of extensible+--   tuples; one tuple per result row, and one tuple element per column.+type QueryRunner a = Text -> [Param] -> IO a++-- | A prepared statement.+data SeldaStmt = SeldaStmt+ { -- | Backend-specific handle to the prepared statement.+   stmtHandle :: !Dynamic++   -- | The SQL code for the statement.+ , stmtText :: !Text++   -- | All parameters to be passed to the prepared statement.+   --   Parameters that are unique to each invocation are specified as indices+   --   starting at 0.+   --   Backends implementing @runPrepared@ should probably ignore this field.+ , stmtParams :: ![Either Int Param]+   +   -- | All tables touched by the statement.+ , stmtTables :: ![TableName]+ }++data SeldaConnection = SeldaConnection+  { -- | The backend used by the current connection.+    connBackend :: !SeldaBackend++    -- | A string uniquely identifying the database used by this connection.+    --   This could be, for instance, a PostgreSQL connection+    --   string or the absolute path to an SQLite file.+  , connDbId :: Text++    -- | All statements prepared for this connection.+  , connStmts :: !(IORef (M.HashMap StmtID SeldaStmt))++    -- | Is the connection closed?+  , connClosed :: !(IORef Bool)++    -- | Lock to prevent this connection from being used concurrently by+    --   multiple invocations of 'runSeldaT'.+  , connLock :: !(MVar ())+}++-- | Create a new Selda connection for the given backend and database+--   identifier string.+newConnection :: MonadIO m => SeldaBackend -> Text -> m SeldaConnection+newConnection back dbid =+  liftIO $ SeldaConnection back dbid <$> newIORef M.empty+                                     <*> newIORef False+                                     <*> newMVar ()++-- | Get all statements and their corresponding identifiers for the current+--   connection.+allStmts :: SeldaConnection -> IO [(StmtID, Dynamic)]+allStmts =+  fmap (map (\(k, v) -> (k, stmtHandle v)) . M.toList) . readIORef . connStmts++-- | A collection of functions making up a Selda backend.+data SeldaBackend = SeldaBackend+  { -- | Execute an SQL statement.+    runStmt :: Text -> [Param] -> IO (Int, [[SqlValue]])++    -- | Execute an SQL statement and return the last inserted primary key,+    --   where the primary key is auto-incrementing.+    --   Backends must take special care to make this thread-safe.+  , runStmtWithPK :: Text -> [Param] -> IO Int++    -- | Prepare a statement using the given statement identifier.+  , prepareStmt :: StmtID -> [SqlTypeRep] -> Text -> IO Dynamic++    -- | Execute a prepared statement.+  , runPrepared :: Dynamic -> [Param] -> IO (Int, [[SqlValue]])++    -- | SQL pretty-printer configuration.+  , ppConfig :: PPConfig++    -- | Close the currently open connection.+  , closeConnection :: SeldaConnection -> IO ()++    -- | Unique identifier for this backend.+  , backendId :: BackendID+  }++data SeldaState = SeldaState+  { -- | Connection in use by the current computation.+    stConnection :: !SeldaConnection++    -- | Tables modified by the current transaction.+    --   Invariant: always @Just xs@ during a transaction, and always+    --   @Nothing@ when not in a transaction.+  , stTouchedTables :: !(Maybe [TableName])+  }++-- | Some monad with Selda SQL capabilitites.+class MonadIO m => MonadSelda m where+  -- | Get the connection in use by the computation.+  seldaConnection :: m SeldaConnection++  -- | Invalidate the given table as soon as the current transaction finishes.+  --   Invalidate the table immediately if no transaction is ongoing.+  invalidateTable :: Table a -> m ()++  -- | Indicates the start of a new transaction.+  --   Starts bookkeeping to invalidate all tables modified during+  --   the transaction at the next call to 'endTransaction'.+  beginTransaction :: m ()++  -- | Indicates the end of the current transaction.+  --   Invalidates all tables that were modified since the last call to+  --   'beginTransaction', unless the transaction was rolled back.+  endTransaction :: Bool -- ^ @True@ if the transaction was committed,+                         --   @False@ if it was rolled back.+                 -> m ()++-- | Get the backend in use by the computation.+seldaBackend :: MonadSelda m => m SeldaBackend+seldaBackend = connBackend <$> seldaConnection++-- | Monad transformer adding Selda SQL capabilities.+newtype SeldaT m a = S {unS :: StateT SeldaState m a}+  deriving ( Functor, Applicative, Monad, MonadIO+           , MonadThrow, MonadCatch, MonadMask, MonadTrans+           )++instance MonadIO m => MonadSelda (SeldaT m) where+  seldaConnection = S $ fmap stConnection get++  invalidateTable tbl = S $ do+    st <- get+    case stTouchedTables st of+      Nothing -> liftIO $ invalidate [tableName tbl]+      Just ts -> put $ st {stTouchedTables = Just (tableName tbl : ts)}++  beginTransaction = S $ do+    st <- get+    case stTouchedTables st of+      Nothing -> put $ st {stTouchedTables = Just []}+      Just _  -> liftIO $ throwM $ SqlError "attempted to nest transactions"++  endTransaction committed = S $ do+    st <- get+    case stTouchedTables st of+      Just ts | committed -> liftIO $ invalidate ts+      _                   -> return ()+    put $ st {stTouchedTables = Nothing}++-- | The simplest form of Selda computation; 'SeldaT' specialized to 'IO'.+type SeldaM = SeldaT IO++-- | Run a Selda transformer. Backends should use this to implement their+--   @withX@ functions.+runSeldaT :: (MonadIO m, MonadMask m) => SeldaT m a -> SeldaConnection -> m a+runSeldaT m c = do+    liftIO $ takeMVar (connLock c)+    go `finally` liftIO (putMVar (connLock c) ())+  where+    go = do+      closed <- liftIO $ readIORef (connClosed c)+      when closed $ do+        liftIO $ throwM $ DbError "runSeldaT called with a closed connection"+      fst <$> runStateT (unS m) (SeldaState c Nothing)

@@ -47,6 +47,7 @@   hashWithSalt s (LDateTime x) = hashWithSalt s x   hashWithSalt s (LDate x)     = hashWithSalt s x   hashWithSalt s (LTime x)     = hashWithSalt s x+  hashWithSalt s (LBlob x)     = hashWithSalt s x   hashWithSalt s (LJust x)     = hashWithSalt s x   hashWithSalt _ (LNull)       = 0   hashWithSalt s (LCustom l)   = hashWithSalt s l

@@ -12,6 +12,7 @@ import Database.Selda.Query.Type import Database.Selda.SQL import Database.Selda.SQL.Print+import Database.Selda.SQL.Print.Config import Database.Selda.SqlType import Database.Selda.Table import Database.Selda.Table.Compile@@ -26,36 +27,36 @@ --   The types given are tailored for SQLite. To translate SQLite types into --   whichever types are used by your backend, use 'compileWith'. compile :: Result a => Query s a -> (Text, [Param])-compile = snd . compileWithTables id+compile = snd . compileWithTables defPPConfig  -- | Compile a query using the given type translation function.-compileWith :: Result a => (Text -> Text) -> Query s a -> (Text, [Param])-compileWith ttr = snd . compileWithTables ttr+compileWith :: Result a => PPConfig -> Query s a -> (Text, [Param])+compileWith cfg = snd . compileWithTables cfg  -- | Compile a query into a parameterised SQL statement. Also returns all --   tables depended on by the query. compileWithTables :: Result a-                  => (Text -> Text)+                  => PPConfig                   -> Query s a                   -> ([TableName], (Text, [Param]))-compileWithTables ttr = compSql ttr . snd . compQuery+compileWithTables cfg = compSql cfg . snd . compQuery  -- | Compile an @INSERT@ query, given the keyword representing default values --   in the target SQL dialect, a table and a list of items corresponding --   to the table.-compileInsert :: Insert a => Text -> Table a -> [a] -> (Text, [Param])-compileInsert _ _ []         = (empty, [])-compileInsert defkw tbl rows = compInsert defkw tbl (map params rows)+compileInsert :: Insert a => PPConfig -> Table a -> [a] -> (Text, [Param])+compileInsert _ _ []       = (empty, [])+compileInsert cfg tbl rows = compInsert cfg tbl (map params rows)  -- | Compile an @UPDATE@ query. compileUpdate :: forall s a. (Columns (Cols s a), Result (Cols s a))-              => (Text -> Text)           -- ^ Type translation function.+              => PPConfig                 -- ^ SQL pretty-printer config.               -> Table a                  -- ^ The table to update.               -> (Cols s a -> Cols s a)   -- ^ Update function.               -> (Cols s a -> Col s Bool) -- ^ Predicate: update only when true.               -> (Text, [Param])-compileUpdate ttr tbl upd check =-    compUpdate ttr (tableName tbl) predicate updated+compileUpdate cfg tbl upd check =+    compUpdate cfg (tableName tbl) predicate updated   where     names = map colName (tableCols tbl)     cs = toTup names@@ -64,8 +65,8 @@  -- | Compile a @DELETE FROM@ query. compileDelete :: Columns (Cols s a)-              => Table a -> (Cols s a -> Col s Bool) -> (Text, [Param])-compileDelete tbl check = compDelete (tableName tbl) predicate+              => PPConfig -> Table a -> (Cols s a -> Col s Bool) -> (Text, [Param])+compileDelete cfg tbl check = compDelete cfg (tableName tbl) predicate   where C predicate = check $ toTup $ map colName $ tableCols tbl  -- | Compile a query to an SQL AST.

@@ -20,7 +20,7 @@   BinOp   :: !(BinOp a b) -> !(Exp sql a) -> !(Exp sql a) -> Exp sql b   UnOp    :: !(UnOp a b) -> !(Exp sql a) -> Exp sql b   Fun2    :: !Text -> !(Exp sql a) -> !(Exp sql b) -> Exp sql c-  Cast    :: !Text -> !(Exp sql a) -> Exp sql b+  Cast    :: !SqlTypeRep -> !(Exp sql a) -> Exp sql b   AggrEx  :: !Text -> !(Exp sql a) -> Exp sql b   InList  :: !(Exp sql a) -> ![Exp sql a] -> Exp sql Bool   InQuery :: !(Exp sql a) -> !sql -> Exp sql Bool

@@ -10,7 +10,7 @@   , dropTable, tryDropTable   , transaction, setLocalCache   ) where-import Database.Selda.Backend+import Database.Selda.Backend.Internal import Database.Selda.Caching import Database.Selda.Column import Database.Selda.Compile@@ -23,6 +23,7 @@ import Data.Text (Text) import Control.Monad import Control.Monad.Catch+import Control.Monad.IO.Class  -- | Run a query within a Selda monad. In practice, this is often a 'SeldaT' --   transformer on top of some other monad.@@ -61,8 +62,8 @@ insert _ [] = do   return 0 insert t cs = do-  kw <- defaultKeyword <$> seldaBackend-  res <- uncurry exec $ compileInsert kw t cs+  cfg <- ppConfig <$> seldaBackend+  res <- uncurry exec $ compileInsert cfg t cs   invalidateTable t   return res @@ -139,7 +140,7 @@   if tableHasAutoPK t     then do       res <- liftIO $ do-        uncurry (runStmtWithPK b) $ compileInsert (defaultKeyword b) t cs+        uncurry (runStmtWithPK b) $ compileInsert (ppConfig b) t cs       invalidateTable t       return $ unsafeRowId res     else do@@ -154,8 +155,8 @@        -> (Cols s a -> Cols s a)   -- ^ Update function.        -> m Int update tbl check upd = do-  tt <- typeTrans <$> seldaBackend-  res <- uncurry exec $ compileUpdate tt tbl upd check+  cfg <- ppConfig <$> seldaBackend+  res <- uncurry exec $ compileUpdate cfg tbl upd check   invalidateTable tbl   return res @@ -172,7 +173,8 @@ deleteFrom :: (MonadSelda m, Columns (Cols s a))            => Table a -> (Cols s a -> Col s Bool) -> m Int deleteFrom tbl f = do-  res <- uncurry exec $ compileDelete tbl f+  cfg <- ppConfig <$> seldaBackend+  res <- uncurry exec $ compileDelete cfg tbl f   invalidateTable tbl   return res @@ -184,14 +186,14 @@ -- | Create a table from the given schema. createTable :: MonadSelda m => Table a -> m () createTable tbl = do-  cct <- customColType <$> seldaBackend-  void . flip exec [] $ compileCreateTable cct Fail tbl+  cfg <- ppConfig <$> seldaBackend+  void . flip exec [] $ compileCreateTable cfg Fail tbl  -- | Create a table from the given schema, unless it already exists. tryCreateTable :: MonadSelda m => Table a -> m () tryCreateTable tbl = do-  cct <- customColType <$> seldaBackend-  void . flip exec [] $ compileCreateTable cct Ignore tbl+  cfg <- ppConfig <$> seldaBackend+  void . flip exec [] $ compileCreateTable cfg Ignore tbl  -- | Drop the given table. dropTable :: MonadSelda m => Table a -> m ()@@ -237,10 +239,11 @@ queryWith :: forall s m a. (MonadSelda m, Result a)           => QueryRunner (Int, [[SqlValue]]) -> Query s a -> m [Res a] queryWith qr q = do-  backend <- seldaBackend-  let db = dbIdentifier backend+  conn <- seldaConnection+  let backend = connBackend conn+      db = connDbId conn       cacheKey = (db, qs, ps)-      (tables, qry@(qs, ps)) = compileWithTables (typeTrans backend) q+      (tables, qry@(qs, ps)) = compileWithTables (ppConfig backend) q   mres <- liftIO $ cached cacheKey   case mres of     Just res -> do@@ -250,10 +253,6 @@       let res' = mkResults (Proxy :: Proxy a) res       liftIO $ cache tables cacheKey res'       return res'---- | Translate types for casts. Column attributes are ignored here.-typeTrans :: SeldaBackend -> Text -> Text-typeTrans backend t = maybe t id (customColType backend t [])  -- | Generate the final result of a query from a list of untyped result rows. mkResults :: Result a => Proxy a -> [[SqlValue]] -> [Res a]

@@ -37,7 +37,6 @@ import Database.Selda.Table import Database.Selda.Types import Database.Selda.Selectors-import Database.Selda.SqlType  -- | Any type which has a corresponding relation. --   To make a @Relational@ instance for some type, simply derive 'Generic'.

@@ -0,0 +1,191 @@+{-# LANGUAGE TypeFamilies, FlexibleInstances, ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-}+-- | Building and executing prepared statements.+module Database.Selda.Prepared (Preparable, Prepare, prepared) where+import Database.Selda.Backend.Internal+import Database.Selda.Caching+import Database.Selda.Column+import Database.Selda.Compile+import Database.Selda.Query.Type+import Database.Selda.SQL (param, paramType)+import Database.Selda.Types (TableName)+import Control.Exception+import Control.Monad.IO.Class+import qualified Data.HashMap.Strict as M+import Data.IORef+import Data.Proxy+import Data.Text (Text)+import System.IO.Unsafe++data Placeholder = Placeholder Int+  deriving Show+instance Exception Placeholder++-- | Index of first argument parameter to a query.+firstParamIx :: Int+firstParamIx = 0++-- | Result type of a monadic computation.+type family ResultT f where+  ResultT (a -> b) = ResultT b+  ResultT (m a)    = a++type family Equiv q f where+  Equiv (Col s a -> q) (a -> f) = Equiv q f+  Equiv (Query s a)    (m [b])  = Res a ~ b++type CompResult = (Text, [Either Int Param], [SqlTypeRep], [TableName])++class Preparable q where+  -- | Prepare the query and parameter list.+  mkQuery :: MonadSelda m+          => Int -- ^ Next argument index.+          -> q   -- ^ The query.+          -> [SqlTypeRep] -- ^ The list of param types so far.+          -> m CompResult++-- | Some parameterized query @q@ that can be prepared into a function @f@+--   in some @MonadSelda@.+class Prepare q f where+  -- | Build the function that prepares and execute the query.+  mkFun :: Preparable q+        => IORef (Maybe (BackendID, CompResult))+        -> StmtID+        -> q+        -> [Param]+        -> f++instance (SqlType a, Prepare q b) => Prepare q (a -> b) where+  mkFun ref sid qry ps x = mkFun ref sid qry (param x : ps)++instance (MonadSelda m, a ~ Res (ResultT q), Result (ResultT q)) =>+         Prepare q (m [a]) where+  mkFun ref sid qry arguments = do+    conn <- seldaConnection+    let backend = connBackend conn+        args = reverse arguments+    stmts <- liftIO $ readIORef (connStmts conn)+    case M.lookup sid stmts of+      Just stm -> do+        -- Statement already prepared for this connection; just execute it.+        liftIO $ do+          runQuery conn stm args+      _ -> do+        -- Statement wasn't prepared for this connection; check if it was at+        -- least previously compiled for this backend.+        compiled <- liftIO $ readIORef ref+        (q, params, reps, ts) <- case compiled of+          Just (bid, comp) | bid == backendId backend -> do+            return comp+          _ -> do+            comp <- mkQuery firstParamIx qry []+            liftIO $ writeIORef ref (Just (backendId backend, comp))+            return comp++        -- Prepare and execute+        liftIO $ do+          hdl <- prepareStmt backend sid reps q+          let stm = SeldaStmt+                { stmtHandle = hdl+                , stmtParams = params+                , stmtTables = ts+                , stmtText = q+                }+          atomicModifyIORef' (connStmts conn) $ \m -> (M.insert sid stm m, ())+          runQuery conn stm args+    where+      runQuery conn stm args = do+        let backend = connBackend conn+            ps = replaceParams (stmtParams stm) args+            key = (connDbId conn, stmtText stm, ps)+            hdl = stmtHandle stm+        mres <- cached key+        case mres of+          Just res -> do+            return res+          _ -> do+            res <- runPrepared backend hdl ps+            cache (stmtTables stm) key res+            return $ map (toRes (Proxy :: Proxy (ResultT q))) (snd res)++instance (SqlType a, Preparable b) => Preparable (Col s a -> b) where+  mkQuery n f ts = mkQuery (n+1) (f x) (sqlType (Proxy :: Proxy a) : ts)+    where x = C $ Lit $ LCustom (throw (Placeholder n) :: Lit a)++instance Result a => Preparable (Query s a) where+  mkQuery _ q types = do+    b <- seldaBackend+    case compileWithTables (ppConfig b) q of+      (tables, (q', ps)) -> do+        (ps', types') <- liftIO $ inspectParams (reverse types) ps+        return (q', ps', types', tables)++-- | Create a prepared Selda function. A prepared function has zero or more+--   arguments, and will get compiled into a prepared statement by the first+--   backend to execute it. Any subsequent calls to the function for the duration+--   of the connection to the database will reuse the prepared statement.+--+--   Preparable functions are of the form+--   @(SqlType a, SqlType b, ...) => Col s a -> Col s b -> ... -> Query s r@.+--   The resulting prepared function will be of the form+--   @MonadSelda m => a -> b -> ... -> m [Res r]@.+--   Note, however, that when using @prepared@, you must give a concrete type+--   for @m@ due to how Haskell's type class resolution works.+--+--   Prepared functions rely on memoization for just-in-time preparation and+--   caching. This means that if GHC accidentally inlines your prepared function,+--   it may get prepared twice.+--   While this does not affect the correctness of your program, and is+--   fairly unlikely to happen, if you want to be absolutely sure that your+--   queries aren't re-prepared more than absolutely necessary,+--   consider adding a @NOINLINE@ annotation to each prepared function.+--+--   A usage example:+--+-- > ages :: Table (Text :*: Int)+-- > ages = table "ages" $ primary "name" :*: required "age"+-- >+-- > {-# NOINLINE ageOf #-}+-- > ageOf :: Text -> SeldaM [Int]+-- > ageOf = prepared $ \n -> do+-- >   (name :*: age) <- select ages+-- >   restrict $ name .== n+-- >   return age+{-# NOINLINE prepared #-}+prepared :: (Preparable q, Prepare q f, Equiv q f) => q -> f+prepared q = unsafePerformIO $ do+  ref <- newIORef Nothing+  sid <- freshStmtId+  return $ mkFun ref sid q []++-- | Replace every indexed parameter with the corresponding provided parameter.+--   Keep all non-indexed parameters in place.+replaceParams :: [Either Int Param] -> [Param] -> [Param]+replaceParams params = map fromRight . go firstParamIx params+  where+    go n ps (x:xs) = go (n+1) (map (subst n x) ps) xs+    go _ ps _      = ps++    subst n x (Left n') | n == n' = Right x+    subst _ _ old                 = old++    fromRight (Right x) = x+    fromRight _         = error "BUG: query parameter not substituted!"++-- | Inspect a list of parameters, denoting each parameter with either a+--   placeholder index or a literal parameter.+inspectParams :: [SqlTypeRep] -> [Param] -> IO ([Either Int Param], [SqlTypeRep])+inspectParams ts (x:xs) = do+  res <- try $ pure $! forceParam x+  let (x', t) = case res of+        Right p               -> (Right p, paramType p)+        Left (Placeholder ix) -> (Left ix, ts !! ix)+  (xs', ts') <- inspectParams ts xs+  return (x' : xs', t : ts')+inspectParams _ [] = do+  return ([], [])++-- | Force a parameter deep enough to determine whether it is a placeholder.+forceParam :: Param -> Param+forceParam p@(Param (LCustom x)) | x `seq` True = p+forceParam p                                    = p

@@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleContexts, OverloadedStrings #-} -- | Query monad and primitive operations. module Database.Selda.Query-  (select, selectValues+  ( select, selectValues   , restrict, groupBy, limit, order   , aggregate, leftJoin, innerJoin   ) where@@ -12,6 +12,7 @@ import Database.Selda.Table import Database.Selda.Transform import Control.Monad.State.Strict+import Unsafe.Coerce  -- | Query the given table. Result is returned as an inductive tuple, i.e. --   @first :*: second :*: third <- query tableOfThree@.@@ -178,7 +179,7 @@  -- | Drop the first @m@ rows, then get at most @n@ of the remaining rows from the --   given subquery.-limit :: Int -> Int -> Query (Inner s) a -> Query s a+limit :: Int -> Int -> Query (Inner s) a -> Query s (OuterCols a) limit from to q = Query $ do   (lim_st, res) <- isolate q   st <- get@@ -188,7 +189,8 @@         ss ->           SQL (allCols ss) (Product ss) [] [] [] (Just (from, to))   put $ st {sources = sql : sources st}-  return res+  -- TODO: replace with safe coercion+  return $ unsafeCoerce res  -- | Sort the result rows in ascending or descending order on the given row. order :: Col s a -> Order -> Query s ()

@@ -63,6 +63,14 @@ instance Ord Param where   compare (Param a) (Param b) = compLit a b +-- | Create a parameter from the given value.+param :: SqlType a => a -> Param+param = Param . mkLit++-- | The SQL type of the given parameter.+paramType :: Param -> SqlTypeRep+paramType (Param p) = litType p+ -- | Exception indicating the use of a default value. --   If any values throwing this during evaluation of @param xs@ will be --   replaced by their default value.

@@ -3,6 +3,8 @@ module Database.Selda.SQL.Print where import Database.Selda.Column import Database.Selda.SQL+import Database.Selda.SQL.Print.Config (PPConfig)+import qualified Database.Selda.SQL.Print.Config as Cfg import Database.Selda.SqlType import Database.Selda.Types import Control.Monad.State@@ -24,34 +26,34 @@   , ppTables  :: ![TableName]   , ppParamNS :: !Int   , ppQueryNS :: !Int-  , ppTypeTr  :: !(Text -> Text)+  , ppConfig  :: !PPConfig   }  -- | Run a pretty-printer.-runPP :: (Text -> Text)+runPP :: PPConfig       -> PP Text       -> ([TableName], (Text, [Param]))-runPP typetr pp =-  case runState pp (PPState [] [] 1 0 typetr) of+runPP cfg pp =+  case runState pp (PPState [] [] 1 0 cfg) of     (q, st) -> (snub $ ppTables st, (q, reverse (ppParams st)))  -- | Compile an SQL AST into a parameterized SQL query.-compSql :: (Text -> Text)+compSql :: PPConfig         -> SQL         -> ([TableName], (Text, [Param]))-compSql typetr = runPP typetr . ppSql+compSql cfg = runPP cfg . ppSql  -- | Compile a single column expression.-compExp :: (Text -> Text) -> Exp SQL a -> (Text, [Param])-compExp typetr = snd . runPP typetr . ppCol+compExp :: PPConfig -> Exp SQL a -> (Text, [Param])+compExp cfg = snd . runPP cfg . ppCol  -- | Compile an @UPATE@ statement.-compUpdate :: (Text -> Text)+compUpdate :: PPConfig            -> TableName            -> Exp SQL Bool            -> [(ColName, SomeCol SQL)]            -> (Text, [Param])-compUpdate typetr tbl p cs = snd $ runPP typetr ppUpd+compUpdate cfg tbl p cs = snd $ runPP cfg ppUpd   where     ppUpd = do       updates <- mapM ppUpdate cs@@ -76,19 +78,13 @@         us' -> Text.intercalate ", " us'  -- | Compile a @DELETE@ statement.-compDelete :: TableName -> Exp SQL Bool -> (Text, [Param])-compDelete tbl p = snd $ runPP id ppDelete+compDelete :: PPConfig -> TableName -> Exp SQL Bool -> (Text, [Param])+compDelete cfg tbl p = snd $ runPP cfg ppDelete   where     ppDelete = do       c' <- ppCol p       pure $ Text.unwords ["DELETE FROM", fromTableName tbl, "WHERE", c'] --- | Pretty-print a type name.-ppType :: Text -> PP Text-ppType t = do-  typeTr <- ppTypeTr <$> get-  pure $ typeTr t- -- | Pretty-print a literal as a named parameter and save the --   name-value binding in the environment. ppLit :: Lit a -> PP Text@@ -208,6 +204,11 @@ ppCols cs = do   cs' <- mapM ppCol (reverse cs)   pure $ "(" <> Text.intercalate ") AND (" cs' <> ")"++ppType :: SqlTypeRep -> PP Text+ppType t = do+  c <- ppConfig <$> get+  pure $ Cfg.ppType c t  ppCol :: Exp SQL a -> PP Text ppCol (TblCol xs)    = error $ "compiler bug: ppCol saw TblCol: " ++ show xs

@@ -0,0 +1,52 @@+{-# LANGUAGE OverloadedStrings #-}+module Database.Selda.SQL.Print.Config (PPConfig (..), defPPConfig) where+import Data.Text (Text)+import qualified Data.Text as T+import Database.Selda.SqlType+import Database.Selda.Table++-- | Backend-specific configuration for the SQL pretty-printer.+data PPConfig = PPConfig+  { -- | The SQL type name of the given type.+    ppType :: SqlTypeRep -> Text++    -- | Parameter placeholder for the @n@th parameter.+  , ppPlaceholder :: Int -> Text++    -- | List of column attributes, such as +  , ppColAttrs :: [ColAttr] -> Text++    -- | The value used for the next value for an auto-incrementing column.+    --   For instance, @DEFAULT@ for PostgreSQL, and @NULL@ for SQLite.+  , ppAutoIncInsert :: Text+  }++-- | Default settings for pretty-printing.+--   Geared towards SQLite.+defPPConfig :: PPConfig+defPPConfig = PPConfig+    { ppType = defType+    , ppPlaceholder = T.cons '$' . T.pack . show+    , ppColAttrs = T.unwords . map defColAttr+    , ppAutoIncInsert = "NULL"+    }++-- | Default compilation for SQL types.+defType :: SqlTypeRep -> Text+defType TText     = "TEXT"+defType TRowID    = "INTEGER"+defType TInt      = "INT"+defType TFloat    = "DOUBLE"+defType TBool     = "INT"+defType TDateTime = "DATETIME"+defType TDate     = "DATE"+defType TTime     = "TIME"+defType TBlob     = "BLOB"++-- | Default compilation for a column attribute.+defColAttr :: ColAttr -> Text+defColAttr Primary       = "PRIMARY KEY"+defColAttr AutoIncrement = "AUTOINCREMENT"+defColAttr Required      = "NOT NULL"+defColAttr Optional      = "NULL"+defColAttr Unique        = "UNIQUE"

@@ -1,12 +1,14 @@ {-# LANGUAGE GADTs, OverloadedStrings, ScopedTypeVariables, FlexibleInstances #-} -- | Types representable in Selda's subset of SQL. module Database.Selda.SqlType-  ( Lit (..), RowID, SqlValue (..), SqlType-  , invalidRowId, isInvalidRowId, unsafeRowId-  , mkLit, sqlType, fromSql, defaultValue+  ( Lit (..), RowID, SqlValue (..), SqlType, SqlTypeRep (..)+  , invalidRowId, isInvalidRowId, unsafeRowId, fromRowId+  , mkLit, sqlType, litType, fromSql, defaultValue   , compLit   , sqlDateTimeFormat, sqlDateFormat, sqlTimeFormat   ) where+import Data.ByteString (ByteString, empty)+import qualified Data.ByteString.Lazy as BSL import Data.Proxy import Data.Text (Text, pack, unpack) import Data.Time@@ -27,26 +29,65 @@ sqlTimeFormat :: String sqlTimeFormat = "%H:%M:%S%Q" +-- | Representation of an SQL type.+data SqlTypeRep+  = TText+  | TRowID+  | TInt+  | TFloat+  | TBool+  | TDateTime+  | TDate+  | TTime+  | TBlob+    deriving (Show, Eq, Ord)+ -- | Any datatype representable in (Selda's subset of) SQL. class Typeable a => SqlType a where-  mkLit        :: a -> Lit a-  sqlType      :: Proxy a -> Text-  fromSql      :: SqlValue -> a+  -- | Create a literal of this type.+  mkLit :: a -> Lit a++  -- | The SQL representation for this type.+  sqlType :: Proxy a -> SqlTypeRep+  sqlType _ = litType (defaultValue :: Lit a)++  -- | Convert an SqlValue into this type.+  fromSql :: SqlValue -> a++  -- | Default value when using 'def' at this type.   defaultValue :: Lit a  -- | An SQL literal. data Lit a where-  LText     :: !Text    -> Lit Text-  LInt      :: !Int     -> Lit Int-  LDouble   :: !Double  -> Lit Double-  LBool     :: !Bool    -> Lit Bool-  LDateTime :: !Text    -> Lit UTCTime-  LDate     :: !Text    -> Lit Day-  LTime     :: !Text    -> Lit TimeOfDay-  LJust     :: !(Lit a) -> Lit (Maybe a)-  LNull     :: Lit (Maybe a)-  LCustom   :: !(Lit a) -> Lit b+  LText     :: !Text       -> Lit Text+  LInt      :: !Int        -> Lit Int+  LDouble   :: !Double     -> Lit Double+  LBool     :: !Bool       -> Lit Bool+  LDateTime :: !Text       -> Lit UTCTime+  LDate     :: !Text       -> Lit Day+  LTime     :: !Text       -> Lit TimeOfDay+  LJust     :: SqlType a => !(Lit a) -> Lit (Maybe a)+  LBlob     :: !ByteString -> Lit ByteString+  LNull     :: SqlType a => Lit (Maybe a)+  LCustom   :: Lit a -> Lit b +-- | The SQL type representation for the given literal.+litType :: Lit a -> SqlTypeRep+litType (LText{})     = TText+litType (LInt{})      = TInt+litType (LDouble{})   = TFloat+litType (LBool{})     = TBool+litType (LDateTime{}) = TDateTime+litType (LDate{})     = TDate+litType (LTime{})     = TTime+litType (LJust x)     = litType x+litType (LBlob{})     = TBlob+litType (x@LNull)     = sqlType (proxyFor x)+  where+    proxyFor :: Lit (Maybe a) -> Proxy a+    proxyFor _ = Proxy+litType (LCustom x)   = litType x+ instance Eq (Lit a) where   a == b = compLit a b == EQ @@ -63,8 +104,9 @@ litConTag (LDate{})     = 5 litConTag (LTime{})     = 6 litConTag (LJust{})     = 7-litConTag (LNull)       = 8-litConTag (LCustom{})   = 9+litConTag (LBlob{})     = 8+litConTag (LNull)       = 9+litConTag (LCustom{})   = 10  -- | Compare two literals of different type for equality. compLit :: Lit a -> Lit b -> Ordering@@ -75,16 +117,18 @@ compLit (LDateTime x) (LDateTime x') = x `compare` x' compLit (LDate x)     (LDate x')     = x `compare` x' compLit (LTime x)     (LTime x')     = x `compare` x'+compLit (LBlob x)     (LBlob x')     = x `compare` x' compLit (LJust x)     (LJust x')     = x `compLit` x' compLit (LCustom x)   (LCustom x')   = x `compLit` x' compLit a             b              = litConTag a `compare` litConTag b  -- | Some value that is representable in SQL. data SqlValue where-  SqlInt    :: !Int    -> SqlValue-  SqlFloat  :: !Double -> SqlValue-  SqlString :: !Text   -> SqlValue-  SqlBool   :: !Bool   -> SqlValue+  SqlInt    :: !Int        -> SqlValue+  SqlFloat  :: !Double     -> SqlValue+  SqlString :: !Text       -> SqlValue+  SqlBool   :: !Bool       -> SqlValue+  SqlBlob   :: !ByteString -> SqlValue   SqlNull   :: SqlValue  instance Show SqlValue where@@ -92,6 +136,7 @@   show (SqlFloat f)  = "SqlFloat " ++ show f   show (SqlString s) = "SqlString " ++ show s   show (SqlBool b)   = "SqlBool " ++ show b+  show (SqlBlob b)   = "SqlBlob " ++ show b   show (SqlNull)     = "SqlNull"  instance Show (Lit a) where@@ -102,6 +147,7 @@   show (LDateTime s) = show s   show (LDate s)     = show s   show (LTime s)     = show s+  show (LBlob b)     = show b   show (LJust x)     = "Just " ++ show x   show (LNull)       = "Nothing"   show (LCustom l)   = show l@@ -109,7 +155,7 @@ -- | A row identifier for some table. --   This is the type of auto-incrementing primary keys. newtype RowID = RowID Int-  deriving (Eq, Typeable)+  deriving (Eq, Ord, Typeable) instance Show RowID where   show (RowID n) = show n @@ -129,37 +175,41 @@ unsafeRowId :: Int -> RowID unsafeRowId = RowID +-- | Inspect a row identifier.+fromRowId :: RowID -> Int+fromRowId (RowID n) = n+ instance SqlType RowID where   mkLit (RowID n) = LCustom $ LInt n-  sqlType _ = sqlType (Proxy :: Proxy Int)+  sqlType _ = TRowID   fromSql (SqlInt x) = RowID x   fromSql v          = error $ "fromSql: RowID column with non-int value: " ++ show v   defaultValue = mkLit invalidRowId  instance SqlType Int where   mkLit = LInt-  sqlType _ = "INTEGER"+  sqlType _ = TInt   fromSql (SqlInt x) = x   fromSql v          = error $ "fromSql: int column with non-int value: " ++ show v   defaultValue = LInt 0  instance SqlType Double where   mkLit = LDouble-  sqlType _ = "DOUBLE"+  sqlType _ = TFloat   fromSql (SqlFloat x) = x   fromSql v            = error $ "fromSql: float column with non-float value: " ++ show v   defaultValue = LDouble 0  instance SqlType Text where   mkLit = LText-  sqlType _ = "TEXT"+  sqlType _ = TText   fromSql (SqlString x) = x   fromSql v             = error $ "fromSql: text column with non-text value: " ++ show v   defaultValue = LText ""  instance SqlType Bool where   mkLit = LBool-  sqlType _ = "INT"+  sqlType _ = TBool   fromSql (SqlBool x) = x   fromSql (SqlInt 0)  = False   fromSql (SqlInt _)  = True@@ -168,7 +218,7 @@  instance SqlType UTCTime where   mkLit = LDateTime . pack . formatTime defaultTimeLocale sqlDateTimeFormat-  sqlType _             = "DATETIME"+  sqlType _             = TDateTime   fromSql (SqlString s) =     case parseTimeM True defaultTimeLocale sqlDateTimeFormat (unpack s) of       Just t -> t@@ -178,7 +228,7 @@  instance SqlType Day where   mkLit = LDate . pack . formatTime defaultTimeLocale sqlDateFormat-  sqlType _             = "DATE"+  sqlType _             = TDate   fromSql (SqlString s) =     case parseTimeM True defaultTimeLocale sqlDateFormat (unpack s) of       Just t -> t@@ -188,13 +238,27 @@  instance SqlType TimeOfDay where   mkLit = LTime . pack . formatTime defaultTimeLocale sqlTimeFormat-  sqlType _             = "TIME"+  sqlType _             = TTime   fromSql (SqlString s) =     case parseTimeM True defaultTimeLocale sqlTimeFormat (unpack s) of       Just t -> t       _      -> error $ "fromSql: bad time string: " ++ unpack s   fromSql v             = error $ "fromSql: time column with non-time value: " ++ show v   defaultValue = LTime "00:00:00"++instance SqlType ByteString where+  mkLit = LBlob+  sqlType _ = TBlob+  fromSql (SqlBlob x) = x+  fromSql v           = error $ "fromSql: blob column with non-blob value: " ++ show v+  defaultValue = LBlob empty++instance SqlType BSL.ByteString where+  mkLit = LCustom . LBlob . BSL.toStrict+  sqlType _ = TBlob+  fromSql (SqlBlob x) = BSL.fromStrict x+  fromSql v           = error $ "fromSql: blob column with non-blob value: " ++ show v+  defaultValue = LCustom $ LBlob empty  instance SqlType a => SqlType (Maybe a) where   mkLit (Just x) = LJust $ mkLit x

@@ -9,7 +9,7 @@ import Data.Dynamic import Data.List (sort, group) import Data.Monoid-import Data.Text (Text, unpack, intercalate, any)+import Data.Text (unpack, intercalate, any)  -- | An error occurred when validating a database table. --   If this error is thrown, there is a bug in your database schema, and the@@ -44,7 +44,7 @@  data ColInfo = ColInfo   { colName  :: !ColName-  , colType  :: !Text+  , colType  :: !SqlTypeRep   , colAttrs :: ![ColAttr]   , colFKs   :: ![(Table (), ColName)]   }@@ -100,7 +100,7 @@ --   Also adds the @PRIMARY KEY@ and @UNIQUE@ attributes on the column. autoPrimary :: ColName -> ColSpec RowID autoPrimary n = ColSpec [c {colAttrs = [Primary, AutoIncrement, Required, Unique]}]-  where ColSpec [c] = newCol n :: ColSpec Int+  where ColSpec [c] = newCol n :: ColSpec RowID  -- | Add a uniqueness constraint to the given column. --   Adding a uniqueness constraint to a column that is already implied to be

@@ -6,14 +6,15 @@ import Data.Monoid import Data.Text (Text, intercalate, pack) import qualified Data.Text as Text-import Database.Selda.SQL hiding (params)+import Database.Selda.SQL hiding (params, param)+import Database.Selda.SQL.Print.Config import Database.Selda.Types  data OnError = Fail | Ignore   deriving (Eq, Ord, Show)  -- | Compile a @CREATE TABLE@ query from a table definition.-compileCreateTable :: (Text -> [ColAttr] -> Maybe Text) -> OnError -> Table a -> Text+compileCreateTable :: PPConfig -> OnError -> Table a -> Text compileCreateTable customColType ifex tbl = mconcat   [ "CREATE TABLE ", ifNotExists ifex, fromTableName (tableName tbl), "("   , intercalate ", " (map (compileTableCol customColType) (tableCols tbl))@@ -38,16 +39,11 @@     fkName = fromColName $ addColPrefix col ("fk" <> pack (show n) <> "_")  -- | Compile a table column.-compileTableCol :: (Text -> [ColAttr] -> Maybe Text) -> ColInfo -> Text-compileTableCol customColType ci = Text.unwords+compileTableCol :: PPConfig -> ColInfo -> Text+compileTableCol cfg ci = Text.unwords   [ fromColName (colName ci)-  , case customColType typ attrs of-      Just s -> s-      _      -> typ <> " " <> Text.unwords (map compileColAttr attrs)+  , ppType cfg (colType ci) <> " " <> ppColAttrs cfg (colAttrs ci)   ]-  where-    typ = colType ci-    attrs = colAttrs ci  -- | Compile a @DROP TABLE@ query. compileDropTable :: OnError -> Table a -> Text@@ -60,8 +56,8 @@ --   Note that backends expect insertions to NOT have a semicolon at the end. --   In addition to the compiled query, this function also returns the list of --   parameters to be passed to the backend.-compInsert :: Text -> Table a -> [[Either Param Param]] -> (Text, [Param])-compInsert defaultKeyword tbl defs =+compInsert :: PPConfig -> Table a -> [[Either Param Param]] -> (Text, [Param])+compInsert cfg tbl defs =     (query, parameters)   where     colNames = map colName $ tableCols tbl@@ -94,7 +90,7 @@     mkCol :: Int -> Either Param Param -> ColInfo -> [Param] -> (Int, Text, [Param])     mkCol n (Left def) col ps       | AutoIncrement `elem` colAttrs col =-        (n, defaultKeyword, ps)+        (n, ppAutoIncInsert cfg, ps)       | otherwise =         (n+1, pack ('$':show n), def:ps)     mkCol n (Right val) _ ps =@@ -105,11 +101,3 @@     mkCols (n, names, params) (param, col) =       case mkCol n param col params of         (n', name, params') -> (n', name:names, params')---- | Compile a column attribute.-compileColAttr :: ColAttr -> Text-compileColAttr Primary       = "PRIMARY KEY"-compileColAttr AutoIncrement = "AUTOINCREMENT"-compileColAttr Required      = "NOT NULL"-compileColAttr Optional      = "NULL"-compileColAttr Unique        = "UNIQUE"