diff --git a/Database/Persist/Class/PersistStore.hs b/Database/Persist/Class/PersistStore.hs --- a/Database/Persist/Class/PersistStore.hs +++ b/Database/Persist/Class/PersistStore.hs @@ -49,9 +49,6 @@ ) => PersistStore backend where data BackendKey backend - backendKeyToValues :: BackendKey backend -> [PersistValue] - backendKeyFromValues :: [PersistValue] -> Either T.Text (BackendKey backend) - -- | Get a record by identifier, if available. get :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val) => Key val -> ReaderT backend m (Maybe val) @@ -67,6 +64,9 @@ insert_ val = insert val >> return () -- | Create multiple records in the database. + -- + -- If you don't need the inserted @Key@s, use 'insertMany_' + -- -- SQL backends currently use the slow default implementation of -- @mapM insert@ insertMany :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val) @@ -74,6 +74,7 @@ insertMany = mapM insert -- | Same as 'insertMany', but doesn't return any @Key@s. + -- -- SQL backends currently use an efficient implementation for this -- unlike 'insertMany'. insertMany_ :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val) diff --git a/Database/Persist/Quasi.hs b/Database/Persist/Quasi.hs --- a/Database/Persist/Quasi.hs +++ b/Database/Persist/Quasi.hs @@ -23,7 +23,7 @@ import qualified Data.Text as T import Control.Arrow ((&&&)) import qualified Data.Map as M -import Data.List (foldl',find) +import Data.List (foldl') import Data.Monoid (mappend) data ParseState a = PSDone | PSFail | PSSuccess a Text @@ -219,7 +219,7 @@ Just pdef -> if length foreignFieldTexts /= length (primaryFields pdef) then lengthError pdef - else let fds_ffs = zipWith (toForeignFields ent pent) + else let fds_ffs = zipWith (toForeignFields pent) foreignFieldTexts (primaryFields pdef) in fdef { foreignFields = map snd fds_ffs @@ -241,7 +241,7 @@ ++ show (map (unHaskellName . fieldHaskell) (fd:fds)) isNull = (NotNullable /=) . nullable . fieldAttrs - toForeignFields ent pent fieldText pfd = + toForeignFields pent fieldText pfd = case chktypes fd haskellField (entityFields pent) pfh of Just err -> error err Nothing -> (fd, ((haskellField, fieldDB fd), (pfh, pfdb))) @@ -252,7 +252,7 @@ (pfh, pfdb) = (fieldHaskell pfd, fieldDB pfd) chktypes :: FieldDef -> HaskellName -> [FieldDef] -> HaskellName -> Maybe String - chktypes ffld fkey pflds pkey = + chktypes ffld _fkey pflds pkey = if fieldType ffld == fieldType pfld then Nothing else Just $ "fieldType mismatch: " ++ show (fieldType ffld) ++ ", " ++ show (fieldType pfld) where @@ -261,15 +261,15 @@ entName = entityHaskell ent getFd [] t = error $ "foreign key constraint for: " ++ show (unHaskellName entName) ++ " unknown column: " ++ show t - getFd (fd:fds) t - | fieldHaskell fd == t = fd - | otherwise = getFd fds t + getFd (f:fs) t + | fieldHaskell f == t = f + | otherwise = getFd fs t lengthError pdef = error $ "found " ++ show (length foreignFieldTexts) ++ " fkeys and " ++ show (length (primaryFields pdef)) ++ " pkeys: fdef=" ++ show fdef ++ " pdef=" ++ show pdef data UnboundEntityDef = UnboundEntityDef - { unboundForeignDefs :: [UnboundForeignDef] + { _unboundForeignDefs :: [UnboundForeignDef] , unboundEntityDef :: EntityDef } @@ -398,8 +398,8 @@ takeUniq _ tableName _ xs = error $ "invalid unique constraint on table[" ++ show tableName ++ "] expecting an uppercase constraint name xs=" ++ show xs data UnboundForeignDef = UnboundForeignDef - { unboundFields :: [Text] -- ^ fields in other entity - , unboundForeignDef :: ForeignDef + { _unboundFields :: [Text] -- ^ fields in other entity + , _unboundForeignDef :: ForeignDef } takeForeign :: PersistSettings @@ -407,7 +407,7 @@ -> [FieldDef] -> [Text] -> UnboundForeignDef -takeForeign ps tableName defs (refTableName:n:rest) +takeForeign ps tableName _defs (refTableName:n:rest) | not (T.null n) && isLower (T.head n) = UnboundForeignDef fields $ ForeignDef (HaskellName refTableName) diff --git a/Database/Persist/Sql/Class.hs b/Database/Persist/Sql/Class.hs --- a/Database/Persist/Sql/Class.hs +++ b/Database/Persist/Sql/Class.hs @@ -10,6 +10,7 @@ module Database.Persist.Sql.Class ( RawSql (..) , PersistFieldSql (..) + , IsSqlKey (..) ) where import Control.Applicative ((<$>), (<*>)) @@ -268,3 +269,10 @@ -- An embedded Entity instance (PersistField record, PersistEntity record) => PersistFieldSql (Entity record) where sqlType _ = SqlString + +-- | A class for all numeric SQL keys, for easy conversion to/from Int64 values. +-- +-- Since 2.0.2 +class IsSqlKey a where + toSqlKey :: Int64 -> a + fromSqlKey :: a -> Int64 diff --git a/Database/Persist/Sql/Orphan/PersistStore.hs b/Database/Persist/Sql/Orphan/PersistStore.hs --- a/Database/Persist/Sql/Orphan/PersistStore.hs +++ b/Database/Persist/Sql/Orphan/PersistStore.hs @@ -1,12 +1,14 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Database.Persist.Sql.Orphan.PersistStore (withRawQuery, BackendKey(..)) where import Database.Persist import Database.Persist.Sql.Types import Database.Persist.Sql.Raw +import Database.Persist.Sql.Class (IsSqlKey (..)) import qualified Data.Conduit as C import qualified Data.Conduit.List as CL import qualified Data.Text as T @@ -32,15 +34,14 @@ srcRes <- rawQueryRes sql vals liftIO $ with srcRes (C.$$ sink) +instance IsSqlKey (BackendKey SqlBackend) where + toSqlKey = SqlBackendKey + fromSqlKey = unSqlBackendKey + instance PersistStore Connection where newtype BackendKey SqlBackend = SqlBackendKey { unSqlBackendKey :: Int64 } deriving (Show, Read, Eq, Ord, Num, Integral, PersistField, PersistFieldSql, PathPiece, Real, Enum, Bounded, A.ToJSON, A.FromJSON) - backendKeyToValues (SqlBackendKey i) = [PersistInt64 i] - backendKeyFromValues [PersistInt64 i] = Right $ SqlBackendKey i - backendKeyFromValues [PersistDouble i] = Right $ SqlBackendKey $ truncate i - backendKeyFromValues s = Left $ pack $ show s - update _ [] = return () update k upds = do conn <- ask @@ -114,6 +115,7 @@ t = entityDef $ Just val vals = map toPersistValue $ toPersistFields val + insertMany_ [] = return () insertMany_ vals = do conn <- ask let sql = T.concat @@ -125,7 +127,11 @@ , T.intercalate "),(" $ replicate (length valss) $ T.intercalate "," $ map (const "?") (entityFields t) , ")" ] - rawExecute sql (concat valss) + + -- SQLite support is only in later versions + if connRDBMS conn == "sqlite" + then mapM_ insert vals + else rawExecute sql (concat valss) where t = entityDef vals valss = map (map toPersistValue . toPersistFields) vals diff --git a/persistent.cabal b/persistent.cabal --- a/persistent.cabal +++ b/persistent.cabal @@ -1,9 +1,9 @@ name: persistent -version: 2.0.1.1 +version: 2.0.2 license: MIT license-file: LICENSE author: Michael Snoyman -maintainer: Michael Snoyman +maintainer: Michael Snoyman , Greg Weber synopsis: Type-safe, multi-backend data serialization. description: Type-safe, data serialization. You must use a specific backend in order to make this useful. category: Database, Yesod