groundhog 0.7.0.3 → 0.12.0
raw patch · 11 files changed
Files
- Database/Groundhog.hs +43/−36
- Database/Groundhog/Core.hs +432/−315
- Database/Groundhog/Expression.hs +241/−170
- Database/Groundhog/Generic.hs +260/−201
- Database/Groundhog/Generic/Migration.hs +359/−281
- Database/Groundhog/Generic/PersistBackendHelpers.hs +348/−225
- Database/Groundhog/Generic/Sql.hs +257/−194
- Database/Groundhog/Generic/Sql/Functions.hs +69/−46
- Database/Groundhog/Instances.hs +291/−222
- changelog +24/−0
- groundhog.cabal +13/−10
Database/Groundhog.hs view
@@ -1,44 +1,51 @@ -- | This module exports the most commonly used functions and datatypes. -- -- See <http://github.com/lykahb/groundhog/blob/master/examples/>.+module Database.Groundhog+ ( -- * Core datatypes and functions+ PersistBackend (..),+ PersistBackendConn (..),+ Key,+ DefaultKey,+ AutoKey,+ Unique,+ UniqueMarker,+ BackendSpecific,+ extractUnique,+ Cond (..),+ Order (..),+ Selector (..),+ AutoKeyField (..),+ (~>),+ limitTo,+ offsetBy,+ orderBy, -module Database.Groundhog (- -- * Core datatypes and functions- PersistBackend(..)- , DbPersist(..)- , Key- , DefaultKey- , AutoKey- , Unique- , UniqueMarker- , BackendSpecific- , extractUnique- , Cond(..)- , Order(..)- , Selector(..)- , AutoKeyField(..)- , (~>)- , limitTo- , offsetBy- , orderBy- , deleteByKey- -- * Expressions- , (=.)- , (&&.), (||.)- , (==.), (/=.), (<.), (<=.), (>.), (>=.)- , isFieldNothing- , liftExpr- , toArith- -- * Migration- , createMigration- , executeMigration- , executeMigrationUnsafe- , runMigration- , runMigrationUnsafe- , printMigration-) where+ -- * Expressions+ (=.),+ (&&.),+ (||.),+ (==.),+ (/=.),+ (<.),+ (<=.),+ (>.),+ (>=.),+ isFieldNothing,+ liftExpr,+ toArith, -import Database.Groundhog.Core+ -- * Migration+ createMigration,+ executeMigration,+ executeMigrationUnsafe,+ runMigration,+ runMigrationUnsafe,+ printMigration,+ )+where++import Database.Groundhog.Core hiding (projectStream, selectAllStream, selectStream) import Database.Groundhog.Expression import Database.Groundhog.Generic import Database.Groundhog.Instances
Database/Groundhog/Core.hs view
@@ -1,142 +1,181 @@-{-# LANGUAGE GADTs, TypeFamilies, ExistentialQuantification, MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, EmptyDataDecls, ConstraintKinds, CPP #-}-{-# LANGUAGE UndecidableInstances #-} -- Required for Projection'+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LiberalTypeSynonyms #-}+{-# LANGUAGE TypeFamilies #-}+-- Required for Projection'+{-# LANGUAGE UndecidableInstances #-}+-- Required for Projection'+{-# LANGUAGE UndecidableSuperClasses #-}+ -- | This module defines the functions and datatypes used throughout the framework. -- Most of them are for the internal use module Database.Groundhog.Core- ( - -- * Main types- PersistEntity(..)- , PersistValue(..)- , PersistField(..)- , SinglePersistField(..)- , PurePersistField(..)- , PrimitivePersistField(..)- , Embedded(..)- , Projection(..)- , Projection'- , RestrictionHolder- , Unique- , KeyForBackend(..)- , BackendSpecific- , ConstructorMarker- , UniqueMarker- , HFalse- , HTrue- , ZT (..) -- ZonedTime wrapper- , Utf8(..)- , fromUtf8- , delim- -- * Constructing expressions- , Cond(..)- , ExprRelation(..)- , Update(..)- , (~>)- , FieldLike(..)- , Assignable- , SubField(..)- , AutoKeyField(..)- , FieldChain- , NeverNull- , UntypedExpr(..)- , Expr(..)- , Order(..)- , HasSelectOptions(..)- , SelectOptions(..)- , limitTo- , offsetBy- , orderBy- , distinct- -- * Type description- -- $types- , DbTypePrimitive'(..)- , DbTypePrimitive- , DbType(..)- , EntityDef'(..)- , EntityDef- , EmbeddedDef'(..)- , EmbeddedDef- , OtherTypeDef'(..)- , OtherTypeDef- , ConstructorDef'(..)- , ConstructorDef- , Constructor(..)- , EntityConstr(..)- , IsUniqueKey(..)- , UniqueDef'(..)- , UniqueDef- , UniqueType(..)- , ReferenceActionType(..)- , ParentTableReference- -- * Migration- , SingleMigration- , NamedMigrations- , Migration- -- * Database- , PersistBackend(..)- , DbDescriptor(..)- , RowPopper- , DbPersist(..)- , runDbPersist- -- * Connections and transactions- , ConnectionManager(..)- , SingleConnectionManager- , Savepoint(..)- ) where+ ( -- * Main types+ PersistEntity (..),+ PersistValue (..),+ PersistField (..),+ SinglePersistField (..),+ PurePersistField (..),+ PrimitivePersistField (..),+ Embedded (..),+ Projection (..),+ Projection',+ RestrictionHolder,+ Unique,+ KeyForBackend (..),+ BackendSpecific,+ ConstructorMarker,+ UniqueMarker,+ HFalse,+ HTrue,+ ZT (..), -- ZonedTime wrapper+ Utf8 (..),+ fromUtf8,+ delim, -import Blaze.ByteString.Builder (Builder, fromByteString, toByteString)-import Control.Applicative (Applicative)-import Control.Monad.Base (MonadBase (liftBase))-import Control.Monad.Logger (MonadLogger(..))-import Control.Monad.Trans.Class (MonadTrans(..))-import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad.Trans.Control (MonadBaseControl (..), ComposeSt, defaultLiftBaseWith, defaultRestoreM, MonadTransControl (..))-import Control.Monad.Trans.Reader (ReaderT(..), runReaderT, mapReaderT)-import Control.Monad.Trans.State (StateT)-import Control.Monad.Reader (MonadReader(..))-import Control.Monad (liftM)-import qualified Control.Monad.Cont.Class as Mtl-import qualified Control.Monad.Error.Class as Mtl-import qualified Control.Monad.State.Class as Mtl-import qualified Control.Monad.Writer.Class as Mtl+ -- * Constructing expressions+ Cond (..),+ ExprRelation (..),+ Update (..),+ (~>),+ FieldLike (..),+ Assignable,+ SubField (..),+ AutoKeyField (..),+ FieldChain,+ NeverNull,+ UntypedExpr (..),+ Expr (..),+ Order (..),+ HasSelectOptions (..),+ SelectOptions (..),+ limitTo,+ offsetBy,+ orderBy,+ distinct,++ -- * Type description+ -- $types+ DbTypePrimitive' (..),+ DbTypePrimitive,+ DbType (..),+ EntityDef' (..),+ EntityDef,+ EmbeddedDef' (..),+ EmbeddedDef,+ OtherTypeDef' (..),+ OtherTypeDef,+ ConstructorDef' (..),+ ConstructorDef,+ Constructor (..),+ EntityConstr (..),+ IsUniqueKey (..),+ UniqueDef' (..),+ UniqueDef,+ UniqueType (..),+ ReferenceActionType (..),+ ParentTableReference,++ -- * Migration+ SingleMigration,+ NamedMigrations,+ Migration,++ -- * Database+ PersistBackend (..),+ PersistBackendConn (..),+ Action,+ TryAction,+ RowStream,+ DbDescriptor (..),++ -- * Connections and transactions+ ExtractConnection (..),+ ConnectionManager (..),+ TryConnectionManager (..),+ Savepoint (..),+ withSavepoint,+ runDb,+ runDbConn,+ runTryDbConn,+ runTryDbConn',+ runDb',+ runDbConn',+ )+where++import Control.Exception.Safe (Exception, MonadCatch, SomeException (..), tryAny)+import Control.Monad.Fail (MonadFail)+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Reader (MonadReader (..))+import Control.Monad.Trans.Control (MonadBaseControl (..))+import Control.Monad.Trans.Except (ExceptT, runExceptT)+import Control.Monad.Trans.Reader (ReaderT (..), runReaderT)+import Control.Monad.Trans.State (StateT (..))+import Data.Acquire (Acquire) import Data.ByteString.Char8 (ByteString)+import Data.ByteString.Lazy (toStrict) import Data.Int (Int64)+import Data.Kind (Constraint, Type) import Data.Map (Map)+import Data.Semigroup (Semigroup)+import Data.String (IsString)+import Data.Text (Text)+import Data.Text.Lazy.Builder (Builder, fromText, toLazyText)+import Data.Text.Lazy.Encoding (encodeUtf8) import Data.Time (Day, TimeOfDay, UTCTime)-import Data.Time.LocalTime (ZonedTime, zonedTimeToUTC, zonedTimeToLocalTime, zonedTimeZone)-import GHC.Exts (Constraint)+import Data.Time.LocalTime (ZonedTime, zonedTimeToLocalTime, zonedTimeToUTC, zonedTimeZone) -- | Only instances of this class can be persisted in a database class (PurePersistField (AutoKey v), PurePersistField (DefaultKey v)) => PersistEntity v where -- | This type is used for typesafe manipulation of separate fields of datatype v. -- Each constructor in 'Field' corresponds to its field in a datatype v. -- It is parametrised by constructor phantom type and field value type.- data Field v :: ((* -> *) -> *) -> * -> *+ data Field v :: ((Type -> Type) -> Type) -> Type -> Type+ -- | A unique identifier of a value stored in a database. This may be a primary key, a constraint or unique indices. The second parameter is the key description.- data Key v :: * -> *+ data Key v :: Type -> Type+ -- | This type is the default autoincremented key for the entity. If entity does not have such key, AutoKey v = (). type AutoKey v+ -- | This type is the default key for the entity. type DefaultKey v+ -- | It is HFalse for entity with one constructor and HTrue for sum types. type IsSumType v+ -- | Returns a complete description of the type entityDef :: DbDescriptor db => proxy db -> v -> EntityDef+ -- | Marshalls value to a list of 'PersistValue' ready for insert to a database toEntityPersistValues :: PersistBackend m => v -> m ([PersistValue] -> [PersistValue])+ -- | Constructs the value from the list of 'PersistValue' fromEntityPersistValues :: PersistBackend m => [PersistValue] -> m (v, [PersistValue])+ -- | Returns constructor number and a list of uniques names and corresponding field values- getUniques :: DbDescriptor db => proxy db -> v -> (Int, [(String, [PersistValue] -> [PersistValue])])+ getUniques :: v -> (Int, [(String, [PersistValue] -> [PersistValue])])+ -- | Is internally used by FieldLike Field instance -- We could avoid this function if class FieldLike allowed FieldLike Fields Data or FieldLike (Fields Data). However that would require additional extensions in user-space code entityFieldChain :: DbDescriptor db => proxy db -> Field v c a -> FieldChain -- | A holder for Unique constraints-data Unique (u :: (* -> *) -> *)+data Unique (u :: (Type -> Type) -> Type)+ -- | Key marked with this type can have value for any backend data BackendSpecific+ -- | A phantom datatype to make instance head different @c (ConstructorMarker v)@ data ConstructorMarker v a+ -- | A phantom datatype to make instance head different @u (UniqueMarker v)@ data UniqueMarker v a @@ -144,24 +183,26 @@ data KeyForBackend db v = (DbDescriptor db, PersistEntity v) => KeyForBackend (AutoKeyType db) data HFalse+ data HTrue -- | Represents condition for a query.-data Cond db r =- And (Cond db r) (Cond db r)- | Or (Cond db r) (Cond db r)+data Cond db r+ = And (Cond db r) (Cond db r)+ | Or (Cond db r) (Cond db r) | Not (Cond db r) | Compare ExprRelation (UntypedExpr db r) (UntypedExpr db r) | CondRaw (QueryRaw db r) | CondEmpty -data ExprRelation = Eq | Ne | Gt | Lt | Ge | Le deriving Show+data ExprRelation = Eq | Ne | Gt | Lt | Ge | Le deriving (Show) -data Update db r = forall f a . (Assignable f a, Projection' f db r a) => Update f (UntypedExpr db r)+data Update db r = forall f a. (Assignable f a, Projection' f db r a) => Update f (UntypedExpr db r) -- | Defines sort order of a result-set-data Order db r = forall a f . (Projection' f db r a) => Asc f- | forall a f . (Projection' f db r a) => Desc f+data Order db r+ = forall a f. (Projection' f db r a) => Asc f+ | forall a f. (Projection' f db r a) => Desc f -- | It is used to map field to column names. It can be either a column name for a regular field of non-embedded type or a list of this field and the outer fields in reverse order. Eg, fieldChain $ SomeField ~> Tuple2_0Selector may result in [(\"val0\", DbString), (\"some\", DbEmbedded False [dbType \"\", dbType True])]. type FieldChain = ((String, DbType), [(String, EmbeddedDef)])@@ -170,12 +211,15 @@ class Projection p a | p -> a where type ProjectionDb p db :: Constraint type ProjectionRestriction p r :: Constraint+ -- | It returns multiple expressions that can be transformed into values which can be selected. Difflist is used for concatenation efficiency. projectionExprs :: (DbDescriptor db, ProjectionDb p db, ProjectionRestriction p r) => p -> [UntypedExpr db r] -> [UntypedExpr db r]+ -- | It is like 'fromPersistValues'. However, we cannot use it for projections in all cases. For the 'PersistEntity' instances 'fromPersistValues' expects entity id instead of the entity values. projectionResult :: PersistBackend m => p -> [PersistValue] -> m (a, [PersistValue]) class (Projection p a, ProjectionDb p db, ProjectionRestriction p r) => Projection' p db r a+ instance (Projection p a, ProjectionDb p db, ProjectionRestriction p r) => Projection' p db r a -- | This subset of Projection instances is for things that behave like fields. Namely, they can occur in condition expressions (for example, Field and SubField) and on the left side of update statements. For example \"lower(field)\" is a valid Projection, but not Field like because it cannot be on the left side. Datatypes that index PostgreSQL arrays \"arr[5]\" or access composites \"(comp).subfield\" are valid instances of Assignable.@@ -186,38 +230,40 @@ fieldChain :: (DbDescriptor db, ProjectionDb f db) => proxy db -> f -> FieldChain class PersistField v => Embedded v where- data Selector v :: * -> *+ data Selector v :: Type -> Type selectorNum :: Selector v a -> Int infixl 5 ~>+ -- | Accesses fields of the embedded datatypes. For example, @SomeField ==. (\"abc\", \"def\") ||. SomeField ~> Tuple2_0Selector ==. \"def\"@ (~>) :: (EntityConstr v c, FieldLike f a, DbDescriptor db, Projection' f db (RestrictionHolder v c) a, Embedded a) => f -> Selector a a' -> SubField db v c a'-field ~> sel = subField where- subField = case fieldChain db field of- ((name, typ), prefix) -> case typ of- DbEmbedded emb@(EmbeddedDef _ ts) _ -> SubField (ts !! selectorNum sel, (name, emb):prefix)- other -> error $ "(~>): cannot get subfield of non-embedded type " ++ show other- db = (undefined :: SubField db v c a' -> proxy db) subField+field ~> sel = subField+ where+ subField = case fieldChain db field of+ ((name, typ), prefix) -> case typ of+ DbEmbedded emb@(EmbeddedDef _ ts) _ -> SubField (ts !! selectorNum sel, (name, emb) : prefix)+ other -> error $ "(~>): cannot get subfield of non-embedded type " ++ show other+ db = (undefined :: SubField db v c a' -> proxy db) subField -newtype SubField db v (c :: (* -> *) -> *) a = SubField FieldChain+newtype SubField db v (c :: (Type -> Type) -> Type) a = SubField FieldChain -- | It can be used in expressions like a regular field. -- For example, @delete (AutoKeyField ==. k)@ -- or @delete (AutoKeyField ==. k ||. SomeField ==. \"DUPLICATE\")@-data AutoKeyField v (c :: (* -> *) -> *) where+data AutoKeyField v (c :: (Type -> Type) -> Type) where AutoKeyField :: AutoKeyField v c -data RestrictionHolder v (c :: (* -> *) -> *)+data RestrictionHolder v (c :: (Type -> Type) -> Type) -data SelectOptions db r hasLimit hasOffset hasOrder hasDistinct = SelectOptions {- condOptions :: Cond db r- , limitOptions :: Maybe Int- , offsetOptions :: Maybe Int- , orderOptions :: [Order db r]- -- ^ False - no DISTINCT, True - DISTINCT- , distinctOptions :: Bool- -- ^ The name of the option and part of the SQL which will be put later- , dbSpecificOptions :: [(String, QueryRaw db r)]+data SelectOptions db r hasLimit hasOffset hasOrder hasDistinct = SelectOptions+ { condOptions :: Cond db r,+ limitOptions :: Maybe Int,+ offsetOptions :: Maybe Int,+ -- | False - no DISTINCT, True - DISTINCT+ orderOptions :: [Order db r],+ -- | The name of the option and part of the SQL which will be put later+ distinctOptions :: Bool,+ dbSpecificOptions :: [(String, QueryRaw db r)] } -- | This class helps to check that limit, offset, or order clauses are added to condition only once.@@ -255,133 +301,126 @@ distinct :: (HasSelectOptions a db r, HasDistinct a ~ HFalse) => a -> SelectOptions db r (HasLimit a) (HasOffset a) (HasOrder a) HTrue distinct opts = (getSelectOptions opts) {distinctOptions = True} -newtype DbPersist conn m a = DbPersist { unDbPersist :: ReaderT conn m a }- deriving (Monad, MonadIO, Functor, Applicative, MonadTrans, MonadReader conn)--instance MonadBase IO m => MonadBase IO (DbPersist conn m) where- liftBase = lift . liftBase--instance MonadTransControl (DbPersist conn) where-#if MIN_VERSION_monad_control(1, 0, 0)- type StT (DbPersist conn) a = StT (ReaderT conn) a- liftWith f = DbPersist $ ReaderT $ \r -> f $ \t -> runReaderT (unDbPersist t) r- restoreT = DbPersist . ReaderT . const-#else- newtype StT (DbPersist conn) a = StReader {unStReader :: a}- liftWith f = DbPersist $ ReaderT $ \r -> f $ \t -> liftM StReader $ runReaderT (unDbPersist t) r- restoreT = DbPersist . ReaderT . const . liftM unStReader-#endif--instance MonadBaseControl IO m => MonadBaseControl IO (DbPersist conn m) where-#if MIN_VERSION_monad_control(1, 0, 0)- type StM (DbPersist conn m) a = ComposeSt (DbPersist conn) m a- liftBaseWith = defaultLiftBaseWith- restoreM = defaultRestoreM-#else- newtype StM (DbPersist conn m) a = StMSP {unStMSP :: ComposeSt (DbPersist conn) m a}- liftBaseWith = defaultLiftBaseWith StMSP- restoreM = defaultRestoreM unStMSP-#endif--instance MonadLogger m => MonadLogger (DbPersist conn m) where- monadLoggerLog a b c = lift . monadLoggerLog a b c--runDbPersist :: Monad m => DbPersist conn m a -> conn -> m a-runDbPersist = runReaderT . unDbPersist--mapDbPersist :: (m a -> n b) -> DbPersist conn m a -> DbPersist conn n b-mapDbPersist f m = DbPersist $ mapReaderT f $ unDbPersist m--instance Mtl.MonadWriter w m => Mtl.MonadWriter w (DbPersist conn m) where- writer = lift . Mtl.writer- tell = lift . Mtl.tell- listen = mapDbPersist Mtl.listen- pass = mapDbPersist Mtl.pass--instance Mtl.MonadError e m => Mtl.MonadError e (DbPersist conn m) where- throwError = lift . Mtl.throwError- catchError m h = DbPersist $ Mtl.catchError (unDbPersist m) (unDbPersist . h)--instance Mtl.MonadCont m => Mtl.MonadCont (DbPersist conn m) where- callCC = liftCallCC Mtl.callCC where- liftCallCC callCC f = DbPersist $ ReaderT $ \ r ->- callCC $ \ c ->- runDbPersist (f (DbPersist . ReaderT . const . c)) r--instance Mtl.MonadState s m => Mtl.MonadState s (DbPersist conn m) where- get = lift Mtl.get- put = lift . Mtl.put- state = lift . Mtl.state- class PrimitivePersistField (AutoKeyType db) => DbDescriptor db where- -- | Type of the database default autoincremented key. For example, Sqlite has Int64+ -- | Type of the database default auto-incremented key. For example, Sqlite has Int64 type AutoKeyType db+ -- | Value of this type can be used as a part of a query. For example, it can be RenderS for relational databases, or BSON for MongoDB.- type QueryRaw db :: * -> *+ type QueryRaw db :: Type -> Type+ -- | Name of backend backendName :: proxy db -> String -class (Monad m, DbDescriptor (PhantomDb m)) => PersistBackend m where- -- | A token which defines the DB type. For example, different monads working with Sqlite, return may Sqlite type.- type PhantomDb m+class (DbDescriptor conn, ConnectionManager conn) => PersistBackendConn conn where -- | Insert a new record to a database and return its autogenerated key or ()- insert :: PersistEntity v => v -> m (AutoKey v)+ insert :: (PersistEntity v, PersistBackend m, Conn m ~ conn) => v -> m (AutoKey v)+ -- | Insert a new record to a database. For some backends it may be faster than 'insert'.- insert_ :: PersistEntity v => v -> m ()+ insert_ :: (PersistEntity v, PersistBackend m, Conn m ~ conn) => v -> m ()+ -- | Try to insert a record and return Right newkey. If there is a constraint violation for the given constraint, Left oldkey is returned -- , where oldkey is an identifier of the record with the matching values.- insertBy :: (PersistEntity v, IsUniqueKey (Key v (Unique u))) => u (UniqueMarker v) -> v -> m (Either (AutoKey v) (AutoKey v))+ insertBy :: (PersistEntity v, IsUniqueKey (Key v (Unique u)), PersistBackend m, Conn m ~ conn) => u (UniqueMarker v) -> v -> m (Either (AutoKey v) (AutoKey v))+ -- | Try to insert a record and return Right newkey. If there is a constraint violation for any constraint, Left oldkey is returned -- , where oldkey is an identifier of the record with the matching values. Note that if several constraints are violated, a key of an arbitrary matching record is returned.- insertByAll :: PersistEntity v => v -> m (Either (AutoKey v) (AutoKey v))+ insertByAll :: (PersistEntity v, PersistBackend m, Conn m ~ conn) => v -> m (Either (AutoKey v) (AutoKey v))+ -- | Replace a record with the given autogenerated key. Result is undefined if the record does not exist.- replace :: (PersistEntity v, PrimitivePersistField (Key v BackendSpecific)) => Key v BackendSpecific -> v -> m ()+ replace :: (PersistEntity v, PrimitivePersistField (Key v BackendSpecific), PersistBackend m, Conn m ~ conn) => Key v BackendSpecific -> v -> m ()+ -- | Replace a record. The unique key marker defines what unique key of the entity is used.- replaceBy :: (PersistEntity v, IsUniqueKey (Key v (Unique u))) => u (UniqueMarker v) -> v -> m ()+ replaceBy :: (PersistEntity v, IsUniqueKey (Key v (Unique u)), PersistBackend m, Conn m ~ conn) => u (UniqueMarker v) -> v -> m ()+ -- | Return a list of the records satisfying the condition. Example: @select $ (FirstField ==. \"abc\" &&. SecondField >. \"def\") \`orderBy\` [Asc ThirdField] \`limitTo\` 100@- select :: (PersistEntity v, EntityConstr v c, HasSelectOptions opts (PhantomDb m) (RestrictionHolder v c))- => opts -> m [v]+ select ::+ (PersistEntity v, EntityConstr v c, HasSelectOptions opts conn (RestrictionHolder v c), PersistBackend m, Conn m ~ conn) =>+ opts ->+ m [v]++ -- | Return a list of the records satisfying the condition. Example: @select $ (FirstField ==. \"abc\" &&. SecondField >. \"def\") \`orderBy\` [Asc ThirdField] \`limitTo\` 100@+ selectStream ::+ (PersistEntity v, EntityConstr v c, HasSelectOptions opts conn (RestrictionHolder v c), PersistBackend m, Conn m ~ conn) =>+ opts ->+ m (RowStream v)+ -- | Return a list of all records. Order is undefined. It can be useful for datatypes with multiple constructors.- selectAll :: PersistEntity v => m [(AutoKey v, v)]+ selectAll :: (PersistEntity v, PersistBackend m, Conn m ~ conn) => m [(AutoKey v, v)]++ -- | Return a list of all records. Order is undefined. It can be useful for datatypes with multiple constructors.+ selectAllStream :: (PersistEntity v, PersistBackend m, Conn m ~ conn) => m (RowStream (AutoKey v, v))+ -- | Fetch an entity from a database- get :: (PersistEntity v, PrimitivePersistField (Key v BackendSpecific)) => Key v BackendSpecific -> m (Maybe v)+ get :: (PersistEntity v, PrimitivePersistField (Key v BackendSpecific), PersistBackend m, Conn m ~ conn) => Key v BackendSpecific -> m (Maybe v)+ -- | Fetch an entity from a database by its unique key- getBy :: (PersistEntity v, IsUniqueKey (Key v (Unique u))) => Key v (Unique u) -> m (Maybe v)+ getBy :: (PersistEntity v, IsUniqueKey (Key v (Unique u)), PersistBackend m, Conn m ~ conn) => Key v (Unique u) -> m (Maybe v)+ -- | Update the records satisfying the condition. Example: @update [FirstField =. \"abc\"] $ FirstField ==. \"def\"@- update :: (PersistEntity v, EntityConstr v c) => [Update (PhantomDb m) (RestrictionHolder v c)] -> Cond (PhantomDb m) (RestrictionHolder v c) -> m ()+ update :: (PersistEntity v, EntityConstr v c, PersistBackend m, Conn m ~ conn) => [Update conn (RestrictionHolder v c)] -> Cond conn (RestrictionHolder v c) -> m ()+ -- | Remove the records satisfying the condition- delete :: (PersistEntity v, EntityConstr v c) => Cond (PhantomDb m) (RestrictionHolder v c) -> m ()+ delete :: (PersistEntity v, EntityConstr v c, PersistBackend m, Conn m ~ conn) => Cond conn (RestrictionHolder v c) -> m ()+ -- | Remove the record with given key. No-op if the record does not exist- deleteBy :: (PersistEntity v, PrimitivePersistField (Key v BackendSpecific)) => Key v BackendSpecific -> m ()+ deleteBy :: (PersistEntity v, PrimitivePersistField (Key v BackendSpecific), PersistBackend m, Conn m ~ conn) => Key v BackendSpecific -> m ()+ -- | Remove all records. The entity parameter is used only for type inference.- deleteAll :: PersistEntity v => v -> m ()+ deleteAll :: (PersistEntity v, PersistBackend m, Conn m ~ conn) => v -> m ()+ -- | Count total number of records satisfying the condition- count :: (PersistEntity v, EntityConstr v c) => Cond (PhantomDb m) (RestrictionHolder v c) -> m Int+ count :: (PersistEntity v, EntityConstr v c, PersistBackend m, Conn m ~ conn) => Cond conn (RestrictionHolder v c) -> m Int+ -- | Count total number of records with all constructors. The entity parameter is used only for type inference- countAll :: PersistEntity v => v -> m Int+ countAll :: (PersistEntity v, PersistBackend m, Conn m ~ conn) => v -> m Int+ -- | Fetch projection of some fields. Example: @project (SecondField, ThirdField) $ (FirstField ==. \"abc\" &&. SecondField >. \"def\") \`orderBy\` [Asc ThirdField] \`offsetBy\` 100@- project :: (PersistEntity v, EntityConstr v c, Projection' p (PhantomDb m) (RestrictionHolder v c) a, HasSelectOptions opts (PhantomDb m) (RestrictionHolder v c))- => p- -> opts- -> m [a]+ project ::+ (PersistEntity v, EntityConstr v c, Projection' p conn (RestrictionHolder v c) a, HasSelectOptions opts conn (RestrictionHolder v c), PersistBackend m, Conn m ~ conn) =>+ p ->+ opts ->+ m [a]++ projectStream ::+ (PersistEntity v, EntityConstr v c, Projection' p conn (RestrictionHolder v c) a, HasSelectOptions opts conn (RestrictionHolder v c), PersistBackend m, Conn m ~ conn) =>+ p ->+ opts ->+ m (RowStream a)+ -- | Check database schema and create migrations for the entity and the entities it contains- migrate :: PersistEntity v => v -> Migration m+ migrate :: (PersistEntity v, PersistBackend m, Conn m ~ conn) => v -> Migration m+ -- | Execute raw query- executeRaw :: Bool -- ^ keep in cache- -> String -- ^ query- -> [PersistValue] -- ^ positional parameters- -> m ()+ executeRaw ::+ (PersistBackend m, Conn m ~ conn) =>+ -- | keep in cache+ Bool ->+ -- | query+ String ->+ -- | positional parameters+ [PersistValue] ->+ m ()+ -- | Execute raw query with results- queryRaw :: Bool -- ^ keep in cache- -> String -- ^ query- -> [PersistValue] -- ^ positional parameters- -> (RowPopper m -> m a) -- ^ results processing function- -> m a- insertList :: PersistField a => [a] -> m Int64- getList :: PersistField a => Int64 -> m [a]+ queryRaw ::+ (PersistBackend m, Conn m ~ conn) =>+ -- | keep in cache+ Bool ->+ -- | query+ String ->+ -- | positional parameters+ [PersistValue] ->+ m (RowStream [PersistValue]) -type RowPopper m = m (Maybe [PersistValue])+ insertList :: (PersistField a, PersistBackend m, Conn m ~ conn) => [a] -> m Int64+ getList :: (PersistField a, PersistBackend m, Conn m ~ conn) => Int64 -> m [a] +type Action conn = ReaderT conn IO++type TryAction e m conn = ReaderT conn (ExceptT e m)++type RowStream a = Acquire (IO (Maybe a))+ type Migration m = StateT NamedMigrations m () -- | Datatype names and corresponding migrations@@ -394,30 +433,32 @@ -- These types describe the mapping between database schema and datatype. They hold table names, columns, constraints, etc. Some types below are parameterized by string type str and dbType. This is done to make them promotable to kind level. -- | Describes an ADT.-data EntityDef' str dbType = EntityDef {- -- | Entity name. @entityName (entityDef v) == persistName v@- entityName :: str- -- | Database schema for the entity table and tables of its constructors- , entitySchema :: Maybe str- -- | Named types of the instantiated polymorphic type parameters- , typeParams :: [dbType]- -- | List of entity constructors definitions- , constructors :: [ConstructorDef' str dbType]-} deriving (Show, Eq)+data EntityDef' str dbType = EntityDef+ { -- | Entity name. @entityName (entityDef v) == persistName v@+ entityName :: str,+ -- | Database schema for the entity table and tables of its constructors+ entitySchema :: Maybe str,+ -- | Named types of the instantiated polymorphic type parameters+ typeParams :: [dbType],+ -- | List of entity constructors definitions+ constructors :: [ConstructorDef' str dbType]+ }+ deriving (Show, Eq) type EntityDef = EntityDef' String DbType -- | Describes an entity constructor-data ConstructorDef' str dbType = ConstructorDef {- -- | Constructor name- constrName :: str- -- | Autokey name if any- , constrAutoKeyName :: Maybe str- -- | Parameter names with their named type- , constrParams :: [(str, dbType)]- -- | Uniqueness constraints on the constructor fiels- , constrUniques :: [UniqueDef' str (Either (str, dbType) str)]-} deriving (Show, Eq)+data ConstructorDef' str dbType = ConstructorDef+ { -- | Constructor name+ constrName :: str,+ -- | Autokey name if any+ constrAutoKeyName :: Maybe str,+ -- | Parameter names with their named type+ constrParams :: [(str, dbType)],+ -- | Uniqueness constraints on the constructor fiels+ constrUniques :: [UniqueDef' str (Either (str, dbType) str)]+ }+ deriving (Show, Eq) type ConstructorDef = ConstructorDef' String DbType @@ -426,78 +467,86 @@ -- returning ConstructorDef seems more logical, but it would require the value datatype -- it can be supplied either as a part of constructor type, eg instance Constructor (MyDataConstructor (MyData a)) which requires -XFlexibleInstances -- or as a separate type, eg instance Constructor MyDataConstructor (MyData a) which requires -XMultiParamTypeClasses+ -- | Returns constructor index which can be used to get ConstructorDef from EntityDef- phantomConstrNum :: c (a :: * -> *) -> Int+ phantomConstrNum :: c (a :: Type -> Type) -> Int -- | This class helps type inference in cases when query does not contain any fields which -- define the constructor, but the entity has only one. -- For example, in @select $ AutoKeyField ==. k@ the condition would need type annotation with constructor name only if we select a sum type. class PersistEntity v => EntityConstr v c where- entityConstrNum :: proxy v -> c (a :: * -> *) -> Int+ entityConstrNum :: proxy v -> c (a :: Type -> Type) -> Int class PurePersistField uKey => IsUniqueKey uKey where -- | Creates value of unique key using the data extracted from the passed value extractUnique :: uKey ~ Key v u => v -> uKey+ -- | Ordinal number of the unique constraint in the list returned by 'constrUniques' uniqueNum :: uKey -> Int -- | Unique name and list of the fields that form a unique combination. The fields are parametrized to reuse this datatype both with field and DbType and with column name-data UniqueDef' str field = UniqueDef {- uniqueDefName :: Maybe str- , uniqueDefType :: UniqueType- , uniqueDefFields :: [field]-} deriving (Show, Eq)+data UniqueDef' str field = UniqueDef+ { uniqueDefName :: Maybe str,+ uniqueDefType :: UniqueType,+ uniqueDefFields :: [field]+ }+ deriving (Show, Eq) -- | Field is either a pair of entity field name and its type or an expression which will be used in query as-is. type UniqueDef = UniqueDef' String (Either (String, DbType) String) -- | Defines how to treat the unique set of fields for a datatype-data UniqueType = UniqueConstraint- | UniqueIndex- | UniquePrimary Bool -- ^ is autoincremented+data UniqueType+ = UniqueConstraint+ | UniqueIndex+ | -- | is autoincremented+ UniquePrimary Bool deriving (Show, Eq, Ord) -data ReferenceActionType = NoAction- | Restrict- | Cascade- | SetNull- | SetDefault+data ReferenceActionType+ = NoAction+ | Restrict+ | Cascade+ | SetNull+ | SetDefault deriving (Eq, Show) -- | A DB data type. Naming attempts to reflect the underlying Haskell -- datatypes, eg DbString instead of DbVarchar. Different databases may -- have different representations for these types.-data DbTypePrimitive' str =- DbString- | DbInt32- | DbInt64- | DbReal- | DbBool- | DbDay- | DbTime- | DbDayTime- | DbDayTimeZoned- | DbBlob -- ^ ByteString- | DbOther (OtherTypeDef' str)+data DbTypePrimitive' str+ = DbString+ | DbInt32+ | DbInt64+ | DbReal+ | DbBool+ | DbDay+ | DbTime+ | DbDayTime+ | DbDayTimeZoned+ | -- | ByteString+ DbBlob+ | DbOther (OtherTypeDef' str) deriving (Eq, Show) type DbTypePrimitive = DbTypePrimitive' String -data DbType = - -- | type, nullable, default value, reference- DbTypePrimitive DbTypePrimitive Bool (Maybe String) (Maybe ParentTableReference)- | DbEmbedded EmbeddedDef (Maybe ParentTableReference)- | DbList String DbType -- ^ List table name and type of its argument+data DbType+ = -- | type, nullable, default value, reference+ DbTypePrimitive DbTypePrimitive Bool (Maybe String) (Maybe ParentTableReference)+ | DbEmbedded EmbeddedDef (Maybe ParentTableReference)+ | -- | List table name and type of its argument+ DbList String DbType deriving (Eq, Show) --- | The reference contains either EntityDef of the parent table and name of the unique constraint. Or for tables not mapped by Groundhog schema name, table name, and list of columns +-- | The reference contains either EntityDef of the parent table and name of the unique constraint. Or for tables not mapped by Groundhog schema name, table name, and list of columns -- Reference to the autogenerated key of a mapped entity = (Left (entityDef, Nothing), onDelete, onUpdate) -- Reference to a unique key of a mapped entity = (Left (entityDef, Just uniqueKeyName), onDelete, onUpdate) -- Reference to a table that is not mapped = (Right ((schema, tableName), columns), onDelete, onUpdate) type ParentTableReference = (Either (EntityDef, Maybe String) ((Maybe String, String), [String]), Maybe ReferenceActionType, Maybe ReferenceActionType) -- | Stores a database type. The list contains two kinds of tokens for the type string. Backend will choose a string representation for DbTypePrimitive's, and the string literals will go to the type as-is. As the final step, these tokens are concatenated. For example, @[Left \"varchar(50)\"]@ will become a string with max length and @[Right DbInt64, Left \"[]\"]@ will become integer[] in PostgreSQL.-newtype OtherTypeDef' str = OtherTypeDef ([Either str (DbTypePrimitive' str)]) deriving (Eq, Show)+newtype OtherTypeDef' str = OtherTypeDef [Either str (DbTypePrimitive' str)] deriving (Eq, Show) type OtherTypeDef = OtherTypeDef' String @@ -507,41 +556,41 @@ type EmbeddedDef = EmbeddedDef' String DbType --- | Datatype for incremental building SQL queries newtype Utf8 = Utf8 Builder-instance Eq Utf8 where- a == b = fromUtf8 a == fromUtf8 b-instance Show Utf8 where- show = show . fromUtf8-instance Read Utf8 where- readsPrec prec str = map (\(a, b) -> (Utf8 $ fromByteString a, b)) $ readsPrec prec str+ deriving (Eq, Ord, Show, Semigroup, Monoid, IsString) fromUtf8 :: Utf8 -> ByteString-fromUtf8 (Utf8 a) = toByteString a+fromUtf8 (Utf8 s) = toStrict $ encodeUtf8 $ toLazyText s +instance Read Utf8 where+ readsPrec prec str = map (\(a, b) -> (Utf8 $ fromText a, b)) $ readsPrec prec str+ -- | A raw value which can be stored in any backend and can be marshalled to -- and from a 'PersistField'.-data PersistValue = PersistString String- | PersistByteString ByteString- | PersistInt64 Int64- | PersistDouble Double- | PersistBool Bool- | PersistDay Day- | PersistTimeOfDay TimeOfDay- | PersistUTCTime UTCTime- | PersistZonedTime ZT- | PersistNull- -- | Creating some datatypes may require calling a function, using a special constructor, or other syntax. The string (which can have placeholders) is included into query without escaping. The recursive constructions are not allowed, i.e., [PersistValue] cannot contain PersistCustom values.- | PersistCustom Utf8 [PersistValue]+data PersistValue+ = PersistString String+ | PersistText Text+ | PersistByteString ByteString+ | PersistInt64 Int64+ | PersistDouble Double+ | PersistBool Bool+ | PersistDay Day+ | PersistTimeOfDay TimeOfDay+ | PersistUTCTime UTCTime+ | PersistZonedTime ZT+ | PersistNull+ | -- | Creating some datatypes may require calling a function, using a special constructor, or other syntax. The string (which can have placeholders) is included into query without escaping. The recursive constructions are not allowed, i.e., [PersistValue] cannot contain PersistCustom values.+ PersistCustom Utf8 [PersistValue] deriving (Eq, Show, Read) -- | Avoid orphan instances. newtype ZT = ZT ZonedTime deriving (Show, Read) instance Eq ZT where- ZT a == ZT b = zonedTimeToLocalTime a == zonedTimeToLocalTime b && zonedTimeZone a == zonedTimeZone b+ ZT a == ZT b = zonedTimeToLocalTime a == zonedTimeToLocalTime b && zonedTimeZone a == zonedTimeZone b+ instance Ord ZT where- ZT a `compare` ZT b = zonedTimeToUTC a `compare` zonedTimeToUTC b+ ZT a `compare` ZT b = zonedTimeToUTC a `compare` zonedTimeToUTC b -- | Types which are never NULL when converted to 'PersistValue'. -- Consider the type @Maybe (Maybe a)@. Now Nothing is stored as NULL, so we cannot distinguish between Just Nothing and Nothing which is a problem.@@ -552,25 +601,30 @@ -- | Used to uniformly represent fields, constants and more complex things, e.g., arithmetic expressions. -- A value should be converted to 'UntypedExpr' for usage in expressions data UntypedExpr db r where- ExprRaw :: QueryRaw db r -> UntypedExpr db r+ ExprRaw :: DbType -> QueryRaw db r -> UntypedExpr db r ExprField :: FieldChain -> UntypedExpr db r- ExprPure :: forall db r a . PurePersistField a => a -> UntypedExpr db r+ ExprPure :: forall db r a. PurePersistField a => a -> UntypedExpr db r ExprCond :: Cond db r -> UntypedExpr db r -- | Expr with phantom type helps to keep type safety in complex expressions newtype Expr db r a = Expr (UntypedExpr db r)+ instance Show (Expr db r a) where show _ = "Expr"+ instance Eq (Expr db r a) where (==) = error "(==): this instance Eq (Expr db r a) is made only for Num superclass constraint" -- | Represents everything which can be put into a database. This data can be stored in multiple columns and tables. To get value of those columns we might need to access another table. That is why the result type is monadic. class PersistField a where -- | Return name of the type. If it is polymorphic, the names of parameter types are separated with 'Database.Groundhog.Generic.delim' symbol persistName :: a -> String+ -- | Convert a value into something which can be stored in a database column. -- Note that for complex datatypes it may insert them to return identifier toPersistValues :: PersistBackend m => a -> m ([PersistValue] -> [PersistValue])+ -- | Constructs a value from a 'PersistValue'. For complex datatypes it may query the database fromPersistValues :: PersistBackend m => [PersistValue] -> m (a, [PersistValue])+ -- | Description of value type. It depends on database so that we can have, for example, xml column type in Postgres and varchar type in other databases dbType :: DbDescriptor db => proxy db -> a -> DbType @@ -581,27 +635,90 @@ -- | Represents all datatypes that map into several columns. Getting values for those columns is pure. class PersistField a => PurePersistField a where- toPurePersistValues :: DbDescriptor db => proxy db -> a -> ([PersistValue] -> [PersistValue])- fromPurePersistValues :: DbDescriptor db => proxy db -> [PersistValue] -> (a, [PersistValue])+ toPurePersistValues :: a -> ([PersistValue] -> [PersistValue])+ fromPurePersistValues :: [PersistValue] -> (a, [PersistValue]) --- | Datatypes which can be converted directly to 'PersistValue'. The no-value parameter @DbDescriptor db => proxy db@ allows conversion depend the database details while keeping it pure. A type which has an instance of 'PrimitivePersistField' should be an instance of superclasses 'SinglePersistField' and 'PurePersistField' as well.+-- | Datatypes which can be converted directly to 'PersistValue' class PersistField a => PrimitivePersistField a where- toPrimitivePersistValue :: DbDescriptor db => proxy db -> a -> PersistValue- fromPrimitivePersistValue :: DbDescriptor db => proxy db -> PersistValue -> a+ toPrimitivePersistValue :: a -> PersistValue+ fromPrimitivePersistValue :: PersistValue -> a delim :: Char delim = '#' +class ExtractConnection cm conn | cm -> conn where+ -- | Extracts the connection. The connection manager can be a pool or the connection itself+ extractConn :: (MonadBaseControl IO m, MonadIO m) => (conn -> m a) -> cm -> m a+ -- | Connection manager provides connection to the passed function handles transations. Manager can be a connection itself, a pool, Snaplet in Snap, foundation datatype in Yesod, etc.-class ConnectionManager cm conn | cm -> conn where- -- | Extracts the connection from manager and opens the transaction.- withConn :: (MonadBaseControl IO m, MonadIO m) => (conn -> m a) -> cm -> m a- -- | Extracts the connection.- withConnNoTransaction :: (MonadBaseControl IO m, MonadIO m) => (conn -> m a) -> cm -> m a+class ConnectionManager conn where+ -- | Opens the transaction.+ withConn :: (MonadBaseControl IO m, MonadIO m) => (conn -> m a) -> conn -> m a --- | This connection manager always returns the same connection. This constraint is useful when performing operations which make sense only within one connection, for example, nested savepoints..-class ConnectionManager cm conn => SingleConnectionManager cm conn+class TryConnectionManager conn where+ -- | Tries the transaction, using a provided function which evaluates to an Either. Any Left result will cause transaction rollback.+ tryWithConn :: (MonadBaseControl IO m, MonadIO m, MonadCatch m) => (conn -> n a) -> (n a -> m (Either SomeException a)) -> conn -> m (Either SomeException a) class Savepoint conn where -- | Wraps the passed action into a named savepoint withConnSavepoint :: (MonadBaseControl IO m, MonadIO m) => String -> m a -> conn -> m a++-- | This class helps to shorten the type signatures of user monadic code.+-- If your monad has several connections, e.g., for main and audit databases, create run*Db function+-- runAuditDb :: Action conn a -> m a+class (Monad m, MonadIO m, MonadFail m, ConnectionManager (Conn m), PersistBackendConn (Conn m)) => PersistBackend m where+ type Conn m+ getConnection :: m (Conn m)++instance (Monad m, MonadIO m, MonadFail m, PersistBackendConn conn) => PersistBackend (ReaderT conn m) where+ type Conn (ReaderT conn m) = conn+ getConnection = ask++-- | It helps to run database operations within an application monad.+runDb :: PersistBackend m => Action (Conn m) a -> m a+runDb f = getConnection >>= liftIO . withConn (runReaderT f)++-- | Runs action within connection. It can handle a simple connection, a pool of them, etc.+runDbConn :: (MonadIO m, MonadBaseControl IO m, ConnectionManager conn, ExtractConnection cm conn) => Action conn a -> cm -> m a+runDbConn f = extractConn (liftIO . withConn (runReaderT f))++-- | Runs TryAction within connection.+runTryDbConn :: (MonadIO m, MonadBaseControl IO m, MonadCatch m, TryConnectionManager conn, ExtractConnection cm conn, Exception e) => TryAction e m conn a -> cm -> m (Either SomeException a)+runTryDbConn f = extractConn (tryWithConn (runReaderT f) tryExceptT)++-- | Tries Action within connection.+runTryDbConn' :: (MonadIO m, MonadBaseControl IO m, MonadCatch m, TryConnectionManager conn, ExtractConnection cm conn) => Action conn a -> cm -> m (Either SomeException a)+runTryDbConn' f = extractConn (liftIO . tryWithConn (runReaderT f) tryAny)++-- | It helps to run database operations within an application monad. Unlike `runDb` it does not wrap action in transaction+runDb' :: PersistBackend m => Action (Conn m) a -> m a+runDb' f = getConnection >>= liftIO . runReaderT f++-- | It is similar to `runDbConn` but runs action without transaction.+--+-- @+-- flip withConn conn $ \\conn -> liftIO $ do+-- -- transaction is already opened by withConn at this point+-- someIOAction+-- runDbConn' (insert_ value) conn+-- @+runDbConn' :: (MonadIO m, MonadBaseControl IO m, ConnectionManager conn, ExtractConnection cm conn) => Action conn a -> cm -> m a+runDbConn' f = extractConn (liftIO . runReaderT f)++-- | It helps to run 'withConnSavepoint' within a monad. Make sure that transaction is open+withSavepoint :: (PersistBackend m, MonadBaseControl IO m, MonadIO m, Savepoint (Conn m)) => String -> m a -> m a+withSavepoint name m = getConnection >>= withConnSavepoint name m++tryExceptT ::+ ( MonadCatch m,+ Exception e+ ) =>+ ExceptT e m a ->+ m (Either SomeException a)+tryExceptT e = do+ outside <- tryAny $ runExceptT e+ case outside of+ Left outsideErr -> pure . Left $ outsideErr+ Right inside -> case inside of+ Left insideErr -> pure . Left . SomeException $ insideErr+ Right y -> pure $ Right y
Database/Groundhog/Expression.hs view
@@ -1,170 +1,241 @@-{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts, FlexibleInstances, FunctionalDependencies, UndecidableInstances, OverlappingInstances, EmptyDataDecls, ConstraintKinds #-} - --- | This module provides mechanism for flexible and typesafe usage of plain data values and fields. --- The expressions can used in conditions and right part of Update statement. --- Example: --- --- @ --- StringField ==. \"abc\" &&. NumberField >. (0 :: Int) ||. MaybeField ==. (Nothing :: Maybe String) ||. MaybeField ==. Just \"def\" --- @ --- --- Note that polymorphic values like numbers or Nothing must have a type annotation. --- Comparison operators specific for SQL such as IN and LIKE are defined in "Database.Groundhog.Generic.Sql.Functions". - -module Database.Groundhog.Expression - ( Expression(..) - , Unifiable - , ExpressionOf - , (=.) - , (&&.), (||.) - , (==.), (/=.), (<.), (<=.), (>.), (>=.) - , isFieldNothing - , liftExpr - , toArith - ) where - -import Database.Groundhog.Core -import Database.Groundhog.Instances () - --- | Instances of this type can be converted to 'UntypedExpr'. It is useful for uniform manipulation over fields, constant values, etc. -class Expression db r a where - toExpr :: a -> UntypedExpr db r - --- | This helper class can make type signatures more concise -class (Expression db r a, PersistField a') => ExpressionOf db r a a' | a -> a' - -instance (Expression db r a, Normalize HTrue a (flag, a'), PersistField a') => ExpressionOf db r a a' - -instance PurePersistField a => Expression db r a where - toExpr = ExprPure - -instance (PersistField a, db' ~ db, r' ~ r) => Expression db' r' (Expr db r a) where - toExpr (Expr e) = e - -fieldHelper :: (FieldLike f a, DbDescriptor db, ProjectionDb f db) => f -> UntypedExpr db r -fieldHelper f = result where - result = ExprField $ fieldChain db f - db = (undefined :: UntypedExpr db r -> proxy db) result - -instance (EntityConstr v c, DbDescriptor db, PersistField a, RestrictionHolder v c ~ r') => Expression db r' (Field v c a) where - toExpr = fieldHelper - -instance (EntityConstr v c, DbDescriptor db, PersistField a, db' ~ db, RestrictionHolder v c ~ r') => Expression db' r' (SubField db v c a) where - toExpr = fieldHelper - -instance (EntityConstr v c, DbDescriptor db, RestrictionHolder v c ~ r') => Expression db r' (AutoKeyField v c) where - toExpr = fieldHelper - -instance (PersistEntity v, DbDescriptor db, IsUniqueKey k, k ~ Key v (Unique u), RestrictionHolder v c ~ r') - => Expression db r' (u (UniqueMarker v)) where - toExpr = fieldHelper - -instance (db' ~ db, r' ~ r) => Expression db' r' (Cond db r) where - toExpr = ExprCond - --- Let's call "plain type" the types that uniquely define type of a Field it is compared to. --- Example: Int -> Field v c Int, but Entity -> Field v c (Entity / Key Entity) -class Unifiable a b -instance Unifiable a a --- Tie a type-level knot. Knowing if another type is plain helps to avoid indirection. In practice, it enables to infer type of polymorphic field when it is compared to a plain type. -instance (Normalize bk a (ak, r), Normalize ak b (bk, r)) => Unifiable a b - -class Normalize counterpart t r | t -> r -instance NormalizeValue a (isPlain, r) => Normalize HFalse (Field v c a) (HFalse, r) -instance r ~ (HFalse, a) => Normalize HTrue (Field v c a) r -instance NormalizeValue a (isPlain, r) => Normalize HFalse (SubField db v c a) (HFalse, r) -instance r ~ (HFalse, a) => Normalize HTrue (SubField db v c a) r -instance NormalizeValue a (isPlain, r) => Normalize HFalse (Expr db r' a) (HFalse, r) -instance r ~ (HFalse, a) => Normalize HTrue (Expr db r' a) r -instance NormalizeValue (Key v (Unique u)) (isPlain, r) => Normalize HFalse (u (UniqueMarker v)) (HFalse, r) -instance r ~ (HFalse, Key v (Unique u)) => Normalize HTrue (u (UniqueMarker v)) r -instance NormalizeValue (Key v BackendSpecific) (isPlain, r) => Normalize HFalse (AutoKeyField v c) (HFalse, r) -instance r ~ (HFalse, Key v BackendSpecific) => Normalize HTrue (AutoKeyField v c) r -instance r ~ (HTrue, Bool) => Normalize HFalse (Cond db r') r -instance r ~ (HTrue, Bool) => Normalize HTrue (Cond db r') r -instance NormalizeValue t r => Normalize HFalse t r -instance r ~ (HTrue, t) => Normalize HTrue t r - -class NormalizeValue t r | t -> r --- Normalize @Key v u@ to @v@ only if this key is used for storing @v@. -instance (TypeEq (DefaultKey v) (Key v u) isDef, - NormalizeKey isDef v u k, - r ~ (Not isDef, Maybe k)) - => NormalizeValue (Maybe (Key v u)) r -instance (TypeEq (DefaultKey v) (Key v u) isDef, - NormalizeKey isDef v u k, - r ~ (Not isDef, k)) - => NormalizeValue (Key v u) r -instance r ~ (HTrue, a) => NormalizeValue a r - -class TypeEq x y b | x y -> b -instance b ~ HFalse => TypeEq x y b -instance TypeEq x x HTrue - -class NormalizeKey isDef v u k | isDef v u -> k, k -> v -instance k ~ v => NormalizeKey HTrue v u k -instance k ~ Key v u => NormalizeKey HFalse v u k - -type family Not bool -type instance Not HTrue = HFalse -type instance Not HFalse = HTrue - --- | Update field -infixr 3 =. -(=.) :: - ( Assignable f a' - , ProjectionDb f db - , ProjectionRestriction f r - , Expression db r b - , Unifiable f b) - => f -> b -> Update db r -f =. b = Update f (toExpr b) - --- | Boolean \"and\" operator. -(&&.) :: Cond db r -> Cond db r -> Cond db r - --- | Boolean \"or\" operator. -(||.) :: Cond db r -> Cond db r -> Cond db r - -infixr 3 &&. -a &&. b = And a b - -infixr 2 ||. -a ||. b = Or a b - -(==.), (/=.) :: - ( Expression db r a - , Expression db r b - , Unifiable a b) - => a -> b -> Cond db r - -(<.), (<=.), (>.), (>=.) :: - ( Expression db r a - , Expression db r b - , Unifiable a b) - => a -> b -> Cond db r - -infix 4 ==., /=., <., <=., >., >=. -a ==. b = Compare Eq (toExpr a) (toExpr b) -a /=. b = Compare Ne (toExpr a) (toExpr b) -a <. b = Compare Lt (toExpr a) (toExpr b) -a <=. b = Compare Le (toExpr a) (toExpr b) -a >. b = Compare Gt (toExpr a) (toExpr b) -a >=. b = Compare Ge (toExpr a) (toExpr b) - --- | This function more limited than (==.), but has better type inference. --- If you want to compare your value to Nothing with @(==.)@ operator, you have to write the types explicitly @myExpr ==. (Nothing :: Maybe Int)@. --- TODO: restrict db r -isFieldNothing :: (Expression db r f, Projection f (Maybe a), PrimitivePersistField (Maybe a), Unifiable f (Maybe a)) => f -> Cond db r -isFieldNothing a = a `eq` Nothing where - eq :: (Expression db r f, Expression db r a, Projection f a, Unifiable f a) => f -> a -> Cond db r - eq = (==.) - --- | Converts value to 'Expr'. It can help to pass values of different types into functions which expect arguments of the same type, like (+). -liftExpr :: ExpressionOf db r a a' => a -> Expr db r a' -liftExpr a = Expr $ toExpr a - -{-# DEPRECATED toArith "Please use liftExpr instead" #-} --- | It is kept for compatibility with older Groundhog versions and can be replaced with "liftExpr". -toArith :: ExpressionOf db r a a' => a -> Expr db r a' -toArith = liftExpr +{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- | This module provides mechanism for flexible and typesafe usage of plain data values and fields.+-- The expressions can used in conditions and right part of Update statement.+-- Example:+--+-- @+-- StringField ==. \"abc\" &&. NumberField >. (0 :: Int) ||. MaybeField ==. (Nothing :: Maybe String) ||. MaybeField ==. Just \"def\"+-- @+--+-- Note that polymorphic values like numbers or Nothing must have a type annotation.+-- Comparison operators specific for SQL such as IN and LIKE are defined in "Database.Groundhog.Generic.Sql.Functions".+module Database.Groundhog.Expression+ ( Expression (..),+ Unifiable,+ ExpressionOf,+ (=.),+ (&&.),+ (||.),+ (==.),+ (/=.),+ (<.),+ (<=.),+ (>.),+ (>=.),+ isFieldNothing,+ liftExpr,+ toArith,+ )+where++import Database.Groundhog.Core+import Database.Groundhog.Instances ()++-- | Instances of this type can be converted to 'UntypedExpr'. It is useful for uniform manipulation over fields, constant values, etc.+class Expression db r a where+ toExpr :: a -> UntypedExpr db r++fieldHelper :: (FieldLike f a, DbDescriptor db, ProjectionDb f db) => f -> UntypedExpr db r+fieldHelper f = result+ where+ result = ExprField $ fieldChain db f+ db = (undefined :: UntypedExpr db r -> proxy db) result++instance {-# OVERLAPPING #-} (EntityConstr v c, DbDescriptor db, PersistField a, RestrictionHolder v c ~ r') => Expression db r' (Field v c a) where+ toExpr = fieldHelper++instance {-# OVERLAPPING #-} (EntityConstr v c, DbDescriptor db, PersistField a, db' ~ db, RestrictionHolder v c ~ r') => Expression db' r' (SubField db v c a) where+ toExpr = fieldHelper++instance {-# OVERLAPPING #-} (EntityConstr v c, DbDescriptor db, RestrictionHolder v c ~ r') => Expression db r' (AutoKeyField v c) where+ toExpr = fieldHelper++instance+ {-# OVERLAPPING #-}+ (PersistEntity v, DbDescriptor db, IsUniqueKey k, k ~ Key v (Unique u), RestrictionHolder v c ~ r') =>+ Expression db r' (u (UniqueMarker v))+ where+ toExpr = fieldHelper++instance {-# OVERLAPPING #-} (db' ~ db, r' ~ r) => Expression db' r' (Cond db r) where+ toExpr = ExprCond++-- Let's call "plain type" the types that uniquely define type of a Field it is compared to.+-- Example: Int -> Field v c Int, but Entity -> Field v c (Entity / Key Entity)+class Unifiable a b++instance {-# OVERLAPPING #-} Unifiable a a++-- Tie a type-level knot. Knowing if another type is plain helps to avoid indirection. In practice, it enables to infer type of polymorphic field when it is compared to a plain type.+instance {-# OVERLAPPABLE #-} (Normalize bk a (ak, r), Normalize ak b (bk, r)) => Unifiable a b++-- | This helper class can make type signatures more concise+class (Expression db r a, PersistField a') => ExpressionOf db r a a' | a -> a'++instance (Expression db r a, Normalize HTrue a (flag, a'), PersistField a') => ExpressionOf db r a a'++instance {-# OVERLAPPABLE #-} PurePersistField a => Expression db r a where+ toExpr = ExprPure++instance {-# OVERLAPPING #-} (PersistField a, db' ~ db, r' ~ r) => Expression db' r' (Expr db r a) where+ toExpr (Expr e) = e++class Normalize counterpart t r | t -> r++instance {-# OVERLAPPING #-} NormalizeValue a (isPlain, r) => Normalize HFalse (Field v c a) (HFalse, r)++instance {-# OVERLAPS #-} r ~ (HFalse, a) => Normalize HTrue (Field v c a) r++instance {-# OVERLAPPING #-} NormalizeValue a (isPlain, r) => Normalize HFalse (SubField db v c a) (HFalse, r)++instance {-# OVERLAPS #-} r ~ (HFalse, a) => Normalize HTrue (SubField db v c a) r++instance {-# OVERLAPPING #-} NormalizeValue a (isPlain, r) => Normalize HFalse (Expr db r' a) (HFalse, r)++instance {-# OVERLAPS #-} r ~ (HFalse, a) => Normalize HTrue (Expr db r' a) r++instance {-# OVERLAPPING #-} NormalizeValue (Key v (Unique u)) (isPlain, r) => Normalize HFalse (u (UniqueMarker v)) (HFalse, r)++instance {-# OVERLAPS #-} r ~ (HFalse, Key v (Unique u)) => Normalize HTrue (u (UniqueMarker v)) r++instance {-# OVERLAPPING #-} NormalizeValue (Key v BackendSpecific) (isPlain, r) => Normalize HFalse (AutoKeyField v c) (HFalse, r)++instance {-# OVERLAPS #-} r ~ (HFalse, Key v BackendSpecific) => Normalize HTrue (AutoKeyField v c) r++instance {-# OVERLAPPING #-} r ~ (HTrue, Bool) => Normalize HFalse (Cond db r') r++instance {-# OVERLAPPING #-} r ~ (HTrue, Bool) => Normalize HTrue (Cond db r') r++instance {-# OVERLAPPABLE #-} NormalizeValue t r => Normalize HFalse t r++instance {-# OVERLAPPABLE #-} r ~ (HTrue, t) => Normalize HTrue t r++class NormalizeValue t r | t -> r++-- Normalize @Key v u@ to @v@ only if this key is used for storing @v@.++instance+ {-# OVERLAPPING #-}+ ( TypeEq (DefaultKey v) (Key v u) isDef,+ NormalizeKey isDef v u k,+ r ~ (Not isDef, Maybe k)+ ) =>+ NormalizeValue (Maybe (Key v u)) r++instance+ {-# OVERLAPPING #-}+ ( TypeEq (DefaultKey v) (Key v u) isDef,+ NormalizeKey isDef v u k,+ r ~ (Not isDef, k)+ ) =>+ NormalizeValue (Key v u) r++instance {-# OVERLAPPABLE #-} r ~ (HTrue, a) => NormalizeValue a r++class TypeEq x y b | x y -> b++instance {-# OVERLAPPABLE #-} b ~ HFalse => TypeEq x y b++instance {-# OVERLAPPING #-} TypeEq x x HTrue++class NormalizeKey isDef v u k | isDef v u -> k, k -> v++instance k ~ v => NormalizeKey HTrue v u k++instance k ~ Key v u => NormalizeKey HFalse v u k++type family Not bool++type instance Not HTrue = HFalse++type instance Not HFalse = HTrue++-- | Update field+infixr 3 =.++(=.) ::+ ( Assignable f a',+ ProjectionDb f db,+ ProjectionRestriction f r,+ Expression db r b,+ Unifiable f b+ ) =>+ f ->+ b ->+ Update db r+f =. b = Update f (toExpr b)++-- | Boolean \"and\" operator.+(&&.) :: Cond db r -> Cond db r -> Cond db r++-- | Boolean \"or\" operator.+(||.) :: Cond db r -> Cond db r -> Cond db r++infixr 3 &&.++a &&. b = And a b++infixr 2 ||.++a ||. b = Or a b++(==.),+ (/=.) ::+ ( Expression db r a,+ Expression db r b,+ Unifiable a b+ ) =>+ a ->+ b ->+ Cond db r+(<.),+ (<=.),+ (>.),+ (>=.) ::+ ( Expression db r a,+ Expression db r b,+ Unifiable a b+ ) =>+ a ->+ b ->+ Cond db r++infix 4 ==., /=., <., <=., >., >=.++a ==. b = Compare Eq (toExpr a) (toExpr b)++a /=. b = Compare Ne (toExpr a) (toExpr b)++a <. b = Compare Lt (toExpr a) (toExpr b)++a <=. b = Compare Le (toExpr a) (toExpr b)++a >. b = Compare Gt (toExpr a) (toExpr b)++a >=. b = Compare Ge (toExpr a) (toExpr b)++-- | This function more limited than (==.), but has better type inference.+-- If you want to compare your value to Nothing with @(==.)@ operator, you have to write the types explicitly @myExpr ==. (Nothing :: Maybe Int)@.+-- TODO: restrict db r+isFieldNothing :: (Expression db r f, Projection f (Maybe a), PrimitivePersistField (Maybe a), Unifiable f (Maybe a)) => f -> Cond db r+isFieldNothing a = a `eq` Nothing+ where+ eq :: (Expression db r f, Expression db r a, Projection f a, Unifiable f a) => f -> a -> Cond db r+ eq = (==.)++-- | Converts value to 'Expr'. It can help to pass values of different types into functions which expect arguments of the same type, like (+).+liftExpr :: ExpressionOf db r a a' => a -> Expr db r a'+liftExpr a = Expr $ toExpr a++{-# DEPRECATED toArith "Please use liftExpr instead" #-}++-- | It is kept for compatibility with older Groundhog versions and can be replaced with "liftExpr".+toArith :: ExpressionOf db r a a' => a -> Expr db r a'+toArith = liftExpr
Database/Groundhog/Generic.hs view
@@ -1,101 +1,112 @@-{-# LANGUAGE FlexibleContexts, ExistentialQuantification, ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-} -- | This helper module is intended for use by the backend creators module Database.Groundhog.Generic- ( - -- * Migration- createMigration- , executeMigration- , executeMigrationSilent- , executeMigrationUnsafe- , runMigration- , runMigrationSilent- , runMigrationUnsafe- , getQueries- , printMigration- , mergeMigrations- -- * Helpers for running Groundhog actions- , HasConn- , runDb- , runDbConn- , runDbConnNoTransaction- , withSavepoint- -- * Helper functions for defining *PersistValue instances- , primToPersistValue- , primFromPersistValue- , primToPurePersistValues- , primFromPurePersistValues- , primToSinglePersistValue- , primFromSinglePersistValue- , pureToPersistValue- , pureFromPersistValue- , singleToPersistValue- , singleFromPersistValue- , toSinglePersistValueUnique- , fromSinglePersistValueUnique- , toPersistValuesUnique- , fromPersistValuesUnique- , toSinglePersistValueAutoKey- , fromSinglePersistValueAutoKey- , failMessage- , failMessageNamed- -- * Other- , bracket- , finally- , onException- , PSFieldDef(..)- , applyDbTypeSettings- , findOne- , replaceOne- , matchElements- , haveSameElems- , mapAllRows- , phantomDb- , getAutoKeyType- , getUniqueFields- , isSimple- , deleteByKey- ) where+ ( -- * Migration+ createMigration,+ executeMigration,+ executeMigrationSilent,+ executeMigrationUnsafe,+ runMigration,+ runMigrationSilent,+ runMigrationUnsafe,+ getQueries,+ printMigration,+ mergeMigrations, -import Database.Groundhog.Core+ -- * Helper functions for defining *PersistValue instances+ primToPersistValue,+ primFromPersistValue,+ primToPurePersistValues,+ primFromPurePersistValues,+ primToSinglePersistValue,+ primFromSinglePersistValue,+ pureToPersistValue,+ pureFromPersistValue,+ singleToPersistValue,+ singleFromPersistValue,+ toSinglePersistValueUnique,+ fromSinglePersistValueUnique,+ toPersistValuesUnique,+ fromPersistValuesUnique,+ toSinglePersistValueAutoKey,+ fromSinglePersistValueAutoKey,+ failMessage,+ failMessageNamed, + -- * Other+ bracket,+ finally,+ onException,+ PSFieldDef (..),+ applyDbTypeSettings,+ findOne,+ replaceOne,+ matchElements,+ haveSameElems,+ phantomDb,+ getDefaultAutoKeyType,+ getUniqueFields,+ isSimple,+ firstRow,+ streamToList,+ mapStream,+ joinStreams,+ )+where+ import Control.Applicative ((<|>))-import Control.Monad (liftM, forM_, unless, (>=>))-import Control.Monad.Logger (MonadLogger, NoLoggingT(..))-import Control.Monad.Trans.State (StateT(..))-import Control.Monad.Trans.Control (MonadBaseControl, control, restoreM) import qualified Control.Exception as E+import Control.Monad (forM_, unless) import Control.Monad.IO.Class (MonadIO (..))-import Control.Monad.Reader.Class (MonadReader(..))+import Control.Monad.Trans.Control (MonadBaseControl, control, restoreM)+import Control.Monad.Trans.Reader (ReaderT (..), ask, runReaderT)+import Control.Monad.Trans.State (StateT (..))+import Data.Acquire (with)+import Data.Acquire.Internal (Acquire (..), Allocated (..), ReleaseType (..)) import Data.Either (partitionEithers) import Data.Function (on)+import Data.IORef import Data.List (partition, sortBy) import qualified Data.Map as Map+import Database.Groundhog.Core import System.IO (hPutStrLn, stderr) -- | Produce the migrations but not execute them. Fails when an unsafe migration occurs. createMigration :: Monad m => Migration m -> m NamedMigrations-createMigration m = liftM snd $ runStateT m Map.empty+createMigration m = snd <$> runStateT m Map.empty -- | Returns either a list of errors in migration or a list of queries-getQueries :: Bool -- ^ True - support unsafe queries- -> SingleMigration -> Either [String] [String]+getQueries ::+ -- | True - support unsafe queries+ Bool ->+ SingleMigration ->+ Either [String] [String] getQueries _ (Left errs) = Left errs-getQueries runUnsafe (Right migs) = (if runUnsafe || null unsafe- then Right $ map (\(_, _, query) -> query) migs'- else Left $- [ "Database migration: manual intervention required."- , "The following actions are considered unsafe:"- ] ++ map (\(_, _, query) -> query) unsafe) where- migs' = sortBy (compare `on` \(_, i, _) -> i) migs- unsafe = filter (\(isUnsafe, _, _) -> isUnsafe) migs'+getQueries runUnsafe (Right migs) =+ if runUnsafe || null unsafe+ then Right $ map (\(_, _, query) -> query) migs'+ else+ Left $+ [ "Database migration: manual intervention required.",+ "The following actions are considered unsafe:"+ ]+ ++ map (\(_, _, query) -> query) unsafe+ where+ migs' = sortBy (compare `on` \(_, i, _) -> i) migs+ unsafe = filter (\(isUnsafe, _, _) -> isUnsafe) migs' executeMigration' :: (PersistBackend m, MonadIO m) => Bool -> Bool -> NamedMigrations -> m () executeMigration' runUnsafe silent m = do let migs = getQueries runUnsafe $ mergeMigrations $ Map.elems m case migs of Left errs -> fail $ unlines errs- Right qs -> forM_ qs $ \q -> do+ Right qs -> forM_ qs $ \q -> do unless silent $ liftIO $ hPutStrLn stderr $ "Migrating: " ++ q executeRaw False q [] @@ -113,13 +124,14 @@ -- | Pretty print the migrations printMigration :: MonadIO m => NamedMigrations -> m ()-printMigration migs = liftIO $ forM_ (Map.assocs migs) $ \(k, v) -> do- putStrLn $ "Datatype " ++ k ++ ":"- case v of- Left errors -> mapM_ (putStrLn . ("\tError:\t" ++)) errors- Right sqls -> do- let showSql (isUnsafe, _, sql) = (if isUnsafe then "Unsafe:\t" else "Safe:\t") ++ sql- mapM_ (putStrLn . ("\t" ++) . showSql) sqls+printMigration migs = liftIO $+ forM_ (Map.assocs migs) $ \(k, v) -> do+ putStrLn $ "Datatype " ++ k ++ ":"+ case v of+ Left errors -> mapM_ (putStrLn . ("\tError:\t" ++)) errors+ Right sqls -> do+ let showSql (isUnsafe, _, sql) = (if isUnsafe then "Unsafe:\t" else "Safe:\t") ++ sql+ mapM_ (putStrLn . ("\t" ++) . showSql) sqls -- | Creates migrations and executes them with printing to stderr. Fails when an unsafe migration occurs. -- > runMigration m = createMigration m >>= executeMigration@@ -140,7 +152,7 @@ mergeMigrations :: [SingleMigration] -> SingleMigration mergeMigrations ms = case partitionEithers ms of ([], statements) -> Right $ concat statements- (errors, _) -> Left $ concat errors+ (errors, _) -> Left $ concat errors failMessage :: PersistField a => a -> [PersistValue] -> String failMessage a = failMessageNamed (persistName a)@@ -148,191 +160,238 @@ failMessageNamed :: String -> [PersistValue] -> String failMessageNamed name xs = "Invalid list for " ++ name ++ ": " ++ show xs -finally :: MonadBaseControl IO m- => m a -- ^ computation to run first- -> m b -- ^ computation to run afterward (even if an exception was raised)- -> m a+finally ::+ MonadBaseControl IO m =>+ -- | computation to run first+ m a ->+ -- | computation to run afterward (even if an exception was raised)+ m b ->+ m a finally a sequel = control $ \runInIO ->- E.finally (runInIO a)- (runInIO sequel)+ E.finally+ (runInIO a)+ (runInIO sequel) -bracket :: MonadBaseControl IO m- => m a -- ^ computation to run first ("acquire resource")- -> (a -> m b) -- ^ computation to run last ("release resource")- -> (a -> m c) -- ^ computation to run in-between- -> m c+bracket ::+ MonadBaseControl IO m =>+ -- | computation to run first ("acquire resource")+ m a ->+ -- | computation to run last ("release resource")+ (a -> m b) ->+ -- | computation to run in-between+ (a -> m c) ->+ m c bracket before after thing = control $ \runInIO ->- E.bracket (runInIO before) (\st -> runInIO $ restoreM st >>= after) (\st -> runInIO $ restoreM st >>= thing)+ E.bracket (runInIO before) (\st -> runInIO $ restoreM st >>= after) (\st -> runInIO $ restoreM st >>= thing) -onException :: MonadBaseControl IO m- => m a- -> m b- -> m a+onException ::+ MonadBaseControl IO m =>+ m a ->+ m b ->+ m a onException io what = control $ \runInIO -> E.onException (runInIO io) (runInIO what) -data PSFieldDef str = PSFieldDef {- psFieldName :: str -- bar- , psDbFieldName :: Maybe str -- SQLbar- , psDbTypeName :: Maybe str -- inet, NUMERIC(5,2), VARCHAR(50)- , psExprName :: Maybe str -- BarField- , psEmbeddedDef :: Maybe [PSFieldDef str]- , psDefaultValue :: Maybe str- , psReferenceParent :: Maybe (Maybe ((Maybe str, str), [str]), Maybe ReferenceActionType, Maybe ReferenceActionType)-} deriving (Eq, Show)+data PSFieldDef str = PSFieldDef+ { -- | name in the record, bar+ psFieldName :: str,+ -- | column name, SQLbar+ psDbFieldName :: Maybe str,+ -- | column type, inet, NUMERIC(5, 2), VARCHAR(50), etc.+ psDbTypeName :: Maybe str,+ -- | name of constructor in the Field GADT, BarField+ psExprName :: Maybe str,+ psEmbeddedDef :: Maybe [PSFieldDef str],+ -- | default value in the database+ psDefaultValue :: Maybe str,+ psReferenceParent :: Maybe (Maybe ((Maybe str, str), [str]), Maybe ReferenceActionType, Maybe ReferenceActionType),+ -- | name of a pair of functions+ psFieldConverter :: Maybe str+ }+ deriving (Eq, Show) applyDbTypeSettings :: PSFieldDef String -> DbType -> DbType-applyDbTypeSettings (PSFieldDef _ _ dbTypeName _ Nothing def psRef) typ = case typ of+applyDbTypeSettings (PSFieldDef _ _ dbTypeName _ Nothing def psRef _) typ = case typ of DbTypePrimitive t nullable def' ref -> DbTypePrimitive (maybe t (\typeName -> DbOther $ OtherTypeDef [Left typeName]) dbTypeName) nullable (def <|> def') (applyReferencesSettings psRef ref) DbEmbedded emb ref -> DbEmbedded emb (applyReferencesSettings psRef ref) t -> t-applyDbTypeSettings (PSFieldDef _ _ _ _ (Just subs) _ psRef) typ = (case typ of- DbEmbedded (EmbeddedDef _ fields) ref -> DbEmbedded (uncurry EmbeddedDef $ go subs fields) (applyReferencesSettings psRef ref)- t -> error $ "applyDbTypeSettings: expected DbEmbedded, got " ++ show t) where- go [] fs = (False, fs)- go st [] = error $ "applyDbTypeSettings: embedded datatype does not have expected fields: " ++ show st- go st (field@(fName, fType):fs) = case partition ((== fName) . psFieldName) st of- ([fDef], rest) -> result where- (flag, fields') = go rest fs- result = case psDbFieldName fDef of- Nothing -> (flag, (fName, applyDbTypeSettings fDef fType):fields')- Just name' -> (True, (name', applyDbTypeSettings fDef fType):fields')- _ -> let (flag, fields') = go st fs in (flag, field:fields')+applyDbTypeSettings (PSFieldDef _ _ _ _ (Just subs) _ psRef _) typ =+ case typ of+ DbEmbedded (EmbeddedDef _ fields) ref -> DbEmbedded (uncurry EmbeddedDef $ go subs fields) (applyReferencesSettings psRef ref)+ t -> error $ "applyDbTypeSettings: expected DbEmbedded, got " ++ show t+ where+ go [] fs = (False, fs)+ go st [] = error $ "applyDbTypeSettings: embedded datatype does not have expected fields: " ++ show st+ go st (field@(fName, fType) : fs) = case partition ((== fName) . psFieldName) st of+ ([fDef], rest) -> result+ where+ (flag, fields') = go rest fs+ result = case psDbFieldName fDef of+ Nothing -> (flag, (fName, applyDbTypeSettings fDef fType) : fields')+ Just name' -> (True, (name', applyDbTypeSettings fDef fType) : fields')+ _ -> let (flag, fields') = go st fs in (flag, field : fields') applyReferencesSettings :: Maybe (Maybe ((Maybe String, String), [String]), Maybe ReferenceActionType, Maybe ReferenceActionType) -> Maybe ParentTableReference -> Maybe ParentTableReference applyReferencesSettings Nothing ref = ref applyReferencesSettings (Just (parent, onDel, onUpd)) (Just (parent', onDel', onUpd')) = Just (maybe parent' Right parent, onDel <|> onDel', onUpd <|> onUpd') applyReferencesSettings (Just (Just parent, onDel, onUpd)) Nothing = Just (Right parent, onDel, onUpd)-applyReferencesSettings _ Nothing = error $ "applyReferencesSettings: expected type with reference, got Nothing"+applyReferencesSettings _ Nothing = error "applyReferencesSettings: expected type with reference, got Nothing" primToPersistValue :: (PersistBackend m, PrimitivePersistField a) => a -> m ([PersistValue] -> [PersistValue])-primToPersistValue a = phantomDb >>= \p -> return (toPrimitivePersistValue p a:)+primToPersistValue a = pure (toPrimitivePersistValue a :) primFromPersistValue :: (PersistBackend m, PrimitivePersistField a) => [PersistValue] -> m (a, [PersistValue])-primFromPersistValue (x:xs) = phantomDb >>= \p -> return (fromPrimitivePersistValue p x, xs)-primFromPersistValue xs = (\a -> fail (failMessage a xs) >> return (a, xs)) undefined+primFromPersistValue (x : xs) = pure (fromPrimitivePersistValue x, xs)+primFromPersistValue xs = (\a -> fail (failMessage a xs) >> pure (a, xs)) undefined -primToPurePersistValues :: (DbDescriptor db, PrimitivePersistField a) => proxy db -> a -> ([PersistValue] -> [PersistValue])-primToPurePersistValues p a = (toPrimitivePersistValue p a:)+primToPurePersistValues :: PrimitivePersistField a => a -> ([PersistValue] -> [PersistValue])+primToPurePersistValues a = (toPrimitivePersistValue a :) -primFromPurePersistValues :: (DbDescriptor db, PrimitivePersistField a) => proxy db -> [PersistValue] -> (a, [PersistValue])-primFromPurePersistValues p (x:xs) = (fromPrimitivePersistValue p x, xs)-primFromPurePersistValues _ xs = (\a -> error (failMessage a xs) `asTypeOf` (a, xs)) undefined+primFromPurePersistValues :: PrimitivePersistField a => [PersistValue] -> (a, [PersistValue])+primFromPurePersistValues (x : xs) = (fromPrimitivePersistValue x, xs)+primFromPurePersistValues xs = (\a -> error (failMessage a xs) `asTypeOf` (a, xs)) undefined primToSinglePersistValue :: (PersistBackend m, PrimitivePersistField a) => a -> m PersistValue-primToSinglePersistValue a = phantomDb >>= \p -> return (toPrimitivePersistValue p a)+primToSinglePersistValue a = pure (toPrimitivePersistValue a) primFromSinglePersistValue :: (PersistBackend m, PrimitivePersistField a) => PersistValue -> m a-primFromSinglePersistValue a = phantomDb >>= \p -> return (fromPrimitivePersistValue p a)+primFromSinglePersistValue a = pure (fromPrimitivePersistValue a) pureToPersistValue :: (PersistBackend m, PurePersistField a) => a -> m ([PersistValue] -> [PersistValue])-pureToPersistValue a = phantomDb >>= \p -> return (toPurePersistValues p a)+pureToPersistValue a = pure (toPurePersistValues a) pureFromPersistValue :: (PersistBackend m, PurePersistField a) => [PersistValue] -> m (a, [PersistValue])-pureFromPersistValue xs = phantomDb >>= \p -> return (fromPurePersistValues p xs)+pureFromPersistValue xs = pure (fromPurePersistValues xs) singleToPersistValue :: (PersistBackend m, SinglePersistField a) => a -> m ([PersistValue] -> [PersistValue])-singleToPersistValue a = toSinglePersistValue a >>= \x -> return (x:)+singleToPersistValue a = toSinglePersistValue a >>= \x -> pure (x :) singleFromPersistValue :: (PersistBackend m, SinglePersistField a) => [PersistValue] -> m (a, [PersistValue])-singleFromPersistValue (x:xs) = fromSinglePersistValue x >>= \a -> return (a, xs)-singleFromPersistValue xs = (\a -> fail (failMessage a xs) >> return (a, xs)) undefined+singleFromPersistValue (x : xs) = fromSinglePersistValue x >>= \a -> pure (a, xs)+singleFromPersistValue xs = (\a -> fail (failMessage a xs) >> pure (a, xs)) undefined -toSinglePersistValueUnique :: forall m v u . (PersistBackend m, PersistEntity v, IsUniqueKey (Key v (Unique u)), PrimitivePersistField (Key v (Unique u)))- => u (UniqueMarker v) -> v -> m PersistValue+toSinglePersistValueUnique ::+ forall m v u.+ (PersistBackend m, PersistEntity v, IsUniqueKey (Key v (Unique u)), PrimitivePersistField (Key v (Unique u))) =>+ u (UniqueMarker v) ->+ v ->+ m PersistValue toSinglePersistValueUnique u v = insertBy u v >> primToSinglePersistValue (extractUnique v :: Key v (Unique u)) -fromSinglePersistValueUnique :: forall m v u . (PersistBackend m, PersistEntity v, IsUniqueKey (Key v (Unique u)), PrimitivePersistField (Key v (Unique u)))- => u (UniqueMarker v) -> PersistValue -> m v-fromSinglePersistValueUnique _ x = phantomDb >>= \proxy -> getBy (fromPrimitivePersistValue proxy x :: Key v (Unique u)) >>= maybe (fail $ "No data with id " ++ show x) return+fromSinglePersistValueUnique ::+ forall m v u.+ (PersistBackend m, PersistEntity v, IsUniqueKey (Key v (Unique u)), PrimitivePersistField (Key v (Unique u))) =>+ u (UniqueMarker v) ->+ PersistValue ->+ m v+fromSinglePersistValueUnique _ x = getBy (fromPrimitivePersistValue x :: Key v (Unique u)) >>= maybe (fail $ "No data with id " ++ show x) pure -toPersistValuesUnique :: forall m v u . (PersistBackend m, PersistEntity v, IsUniqueKey (Key v (Unique u)))- => u (UniqueMarker v) -> v -> m ([PersistValue] -> [PersistValue])+toPersistValuesUnique ::+ forall m v u.+ (PersistBackend m, PersistEntity v, IsUniqueKey (Key v (Unique u))) =>+ u (UniqueMarker v) ->+ v ->+ m ([PersistValue] -> [PersistValue]) toPersistValuesUnique u v = insertBy u v >> toPersistValues (extractUnique v :: Key v (Unique u)) -fromPersistValuesUnique :: forall m v u . (PersistBackend m, PersistEntity v, IsUniqueKey (Key v (Unique u)))- => u (UniqueMarker v) -> [PersistValue] -> m (v, [PersistValue])-fromPersistValuesUnique _ xs = fromPersistValues xs >>= \(k, xs') -> getBy (k :: Key v (Unique u)) >>= maybe (fail $ "No data with id " ++ show xs) (\v -> return (v, xs'))+fromPersistValuesUnique ::+ forall m v u.+ (PersistBackend m, PersistEntity v, IsUniqueKey (Key v (Unique u))) =>+ u (UniqueMarker v) ->+ [PersistValue] ->+ m (v, [PersistValue])+fromPersistValuesUnique _ xs = fromPersistValues xs >>= \(k, xs') -> getBy (k :: Key v (Unique u)) >>= maybe (fail $ "No data with id " ++ show xs) (\v -> pure (v, xs')) -toSinglePersistValueAutoKey :: forall m v . (PersistBackend m, PersistEntity v, PrimitivePersistField (AutoKey v))- => v -> m PersistValue+toSinglePersistValueAutoKey ::+ forall m v.+ (PersistBackend m, PersistEntity v, PrimitivePersistField (AutoKey v)) =>+ v ->+ m PersistValue toSinglePersistValueAutoKey a = insertByAll a >>= primToSinglePersistValue . either id id -fromSinglePersistValueAutoKey :: forall m v . (PersistBackend m, PersistEntity v, PrimitivePersistField (Key v BackendSpecific))- => PersistValue -> m v-fromSinglePersistValueAutoKey x = phantomDb >>= \p -> get (fromPrimitivePersistValue p x :: Key v BackendSpecific) >>= maybe (fail $ "No data with id " ++ show x) return+fromSinglePersistValueAutoKey ::+ forall m v.+ (PersistBackend m, PersistEntity v, PrimitivePersistField (Key v BackendSpecific)) =>+ PersistValue ->+ m v+fromSinglePersistValueAutoKey x = get (fromPrimitivePersistValue x :: Key v BackendSpecific) >>= maybe (fail $ "No data with id " ++ show x) pure replaceOne :: (Eq x, Show x) => String -> (a -> x) -> (b -> x) -> (a -> b -> b) -> a -> [b] -> [b] replaceOne what getter1 getter2 apply a bs = case filter ((getter1 a ==) . getter2) bs of [_] -> map (\b -> if getter1 a == getter2 b then apply a b else b) bs- [] -> error $ "Not found " ++ what ++ " with name " ++ show (getter1 a)- _ -> error $ "Found more than one " ++ what ++ " with name " ++ show (getter1 a)+ [] -> error $ "Not found " ++ what ++ " with name " ++ show (getter1 a)+ _ -> error $ "Found more than one " ++ what ++ " with name " ++ show (getter1 a) findOne :: (Eq x, Show x) => String -> (a -> x) -> x -> [a] -> a findOne what getter x as = case filter ((x ==) . getter) as of [a] -> a- [] -> error $ "Not found " ++ what ++ " with name " ++ show x- _ -> error $ "Found more than one " ++ what ++ " with name " ++ show x+ [] -> error $ "Not found " ++ what ++ " with name " ++ show x+ _ -> error $ "Found more than one " ++ what ++ " with name " ++ show x -- | Returns only old elements, only new elements, and matched pairs (old, new). -- The new ones exist only in datatype, the old are present only in DB, match is typically by name (the properties of the matched elements may differ). matchElements :: Show a => (a -> b -> Bool) -> [a] -> [b] -> ([a], [b], [(a, b)])-matchElements eq oldElems newElems = foldr f (oldElems, [], []) newElems where- f new (olds, news, matches) = case partition (`eq` new) olds of- ([], rest) -> (rest, new:news, matches)- ([old], rest) -> (rest, news, (old, new):matches)- (xs, _) -> error $ "matchElements: more than one element matched " ++ show xs+matchElements eq oldElems newElems = foldr f (oldElems, [], []) newElems+ where+ f new (olds, news, matches) = case partition (`eq` new) olds of+ ([], rest) -> (rest, new : news, matches)+ ([old], rest) -> (rest, news, (old, new) : matches)+ (xs, _) -> error $ "matchElements: more than one element matched " ++ show xs haveSameElems :: Show a => (a -> b -> Bool) -> [a] -> [b] -> Bool haveSameElems p xs ys = case matchElements p xs ys of ([], [], _) -> True- _ -> False--mapAllRows :: Monad m => ([PersistValue] -> m a) -> RowPopper m -> m [a]-mapAllRows f pop = go where- go = pop >>= maybe (return []) (f >=> \a -> liftM (a:) go)+ _ -> False -phantomDb :: PersistBackend m => m (proxy (PhantomDb m))-phantomDb = return $ error "phantomDb"+phantomDb :: PersistBackend m => m (proxy (Conn m))+phantomDb = pure $ error "phantomDb" -getAutoKeyType :: DbDescriptor db => proxy db -> DbTypePrimitive-getAutoKeyType proxy = case dbType proxy ((undefined :: proxy db -> AutoKeyType db) proxy) of+getDefaultAutoKeyType :: DbDescriptor db => proxy db -> DbTypePrimitive+getDefaultAutoKeyType proxy = case dbType proxy ((undefined :: proxy db -> AutoKeyType db) proxy) of DbTypePrimitive t _ _ _ -> t- t -> error $ "autoKeyType: unexpected key type " ++ show t--getUniqueFields :: UniqueDef' str (Either field str) -> [field]-getUniqueFields (UniqueDef _ _ uFields) = map (either id (error "A unique key may not contain expressions")) uFields--isSimple :: [ConstructorDef] -> Bool-isSimple [_] = True-isSimple _ = False+ t -> error $ "getDefaultAutoKeyType: unexpected key type " ++ show t --- | This class helps to shorten the type signatures of user monadic code.-class (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadReader cm m, ConnectionManager cm conn) => HasConn m cm conn-instance (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadReader cm m, ConnectionManager cm conn) => HasConn m cm conn+firstRow :: MonadIO m => RowStream a -> m (Maybe a)+firstRow s = liftIO $ with s id --- | It helps to run database operations within an application monad.-runDb :: HasConn m cm conn => DbPersist conn m a -> m a-runDb f = ask >>= withConn (runDbPersist f)+streamToList :: MonadIO m => RowStream a -> m [a]+streamToList s = liftIO $ with s go+ where+ go next = next >>= maybe (pure []) (\a -> fmap (a :) (go next)) --- | Runs action within connection. It can handle a simple connection, a pool of them, etc.-runDbConn :: (MonadBaseControl IO m, MonadIO m, ConnectionManager cm conn) => DbPersist conn (NoLoggingT m) a -> cm -> m a-runDbConn f cm = runNoLoggingT (withConn (runDbPersist f) cm)+mapStream :: PersistBackendConn conn => (a -> Action conn b) -> RowStream a -> Action conn (RowStream b)+mapStream f s = do+ conn <- ask+ let apply next =+ next >>= \case+ Nothing -> pure Nothing+ Just a' -> Just <$> runReaderT (f a') conn+ pure $ fmap apply s --- | It is similar to `runDbConn` but runs action without transaction. It can be useful if you use Groundhog within IO monad or in other cases when you cannot put `PersistBackend` instance into your monad stack.------ @--- flip withConn cm $ \\conn -> liftIO $ do--- -- transaction is already opened by withConn at this point--- someIOAction--- getValuesFromIO $ \\value -> runDbConnNoTransaction (insert_ value) conn--- @-runDbConnNoTransaction :: (MonadBaseControl IO m, MonadIO m, ConnectionManager cm conn) => DbPersist conn (NoLoggingT m) a -> cm -> m a-runDbConnNoTransaction f cm = runNoLoggingT (withConnNoTransaction (runDbPersist f) cm)+joinStreams :: [Action conn (RowStream a)] -> Action conn (RowStream a)+joinStreams streams = do+ conn <- ask+ var <- liftIO $ newIORef ((pure Nothing, const $ pure ()), streams)+ pure $+ Acquire $ \restore -> do+ let joinedNext = do+ ((next, close), queue) <- readIORef var+ val <- next+ case val of+ Nothing -> case queue of+ [] -> pure Nothing+ (makeStream : queue') -> do+ close ReleaseNormal+ Acquire f <- runReaderT makeStream conn+ Allocated next' close' <- f restore+ writeIORef var ((next', close'), queue')+ joinedNext+ Just a -> pure $ Just a+ joinedClose typ = readIORef var >>= \((_, close), _) -> close typ+ pure $ Allocated joinedNext joinedClose --- | It helps to run 'withConnSavepoint' within a monad.-withSavepoint :: (HasConn m cm conn, SingleConnectionManager cm conn, Savepoint conn) => String -> m a -> m a-withSavepoint name m = ask >>= withConnNoTransaction (withConnSavepoint name m)+getUniqueFields :: UniqueDef' str (Either field str) -> [field]+getUniqueFields (UniqueDef _ _ uFields) = map (either id (error "A unique key may not contain expressions")) uFields -{-# DEPRECATED deleteByKey "Use deleteBy instead" #-}-deleteByKey :: (PersistBackend m, PersistEntity v, PrimitivePersistField (Key v BackendSpecific)) => Key v BackendSpecific -> m ()-deleteByKey = deleteBy+isSimple :: [ConstructorDef] -> Bool+isSimple [_] = True+isSimple _ = False
Database/Groundhog/Generic/Migration.hs view
@@ -1,198 +1,230 @@ {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+ -- | This helper module is intended for use by the backend creators module Database.Groundhog.Generic.Migration- ( Column(..)- , Reference(..)- , QualifiedName- , TableInfo(..)- , UniqueDefInfo- , AlterColumn(..)- , AlterTable(..)- , AlterDB(..)- , MigrationPack(..)- , SchemaAnalyzer(..)- , migrateRecursively- , migrateSchema- , migrateEntity- , migrateList- , getAlters- , defaultMigConstr- , showReferenceAction- , readReferenceAction- ) where--import Database.Groundhog.Core-import Database.Groundhog.Generic-import Database.Groundhog.Generic.Sql (flatten, mainTableName, tableName)+ ( Column (..),+ Reference (..),+ QualifiedName,+ TableInfo (..),+ UniqueDefInfo,+ AlterColumn (..),+ AlterTable (..),+ AlterDB (..),+ MigrationPack (..),+ SchemaAnalyzer (..),+ migrateRecursively,+ migrateSchema,+ migrateEntity,+ migrateList,+ getAlters,+ defaultMigConstr,+ showReferenceAction,+ readReferenceAction,+ )+where -import Control.Applicative (Applicative)-import Control.Arrow ((***), (&&&))-import Control.Monad (liftM, when)+import Control.Arrow ((&&&), (***))+import Control.Monad (when) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State (gets, modify) import Data.Either (lefts) import Data.Function (on)-import qualified Data.Map as Map import Data.List (group, intercalate)-import Data.Maybe (fromMaybe, mapMaybe)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe, isNothing, mapMaybe)+import Database.Groundhog.Core+import Database.Groundhog.Generic+import Database.Groundhog.Generic.Sql (flatten, mainTableName, tableName) data Column = Column- { colName :: String- , colNull :: Bool- , colType :: DbTypePrimitive- , colDefault :: Maybe String- } deriving (Eq, Show)+ { colName :: String,+ colNull :: Bool,+ colType :: DbTypePrimitive,+ colDefault :: Maybe String+ }+ deriving (Eq, Show) -data Reference = Reference {- referencedTableName :: QualifiedName- , referencedColumns :: [(String, String)] -- ^ child column, parent column- , referenceOnDelete :: Maybe ReferenceActionType- , referenceOnUpdate :: Maybe ReferenceActionType- } deriving Show+data Reference = Reference+ { referencedTableName :: QualifiedName,+ -- | child column, parent column+ referencedColumns :: [(String, String)],+ referenceOnDelete :: Maybe ReferenceActionType,+ referenceOnUpdate :: Maybe ReferenceActionType+ }+ deriving (Show) -- | Schema-qualified name of a table of another database object type QualifiedName = (Maybe String, String) -- | Either column name or expression type UniqueDefInfo = UniqueDef' String (Either String String)-data TableInfo = TableInfo {- tableColumns :: [Column]- , tableUniques :: [UniqueDefInfo]++data TableInfo = TableInfo+ { tableColumns :: [Column],+ tableUniques :: [UniqueDefInfo], -- | constraint name and reference- , tableReferences :: [(Maybe String, Reference)]-} deriving Show+ tableReferences :: [(Maybe String, Reference)]+ }+ deriving (Show) -data AlterColumn = Type DbTypePrimitive | IsNull | NotNull- | Default String | NoDefault | UpdateValue String deriving Show+data AlterColumn+ = Type DbTypePrimitive+ | IsNull+ | NotNull+ | Default String+ | NoDefault+ | UpdateValue String+ deriving (Show) -data AlterTable = AddUnique UniqueDefInfo- | DropConstraint String- | DropIndex String- | AddReference Reference- | DropReference String- | DropColumn String- | AddColumn Column- | AlterColumn Column [AlterColumn] deriving Show+data AlterTable+ = AddUnique UniqueDefInfo+ | DropConstraint String+ | DropIndex String+ | AddReference Reference+ | DropReference String+ | DropColumn String+ | AddColumn Column+ | AlterColumn Column [AlterColumn]+ deriving (Show) -data AlterDB = AddTable String- -- | Qualified table name, create statement, structure of table from DB, structure of table from datatype, alters- | AlterTable QualifiedName String TableInfo TableInfo [AlterTable]- -- | Qualified trigger name, qualified table name- | DropTrigger QualifiedName QualifiedName- -- | Qualified trigger name, qualified table name, body- | AddTriggerOnDelete QualifiedName QualifiedName String- -- | Qualified trigger name, qualified table name, field name, body- | AddTriggerOnUpdate QualifiedName QualifiedName (Maybe String) String- -- | Statement which creates the function- | CreateOrReplaceFunction String- -- | Qualified function name- | DropFunction QualifiedName- -- | Schema name, if not exists- | CreateSchema String Bool- deriving Show+data AlterDB+ = AddTable String+ | -- | Qualified table name, create statement, structure of table from DB, structure of table from datatype, alters+ AlterTable QualifiedName String TableInfo TableInfo [AlterTable]+ | -- | Qualified trigger name, qualified table name+ DropTrigger QualifiedName QualifiedName+ | -- | Qualified trigger name, qualified table name, body+ AddTriggerOnDelete QualifiedName QualifiedName String+ | -- | Qualified trigger name, qualified table name, field name, body+ AddTriggerOnUpdate QualifiedName QualifiedName (Maybe String) String+ | -- | Statement which creates the function+ CreateOrReplaceFunction String+ | -- | Qualified function name+ DropFunction QualifiedName+ | -- | Schema name, if not exists+ CreateSchema String Bool+ deriving (Show) -data MigrationPack m = MigrationPack {- compareTypes :: DbTypePrimitive -> DbTypePrimitive -> Bool- , compareRefs :: (Maybe String, Reference) -> (Maybe String, Reference) -> Bool- , compareUniqs :: UniqueDefInfo -> UniqueDefInfo -> Bool- , compareDefaults :: String -> String -> Bool- , migTriggerOnDelete :: QualifiedName -> [(String, String)] -> m (Bool, [AlterDB])- , migTriggerOnUpdate :: QualifiedName -> [(String, String)] -> m [(Bool, [AlterDB])]- , migConstr :: MigrationPack m -> EntityDef -> ConstructorDef -> m (Bool, SingleMigration)- , escape :: String -> String- , autoincrementedKeyTypeName :: String- , mainTableId :: String- , defaultPriority :: Int- -- | Sql pieces for the create table statement that add constraints and alterations for running after the table is created- , addUniquesReferences :: [UniqueDefInfo] -> [Reference] -> ([String], [AlterTable])- , showSqlType :: DbTypePrimitive -> String- , showColumn :: Column -> String- , showAlterDb :: AlterDB -> SingleMigration- , defaultReferenceOnDelete :: ReferenceActionType- , defaultReferenceOnUpdate :: ReferenceActionType-}+data MigrationPack conn = MigrationPack+ { compareTypes :: DbTypePrimitive -> DbTypePrimitive -> Bool,+ compareRefs :: (Maybe String, Reference) -> (Maybe String, Reference) -> Bool,+ compareUniqs :: UniqueDefInfo -> UniqueDefInfo -> Bool,+ compareDefaults :: String -> String -> Bool,+ migTriggerOnDelete :: QualifiedName -> [(String, String)] -> Action conn (Bool, [AlterDB]),+ migTriggerOnUpdate :: QualifiedName -> [(String, String)] -> Action conn [(Bool, [AlterDB])],+ migConstr :: EntityDef -> ConstructorDef -> Action conn (Bool, SingleMigration),+ escape :: String -> String,+ autoincrementedKeyTypeName :: String,+ mainTableId :: String,+ defaultPriority :: Int,+ -- | Sql pieces for the create table statement that add constraints and alterations for running after the table is created+ addUniquesReferences :: [UniqueDefInfo] -> [Reference] -> ([String], [AlterTable]),+ showSqlType :: DbTypePrimitive -> String,+ showColumn :: Column -> String,+ showAlterDb :: AlterDB -> SingleMigration,+ defaultReferenceOnDelete :: ReferenceActionType,+ defaultReferenceOnUpdate :: ReferenceActionType+ } mkColumns :: DbTypePrimitive -> (String, DbType) -> ([Column] -> [Column])-mkColumns autoKeyType field = go "" field where- go prefix (fname, typ) acc = (case typ of- DbEmbedded (EmbeddedDef flag ts) _ -> foldr (go prefix') acc ts where prefix' = if flag then "" else prefix ++ fname ++ [delim]- DbList _ _ -> Column fullName False autoKeyType Nothing : acc- DbTypePrimitive t nullable def _ -> Column fullName nullable t def : acc) where- fullName = prefix ++ fname+mkColumns listAutoKeyType = go ""+ where+ go prefix (fname, typ) acc =+ case typ of+ DbEmbedded (EmbeddedDef flag ts) _ -> foldr (go prefix') acc ts where prefix' = if flag then "" else prefix ++ fname ++ [delim]+ DbList _ _ -> Column fullName False listAutoKeyType Nothing : acc+ DbTypePrimitive t nullable def _ -> Column fullName nullable t def : acc+ where+ fullName = prefix ++ fname mkReferences :: DbTypePrimitive -> (String, DbType) -> [Reference]-mkReferences autoKeyType field = concat $ traverseDbType f field where- f (DbEmbedded _ ref) cols = maybe [] (return . mkReference cols) ref- f (DbList lName _) cols = [mkReference cols (Right ((Nothing, lName), ["id"]), Nothing, Nothing)]- f (DbTypePrimitive _ _ _ ref) cols = maybe [] (return . mkReference cols) ref- mkReference :: [String] -> ParentTableReference -> Reference- mkReference cols (parent, onDel, onUpd) = case parent of- Left (e, Nothing) -> Reference (entitySchema e, entityName e) (zipWith' (,) cols [keyName]) onDel onUpd where- keyName = case constructors e of- [cDef] -> fromMaybe (error "mkReferences: autokey name is Nothing") $ constrAutoKeyName cDef- _ -> "id"- Left (e, (Just uName)) -> Reference (entitySchema e, entityName e) (zipWith' (,) cols (map colName parentColumns)) onDel onUpd where- cDef = case constructors e of- [cDef'] -> cDef'- _ -> error "mkReferences: datatype with unique key cannot have more than one constructor"- uDef = findOne "unique" uniqueDefName (Just uName) $ constrUniques cDef- fields = map (\(fName, _) -> findOne "field" fst fName $ constrParams cDef) $ getUniqueFields uDef- parentColumns = foldr (mkColumns autoKeyType) [] fields- Right (parentTable, parentColumns) -> Reference parentTable (zipWith' (,) cols parentColumns) onDel onUpd- zipWith' _ [] [] = []- zipWith' g (x:xs) (y:ys) = g x y: zipWith' g xs ys- zipWith' _ _ _ = error "mkReferences: the lists have different length"+mkReferences autoKeyType field = concat $ traverseDbType f field+ where+ f (DbEmbedded _ ref) cols = maybe [] (pure . mkReference cols) ref+ f (DbList lName _) cols = [mkReference cols (Right ((Nothing, lName), ["id"]), Nothing, Nothing)]+ f (DbTypePrimitive _ _ _ ref) cols = maybe [] (pure . mkReference cols) ref+ mkReference :: [String] -> ParentTableReference -> Reference+ mkReference cols (parent, onDel, onUpd) = case parent of+ Left (e, Nothing) -> Reference (entitySchema e, entityName e) (zipWith' (,) cols [keyName]) onDel onUpd+ where+ keyName = case constructors e of+ [cDef] -> fromMaybe (error "mkReferences: autokey name is Nothing") $ constrAutoKeyName cDef+ _ -> "id"+ Left (e, Just uName) -> Reference (entitySchema e, entityName e) (zipWith' (,) cols (map colName parentColumns)) onDel onUpd+ where+ cDef = case constructors e of+ [cDef'] -> cDef'+ _ -> error "mkReferences: datatype with unique key cannot have more than one constructor"+ uDef = findOne "unique" uniqueDefName (Just uName) $ constrUniques cDef+ fields = map (\(fName, _) -> findOne "field" fst fName $ constrParams cDef) $ getUniqueFields uDef+ parentColumns = foldr (mkColumns autoKeyType) [] fields+ Right (parentTable, parentColumns) -> Reference parentTable (zipWith' (,) cols parentColumns) onDel onUpd+ zipWith' _ [] [] = []+ zipWith' g (x : xs) (y : ys) = g x y : zipWith' g xs ys+ zipWith' _ _ _ = error "mkReferences: the lists have different length" traverseDbType :: (DbType -> [String] -> a) -> (String, DbType) -> [a]-traverseDbType f field = snd $ go "" field where- go prefix (fname, typ) = (case typ of- t@(DbEmbedded (EmbeddedDef flag ts) _) -> (cols, f t cols : xs) where- prefix' = if flag then "" else prefix ++ fname ++ [delim]- (cols, xs) = concatMap' (go prefix') ts- t@(DbList _ _) -> ([name], [f t [name]])- t@(DbTypePrimitive _ _ _ _) -> ([name], [f t [name]])) where- name = prefix ++ fname- concatMap' g xs = concat *** concat $ unzip $ map g xs+traverseDbType f field = snd $ go "" field+ where+ go prefix (fname, typ) =+ case typ of+ t@(DbEmbedded (EmbeddedDef flag ts) _) -> (cols, f t cols : xs)+ where+ prefix' = if flag then "" else prefix ++ fname ++ [delim]+ (cols, xs) = concatMap' (go prefix') ts+ t@DbList {} -> ([name], [f t [name]])+ t@DbTypePrimitive {} -> ([name], [f t [name]])+ where+ name = prefix ++ fname+ concatMap' g xs = concat *** concat $ unzip $ map g xs -- | Create migration for a given entity and all entities it depends on. -- The stateful Map is used to avoid duplicate migrations when an entity type -- occurs several times in a datatype-migrateRecursively :: (PersistBackend m, PersistEntity v) => - (String -> m SingleMigration) -- ^ migrate schema- -> (EntityDef -> m SingleMigration) -- ^ migrate entity- -> (DbType -> m SingleMigration) -- ^ migrate list- -> v -- ^ initial entity- -> Migration m-migrateRecursively migS migE migL v = result where- result = migEntity $ entityDef proxy v- proxy = (undefined :: t m a -> proxy (PhantomDb m)) result- go l@(DbList lName t) = f ("list " ++ lName) (migL l) (go t)- go (DbEmbedded (EmbeddedDef _ ts) ref) = mapM_ (go . snd) ts >> migRef ref- go (DbTypePrimitive _ _ _ ref) = migRef ref- allSubtypes = map snd . concatMap constrParams . constructors- migRef ref = case ref of- Just (Left (e, _), _, _) -> migEntity e- _ -> return ()- migEntity e = do- case entitySchema e of- Just name -> f ("schema " ++ name) (migS name) (return ())- Nothing -> return ()- f ("entity " ++ mainTableName id e) (migE e) (mapM_ go (allSubtypes e))- f name mig cont = do- a <- gets (Map.lookup name)- when (a == Nothing) $- lift mig >>= modify . Map.insert name >> cont+migrateRecursively ::+ (PersistBackend m, PersistEntity v) =>+ -- | migrate schema+ (String -> m SingleMigration) ->+ -- | migrate entity+ (EntityDef -> m SingleMigration) ->+ -- | migrate list+ (DbType -> m SingleMigration) ->+ -- | initial entity+ v ->+ Migration m+migrateRecursively migS migE migL v = result+ where+ result = migEntity $ entityDef proxy v+ proxy = (undefined :: t m a -> proxy (Conn m)) result+ go l@(DbList lName t) = f ("list " ++ lName) (migL l) (go t)+ go (DbEmbedded (EmbeddedDef _ ts) ref) = mapM_ (go . snd) ts >> migRef ref+ go (DbTypePrimitive _ _ _ ref) = migRef ref+ allSubtypes = map snd . concatMap constrParams . constructors+ migRef ref = case ref of+ Just (Left (e, _), _, _) -> migEntity e+ _ -> pure ()+ migEntity e = do+ case entitySchema e of+ Just name -> f ("schema " ++ name) (migS name) (pure ())+ Nothing -> pure ()+ f ("entity " ++ mainTableName id e) (migE e) (mapM_ go (allSubtypes e))+ f name mig cont = do+ a <- gets (Map.lookup name)+ when (isNothing a) $+ lift mig >>= modify . Map.insert name >> cont -migrateSchema :: SchemaAnalyzer m => MigrationPack m -> String -> m SingleMigration-migrateSchema MigrationPack{..} schema = do+migrateSchema :: SchemaAnalyzer conn => MigrationPack conn -> String -> Action conn SingleMigration+migrateSchema MigrationPack {..} schema = do x <- schemaExists schema- return $ if x- then Right []- else showAlterDb $ CreateSchema schema False+ pure $+ if x+ then Right []+ else showAlterDb $ CreateSchema schema False -migrateEntity :: (SchemaAnalyzer m, PersistBackend m) => MigrationPack m -> EntityDef -> m SingleMigration-migrateEntity m@MigrationPack{..} e = do- autoKeyType <- fmap getAutoKeyType phantomDb+migrateEntity :: (SchemaAnalyzer conn, PersistBackendConn conn) => MigrationPack conn -> EntityDef -> Action conn SingleMigration+migrateEntity m@MigrationPack {..} e = do+ autoKeyType <- fmap getDefaultAutoKeyType phantomDb let name = entityName e constrs = constructors e mainTableQuery = "CREATE TABLE " ++ escape name ++ " (" ++ mainTableId ++ " " ++ autoincrementedKeyTypeName ++ ", discr INTEGER NOT NULL)"@@ -203,34 +235,39 @@ x <- analyzeTable (entitySchema e, name) -- check whether the table was created for multiple constructors before case x of- Just old | null $ getAlters m old expectedMainStructure -> return $ Left- ["Datatype with multiple constructors was truncated to one constructor. Manual migration required. Datatype: " ++ name]- _ -> liftM snd $ migConstr m e $ head constrs+ Just old+ | null $ getAlters m old expectedMainStructure ->+ pure $+ Left+ ["Datatype with multiple constructors was truncated to one constructor. Manual migration required. Datatype: " ++ name]+ _ -> fmap snd $ migConstr e $ head constrs else do mainStructure <- analyzeTable (entitySchema e, name) let constrTable c = name ++ [delim] ++ constrName c- res <- mapM (migConstr m e) constrs- return $ case mainStructure of- Nothing -> + res <- mapM (migConstr e) constrs+ pure $ case mainStructure of+ Nothing -> -- no constructor tables can exist if there is no main data table let orphans = filter (fst . fst) $ zip res constrs- in if null orphans- then mergeMigrations $ Right [(False, defaultPriority, mainTableQuery)]:map snd res- else Left $ map (\(_, c) -> "Orphan constructor table found: " ++ constrTable c) orphans- Just mainStructure' -> if null $ getAlters m mainStructure' expectedMainStructure- then let- -- the datatype had also many constructors before- -- check whether any new constructors appeared and increment older discriminators, which were shifted by newer constructors inserted not in the end- updateDiscriminators = go 0 . map (head &&& length) . group . map fst $ res where- go acc ((False, n):(True, n2):xs) = (False, defaultPriority, "UPDATE " ++ escape name ++ " SET discr = discr + " ++ show n ++ " WHERE discr >= " ++ show acc) : go (acc + n + n2) xs- go acc ((True, n):xs) = go (acc + n) xs- go _ _ = []- in mergeMigrations $ Right updateDiscriminators: map snd res- else Left ["Unexpected structure of main table for Datatype: " ++ name ++ ". Table info: " ++ show mainStructure']+ in if null orphans+ then mergeMigrations $ Right [(False, defaultPriority, mainTableQuery)] : map snd res+ else Left $ map (\(_, c) -> "Orphan constructor table found: " ++ constrTable c) orphans+ Just mainStructure' ->+ if null $ getAlters m mainStructure' expectedMainStructure+ then+ let -- the datatype had also many constructors before+ -- check whether any new constructors appeared and increment older discriminators, which were shifted by newer constructors inserted not in the end+ updateDiscriminators = go 0 . map (head &&& length) . group . map fst $ res+ where+ go acc ((False, n) : (True, n2) : xs) = (False, defaultPriority, "UPDATE " ++ escape name ++ " SET discr = discr + " ++ show n ++ " WHERE discr >= " ++ show acc) : go (acc + n + n2) xs+ go acc ((True, n) : xs) = go (acc + n) xs+ go _ _ = []+ in mergeMigrations $ Right updateDiscriminators : map snd res+ else Left ["Unexpected structure of main table for Datatype: " ++ name ++ ". Table info: " ++ show mainStructure'] -migrateList :: (SchemaAnalyzer m, PersistBackend m) => MigrationPack m -> DbType -> m SingleMigration-migrateList m@MigrationPack{..} (DbList mainName t) = do- autoKeyType <- fmap getAutoKeyType phantomDb+migrateList :: (SchemaAnalyzer conn, PersistBackendConn conn) => MigrationPack conn -> DbType -> Action conn SingleMigration+migrateList m@MigrationPack {..} (DbList mainName t) = do+ autoKeyType <- fmap getDefaultAutoKeyType phantomDb let valuesName = mainName ++ delim : "values" (valueCols, valueRefs) = (($ []) . mkColumns autoKeyType) &&& mkReferences autoKeyType $ ("value", t) refs' = Reference (Nothing, mainName) [("id", "id")] (Just Cascade) Nothing : valueRefs@@ -245,25 +282,29 @@ valuesStructure <- analyzeTable (Nothing, valuesName) let triggerMain = [] (_, triggerValues) <- migTriggerOnDelete (Nothing, valuesName) $ mkDeletes escape ("value", t)- return $ case (mainStructure, valuesStructure) of- (Nothing, Nothing) -> let- rest = [AlterTable (Nothing, valuesName) valuesQuery expectedValuesStructure expectedValuesStructure addInAlters]- in mergeMigrations $ map showAlterDb $ [AddTable mainQuery, AddTable valuesQuery] ++ rest ++ triggerMain ++ triggerValues- (Just mainStructure', Just valuesStructure') -> let- f name a b = if null $ getAlters m a b- then []- else ["List table " ++ name ++ " error. Expected: " ++ show b ++ ". Found: " ++ show a]- errors = f mainName mainStructure' expectedMainStructure ++ f valuesName valuesStructure' expectedValuesStructure- in if null errors then Right [] else Left errors+ pure $ case (mainStructure, valuesStructure) of+ (Nothing, Nothing) ->+ let rest = [AlterTable (Nothing, valuesName) valuesQuery expectedValuesStructure expectedValuesStructure addInAlters]+ in mergeMigrations $ map showAlterDb $ [AddTable mainQuery, AddTable valuesQuery] ++ rest ++ triggerMain ++ triggerValues+ (Just mainStructure', Just valuesStructure') ->+ let f name a b =+ if null $ getAlters m a b+ then []+ else ["List table " ++ name ++ " error. Expected: " ++ show b ++ ". Found: " ++ show a]+ errors = f mainName mainStructure' expectedMainStructure ++ f valuesName valuesStructure' expectedValuesStructure+ in if null errors then Right [] else Left errors (_, Nothing) -> Left ["Found orphan main list table " ++ mainName] (Nothing, _) -> Left ["Found orphan list values table " ++ valuesName] migrateList _ t = fail $ "migrateList: expected DbList, got " ++ show t -getAlters :: MigrationPack m- -> TableInfo -- ^ From database- -> TableInfo -- ^ From datatype- -> [AlterTable]-getAlters m@MigrationPack{..} (TableInfo oldColumns oldUniques oldRefs) (TableInfo newColumns newUniques newRefs) = tableAlters+getAlters ::+ MigrationPack m ->+ -- | From database+ TableInfo ->+ -- | From datatype+ TableInfo ->+ [AlterTable]+getAlters m@MigrationPack {..} (TableInfo oldColumns oldUniques oldRefs) (TableInfo newColumns newUniques newRefs) = tableAlters where (oldOnlyColumns, newOnlyColumns, commonColumns) = matchElements ((==) `on` colName) oldColumns newColumns (oldOnlyUniques, newOnlyUniques, commonUniques) = matchElements compareUniqs oldUniques newUniques@@ -272,97 +313,115 @@ colAlters = mapMaybe (\(a, b) -> mkAlterColumn b $ migrateColumn m a b) (filter ((`notElem` primaryColumns) . colName . fst) commonColumns) mkAlterColumn col alters = if null alters then Nothing else Just $ AlterColumn col alters- tableAlters = - map (DropColumn . colName) oldOnlyColumns- ++ map AddColumn newOnlyColumns- ++ colAlters- ++ map dropUnique oldOnlyUniques- ++ map AddUnique newOnlyUniques- ++ concatMap (uncurry migrateUniq) commonUniques- ++ map (DropReference . fromMaybe (error "getAlters: old reference does not have name") . fst) oldOnlyRefs- ++ map (AddReference . snd) newOnlyRefs+ tableAlters =+ map (DropColumn . colName) oldOnlyColumns+ ++ map AddColumn newOnlyColumns+ ++ colAlters+ ++ map dropUnique oldOnlyUniques+ ++ map AddUnique newOnlyUniques+ ++ concatMap (uncurry migrateUniq) commonUniques+ ++ map (DropReference . fromMaybe (error "getAlters: old reference does not have name") . fst) oldOnlyRefs+ ++ map (AddReference . snd) newOnlyRefs -- from database, from datatype migrateColumn :: MigrationPack m -> Column -> Column -> [AlterColumn]-migrateColumn MigrationPack{..} (Column _ isNull1 type1 def1) (Column _ isNull2 type2 def2) = modDef ++ modNull ++ modType where- modNull = case (isNull1, isNull2) of- (False, True) -> [IsNull]- (True, False) -> case def2 of- Nothing -> [NotNull]- Just s -> [UpdateValue s, NotNull]- _ -> []- modType = if compareTypes type1 type2 then [] else [Type type2]- modDef = case (def1, def2) of- (Nothing, Nothing) -> []- (Just def1', Just def2') | compareDefaults def1' def2' -> []- _ -> [maybe NoDefault Default def2]+migrateColumn MigrationPack {..} (Column _ isNull1 type1 def1) (Column _ isNull2 type2 def2) = modDef ++ modNull ++ modType+ where+ modNull = case (isNull1, isNull2) of+ (False, True) -> [IsNull]+ (True, False) -> case def2 of+ Nothing -> [NotNull]+ Just s -> [UpdateValue s, NotNull]+ _ -> []+ modType = if compareTypes type1 type2 then [] else [Type type2]+ modDef = case (def1, def2) of+ (Nothing, Nothing) -> []+ (Just def1', Just def2') | compareDefaults def1' def2' -> []+ _ -> [maybe NoDefault Default def2] -- from database, from datatype migrateUniq :: UniqueDefInfo -> UniqueDefInfo -> [AlterTable]-migrateUniq u1@(UniqueDef _ _ cols1) u2@(UniqueDef _ _ cols2) = if haveSameElems (==) cols1 cols2- then []- else [dropUnique u1, AddUnique u2]+migrateUniq u1@(UniqueDef _ _ cols1) u2@(UniqueDef _ _ cols2) =+ if haveSameElems (==) cols1 cols2+ then []+ else [dropUnique u1, AddUnique u2] dropUnique :: UniqueDefInfo -> AlterTable-dropUnique (UniqueDef name typ _) = (case typ of- UniqueConstraint -> DropConstraint name'- UniqueIndex -> DropIndex name'- UniquePrimary _ -> DropConstraint name') where- name' = fromMaybe (error $ "dropUnique: constraint which should be dropped does not have a name") name- -defaultMigConstr :: (SchemaAnalyzer m, PersistBackend m) => MigrationPack m -> EntityDef -> ConstructorDef -> m (Bool, SingleMigration)-defaultMigConstr m@MigrationPack{..} e constr = do+dropUnique (UniqueDef name typ _) =+ case typ of+ UniqueConstraint -> DropConstraint name'+ UniqueIndex -> DropIndex name'+ UniquePrimary _ -> DropConstraint name'+ where+ name' = fromMaybe (error "dropUnique: constraint which should be dropped does not have a name") name++defaultMigConstr :: (SchemaAnalyzer conn, PersistBackendConn conn) => MigrationPack conn -> EntityDef -> ConstructorDef -> Action conn (Bool, SingleMigration)+defaultMigConstr m@MigrationPack {..} e constr = do let simple = isSimple $ constructors e name = entityName e qualifiedCName = (entitySchema e, if simple then name else name ++ [delim] ++ constrName constr)- autoKeyType <- fmap getAutoKeyType phantomDb+ autoKeyType <- fmap getDefaultAutoKeyType phantomDb tableStructure <- analyzeTable qualifiedCName let dels = concatMap (mkDeletes escape) $ constrParams constr (triggerExisted, delTrigger) <- migTriggerOnDelete qualifiedCName dels- updTriggers <- liftM (concatMap snd) $ migTriggerOnUpdate qualifiedCName dels- - let (expectedTableStructure, (addTable, addInAlters)) = (case constrAutoKeyName constr of- Nothing -> (TableInfo columns uniques (mkRefs refs), f [] columns uniques refs)- Just keyName -> let keyColumn = Column keyName False autoKeyType Nothing - in if simple- then (TableInfo (keyColumn:columns) (uniques ++ [UniqueDef Nothing (UniquePrimary True) [Left keyName]]) (mkRefs refs)- , f [escape keyName ++ " " ++ autoincrementedKeyTypeName] columns uniques refs)- else let columns' = keyColumn:columns- refs' = refs ++ [Reference (entitySchema e, name) [(keyName, mainTableId)] (Just Cascade) Nothing]- uniques' = uniques ++ [UniqueDef Nothing UniqueConstraint [Left keyName]]- in (TableInfo columns' uniques' (mkRefs refs'), f [] columns' uniques' refs')) where- (columns, refs) = foldr (mkColumns autoKeyType) [] &&& concatMap (mkReferences autoKeyType) $ constrParams constr- uniques = map (\u -> u {uniqueDefFields = concatMap (either (map Left . ($ []) . flatten id) (return . Right)) $ uniqueDefFields u}) $ constrUniques constr- f autoKey cols uniqs refs' = (addTable', addInAlters') where- (addInCreate, addInAlters') = addUniquesReferences uniqs refs'- items = autoKey ++ map showColumn cols ++ addInCreate- addTable' = "CREATE TABLE " ++ tableName escape e constr ++ " (" ++ intercalate ", " items ++ ")"- mkRefs = map (\r -> (Nothing, r))+ updTriggers <- concatMap snd <$> migTriggerOnUpdate qualifiedCName dels + let (expectedTableStructure, (addTable, addInAlters)) =+ ( case constrAutoKeyName constr of+ Nothing -> (TableInfo columns uniques (mkRefs refs), f [] columns uniques refs)+ Just keyName ->+ let keyColumn = Column keyName False autoKeyType Nothing+ in if simple+ then+ ( TableInfo (keyColumn : columns) (uniques ++ [UniqueDef Nothing (UniquePrimary True) [Left keyName]]) (mkRefs refs),+ f [escape keyName ++ " " ++ autoincrementedKeyTypeName] columns uniques refs+ )+ else+ let columns' = keyColumn : columns+ refs' = refs ++ [Reference (entitySchema e, name) [(keyName, mainTableId)] (Just Cascade) Nothing]+ uniques' = uniques ++ [UniqueDef Nothing UniqueConstraint [Left keyName]]+ in (TableInfo columns' uniques' (mkRefs refs'), f [] columns' uniques' refs')+ )+ where+ (columns, refs) = foldr (mkColumns autoKeyType) [] &&& concatMap (mkReferences autoKeyType) $ constrParams constr+ uniques = map (\u -> u {uniqueDefFields = concatMap (either (map Left . ($ []) . flatten id) (pure . Right)) $ uniqueDefFields u}) $ constrUniques constr+ f autoKey cols uniqs refs' = (addTable', addInAlters')+ where+ (addInCreate, addInAlters') = addUniquesReferences uniqs refs'+ items = autoKey ++ map showColumn cols ++ addInCreate+ addTable' = "CREATE TABLE " ++ tableName escape e constr ++ " (" ++ intercalate ", " items ++ ")"+ mkRefs = map (\r -> (Nothing, r))+ (migErrs, constrExisted, mig) = case tableStructure of- Nothing -> let- rest = AlterTable qualifiedCName addTable expectedTableStructure expectedTableStructure addInAlters- in ([], False, [AddTable addTable, rest])- Just oldTableStructure -> let- alters = getAlters m oldTableStructure expectedTableStructure- alterTable = if null alters- then []- else [AlterTable qualifiedCName addTable oldTableStructure expectedTableStructure alters]- in ([], True, alterTable)+ Nothing ->+ let rest = AlterTable qualifiedCName addTable expectedTableStructure expectedTableStructure addInAlters+ in ([], False, [AddTable addTable, rest])+ Just oldTableStructure ->+ let alters = getAlters m oldTableStructure expectedTableStructure+ alterTable =+ if null alters+ then []+ else [AlterTable qualifiedCName addTable oldTableStructure expectedTableStructure alters]+ in ([], True, alterTable) -- this can happen when an ephemeral field was added. Consider doing something else except throwing an error- allErrs = if constrExisted == triggerExisted || (constrExisted && null dels)- then migErrs- else ["Both trigger and constructor table must exist: " ++ show qualifiedCName] ++ migErrs- return $ (constrExisted, if null allErrs- then mergeMigrations $ map showAlterDb $ mig ++ delTrigger ++ updTriggers- else Left allErrs)+ allErrs =+ if constrExisted == triggerExisted || (constrExisted && null dels)+ then migErrs+ else ("Both trigger and constructor table must exist: " ++ show qualifiedCName) : migErrs+ pure+ ( constrExisted,+ if null allErrs+ then mergeMigrations $ map showAlterDb $ mig ++ delTrigger ++ updTriggers+ else Left allErrs+ ) -- on delete removes all ephemeral data -- returns column name and delete statement for the referenced table mkDeletes :: (String -> String) -> (String, DbType) -> [(String, String)]-mkDeletes esc = concat . traverseDbType f where- f (DbList ref _) [col] = [(col, "DELETE FROM " ++ esc ref ++ " WHERE id=old." ++ esc col ++ ";")]- f _ _ = []+mkDeletes esc = concat . traverseDbType f+ where+ f (DbList ref _) [col] = [(col, "DELETE FROM " ++ esc ref ++ " WHERE id=old." ++ esc col ++ ";")]+ f _ _ = [] showReferenceAction :: ReferenceActionType -> String showReferenceAction NoAction = "NO ACTION"@@ -380,18 +439,37 @@ "SET DEFAULT" -> Just SetDefault _ -> Nothing -class (Applicative m, Monad m) => SchemaAnalyzer m where- schemaExists :: String -- ^ Schema name- -> m Bool- getCurrentSchema :: m (Maybe String)- listTables :: Maybe String -- ^ Schema name- -> m [String]- listTableTriggers :: QualifiedName -- ^ Qualified table name- -> m [String]- analyzeTable :: QualifiedName -- ^ Qualified table name- -> m (Maybe TableInfo)- analyzeTrigger :: QualifiedName -- ^ Qualified trigger name- -> m (Maybe String)- analyzeFunction :: QualifiedName -- ^ Qualified function name- -> m (Maybe (Maybe [DbTypePrimitive], Maybe DbTypePrimitive, String)) -- ^ Argument types, return type, and body- getMigrationPack :: m (MigrationPack m)+class PersistBackendConn conn => SchemaAnalyzer conn where+ schemaExists ::+ (PersistBackend m, Conn m ~ conn) =>+ -- | Schema name+ String ->+ m Bool+ getCurrentSchema :: (PersistBackend m, Conn m ~ conn) => m (Maybe String)+ listTables ::+ (PersistBackend m, Conn m ~ conn) =>+ -- | Schema name+ Maybe String ->+ m [String]+ listTableTriggers ::+ (PersistBackend m, Conn m ~ conn) =>+ -- | Qualified table name+ QualifiedName ->+ m [String]+ analyzeTable ::+ (PersistBackend m, Conn m ~ conn) =>+ -- | Qualified table name+ QualifiedName ->+ m (Maybe TableInfo)+ analyzeTrigger ::+ (PersistBackend m, Conn m ~ conn) =>+ -- | Qualified trigger name+ QualifiedName ->+ m (Maybe String)+ analyzeFunction ::+ (PersistBackend m, Conn m ~ conn) =>+ -- | Qualified function name+ QualifiedName ->+ -- | Argument types, return type, and body+ m (Maybe (Maybe [DbTypePrimitive], Maybe DbTypePrimitive, String))+ getMigrationPack :: (PersistBackend m, Conn m ~ conn) => m (MigrationPack conn)
Database/Groundhog/Generic/PersistBackendHelpers.hs view
@@ -1,181 +1,261 @@-{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, OverloadedStrings, RecordWildCards, Rank2Types, TypeFamilies, ConstraintKinds #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-} -- | This helper module contains generic versions of PersistBackend functions module Database.Groundhog.Generic.PersistBackendHelpers- ( - get- , select- , selectAll- , getBy- , project- , count- , replace- , replaceBy- , update- , delete- , deleteBy- , deleteAll- , insertByAll- , countAll- , insertBy- ) where+ ( get,+ select,+ selectAll,+ selectStream,+ selectAllStream,+ getBy,+ project,+ projectStream,+ count,+ replace,+ replaceBy,+ update,+ delete,+ deleteBy,+ deleteAll,+ insertByAll,+ countAll,+ insertBy,+ )+where -import Database.Groundhog.Core hiding (PersistBackend(..))-import Database.Groundhog.Core (PersistBackend, PhantomDb)+import Data.Either (rights)+import Data.Maybe (catMaybes, fromJust, fromMaybe, mapMaybe)+import Database.Groundhog.Core (PersistBackendConn)+import Database.Groundhog.Core hiding (PersistBackendConn (..)) import qualified Database.Groundhog.Core as Core-import Database.Groundhog.Generic+import Database.Groundhog.Generic (firstRow, getUniqueFields, isSimple, joinStreams, mapStream, streamToList) import Database.Groundhog.Generic.Sql -import Control.Monad (liftM, forM, (>=>))-import Data.Either (rights)-import Data.Maybe (catMaybes, fromJust, mapMaybe)-import Data.Monoid--{-# INLINABLE get #-}-get :: forall m v . (PersistBackend m, PersistEntity v, PrimitivePersistField (Key v BackendSpecific))- => RenderConfig -> (forall a . Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> Key v BackendSpecific -> m (Maybe v)-get RenderConfig{..} queryFunc (k :: Key v BackendSpecific) = do+get ::+ forall conn v.+ (PersistBackendConn conn, PersistEntity v, PrimitivePersistField (Key v BackendSpecific)) =>+ RenderConfig ->+ (Utf8 -> [PersistValue] -> Action conn (RowStream [PersistValue])) ->+ Key v BackendSpecific ->+ Action conn (Maybe v)+get RenderConfig {..} queryFunc (k :: Key v BackendSpecific) = do let e = entityDef proxy (undefined :: v)- proxy = undefined :: proxy (PhantomDb m)+ proxy = undefined :: proxy conn if isSimple (constructors e) then do let constr = head $ constructors e let fields = renderFields esc (constrParams constr) let query = "SELECT " <> fields <> " FROM " <> tableName esc e constr <> " WHERE " <> fromJust (constrId esc constr) <> "=?"- x <- queryFunc query [toPrimitivePersistValue proxy k] id+ x <- queryFunc query [toPrimitivePersistValue k] >>= firstRow case x of- Just xs -> liftM (Just . fst) $ fromEntityPersistValues $ PersistInt64 0:xs- Nothing -> return Nothing+ Just xs -> fmap (Just . fst) $ fromEntityPersistValues $ PersistInt64 0 : xs+ Nothing -> pure Nothing else do let query = "SELECT discr FROM " <> mainTableName esc e <> " WHERE id=?"- x <- queryFunc query [toPrimitivePersistValue proxy k] id+ x <- queryFunc query [toPrimitivePersistValue k] >>= firstRow case x of Just [discr] -> do- let constructorNum = fromPrimitivePersistValue proxy discr+ let constructorNum = fromPrimitivePersistValue discr constr = constructors e !! constructorNum fields = renderFields esc (constrParams constr) cQuery = "SELECT " <> fields <> " FROM " <> tableName esc e constr <> " WHERE " <> fromJust (constrId esc constr) <> "=?"- x2 <- queryFunc cQuery [toPrimitivePersistValue proxy k] id+ x2 <- queryFunc cQuery [toPrimitivePersistValue k] >>= firstRow case x2 of- Just xs -> liftM (Just . fst) $ fromEntityPersistValues $ discr:xs+ Just xs -> fmap (Just . fst) $ fromEntityPersistValues $ discr : xs Nothing -> fail "Missing entry in constructor table" Just x' -> fail $ "Unexpected number of columns returned: " ++ show x'- Nothing -> return Nothing+ Nothing -> pure Nothing -select :: forall m db r v c opts . (SqlDb db, db ~ PhantomDb m, r ~ RestrictionHolder v c, PersistBackend m, PersistEntity v, EntityConstr v c, HasSelectOptions opts db r)- => RenderConfig -> (forall a . Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> (opts -> RenderS db r) -> Utf8 -> opts -> m [v]-select conf@RenderConfig{..} queryFunc preColumns noLimit options = doSelectQuery where- SelectOptions cond limit offset ords dist _ = getSelectOptions options+select ::+ forall conn r v c opts.+ (SqlDb conn, r ~ RestrictionHolder v c, PersistBackendConn conn, PersistEntity v, EntityConstr v c, HasSelectOptions opts conn r) =>+ RenderConfig ->+ (Utf8 -> [PersistValue] -> Action conn (RowStream [PersistValue])) ->+ (opts -> RenderS conn r) ->+ Utf8 ->+ opts ->+ Action conn [v]+select conf queryFunc preColumns noLimit options = selectStream conf queryFunc preColumns noLimit options >>= streamToList - e = entityDef proxy (undefined :: v)- proxy = undefined :: proxy (PhantomDb m)- orders = renderOrders conf ords- lim = case (limit, offset) of- (Nothing, Nothing) -> mempty- (Nothing, o) -> RenderS (" " <> noLimit <> " OFFSET ?") (toPurePersistValues proxy o)- (l, Nothing) -> RenderS " LIMIT ?" (toPurePersistValues proxy l)- (l, o) -> RenderS " LIMIT ? OFFSET ?" (toPurePersistValues proxy (l, o))- cond' = renderCond conf cond- fields = RenderS (renderFields esc (constrParams constr)) id- distinctClause = if dist then "DISTINCT " else mempty- RenderS query binds = "SELECT " <> distinctClause <> preColumns options <> fields <> " FROM " <> RenderS (tableName esc e constr) id <> whereClause <> orders <> lim- whereClause = maybe "" (" WHERE " <>) cond'- doSelectQuery = queryFunc query (binds []) $ mapAllRows $ liftM fst . fromEntityPersistValues . (toPrimitivePersistValue proxy cNum:)- cNum = entityConstrNum (undefined :: proxy v) (undefined :: c a)- constr = constructors e !! cNum+selectStream ::+ forall conn r v c opts.+ (SqlDb conn, r ~ RestrictionHolder v c, PersistBackendConn conn, PersistEntity v, EntityConstr v c, HasSelectOptions opts conn r) =>+ RenderConfig ->+ (Utf8 -> [PersistValue] -> Action conn (RowStream [PersistValue])) ->+ (opts -> RenderS conn r) ->+ Utf8 ->+ opts ->+ Action conn (RowStream v)+selectStream conf@RenderConfig {..} queryFunc preColumns noLimit options = doSelectQuery+ where+ SelectOptions cond limit offset ords dist _ = getSelectOptions options -selectAll :: forall m v . (PersistBackend m, PersistEntity v)- => RenderConfig -> (forall a . Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> m [(AutoKey v, v)]-selectAll RenderConfig{..} queryFunc = start where- start = if isSimple (constructors e)- then let- constr = head $ constructors e- fields = maybe id (\key cont -> key <> fromChar ',' <> cont) (constrId esc constr) $ renderFields esc (constrParams constr)- query = "SELECT " <> fields <> " FROM " <> tableName esc e constr- in queryFunc query [] $ mapAllRows $ mkEntity proxy 0- else liftM concat $ forM (zip [0..] (constructors e)) $ \(cNum, constr) -> do- let fields = fromJust (constrId esc constr) <> fromChar ',' <> renderFields esc (constrParams constr)- let query = "SELECT " <> fields <> " FROM " <> tableName esc e constr- queryFunc query [] $ mapAllRows $ mkEntity proxy cNum- e = entityDef proxy (undefined :: v)- proxy = undefined :: proxy (PhantomDb m)+ e = entityDef proxy (undefined :: v)+ proxy = undefined :: proxy conn+ orders = renderOrders conf ords+ lim = case (limit, offset) of+ (Nothing, Nothing) -> mempty+ (Nothing, o) -> RenderS (" " <> noLimit <> " OFFSET ?") (toPurePersistValues o)+ (l, Nothing) -> RenderS " LIMIT ?" (toPurePersistValues l)+ (l, o) -> RenderS " LIMIT ? OFFSET ?" (toPurePersistValues (l, o))+ cond' = renderCond conf cond+ fields = RenderS (renderFields esc (constrParams constr)) id+ distinctClause = if dist then "DISTINCT " else mempty+ RenderS query binds = "SELECT " <> distinctClause <> preColumns options <> fields <> " FROM " <> RenderS (tableName esc e constr) id <> whereClause <> orders <> lim+ whereClause = maybe "" (" WHERE " <>) cond'+ doSelectQuery = queryFunc query (binds []) >>= mapStream (\xs -> fmap fst $ fromEntityPersistValues $ toPrimitivePersistValue cNum : xs)+ cNum = entityConstrNum (undefined :: proxy v) (undefined :: c a)+ constr = constructors e !! cNum -getBy :: forall m v u . (PersistBackend m, PersistEntity v, IsUniqueKey (Key v (Unique u)))- => RenderConfig- -> (forall a . Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a) -- ^ function to run query- -> Key v (Unique u)- -> m (Maybe v)-getBy conf@RenderConfig{..} queryFunc (k :: Key v (Unique u)) = do+selectAll ::+ forall conn v.+ (PersistBackendConn conn, PersistEntity v) =>+ RenderConfig ->+ (Utf8 -> [PersistValue] -> Action conn (RowStream [PersistValue])) ->+ Action conn [(AutoKey v, v)]+selectAll conf queryFunc = selectAllStream conf queryFunc >>= streamToList++-- | It may call the passed function multiple times+selectAllStream ::+ forall conn v.+ (PersistBackendConn conn, PersistEntity v) =>+ RenderConfig ->+ (Utf8 -> [PersistValue] -> Action conn (RowStream [PersistValue])) ->+ Action conn (RowStream (AutoKey v, v))+selectAllStream RenderConfig {..} queryFunc = start+ where+ start = joinStreams $ zipWith selectConstr [0 ..] $ constructors e+ selectConstr cNum constr = queryFunc query [] >>= mapStream (mkEntity cNum)+ where+ fields = maybe id (\key cont -> key <> fromChar ',' <> cont) (constrId esc constr) $ renderFields esc (constrParams constr)+ query = "SELECT " <> fields <> " FROM " <> tableName esc e constr+ e = entityDef proxy (undefined :: v)+ proxy = undefined :: proxy conn+ mkEntity cNum xs = do+ let (k, xs') = fromPurePersistValues xs+ (v, _) <- fromEntityPersistValues (toPrimitivePersistValue (cNum :: Int) : xs')+ pure (k, v)++getBy ::+ forall conn v u.+ (PersistBackendConn conn, PersistEntity v, IsUniqueKey (Key v (Unique u))) =>+ RenderConfig ->+ -- | function to run query+ (Utf8 -> [PersistValue] -> Action conn (RowStream [PersistValue])) ->+ Key v (Unique u) ->+ Action conn (Maybe v)+getBy conf@RenderConfig {..} queryFunc (k :: Key v (Unique u)) = do uniques <- toPersistValues k let e = entityDef proxy (undefined :: v)- proxy = undefined :: proxy (PhantomDb m)+ proxy = undefined :: proxy conn u = (undefined :: Key v (Unique u) -> u (UniqueMarker v)) k uFields = renderChain conf (fieldChain proxy u) [] RenderS cond vals = intercalateS " AND " $ mkUniqueCond uFields uniques constr = head $ constructors e fields = renderFields esc (constrParams constr) query = "SELECT " <> fields <> " FROM " <> tableName esc e constr <> " WHERE " <> cond- x <- queryFunc query (vals []) id+ x <- queryFunc query (vals []) >>= firstRow case x of- Just xs -> liftM (Just . fst) $ fromEntityPersistValues $ PersistInt64 0:xs- Nothing -> return Nothing+ Just xs -> fmap (Just . fst) $ fromEntityPersistValues $ PersistInt64 0 : xs+ Nothing -> pure Nothing -project :: forall m db r v c p opts a'. (SqlDb db, db ~ PhantomDb m, r ~ RestrictionHolder v c, PersistBackend m, PersistEntity v, EntityConstr v c, Projection p a', ProjectionDb p db, ProjectionRestriction p r, HasSelectOptions opts db r)- => RenderConfig -> (forall a . Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> (opts -> RenderS db r) -> Utf8 -> p -> opts -> m [a']-project conf@RenderConfig{..} queryFunc preColumns noLimit p options = doSelectQuery where- SelectOptions cond limit offset ords dist _ = getSelectOptions options- e = entityDef proxy (undefined :: v)- proxy = undefined :: proxy (PhantomDb m)- orders = renderOrders conf ords- lim = case (limit, offset) of- (Nothing, Nothing) -> mempty- (Nothing, o) -> RenderS (" " <> noLimit <> " OFFSET ?") (toPurePersistValues proxy o)- (l, Nothing) -> RenderS " LIMIT ?" (toPurePersistValues proxy l)- (l, o) -> RenderS " LIMIT ? OFFSET ?" (toPurePersistValues proxy (l, o))- cond' = renderCond conf cond- chains = projectionExprs p []- fields = commasJoin $ concatMap (renderExprExtended conf 0) chains- distinctClause = if dist then "DISTINCT " else mempty- RenderS query binds = "SELECT " <> distinctClause <> preColumns options <> fields <> " FROM " <> RenderS (tableName esc e constr) id <> whereClause <> orders <> lim- whereClause = maybe "" (" WHERE " <>) cond'- doSelectQuery = queryFunc query (binds []) $ mapAllRows $ liftM fst . projectionResult p- constr = constructors e !! entityConstrNum (undefined :: proxy v) (undefined :: c a)+project ::+ forall conn r v c p opts a'.+ (SqlDb conn, r ~ RestrictionHolder v c, PersistBackendConn conn, PersistEntity v, EntityConstr v c, Projection p a', ProjectionDb p conn, ProjectionRestriction p r, HasSelectOptions opts conn r) =>+ RenderConfig ->+ (Utf8 -> [PersistValue] -> Action conn (RowStream [PersistValue])) ->+ (opts -> RenderS conn r) ->+ Utf8 ->+ p ->+ opts ->+ Action conn [a']+project conf queryFunc preColumns noLimit p options = projectStream conf queryFunc preColumns noLimit p options >>= streamToList -count :: forall m db r v c . (SqlDb db, db ~ PhantomDb m, r ~ RestrictionHolder v c, PersistBackend m, PersistEntity v, EntityConstr v c)- => RenderConfig -> (forall a . Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> Cond db r -> m Int-count conf@RenderConfig{..} queryFunc cond = do+projectStream ::+ forall conn r v c p opts a'.+ (SqlDb conn, r ~ RestrictionHolder v c, PersistBackendConn conn, PersistEntity v, EntityConstr v c, Projection p a', ProjectionDb p conn, ProjectionRestriction p r, HasSelectOptions opts conn r) =>+ RenderConfig ->+ (Utf8 -> [PersistValue] -> Action conn (RowStream [PersistValue])) ->+ (opts -> RenderS conn r) ->+ Utf8 ->+ p ->+ opts ->+ Action conn (RowStream a')+projectStream conf@RenderConfig {..} queryFunc preColumns noLimit p options = doSelectQuery+ where+ SelectOptions cond limit offset ords dist _ = getSelectOptions options+ e = entityDef proxy (undefined :: v)+ proxy = undefined :: proxy conn+ orders = renderOrders conf ords+ lim = case (limit, offset) of+ (Nothing, Nothing) -> mempty+ (Nothing, o) -> RenderS (" " <> noLimit <> " OFFSET ?") (toPurePersistValues o)+ (l, Nothing) -> RenderS " LIMIT ?" (toPurePersistValues l)+ (l, o) -> RenderS " LIMIT ? OFFSET ?" (toPurePersistValues (l, o))+ cond' = renderCond conf cond+ chains = projectionExprs p []+ fields = commasJoin $ concatMap (renderExprExtended conf 0) chains+ distinctClause = if dist then "DISTINCT " else mempty+ RenderS query binds = "SELECT " <> distinctClause <> preColumns options <> fields <> " FROM " <> RenderS (tableName esc e constr) id <> whereClause <> orders <> lim+ whereClause = maybe "" (" WHERE " <>) cond'+ doSelectQuery = queryFunc query (binds []) >>= mapStream (fmap fst . projectionResult p)+ constr = constructors e !! entityConstrNum (undefined :: proxy v) (undefined :: c a)++count ::+ forall conn r v c.+ (SqlDb conn, r ~ RestrictionHolder v c, PersistBackendConn conn, PersistEntity v, EntityConstr v c) =>+ RenderConfig ->+ (Utf8 -> [PersistValue] -> Action conn (RowStream [PersistValue])) ->+ Cond conn r ->+ Action conn Int+count conf@RenderConfig {..} queryFunc cond = do let e = entityDef proxy (undefined :: v)- proxy = undefined :: proxy (PhantomDb m)+ proxy = undefined :: proxy conn cond' = renderCond conf cond constr = constructors e !! entityConstrNum (undefined :: proxy v) (undefined :: c a)- query = "SELECT COUNT(*) FROM " <> tableName esc e constr <> whereClause where- whereClause = maybe "" (\c -> " WHERE " <> getQuery c) cond'- x <- queryFunc query (maybe [] (flip getValues []) cond') id+ query = "SELECT COUNT(*) FROM " <> tableName esc e constr <> whereClause+ where+ whereClause = maybe "" (\c -> " WHERE " <> getQuery c) cond'+ x <- queryFunc query (maybe [] (`getValues` []) cond') >>= firstRow case x of- Just [num] -> return $ fromPrimitivePersistValue proxy num+ Just [num] -> pure $ fromPrimitivePersistValue num Just xs -> fail $ "requested 1 column, returned " ++ show (length xs)- Nothing -> fail $ "COUNT returned no rows"+ Nothing -> fail "COUNT returned no rows" -replace :: forall m db r v . (PersistBackend m, PersistEntity v, PrimitivePersistField (Key v BackendSpecific))- => RenderConfig -> (forall a . Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> (Utf8 -> [PersistValue] -> m ()) -> (Bool -> Utf8 -> ConstructorDef -> [PersistValue] -> RenderS db r)- -> Key v BackendSpecific -> v -> m ()-replace RenderConfig{..} queryFunc execFunc insertIntoConstructorTable k v = do+replace ::+ forall conn r v.+ (PersistBackendConn conn, PersistEntity v, PrimitivePersistField (Key v BackendSpecific)) =>+ RenderConfig ->+ (Utf8 -> [PersistValue] -> Action conn (RowStream [PersistValue])) ->+ (Utf8 -> [PersistValue] -> Action conn ()) ->+ (Bool -> Utf8 -> ConstructorDef -> [PersistValue] -> RenderS conn r) ->+ Key v BackendSpecific ->+ v ->+ Action conn ()+replace RenderConfig {..} queryFunc execFunc insertIntoConstructorTable k v = do vals <- toEntityPersistValues' v let e = entityDef proxy v- proxy = undefined :: proxy (PhantomDb m)- constructorNum = fromPrimitivePersistValue proxy (head vals)+ proxy = undefined :: proxy conn+ constructorNum = fromPrimitivePersistValue (head vals) constr = constructors e !! constructorNum- k' = toPrimitivePersistValue proxy k- RenderS upds updsVals = commasJoin $ zipWith f fields $ tail vals where- fields = foldr (flatten esc) [] $ constrParams constr- f f1 f2 = RenderS f1 id <> fromChar '=' <> renderPersistValue f2+ k' = toPrimitivePersistValue k+ RenderS upds updsVals = commasJoin $ zipWith f fields $ tail vals+ where+ fields = foldr (flatten esc) [] $ constrParams constr+ f f1 f2 = RenderS f1 id <> fromChar '=' <> renderPersistValue f2 updateQuery = "UPDATE " <> tableName esc e constr <> " SET " <> upds <> " WHERE " <> fromString (fromJust $ constrAutoKeyName constr) <> "=?" if isSimple (constructors e) then execFunc updateQuery (updsVals [k']) else do let query = "SELECT discr FROM " <> mainTableName esc e <> " WHERE id=?"- x <- queryFunc query [k'] (id >=> return . fmap (fromPrimitivePersistValue proxy . head))+ x <- queryFunc query [k'] >>= fmap (fmap $ fromPrimitivePersistValue . head) . firstRow case x of Just discr -> do let cName = tableName esc e constr@@ -183,7 +263,7 @@ if discr == constructorNum then execFunc updateQuery (updsVals [k']) else do- let RenderS insQuery vals' = insertIntoConstructorTable True cName constr (k':tail vals)+ let RenderS insQuery vals' = insertIntoConstructorTable True cName constr (k' : tail vals) execFunc insQuery (vals' []) let oldConstr = constructors e !! discr@@ -192,151 +272,194 @@ let updateDiscrQuery = "UPDATE " <> mainTableName esc e <> " SET discr=? WHERE id=?" execFunc updateDiscrQuery [head vals, k']- Nothing -> return ()+ Nothing -> pure () -replaceBy :: forall m v u . (PersistBackend m, PersistEntity v, IsUniqueKey (Key v (Unique u)))- => RenderConfig- -> (Utf8 -> [PersistValue] -> m ()) -- ^ function to execute query- -> u (UniqueMarker v)- -> v- -> m ()-replaceBy conf@RenderConfig{..} execFunc u v = do- uniques <- toPersistValues $ (extractUnique v `asTypeOf` ((undefined :: u (UniqueMarker v) -> Key v (Unique u)) u))+replaceBy ::+ forall conn v u.+ (PersistBackendConn conn, PersistEntity v, IsUniqueKey (Key v (Unique u))) =>+ RenderConfig ->+ -- | function to execute query+ (Utf8 -> [PersistValue] -> Action conn ()) ->+ u (UniqueMarker v) ->+ v ->+ Action conn ()+replaceBy conf@RenderConfig {..} execFunc u v = do+ uniques <- toPersistValues (extractUnique v `asTypeOf` (undefined :: u (UniqueMarker v) -> Key v (Unique u)) u) vals <- toEntityPersistValues' v let e = entityDef proxy (undefined :: v)- proxy = undefined :: proxy (PhantomDb m)+ proxy = undefined :: proxy conn uFields = renderChain conf (fieldChain proxy u) [] RenderS cond condVals = intercalateS " AND " $ mkUniqueCond uFields uniques constr = head $ constructors e- RenderS upds updsVals = commasJoin $ zipWith f fields $ tail vals where- fields = foldr (flatten esc) [] $ constrParams constr- f f1 f2 = RenderS f1 id <> fromChar '=' <> renderPersistValue f2+ RenderS upds updsVals = commasJoin $ zipWith f fields $ tail vals+ where+ fields = foldr (flatten esc) [] $ constrParams constr+ f f1 f2 = RenderS f1 id <> fromChar '=' <> renderPersistValue f2 updateQuery = "UPDATE " <> tableName esc e constr <> " SET " <> upds <> " WHERE " <> cond execFunc updateQuery (updsVals . condVals $ []) -update :: forall m db r v c . (SqlDb db, db ~ PhantomDb m, r ~ RestrictionHolder v c, PersistBackend m, PersistEntity v, EntityConstr v c)- => RenderConfig -> (Utf8 -> [PersistValue] -> m ()) -> [Update db r] -> Cond db r -> m ()-update conf@RenderConfig{..} execFunc upds cond = do+update ::+ forall conn r v c.+ (SqlDb conn, r ~ RestrictionHolder v c, PersistBackendConn conn, PersistEntity v, EntityConstr v c) =>+ RenderConfig ->+ (Utf8 -> [PersistValue] -> Action conn ()) ->+ [Update conn r] ->+ Cond conn r ->+ Action conn ()+update conf@RenderConfig {..} execFunc upds cond = do let e = entityDef proxy (undefined :: v)- proxy = undefined :: proxy (PhantomDb m)+ proxy = undefined :: proxy conn case renderUpdates conf upds of Just upds' -> do let cond' = renderCond conf cond constr = constructors e !! entityConstrNum (undefined :: proxy v) (undefined :: c a)- query = "UPDATE " <> tableName esc e constr <> " SET " <> whereClause where- whereClause = maybe (getQuery upds') (\c -> getQuery upds' <> " WHERE " <> getQuery c) cond'+ query = "UPDATE " <> tableName esc e constr <> " SET " <> whereClause+ where+ whereClause = maybe (getQuery upds') (\c -> getQuery upds' <> " WHERE " <> getQuery c) cond' execFunc query (getValues upds' <> maybe mempty getValues cond' $ [])- Nothing -> return ()+ Nothing -> pure () -delete :: forall m db r v c . (SqlDb db, db ~ PhantomDb m, r ~ RestrictionHolder v c, PersistBackend m, PersistEntity v, EntityConstr v c)- => RenderConfig -> (Utf8 -> [PersistValue] -> m ()) -> Cond db r -> m ()-delete conf@RenderConfig{..} execFunc cond = execFunc query (maybe [] (($ []) . getValues) cond') where- e = entityDef proxy (undefined :: v)- proxy = undefined :: proxy (PhantomDb m)- constr = constructors e !! entityConstrNum (undefined :: proxy v) (undefined :: c a)- cond' = renderCond conf cond- whereClause = maybe "" (\c -> " WHERE " <> getQuery c) cond'- query = if isSimple (constructors e)- then "DELETE FROM " <> tableName esc e constr <> whereClause- -- the entries in the constructor table are deleted because of the reference on delete cascade- else "DELETE FROM " <> mainTableName esc e <> " WHERE id IN(SELECT " <> fromJust (constrId esc constr) <> " FROM " <> tableName esc e constr <> whereClause <> ")"+delete ::+ forall conn r v c.+ (SqlDb conn, r ~ RestrictionHolder v c, PersistBackendConn conn, PersistEntity v, EntityConstr v c) =>+ RenderConfig ->+ (Utf8 -> [PersistValue] -> Action conn ()) ->+ Cond conn r ->+ Action conn ()+delete conf@RenderConfig {..} execFunc cond = execFunc query (maybe [] (($ []) . getValues) cond')+ where+ e = entityDef proxy (undefined :: v)+ proxy = undefined :: proxy conn+ constr = constructors e !! entityConstrNum (undefined :: proxy v) (undefined :: c a)+ cond' = renderCond conf cond+ whereClause = maybe "" (\c -> " WHERE " <> getQuery c) cond'+ query =+ if isSimple (constructors e)+ then "DELETE FROM " <> tableName esc e constr <> whereClause+ else -- the entries in the constructor table are deleted because of the reference on delete cascade+ "DELETE FROM " <> mainTableName esc e <> " WHERE id IN(SELECT " <> fromJust (constrId esc constr) <> " FROM " <> tableName esc e constr <> whereClause <> ")" -insertByAll :: forall m v . (PersistBackend m, PersistEntity v)- => RenderConfig- -> (forall a . Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a) -- ^ function to run query- -> Bool -- ^ allow multiple duplication of uniques with nulls- -> v -> m (Either (AutoKey v) (AutoKey v))-insertByAll RenderConfig{..} queryFunc manyNulls v = do+insertByAll ::+ forall conn v.+ (PersistBackendConn conn, PersistEntity v) =>+ RenderConfig ->+ -- | function to run query+ (Utf8 -> [PersistValue] -> Action conn (RowStream [PersistValue])) ->+ -- | allow multiple duplication of uniques with nulls+ Bool ->+ v ->+ Action conn (Either (AutoKey v) (AutoKey v))+insertByAll RenderConfig {..} queryFunc manyNulls v = do let e = entityDef proxy v- proxy = undefined :: proxy (PhantomDb m)- (constructorNum, uniques) = getUniques proxy v+ proxy = undefined :: proxy conn+ (constructorNum, uniques) = getUniques v constr = constructors e !! constructorNum uniqueDefs = constrUniques constr - query = "SELECT " <> maybe "1" id (constrId esc constr) <> " FROM " <> tableName esc e constr <> " WHERE " <> cond- conds = catMaybes $ zipWith (\uFields (_, uVals) -> checkNulls uVals $ intercalateS " AND " $ mkUniqueCond uFields uVals) (mapMaybe f uniqueDefs) uniques where- f u@(UniqueDef _ _ uFields) = if null $ rights uFields- then Just $ foldr (flatten esc) [] $ getUniqueFields u- else Nothing+ query = "SELECT " <> fromMaybe "1" (constrId esc constr) <> " FROM " <> tableName esc e constr <> " WHERE " <> cond+ conds = catMaybes $ zipWith (\uFields (_, uVals) -> checkNulls uVals $ intercalateS " AND " $ mkUniqueCond uFields uVals) (mapMaybe f uniqueDefs) uniques+ where+ f u@(UniqueDef _ _ uFields) =+ if null $ rights uFields+ then Just $ foldr (flatten esc) [] $ getUniqueFields u+ else Nothing -- skip condition if any value is NULL. It allows to insert many values with duplicate unique key- checkNulls uVals x = if manyNulls && any (== PersistNull) (uVals []) then Nothing else Just x+ checkNulls uVals x = if manyNulls && elem PersistNull (uVals []) then Nothing else Just x RenderS cond vals = intercalateS " OR " conds if null conds- then liftM Right $ Core.insert v+ then Right <$> Core.insert v else do- x <- queryFunc query (vals []) id+ x <- queryFunc query (vals []) >>= firstRow case x of- Nothing -> liftM Right $ Core.insert v- Just xs -> return $ Left $ fst $ fromPurePersistValues proxy xs+ Nothing -> Right <$> Core.insert v+ Just xs -> pure $ Left $ fst $ fromPurePersistValues xs -deleteBy :: forall m v . (PersistBackend m, PersistEntity v, PrimitivePersistField (Key v BackendSpecific))- => RenderConfig -> (Utf8 -> [PersistValue] -> m ()) -> Key v BackendSpecific -> m ()-deleteBy RenderConfig{..} execFunc k = execFunc query [toPrimitivePersistValue proxy k] where- e = entityDef proxy ((undefined :: Key v u -> v) k)- proxy = undefined :: proxy (PhantomDb m)- constr = head $ constructors e- idName = if isSimple (constructors e)- then fromJust $ constrId esc constr- else "id"- -- the entries in the constructor table are deleted because of the reference on delete cascade- query = "DELETE FROM " <> mainTableName esc e <> " WHERE " <> idName <> "=?"+deleteBy ::+ forall conn v.+ (PersistBackendConn conn, PersistEntity v, PrimitivePersistField (Key v BackendSpecific)) =>+ RenderConfig ->+ (Utf8 -> [PersistValue] -> Action conn ()) ->+ Key v BackendSpecific ->+ Action conn ()+deleteBy RenderConfig {..} execFunc k = execFunc query [toPrimitivePersistValue k]+ where+ e = entityDef proxy ((undefined :: Key v u -> v) k)+ proxy = undefined :: proxy conn+ constr = head $ constructors e+ idName =+ if isSimple (constructors e)+ then fromJust $ constrId esc constr+ else "id"+ -- the entries in the constructor table are deleted because of the reference on delete cascade+ query = "DELETE FROM " <> mainTableName esc e <> " WHERE " <> idName <> "=?" -deleteAll :: forall m v . (PersistBackend m, PersistEntity v)- => RenderConfig -> (Utf8 -> [PersistValue] -> m ()) -> v -> m ()-deleteAll RenderConfig{..} execFunc (_ :: v) = execFunc query [] where- e = entityDef proxy (undefined :: v)- proxy = undefined :: proxy (PhantomDb m)- query = "DELETE FROM " <> mainTableName esc e+deleteAll ::+ forall conn v.+ (PersistBackendConn conn, PersistEntity v) =>+ RenderConfig ->+ (Utf8 -> [PersistValue] -> Action conn ()) ->+ v ->+ Action conn ()+deleteAll RenderConfig {..} execFunc (_ :: v) = execFunc query []+ where+ e = entityDef proxy (undefined :: v)+ proxy = undefined :: proxy conn+ query = "DELETE FROM " <> mainTableName esc e -countAll :: forall m v . (PersistBackend m, PersistEntity v)- => RenderConfig -> (forall a . Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> v -> m Int-countAll RenderConfig{..} queryFunc (_ :: v) = do+countAll ::+ forall conn v.+ (PersistBackendConn conn, PersistEntity v) =>+ RenderConfig ->+ (Utf8 -> [PersistValue] -> Action conn (RowStream [PersistValue])) ->+ v ->+ Action conn Int+countAll RenderConfig {..} queryFunc (_ :: v) = do let e = entityDef proxy (undefined :: v)- proxy = undefined :: proxy (PhantomDb m)+ proxy = undefined :: proxy conn query = "SELECT COUNT(*) FROM " <> mainTableName esc e- x <- queryFunc query [] id+ x <- queryFunc query [] >>= firstRow case x of- Just [num] -> return $ fromPrimitivePersistValue proxy num+ Just [num] -> pure $ fromPrimitivePersistValue num Just xs -> fail $ "requested 1 column, returned " ++ show (length xs)- Nothing -> fail $ "COUNT returned no rows"+ Nothing -> fail "COUNT returned no rows" -insertBy :: forall m v u . (PersistBackend m, PersistEntity v, IsUniqueKey (Key v (Unique u)))- => RenderConfig- -> (forall a . Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a)- -> Bool- -> u (UniqueMarker v) -> v -> m (Either (AutoKey v) (AutoKey v))-insertBy conf@RenderConfig{..} queryFunc manyNulls u v = do- uniques <- toPersistValues $ (extractUnique v `asTypeOf` ((undefined :: u (UniqueMarker v) -> Key v (Unique u)) u))+insertBy ::+ forall conn v u.+ (PersistBackendConn conn, PersistEntity v, IsUniqueKey (Key v (Unique u))) =>+ RenderConfig ->+ (Utf8 -> [PersistValue] -> Action conn (RowStream [PersistValue])) ->+ Bool ->+ u (UniqueMarker v) ->+ v ->+ Action conn (Either (AutoKey v) (AutoKey v))+insertBy conf@RenderConfig {..} queryFunc manyNulls u v = do+ uniques <- toPersistValues (extractUnique v `asTypeOf` (undefined :: u (UniqueMarker v) -> Key v (Unique u)) u) let e = entityDef proxy v- proxy = undefined :: proxy (PhantomDb m)+ proxy = undefined :: proxy conn uFields = renderChain conf (fieldChain proxy u) [] RenderS cond vals = intercalateS " AND " $ mkUniqueCond uFields uniques -- skip condition if any value is NULL. It allows to insert many values with duplicate unique key- checkNulls uVals = manyNulls && any (== PersistNull) (uVals [])+ checkNulls uVals = manyNulls && elem PersistNull (uVals []) -- this is safe because unique keys exist only for entities with one constructor constr = head $ constructors e- query = "SELECT " <> maybe "1" id (constrId esc constr) <> " FROM " <> tableName esc e constr <> " WHERE " <> cond+ query = "SELECT " <> fromMaybe "1" (constrId esc constr) <> " FROM " <> tableName esc e constr <> " WHERE " <> cond if checkNulls uniques- then liftM Right $ Core.insert v+ then Right <$> Core.insert v else do- x <- queryFunc query (vals []) id+ x <- queryFunc query (vals []) >>= firstRow case x of- Nothing -> liftM Right $ Core.insert v- Just [k] -> return $ Left $ fst $ fromPurePersistValues proxy [k]- Just xs -> fail $ "unexpected query result: " ++ show xs+ Nothing -> Right <$> Core.insert v+ Just [k] -> pure $ Left $ fst $ fromPurePersistValues [k]+ Just xs -> fail $ "unexpected query result: " ++ show xs constrId :: (Utf8 -> Utf8) -> ConstructorDef -> Maybe Utf8 constrId escape = fmap (escape . fromString) . constrAutoKeyName --- | receives constructor number and row of values from the constructor table-mkEntity :: (PersistEntity v, PersistBackend m) => proxy (PhantomDb m) -> Int -> [PersistValue] -> m (AutoKey v, v)-mkEntity proxy i xs = fromEntityPersistValues (toPrimitivePersistValue proxy i:xs') >>= \(v, _) -> return (k, v) where- (k, xs') = fromPurePersistValues proxy xs--toEntityPersistValues' :: (PersistBackend m, PersistEntity v) => v -> m [PersistValue]-toEntityPersistValues' = liftM ($ []) . toEntityPersistValues+toEntityPersistValues' :: (PersistBackendConn conn, PersistEntity v) => v -> Action conn [PersistValue]+toEntityPersistValues' = fmap ($ []) . toEntityPersistValues -mkUniqueCond :: [Utf8] -> ([PersistValue] -> [PersistValue]) -> [RenderS db r]-mkUniqueCond u vals = zipWith f u (vals []) where- f a PersistNull = RenderS (a <> " IS NULL") id- f a x = RenderS (a <> "=?") (x:)+mkUniqueCond :: [Utf8] -> ([PersistValue] -> [PersistValue]) -> [RenderS conn r]+mkUniqueCond u vals = zipWith f u (vals [])+ where+ f a PersistNull = RenderS (a <> " IS NULL") id+ f a x = RenderS (a <> "=?") (x :)
Database/Groundhog/Generic/Sql.hs view
@@ -1,78 +1,75 @@-{-# LANGUAGE FlexibleContexts, OverloadedStrings, FlexibleInstances, TypeFamilies, RecordWildCards #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | This module defines the functions which are used only for backends creation. module Database.Groundhog.Generic.Sql- ( - -- * SQL rendering utilities- renderCond- , defaultShowPrim- , renderOrders- , renderUpdates- , renderFields- , renderChain- , renderExpr- , renderExprPriority- , renderExprExtended- , renderPersistValue- , mkExprWithConf- , prerenderExpr- , intercalateS- , commasJoin- , flatten- , RenderS(..)- , Utf8(..)- , RenderConfig(..)- , fromUtf8- , StringLike(..)- , fromString- , (<>)- , function- , operator- , parens- , mkExpr- , Snippet(..)- , SqlDb(..)- , FloatingSqlDb(..)- , tableName- , mainTableName- ) where+ ( -- * SQL rendering utilities+ renderCond,+ defaultShowPrim,+ renderOrders,+ renderUpdates,+ renderFields,+ renderChain,+ renderExpr,+ renderExprPriority,+ renderExprExtended,+ renderPersistValue,+ mkExprWithConf,+ prerenderExpr,+ intercalateS,+ commasJoin,+ flatten,+ RenderS (..),+ Utf8 (..),+ fromUtf8,+ RenderConfig (..),+ StringLike (..),+ fromString,+ (<>),+ function,+ operator,+ parens,+ mkExpr,+ Snippet (..),+ SqlDb (..),+ FloatingSqlDb (..),+ tableName,+ mainTableName,+ )+where -import Database.Groundhog.Core-import Database.Groundhog.Generic (isSimple)-import Database.Groundhog.Instances ()-import qualified Blaze.ByteString.Builder.Char.Utf8 as B import Data.Maybe (mapMaybe, maybeToList)-import Data.Monoid+import Data.Semigroup (Semigroup (..)) import Data.String-+import qualified Data.Text.Lazy.Builder as B+import Database.Groundhog.Core import Database.Groundhog.Expression+import Database.Groundhog.Generic (isSimple)+import Database.Groundhog.Instances () -class (Monoid a, IsString a) => StringLike a where+class (Semigroup a, Monoid a, IsString a) => StringLike a where fromChar :: Char -> a -data RenderS db r = RenderS {- getQuery :: Utf8- , getValues :: [PersistValue] -> [PersistValue]-}--instance Monoid Utf8 where- mempty = Utf8 mempty- mappend (Utf8 a) (Utf8 b) = Utf8 (mappend a b)--instance IsString Utf8 where- fromString = Utf8 . B.fromString+data RenderS db r = RenderS+ { getQuery :: Utf8,+ getValues :: [PersistValue] -> [PersistValue]+ } instance StringLike Utf8 where- fromChar = Utf8 . B.fromChar+ fromChar = Utf8 . B.singleton -- | Escape function, priority of the outer operator. The result is a list for the embedded data which may expand to several RenderS. newtype Snippet db r = Snippet (RenderConfig -> Int -> [RenderS db r]) -newtype RenderConfig = RenderConfig {- esc :: Utf8 -> Utf8-}+newtype RenderConfig = RenderConfig+ { esc :: Utf8 -> Utf8+ } -- | This class distinguishes databases which support SQL-specific expressions. It contains ad hoc members for features whose syntax differs across the databases. class (DbDescriptor db, QueryRaw db ~ Snippet db) => SqlDb db where@@ -87,13 +84,17 @@ class SqlDb db => FloatingSqlDb db where -- | Natural logarithm log' :: (ExpressionOf db r x a, Floating a) => x -> Expr db r a+ logBase' :: (ExpressionOf db r b a, ExpressionOf db r x a, Floating a) => b -> x -> Expr db r a -- | If we reuse complex expression several times, prerendering it saves time. `RenderConfig` can be obtained with `mkExprWithConf`-prerenderExpr :: SqlDb db => RenderConfig -> Expr db r a -> Expr db r a-prerenderExpr conf (Expr e) = Expr $ ExprRaw $ Snippet $ \_ _ -> prerendered where- -- Priority of outer operation is not known. Assuming that it is high ensures that parentheses won't be missing.- prerendered = renderExprExtended conf maxBound e+prerenderExpr :: forall db r a. (SqlDb db, PersistField a) => RenderConfig -> Expr db r a -> Expr db r a+prerenderExpr conf (Expr e) = Expr $ ExprRaw typ $ Snippet $ \_ _ -> prerendered+ where+ proxy = undefined :: proxy db+ typ = dbType proxy (undefined :: a)+ -- Priority of outer operation is not known. Assuming that it is high ensures that parentheses won't be missing.+ prerendered = renderExprExtended conf maxBound e -- | Helps creating an expression which depends on render configuration. It can be used in pair with `prerenderExpr`. -- @@@ -102,142 +103,198 @@ -- in x' + x' * x'@ -- @ mkExprWithConf :: (SqlDb db, PersistField a) => (RenderConfig -> Int -> Expr db r a) -> Expr db r a-mkExprWithConf f = expr where- expr = mkExpr $ Snippet $ \conf p -> [renderExprPriority conf p $ toExpr $ (f conf p) `asTypeOf` expr]+mkExprWithConf f = expr+ where+ expr = mkExpr $ Snippet $ \conf p -> [renderExprPriority conf p $ toExpr $ f conf p `asTypeOf` expr] renderExpr :: SqlDb db => RenderConfig -> UntypedExpr db r -> RenderS db r-renderExpr conf expr = renderExprPriority conf 0 expr+renderExpr conf = renderExprPriority conf 0 renderExprPriority :: SqlDb db => RenderConfig -> Int -> UntypedExpr db r -> RenderS db r-renderExprPriority conf p expr = (case expr of- ExprRaw (Snippet f) -> let vals = f conf p in ensureOne vals id- ExprField f -> let fs = renderChain conf f []- in ensureOne fs $ \f' -> RenderS f' id- ExprPure a -> let vals = toPurePersistValues proxy a- in ensureOne (vals []) renderPersistValue- ExprCond a -> case renderCondPriority conf p a of- Nothing -> error "renderExprPriority: empty condition"- Just x -> x) where- proxy = (undefined :: f db r -> proxy db) expr- ensureOne :: [a] -> (a -> b) -> b- ensureOne xs f = case xs of- [x] -> f x+renderExprPriority conf p expr =+ case expr of+ ExprRaw _ (Snippet f) -> explicitHead (f conf p)+ ExprField f ->+ let fs = renderChain conf f []+ in RenderS (explicitHead fs) id+ ExprPure a ->+ let vals = toPurePersistValues a+ in renderPersistValue $ explicitHead (vals [])+ ExprCond a -> case renderCondPriority conf p a of+ Nothing -> error "renderExprPriority: empty condition"+ Just x -> x+ where+ explicitHead :: [a] -> a+ explicitHead xs = case xs of+ [x] -> x xs' -> error $ "renderExprPriority: expected one column field, found " ++ show (length xs') renderExprExtended :: SqlDb db => RenderConfig -> Int -> UntypedExpr db r -> [RenderS db r]-renderExprExtended conf p expr = (case expr of- ExprRaw (Snippet f) -> f conf p- ExprField f -> map (flip RenderS id) $ renderChain conf f []- ExprPure a -> let vals = toPurePersistValues proxy a []- in map renderPersistValue vals- ExprCond a -> maybeToList $ renderCondPriority conf p a) where- proxy = (undefined :: f db r -> proxy db) expr+renderExprExtended conf p expr =+ case expr of+ ExprRaw _ (Snippet f) -> f conf p+ ExprField f -> map (`RenderS` id) $ renderChain conf f []+ ExprPure a ->+ let vals = toPurePersistValues a []+ in map renderPersistValue vals+ ExprCond a -> maybeToList $ renderCondPriority conf p a renderPersistValue :: PersistValue -> RenderS db r-renderPersistValue (PersistCustom s as) = RenderS s (as++)-renderPersistValue a = RenderS (fromChar '?') (a:)+renderPersistValue (PersistCustom s as) = RenderS s (as ++)+renderPersistValue a = RenderS (fromChar '?') (a :) +instance Semigroup (RenderS db r) where+ (RenderS f1 g1) <> (RenderS f2 g2) = RenderS (f1 <> f2) (g1 . g2)+ instance Monoid (RenderS db r) where mempty = RenderS mempty id- (RenderS f1 g1) `mappend` (RenderS f2 g2) = RenderS (f1 `mappend` f2) (g1 . g2) +#if !(MIN_VERSION_base(4,11,0))+ mappend = (<>)+#endif+ instance IsString (RenderS db r) where fromString s = RenderS (fromString s) id instance StringLike (RenderS db r) where fromChar c = RenderS (fromChar c) id --- Has bad performance. This instance exists only for testing purposes+-- Has bad performance. This instance exists for testing purposes and migration instance StringLike String where fromChar c = [c] -{-# INLINABLE parens #-}+{-# INLINEABLE parens #-} parens :: Int -> Int -> RenderS db r -> RenderS db r parens p1 p2 expr = if p1 < p2 then fromChar '(' <> expr <> fromChar ')' else expr operator :: (SqlDb db, Expression db r a, Expression db r b) => Int -> String -> a -> b -> Snippet db r-operator pr op = \a b -> Snippet $ \conf p ->+operator pr op a b = Snippet $ \conf p -> [parens pr p $ renderExprPriority conf pr (toExpr a) <> fromString op <> renderExprPriority conf pr (toExpr b)] function :: SqlDb db => String -> [UntypedExpr db r] -> Snippet db r function func args = Snippet $ \conf _ -> [fromString func <> fromChar '(' <> commasJoin (map (renderExpr conf) args) <> fromChar ')'] -mkExpr :: SqlDb db => Snippet db r -> Expr db r a-mkExpr = Expr . ExprRaw+mkExpr :: forall db r a. (SqlDb db, PersistField a) => Snippet db r -> Expr db r a+mkExpr snippet = Expr $ ExprRaw typ snippet+ where+ proxy = undefined :: proxy db+ typ = dbType proxy (undefined :: a) -#if !MIN_VERSION_base(4, 5, 0)-{-# INLINABLE (<>) #-}-(<>) :: Monoid m => m -> m -> m-(<>) = mappend-#endif+{-# INLINEABLE renderCond #-} -{-# INLINABLE renderCond #-} -- | Renders conditions for SQL backend. Returns Nothing if the fields don't have any columns.-renderCond :: SqlDb db- => RenderConfig- -> Cond db r -> Maybe (RenderS db r)-renderCond conf cond = renderCondPriority conf 0 cond where+renderCond ::+ SqlDb db =>+ RenderConfig ->+ Cond db r ->+ Maybe (RenderS db r)+renderCond conf = renderCondPriority conf 0 -{-# INLINABLE renderCondPriority #-}+flattenNullables :: DbType -> [Bool]+flattenNullables typ = go typ []+ where+ go :: DbType -> [Bool] -> [Bool]+ go t acc = case t of+ DbEmbedded (EmbeddedDef _ ts) _ -> foldr (go . snd) acc ts+ DbList _ _ -> False : acc+ DbTypePrimitive _ nullable _ _ -> nullable : acc++{-# INLINEABLE renderCondPriority #-}+ -- | Renders conditions for SQL backend. Returns Nothing if the fields don't have any columns.-renderCondPriority :: SqlDb db- => RenderConfig- -> Int -> Cond db r -> Maybe (RenderS db r)-renderCondPriority conf@RenderConfig{..} priority cond = go cond priority where- go (And a b) p = perhaps andP p " AND " a b- go (Or a b) p = perhaps orP p " OR " a b- go (Not CondEmpty) _ = Just "(1=0)" -- special case for False- go (Not a) p = fmap (\a' -> parens notP p $ "NOT " <> a') $ go a notP- go (Compare compOp f1 f2) p = (case compOp of- Eq -> renderComp andP " AND " 37 equalsOperator f1 f2- Ne -> renderComp orP " OR " 50 notEqualsOperator f1 f2- Gt -> renderComp orP " OR " 38 (\a b -> a <> fromChar '>' <> b) f1 f2- Lt -> renderComp orP " OR " 38 (\a b -> a <> fromChar '<' <> b) f1 f2- Ge -> renderComp orP " OR " 38 (\a b -> a <> ">=" <> b) f1 f2- Le -> renderComp orP " OR " 38 (\a b -> a <> "<=" <> b) f1 f2) where- renderComp interP interOp opP op expr1 expr2 = result where- expr1' = renderExprExtended conf opP expr1- expr2' = renderExprExtended conf opP expr2- result = case zipWith op expr1' expr2' of+renderCondPriority ::+ forall db r.+ SqlDb db =>+ RenderConfig ->+ Int ->+ Cond db r ->+ Maybe (RenderS db r)+renderCondPriority conf@RenderConfig {..} priority cond = go cond priority+ where+ go (And a b) p = perhaps andP p " AND " a b+ go (Or a b) p = perhaps orP p " OR " a b+ go (Not CondEmpty) _ = Just "(1=0)" -- special case for False+ go (Not a) p = (\a' -> parens notP p $ "NOT " <> a') <$> go a notP+ go (Compare compOp f1 f2) p =+ case compOp of+ Eq -> renderCompOps andP " AND " 37 ops f1 f2+ where+ ops = map (\isNull -> if isNull then equalsOperator else (\a b -> a <> fromChar '=' <> b)) eitherNullable+ Ne -> renderCompOps andP " OR " 50 ops f1 f2+ where+ ops = map (\isNull -> if isNull then notEqualsOperator else (\a b -> a <> "<>" <> b)) eitherNullable+ Gt -> renderComp orP " OR " 38 (\a b -> a <> fromChar '>' <> b) f1 f2+ Lt -> renderComp orP " OR " 38 (\a b -> a <> fromChar '<' <> b) f1 f2+ Ge -> renderComp orP " OR " 38 (\a b -> a <> ">=" <> b) f1 f2+ Le -> renderComp orP " OR " 38 (\a b -> a <> "<=" <> b) f1 f2+ where+ proxy = undefined :: proxy db++ eitherNullable = zipWith (||) (nullables f1) (nullables f2)++ nullables expr = case expr of+ ExprRaw t _ -> flattenNullables t+ ExprField ((_, t), _) -> flattenNullables t+ ExprPure a -> flattenNullables $ dbType proxy a+ ExprCond _ -> [False]++ renderZip opP op expr1 expr2 = zipWith op expr1' expr2'+ where+ expr1' = renderExprExtended conf opP expr1+ expr2' = renderExprExtended conf opP expr2++ renderZip3 opP ops expr1 expr2 = zipWith3 (\op e1 e2 -> op e1 e2) ops expr1' expr2'+ where+ expr1' = renderExprExtended conf opP expr1+ expr2' = renderExprExtended conf opP expr2++ groupComparisons interP interOp opP comparisons = case comparisons of [] -> Nothing- [clause] -> Just $ parens (opP - 1) p clause -- put lower priority to make parentheses appear when the same operator is nested- clauses -> Just $ parens interP p $ intercalateS interOp clauses- go (CondRaw (Snippet f)) p = case f conf p of- [] -> Nothing- [a] -> Just a- _ -> error "renderCond: cannot render CondRaw with many elements"- go CondEmpty _ = Nothing- - notP = 35- andP = 30- orP = 20+ [clause] -> Just $ parens (opP - 1) p clause -- put lower priority to make parentheses appear when the same operator is nested+ clauses -> Just $ parens interP p $ intercalateS interOp clauses - perhaps p pOuter op a b = result where- -- we don't know if the current operator is present until we render both operands. Rendering requires priority of the outer operator. We tie a knot to defer calculating the priority- (p', result) = case (go a p', go b p') of- (Just a', Just b') -> (p, Just $ parens p pOuter $ a' <> RenderS op id <> b')- (Just a', Nothing) -> (pOuter, Just a')- (Nothing, Just b') -> (pOuter, Just b')- (Nothing, Nothing) -> (pOuter, Nothing)+ renderComp interP interOp opP op expr1 expr2 = groupComparisons interP interOp opP $ renderZip opP op expr1 expr2+ renderCompOps interP interOp opP ops expr1 expr2 = groupComparisons interP interOp opP $ renderZip3 opP ops expr1 expr2+ go (CondRaw (Snippet f)) p = case f conf p of+ [] -> Nothing+ [a] -> Just a+ _ -> error "renderCond: cannot render CondRaw with many elements"+ go CondEmpty _ = Nothing + notP = 35+ andP = 30+ orP = 20++ perhaps p pOuter op a b = result+ where+ -- we don't know if the current operator is present until we render both operands. Rendering requires priority of the outer operator. We tie a knot to defer calculating the priority+ (p', result) = case (go a p', go b p') of+ (Just a', Just b') -> (p, Just $ parens p pOuter $ a' <> RenderS op id <> b')+ (Just a', Nothing) -> (pOuter, Just a')+ (Nothing, Just b') -> (pOuter, Just b')+ (Nothing, Nothing) -> (pOuter, Nothing)+ {- examples of prefixes-[("val1", DbEmbedded False _), ("val4", EmbeddedDef False _), ("val5", EmbeddedDef False _)] -> "val5$val4$val1"-[("val1", DbEmbedded True _), ("val4", EmbeddedDef False _), ("val5", EmbeddedDef False _)] -> ""-[("val1", DbEmbedded False _), ("val4", EmbeddedDef True _), ("val5", EmbeddedDef False _)] -> "val1"-[("val1", DbEmbedded False _), ("val4", EmbeddedDef True _), ("val5", EmbeddedDef True _)] -> "val1"-[("val1", DbEmbedded False _), ("val4", EmbeddedDef False _), ("val5", EmbeddedDef True _)] -> "val4$val1"+[("val1", EmbeddedDef False _), ("val4", EmbeddedDef False _), ("val5", EmbeddedDef False _)] -> "val5$val4$val1"+[("val1", EmbeddedDef True _), ("val4", EmbeddedDef False _), ("val5", EmbeddedDef False _)] -> ""+[("val1", EmbeddedDef False _), ("val4", EmbeddedDef True _), ("val5", EmbeddedDef False _)] -> "val1"+[("val1", EmbeddedDef False _), ("val4", EmbeddedDef True _), ("val5", EmbeddedDef True _)] -> "val1"+[("val1", EmbeddedDef False _), ("val4", EmbeddedDef False _), ("val5", EmbeddedDef True _)] -> "val4$val1" -}-{-# INLINABLE renderChain #-}+{-# INLINEABLE renderChain #-} renderChain :: RenderConfig -> FieldChain -> [Utf8] -> [Utf8]-renderChain RenderConfig{..} (f, prefix) acc = (case prefix of- ((name, EmbeddedDef False _):fs) -> flattenP esc (goP (fromString name) fs) f acc- _ -> flatten esc f acc) where- goP p ((name, EmbeddedDef False _):fs) = goP (fromString name <> fromChar delim <> p) fs- goP p _ = p+renderChain RenderConfig {..} (f, prefix) acc =+ case prefix of+ ((name, EmbeddedDef False _) : fs) -> flattenP esc (Just $ goP (fromString name) fs) f acc+ _ -> flatten esc f acc+ where+ goP p ((name, EmbeddedDef False _) : fs) = goP (fromString name <> fromChar delim <> p) fs+ goP p _ = p defaultShowPrim :: PersistValue -> String defaultShowPrim (PersistString x) = "'" ++ x ++ "'"+defaultShowPrim (PersistText x) = "'" ++ show x ++ "'" defaultShowPrim (PersistByteString x) = "'" ++ show x ++ "'" defaultShowPrim (PersistInt64 x) = show x defaultShowPrim (PersistDouble x) = show x@@ -246,20 +303,22 @@ defaultShowPrim (PersistTimeOfDay x) = show x defaultShowPrim (PersistUTCTime x) = show x defaultShowPrim (PersistZonedTime x) = show x-defaultShowPrim (PersistNull) = "NULL"+defaultShowPrim PersistNull = "NULL" defaultShowPrim (PersistCustom _ _) = error "Unexpected PersistCustom" -{-# INLINABLE renderOrders #-}+{-# INLINEABLE renderOrders #-} renderOrders :: SqlDb db => RenderConfig -> [Order db r] -> RenderS db r renderOrders _ [] = mempty-renderOrders conf xs = if null orders then mempty else " ORDER BY " <> commasJoin orders where- orders = concatMap go xs- rend conf' a = map (commasJoin . renderExprExtended conf' 0) $ projectionExprs a []- go (Asc a) = rend conf a- go (Desc a) = rend conf' a where- conf' = conf { esc = \f -> esc conf f <> " DESC" }+renderOrders conf xs = if null orders then mempty else " ORDER BY " <> commasJoin orders+ where+ orders = concatMap go xs+ rend conf' a = map (commasJoin . renderExprExtended conf' 0) $ projectionExprs a []+ go (Asc a) = rend conf a+ go (Desc a) = rend conf' a+ where+ conf' = conf {esc = \f -> esc conf f <> " DESC"} -{-# INLINABLE renderFields #-}+{-# INLINEABLE renderFields #-} -- Returns string with comma separated escaped fields like "name,age" -- If there are other columns before renderFields result, do not put comma because the result might be an empty string. This happens when the fields have no columns like (). -- One of the solutions is to add one more field with datatype that is known to have columns, eg renderFields id (("id", namedType (0 :: Int64)) : constrParams constr)@@ -267,26 +326,22 @@ renderFields :: StringLike s => (s -> s) -> [(String, DbType)] -> s renderFields escape = commasJoin . foldr (flatten escape) [] --- TODO: merge code of flatten and flattenP {-# SPECIALIZE flatten :: (Utf8 -> Utf8) -> (String, DbType) -> ([Utf8] -> [Utf8]) #-} flatten :: StringLike s => (s -> s) -> (String, DbType) -> ([s] -> [s])-flatten escape (fname, typ) acc = go typ where- go typ' = case typ' of- DbEmbedded emb _ -> handleEmb emb- _ -> escape fullName : acc- fullName = fromString fname- handleEmb (EmbeddedDef False ts) = foldr (flattenP escape fullName) acc ts- handleEmb (EmbeddedDef True ts) = foldr (flatten escape) acc ts+flatten escape = flattenP escape Nothing -{-# SPECIALIZE flattenP :: (Utf8 -> Utf8) -> Utf8 -> (String, DbType) -> ([Utf8] -> [Utf8]) #-}-flattenP :: StringLike s => (s -> s) -> s -> (String, DbType) -> ([s] -> [s])-flattenP escape prefix (fname, typ) acc = go typ where- go typ' = case typ' of- DbEmbedded emb _ -> handleEmb emb- _ -> escape fullName : acc- fullName = prefix <> fromChar delim <> fromString fname- handleEmb (EmbeddedDef False ts) = foldr (flattenP escape fullName) acc ts- handleEmb (EmbeddedDef True ts) = foldr (flatten escape) acc ts+{-# SPECIALIZE flattenP :: (Utf8 -> Utf8) -> Maybe Utf8 -> (String, DbType) -> ([Utf8] -> [Utf8]) #-}+flattenP :: StringLike s => (s -> s) -> Maybe s -> (String, DbType) -> ([s] -> [s])+flattenP escape prefix (fname, typ) acc = go typ+ where+ go typ' = case typ' of+ DbEmbedded emb _ -> handleEmb emb+ _ -> escape fullName : acc+ fullName = case prefix of+ Nothing -> fromString fname+ Just prefix' -> prefix' <> fromChar delim <> fromString fname+ handleEmb (EmbeddedDef False ts) = foldr (flattenP escape (Just fullName)) acc ts+ handleEmb (EmbeddedDef True ts) = foldr (flattenP escape Nothing) acc ts commasJoin :: StringLike s => [s] -> s commasJoin = intercalateS (fromChar ',')@@ -294,33 +349,41 @@ {-# INLINEABLE intercalateS #-} intercalateS :: StringLike s => s -> [s] -> s intercalateS _ [] = mempty-intercalateS a (x:xs) = x <> go xs where- go [] = mempty- go (f:fs) = a <> f <> go fs+intercalateS a (x : xs) = x <> go xs+ where+ go [] = mempty+ go (f : fs) = a <> f <> go fs -{-# INLINABLE renderUpdates #-}+{-# INLINEABLE renderUpdates #-} renderUpdates :: SqlDb db => RenderConfig -> [Update db r] -> Maybe (RenderS db r)-renderUpdates conf upds = (case mapMaybe go upds of- [] -> Nothing- xs -> Just $ commasJoin xs) where- go (Update field expr) = guard $ commasJoin $ zipWith (\f1 f2 -> f1 <> fromChar '=' <> f2) fs (rend expr) where- rend = renderExprExtended conf 0- fs = concatMap rend (projectionExprs field [])- guard a = if null fs then Nothing else Just a+renderUpdates conf upds =+ case mapMaybe go upds of+ [] -> Nothing+ xs -> Just $ commasJoin xs+ where+ go (Update field expr) = guard $ commasJoin $ zipWith (\f1 f2 -> f1 <> fromChar '=' <> f2) fs (rend expr)+ where+ rend = renderExprExtended conf 0+ fs = concatMap rend (projectionExprs field [])+ guard a = if null fs then Nothing else Just a -- | Returns escaped table name optionally qualified with schema {-# SPECIALIZE tableName :: (Utf8 -> Utf8) -> EntityDef -> ConstructorDef -> Utf8 #-} tableName :: StringLike s => (s -> s) -> EntityDef -> ConstructorDef -> s-tableName esc e c = qualifySchema esc e tName where- tName = esc $ if isSimple (constructors e)- then fromString $ entityName e- else fromString (entityName e) <> fromChar delim <> fromString (constrName c)+tableName esc e c = qualifySchema esc e tName+ where+ tName =+ esc $+ if isSimple (constructors e)+ then fromString $ entityName e+ else fromString (entityName e) <> fromChar delim <> fromString (constrName c) -- | Returns escaped main table name optionally qualified with schema {-# SPECIALIZE mainTableName :: (Utf8 -> Utf8) -> EntityDef -> Utf8 #-} mainTableName :: StringLike s => (s -> s) -> EntityDef -> s-mainTableName esc e = qualifySchema esc e tName where- tName = esc $ fromString $ entityName e+mainTableName esc e = qualifySchema esc e tName+ where+ tName = esc $ fromString $ entityName e {-# SPECIALIZE qualifySchema :: (Utf8 -> Utf8) -> EntityDef -> Utf8 -> Utf8 #-} qualifySchema :: StringLike s => (s -> s) -> EntityDef -> s -> s
Database/Groundhog/Generic/Sql/Functions.hs view
@@ -1,21 +1,25 @@-{-# LANGUAGE FlexibleContexts, TypeFamilies, OverloadedStrings, UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | This module has common SQL functions and operators which are supported in the most SQL databases module Database.Groundhog.Generic.Sql.Functions- ( like- , notLike- , in_- , notIn_- , lower- , upper- , case_- , SqlDb(..)- , cot- , atan2- , radians- , degrees- ) where+ ( like,+ notLike,+ in_,+ notIn_,+ lower,+ upper,+ case_,+ SqlDb (..),+ cot,+ atan2,+ radians,+ degrees,+ )+where import Data.Int (Int64) import Data.String@@ -23,13 +27,19 @@ import Database.Groundhog.Expression import Database.Groundhog.Generic.Sql -in_ :: (SqlDb db, Expression db r a, Expression db r b, PrimitivePersistField b, Unifiable a b) =>- a -> [b] -> Cond db r+in_ ::+ (SqlDb db, Expression db r a, Expression db r b, PrimitivePersistField b, Unifiable a b) =>+ a ->+ [b] ->+ Cond db r in_ _ [] = Not CondEmpty in_ a bs = CondRaw $ Snippet $ \conf p -> [parens 45 p $ renderExpr conf (toExpr a) <> " IN (" <> commasJoin (map (renderExpr conf . toExpr) bs) <> ")"] -notIn_ :: (SqlDb db, Expression db r a, Expression db r b, PrimitivePersistField b, Unifiable a b) =>- a -> [b] -> Cond db r+notIn_ ::+ (SqlDb db, Expression db r a, Expression db r b, PrimitivePersistField b, Unifiable a b) =>+ a ->+ [b] ->+ Cond db r notIn_ _ [] = CondEmpty notIn_ a bs = CondRaw $ Snippet $ \conf p -> [parens 45 p $ renderExpr conf (toExpr a) <> " NOT IN (" <> commasJoin (map (renderExpr conf . toExpr) bs) <> ")"] @@ -77,9 +87,9 @@ asin x = mkExpr $ function "asin" [toExpr x] atan x = mkExpr $ function "atan" [toExpr x] acos x = mkExpr $ function "acos" [toExpr x]- sinh x = (exp x - exp (-x)) / 2+ sinh x = (exp x - exp (- x)) / 2 tanh x = (exp (2 * x) - 1) / (exp (2 * x) + 1)- cosh x = (exp x + exp (-x)) / 2+ cosh x = (exp x + exp (- x)) / 2 asinh x = log $ x + sqrt (x * x + 1) atanh x = log ((1 + x) / (1 - x)) / 2 acosh x = log $ x + sqrt (x * x - 1)@@ -99,32 +109,45 @@ instance (SqlDb db, PurePersistField a, Integral a) => Integral (Expr db r a) where quotRem x y = quotRem' x y- divMod x y = (div', mod') where- div' = mkExprWithConf $ \conf _ -> let- x' = prerenderExpr conf x- y' = prerenderExpr conf y- in case_ [ (x' >. zero &&. y' <. zero, (x' - y' - 1) `quot` y')- , (x' <. zero &&. y' >. zero, (x' - y' + 1) `quot` y')- ] (x' `quot` y')- mod' = mkExprWithConf $ \conf _ -> let- x' = prerenderExpr conf x- y' = prerenderExpr conf y- in case_ [ (x' >. zero &&. y' <. zero ||. x' <. zero &&. y' >. zero,- case_ [((x' `rem` y') /=. zero, x' `rem` y' + y')] zero)- ] (x' `rem` y')- zero = 0 `asTypeOf` ((undefined :: Expr db r a -> a) x)+ divMod x y = (div', mod')+ where+ div' = mkExprWithConf $ \conf _ ->+ let x' = prerenderExpr conf x+ y' = prerenderExpr conf y+ in case_+ [ (x' >. zero &&. y' <. zero, (x' - y' - 1) `quot` y'),+ (x' <. zero &&. y' >. zero, (x' - y' + 1) `quot` y')+ ]+ (x' `quot` y')+ mod' = mkExprWithConf $ \conf _ ->+ let x' = prerenderExpr conf x+ y' = prerenderExpr conf y+ in case_+ [ ( x' >. zero &&. y' <. zero ||. x' <. zero &&. y' >. zero,+ case_ [((x' `rem` y') /=. zero, x' `rem` y' + y')] zero+ )+ ]+ (x' `rem` y')+ zero = 0 `asTypeOf` (undefined :: Expr db r a -> a) x toInteger = error "toInteger: instance Integral (Expr db r a) does not have implementation" -case_ :: (SqlDb db, ExpressionOf db r a a', ExpressionOf db r b a')- => [(Cond db r, a)] -- ^ Conditions- -> b -- ^ It is returned when none of conditions is true- -> Expr db r a'+case_ ::+ (SqlDb db, ExpressionOf db r a a', ExpressionOf db r b a') =>+ -- | Conditions+ [(Cond db r, a)] ->+ -- | It is returned when none of conditions is true+ b ->+ Expr db r a' case_ [] else_ = Expr $ toExpr else_-case_ cases else_ = mkExpr $ Snippet $ \conf _ ->- ["case "- <> intercalateS (fromChar ' ') (map (rend conf) cases)- <> " else " <> renderExpr conf (toExpr else_)- <> " end"] where- rend conf (cond, a) = case renderCond conf cond of- Nothing -> error "case_: empty condition"- Just cond' -> "when " <> cond' <> " then " <> renderExpr conf (toExpr a)+case_ cases else_ = mkExpr $+ Snippet $ \conf _ ->+ [ "case "+ <> intercalateS (fromChar ' ') (map (rend conf) cases)+ <> " else "+ <> renderExpr conf (toExpr else_)+ <> " end"+ ]+ where+ rend conf (cond, a) = case renderCond conf cond of+ Nothing -> error "case_: empty condition"+ Just cond' -> "when " <> cond' <> " then " <> renderExpr conf (toExpr a)
Database/Groundhog/Instances.hs view
@@ -1,31 +1,32 @@-{-# LANGUAGE TypeFamilies, GADTs, TypeSynonymInstances, OverlappingInstances, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, CPP, ConstraintKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-}-module Database.Groundhog.Instances (Selector(..)) where -import Database.Groundhog.Core-import Database.Groundhog.Generic (primToPersistValue, primFromPersistValue, primToPurePersistValues, primFromPurePersistValues, primToSinglePersistValue, primFromSinglePersistValue, phantomDb, getUniqueFields)+module Database.Groundhog.Instances (Selector (..)) where import qualified Data.Aeson as A-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Text.Encoding.Error as T-#if MIN_VERSION_base(4, 7, 0) import Data.Bits (finiteBitSize)-#else-import Data.Bits (bitSize)-#endif+import qualified Data.ByteString.Base64 as B64 import Data.ByteString.Char8 (ByteString, unpack) import qualified Data.ByteString.Lazy.Char8 as Lazy-import qualified Data.ByteString.Base64 as B64-import Data.Int (Int8, Int16, Int32, Int64)-import Data.Time (Day, TimeOfDay, UTCTime)-import Data.Time.LocalTime (ZonedTime, zonedTimeToUTC, utc, utcToZonedTime)-import Data.Word (Word8, Word16, Word32, Word64)-#if MIN_VERSION_aeson(0, 7, 0)+import Data.Int (Int16, Int32, Int64, Int8)+import Data.Kind (Type)+import Data.Maybe (fromMaybe) import qualified Data.Scientific-#else-import qualified Data.Attoparsec.Number as AN-#endif+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Encoding.Error as T+import qualified Data.Text.Lazy as TL+import Data.Time (Day, TimeOfDay, UTCTime)+import Data.Time.LocalTime (ZonedTime, utc, utcToZonedTime, zonedTimeToUTC)+import Data.Word (Word16, Word32, Word64, Word8)+import Database.Groundhog.Core+import Database.Groundhog.Generic (getUniqueFields, primFromPersistValue, primFromPurePersistValues, primFromSinglePersistValue, primToPersistValue, primToPurePersistValues, primToSinglePersistValue) instance (PersistField a', PersistField b') => Embedded (a', b') where data Selector (a', b') constr where@@ -68,208 +69,252 @@ selectorNum Tuple5_4Selector = 4 instance PurePersistField () where- toPurePersistValues _ _ = id- fromPurePersistValues _ xs = ((), xs)+ toPurePersistValues _ = id+ fromPurePersistValues xs = ((), xs) instance (PurePersistField a, PurePersistField b) => PurePersistField (a, b) where- toPurePersistValues p (a, b) = toPurePersistValues p a . toPurePersistValues p b- fromPurePersistValues p xs = let- (a, rest0) = fromPurePersistValues p xs- (b, rest1) = fromPurePersistValues p rest0- in ((a, b), rest1)+ toPurePersistValues (a, b) = toPurePersistValues a . toPurePersistValues b+ fromPurePersistValues xs =+ let (a, rest0) = fromPurePersistValues xs+ (b, rest1) = fromPurePersistValues rest0+ in ((a, b), rest1) instance (PurePersistField a, PurePersistField b, PurePersistField c) => PurePersistField (a, b, c) where- toPurePersistValues p (a, b, c) = toPurePersistValues p a . toPurePersistValues p b . toPurePersistValues p c- fromPurePersistValues p xs = let- (a, rest0) = fromPurePersistValues p xs- (b, rest1) = fromPurePersistValues p rest0- (c, rest2) = fromPurePersistValues p rest1- in ((a, b, c), rest2)- + toPurePersistValues (a, b, c) = toPurePersistValues a . toPurePersistValues b . toPurePersistValues c+ fromPurePersistValues xs =+ let (a, rest0) = fromPurePersistValues xs+ (b, rest1) = fromPurePersistValues rest0+ (c, rest2) = fromPurePersistValues rest1+ in ((a, b, c), rest2)+ instance (PurePersistField a, PurePersistField b, PurePersistField c, PurePersistField d) => PurePersistField (a, b, c, d) where- toPurePersistValues p (a, b, c, d) = toPurePersistValues p a . toPurePersistValues p b . toPurePersistValues p c . toPurePersistValues p d- fromPurePersistValues p xs = let- (a, rest0) = fromPurePersistValues p xs- (b, rest1) = fromPurePersistValues p rest0- (c, rest2) = fromPurePersistValues p rest1- (d, rest3) = fromPurePersistValues p rest2- in ((a, b, c, d), rest3)- + toPurePersistValues (a, b, c, d) = toPurePersistValues a . toPurePersistValues b . toPurePersistValues c . toPurePersistValues d+ fromPurePersistValues xs =+ let (a, rest0) = fromPurePersistValues xs+ (b, rest1) = fromPurePersistValues rest0+ (c, rest2) = fromPurePersistValues rest1+ (d, rest3) = fromPurePersistValues rest2+ in ((a, b, c, d), rest3)+ instance (PurePersistField a, PurePersistField b, PurePersistField c, PurePersistField d, PurePersistField e) => PurePersistField (a, b, c, d, e) where- toPurePersistValues p (a, b, c, d, e) = toPurePersistValues p a . toPurePersistValues p b . toPurePersistValues p c . toPurePersistValues p d . toPurePersistValues p e- fromPurePersistValues p xs = let- (a, rest0) = fromPurePersistValues p xs- (b, rest1) = fromPurePersistValues p rest0- (c, rest2) = fromPurePersistValues p rest1- (d, rest3) = fromPurePersistValues p rest2- (e, rest4) = fromPurePersistValues p rest3- in ((a, b, c, d, e), rest4)+ toPurePersistValues (a, b, c, d, e) = toPurePersistValues a . toPurePersistValues b . toPurePersistValues c . toPurePersistValues d . toPurePersistValues e+ fromPurePersistValues xs =+ let (a, rest0) = fromPurePersistValues xs+ (b, rest1) = fromPurePersistValues rest0+ (c, rest2) = fromPurePersistValues rest1+ (d, rest3) = fromPurePersistValues rest2+ (e, rest4) = fromPurePersistValues rest3+ in ((a, b, c, d, e), rest4) instance PrimitivePersistField String where- toPrimitivePersistValue _ s = PersistString s- fromPrimitivePersistValue _ (PersistString s) = s- fromPrimitivePersistValue _ (PersistByteString bs) = T.unpack $ T.decodeUtf8With T.lenientDecode bs- fromPrimitivePersistValue _ (PersistInt64 i) = show i- fromPrimitivePersistValue _ (PersistDouble d) = show d- fromPrimitivePersistValue _ (PersistDay d) = show d- fromPrimitivePersistValue _ (PersistTimeOfDay d) = show d- fromPrimitivePersistValue _ (PersistUTCTime d) = show d- fromPrimitivePersistValue _ (PersistZonedTime z) = show z- fromPrimitivePersistValue _ (PersistBool b) = show b- fromPrimitivePersistValue _ PersistNull = error "Unexpected NULL"- fromPrimitivePersistValue _ (PersistCustom _ _) = error "Unexpected PersistCustom"+ toPrimitivePersistValue s = PersistText (T.pack s)+ fromPrimitivePersistValue (PersistString s) = s+ fromPrimitivePersistValue (PersistText s) = T.unpack s+ fromPrimitivePersistValue (PersistByteString bs) = T.unpack $ T.decodeUtf8With T.lenientDecode bs+ fromPrimitivePersistValue (PersistInt64 i) = show i+ fromPrimitivePersistValue (PersistDouble d) = show d+ fromPrimitivePersistValue (PersistDay d) = show d+ fromPrimitivePersistValue (PersistTimeOfDay d) = show d+ fromPrimitivePersistValue (PersistUTCTime d) = show d+ fromPrimitivePersistValue (PersistZonedTime z) = show z+ fromPrimitivePersistValue (PersistBool b) = show b+ fromPrimitivePersistValue PersistNull = error "Unexpected NULL"+ fromPrimitivePersistValue (PersistCustom _ _) = error "Unexpected PersistCustom" instance PrimitivePersistField T.Text where- toPrimitivePersistValue _ a = PersistString (T.unpack a)- fromPrimitivePersistValue _ (PersistByteString bs) = T.decodeUtf8With T.lenientDecode bs- fromPrimitivePersistValue p x = T.pack $ fromPrimitivePersistValue p x+ toPrimitivePersistValue s = PersistText s+ fromPrimitivePersistValue (PersistText s) = s+ fromPrimitivePersistValue (PersistByteString bs) = T.decodeUtf8With T.lenientDecode bs+ fromPrimitivePersistValue x = T.pack $ fromPrimitivePersistValue x +instance PrimitivePersistField TL.Text where+ toPrimitivePersistValue s = toPrimitivePersistValue (TL.toStrict s)+ fromPrimitivePersistValue x = TL.fromStrict $ fromPrimitivePersistValue x+ instance PrimitivePersistField ByteString where- toPrimitivePersistValue _ s = PersistByteString s- fromPrimitivePersistValue _ (PersistByteString a) = a- fromPrimitivePersistValue p x = T.encodeUtf8 . T.pack $ fromPrimitivePersistValue p x+ toPrimitivePersistValue s = PersistByteString s+ fromPrimitivePersistValue (PersistByteString a) = a+ fromPrimitivePersistValue x = T.encodeUtf8 . T.pack $ fromPrimitivePersistValue x instance PrimitivePersistField Lazy.ByteString where- toPrimitivePersistValue _ s = PersistByteString $ Lazy.toStrict s- fromPrimitivePersistValue _ (PersistByteString a) = Lazy.fromStrict a- fromPrimitivePersistValue p x = Lazy.fromStrict . T.encodeUtf8 . T.pack $ fromPrimitivePersistValue p x+ toPrimitivePersistValue s = PersistByteString $ Lazy.toStrict s+ fromPrimitivePersistValue (PersistByteString a) = Lazy.fromStrict a+ fromPrimitivePersistValue x = Lazy.fromStrict . T.encodeUtf8 . T.pack $ fromPrimitivePersistValue x instance PrimitivePersistField Int where- toPrimitivePersistValue _ a = PersistInt64 (fromIntegral a)- fromPrimitivePersistValue _ (PersistInt64 a) = fromIntegral a- fromPrimitivePersistValue _ (PersistDouble a) = truncate a- fromPrimitivePersistValue _ x = readHelper x ("Expected Integer, received: " ++ show x)+ toPrimitivePersistValue a = PersistInt64 (fromIntegral a)+ fromPrimitivePersistValue (PersistInt64 a) = fromIntegral a+ fromPrimitivePersistValue (PersistDouble a) = truncate a+ fromPrimitivePersistValue x = readHelper x ("Expected Integer, received: " ++ show x) instance PrimitivePersistField Int8 where- toPrimitivePersistValue _ a = PersistInt64 (fromIntegral a)- fromPrimitivePersistValue _ (PersistInt64 a) = fromIntegral a- fromPrimitivePersistValue _ (PersistDouble a) = truncate a- fromPrimitivePersistValue _ x = readHelper x ("Expected Integer, received: " ++ show x)+ toPrimitivePersistValue a = PersistInt64 (fromIntegral a)+ fromPrimitivePersistValue (PersistInt64 a) = fromIntegral a+ fromPrimitivePersistValue (PersistDouble a) = truncate a+ fromPrimitivePersistValue x = readHelper x ("Expected Integer, received: " ++ show x) instance PrimitivePersistField Int16 where- toPrimitivePersistValue _ a = PersistInt64 (fromIntegral a)- fromPrimitivePersistValue _ (PersistInt64 a) = fromIntegral a- fromPrimitivePersistValue _ (PersistDouble a) = truncate a- fromPrimitivePersistValue _ x = readHelper x ("Expected Integer, received: " ++ show x)+ toPrimitivePersistValue a = PersistInt64 (fromIntegral a)+ fromPrimitivePersistValue (PersistInt64 a) = fromIntegral a+ fromPrimitivePersistValue (PersistDouble a) = truncate a+ fromPrimitivePersistValue x = readHelper x ("Expected Integer, received: " ++ show x) instance PrimitivePersistField Int32 where- toPrimitivePersistValue _ a = PersistInt64 (fromIntegral a)- fromPrimitivePersistValue _ (PersistInt64 a) = fromIntegral a- fromPrimitivePersistValue _ (PersistDouble a) = truncate a- fromPrimitivePersistValue _ x = readHelper x ("Expected Integer, received: " ++ show x)+ toPrimitivePersistValue a = PersistInt64 (fromIntegral a)+ fromPrimitivePersistValue (PersistInt64 a) = fromIntegral a+ fromPrimitivePersistValue (PersistDouble a) = truncate a+ fromPrimitivePersistValue x = readHelper x ("Expected Integer, received: " ++ show x) instance PrimitivePersistField Int64 where- toPrimitivePersistValue _ a = PersistInt64 (fromIntegral a)- fromPrimitivePersistValue _ (PersistInt64 a) = a- fromPrimitivePersistValue _ (PersistDouble a) = truncate a- fromPrimitivePersistValue _ x = readHelper x ("Expected Integer, received: " ++ show x)+ toPrimitivePersistValue a = PersistInt64 (fromIntegral a)+ fromPrimitivePersistValue (PersistInt64 a) = a+ fromPrimitivePersistValue (PersistDouble a) = truncate a+ fromPrimitivePersistValue x = readHelper x ("Expected Integer, received: " ++ show x) instance PrimitivePersistField Word8 where- toPrimitivePersistValue _ a = PersistInt64 (fromIntegral a)- fromPrimitivePersistValue _ (PersistInt64 a) = fromIntegral a- fromPrimitivePersistValue _ (PersistDouble a) = truncate a- fromPrimitivePersistValue _ x = readHelper x ("Expected Integer, received: " ++ show x)+ toPrimitivePersistValue a = PersistInt64 (fromIntegral a)+ fromPrimitivePersistValue (PersistInt64 a) = fromIntegral a+ fromPrimitivePersistValue (PersistDouble a) = truncate a+ fromPrimitivePersistValue x = readHelper x ("Expected Integer, received: " ++ show x) instance PrimitivePersistField Word16 where- toPrimitivePersistValue _ a = PersistInt64 (fromIntegral a)- fromPrimitivePersistValue _ (PersistInt64 a) = fromIntegral a- fromPrimitivePersistValue _ (PersistDouble a) = truncate a- fromPrimitivePersistValue _ x = readHelper x ("Expected Integer, received: " ++ show x)+ toPrimitivePersistValue a = PersistInt64 (fromIntegral a)+ fromPrimitivePersistValue (PersistInt64 a) = fromIntegral a+ fromPrimitivePersistValue (PersistDouble a) = truncate a+ fromPrimitivePersistValue x = readHelper x ("Expected Integer, received: " ++ show x) instance PrimitivePersistField Word32 where- toPrimitivePersistValue _ a = PersistInt64 (fromIntegral a)- fromPrimitivePersistValue _ (PersistInt64 a) = fromIntegral a- fromPrimitivePersistValue _ (PersistDouble a) = truncate a- fromPrimitivePersistValue _ x = readHelper x ("Expected Integer, received: " ++ show x)+ toPrimitivePersistValue a = PersistInt64 (fromIntegral a)+ fromPrimitivePersistValue (PersistInt64 a) = fromIntegral a+ fromPrimitivePersistValue (PersistDouble a) = truncate a+ fromPrimitivePersistValue x = readHelper x ("Expected Integer, received: " ++ show x) instance PrimitivePersistField Word64 where- toPrimitivePersistValue _ a = PersistInt64 (fromIntegral a)- fromPrimitivePersistValue _ (PersistInt64 a) = fromIntegral a- fromPrimitivePersistValue _ (PersistDouble a) = truncate a- fromPrimitivePersistValue _ x = readHelper x ("Expected Integer, received: " ++ show x)+ toPrimitivePersistValue a = PersistInt64 (fromIntegral a)+ fromPrimitivePersistValue (PersistInt64 a) = fromIntegral a+ fromPrimitivePersistValue (PersistDouble a) = truncate a+ fromPrimitivePersistValue x = readHelper x ("Expected Integer, received: " ++ show x) instance PrimitivePersistField Double where- toPrimitivePersistValue _ a = PersistDouble a- fromPrimitivePersistValue _ (PersistDouble a) = a- fromPrimitivePersistValue _ (PersistInt64 a) = fromIntegral a- fromPrimitivePersistValue _ x = readHelper x ("Expected Double, received: " ++ show x)+ toPrimitivePersistValue a = PersistDouble a+ fromPrimitivePersistValue (PersistDouble a) = a+ fromPrimitivePersistValue (PersistInt64 a) = fromIntegral a+ fromPrimitivePersistValue x = readHelper x ("Expected Double, received: " ++ show x) instance PrimitivePersistField Bool where- toPrimitivePersistValue _ a = PersistBool a- fromPrimitivePersistValue _ (PersistBool a) = a- fromPrimitivePersistValue _ (PersistInt64 i) = i /= 0- fromPrimitivePersistValue _ x = error $ "Expected Bool, received: " ++ show x+ toPrimitivePersistValue a = PersistBool a+ fromPrimitivePersistValue (PersistBool a) = a+ fromPrimitivePersistValue (PersistInt64 i) = i /= 0+ fromPrimitivePersistValue x = error $ "Expected Bool, received: " ++ show x instance PrimitivePersistField Day where- toPrimitivePersistValue _ a = PersistDay a- fromPrimitivePersistValue _ (PersistDay a) = a- fromPrimitivePersistValue _ x = readHelper x ("Expected Day, received: " ++ show x)+ toPrimitivePersistValue a = PersistDay a+ fromPrimitivePersistValue (PersistDay a) = a+ fromPrimitivePersistValue x = readHelper x ("Expected Day, received: " ++ show x) instance PrimitivePersistField TimeOfDay where- toPrimitivePersistValue _ a = PersistTimeOfDay a- fromPrimitivePersistValue _ (PersistTimeOfDay a) = a- fromPrimitivePersistValue _ x = readHelper x ("Expected TimeOfDay, received: " ++ show x)+ toPrimitivePersistValue a = PersistTimeOfDay a+ fromPrimitivePersistValue (PersistTimeOfDay a) = a+ fromPrimitivePersistValue x = readHelper x ("Expected TimeOfDay, received: " ++ show x) instance PrimitivePersistField UTCTime where- toPrimitivePersistValue _ a = PersistUTCTime a- fromPrimitivePersistValue _ (PersistUTCTime a) = a- fromPrimitivePersistValue _ (PersistZonedTime (ZT a)) = zonedTimeToUTC a- fromPrimitivePersistValue _ x = readHelper x ("Expected UTCTime, received: " ++ show x)+ toPrimitivePersistValue a = PersistUTCTime a+ fromPrimitivePersistValue (PersistUTCTime a) = a+ fromPrimitivePersistValue (PersistZonedTime (ZT a)) = zonedTimeToUTC a+ fromPrimitivePersistValue x = readHelper x ("Expected UTCTime, received: " ++ show x) instance PrimitivePersistField ZonedTime where- toPrimitivePersistValue _ a = PersistZonedTime (ZT a)- fromPrimitivePersistValue _ (PersistZonedTime (ZT a)) = a- fromPrimitivePersistValue _ (PersistUTCTime a) = utcToZonedTime utc a- fromPrimitivePersistValue _ x = readHelper x ("Expected ZonedTime, received: " ++ show x)+ toPrimitivePersistValue a = PersistZonedTime (ZT a)+ fromPrimitivePersistValue (PersistZonedTime (ZT a)) = a+ fromPrimitivePersistValue (PersistUTCTime a) = utcToZonedTime utc a+ fromPrimitivePersistValue x = readHelper x ("Expected ZonedTime, received: " ++ show x) +instance PrimitivePersistField A.Value where+ toPrimitivePersistValue a = PersistByteString $ Lazy.toStrict $ A.encode a+ fromPrimitivePersistValue x =+ case x of+ PersistString str -> decode' $ T.encodeUtf8 $ T.pack str+ PersistText str -> decode' $ T.encodeUtf8 str+ PersistByteString str -> decode' str+ _ -> error $ "Expected Aeson.Value, received: " ++ show x+ where+ decode' str = case A.eitherDecode $ Lazy.fromStrict str of+ Right val -> val+ Left err -> error $ "Error decoding Aeson.Value: " ++ err+ instance (PrimitivePersistField a, NeverNull a) => PrimitivePersistField (Maybe a) where- toPrimitivePersistValue p a = maybe PersistNull (toPrimitivePersistValue p) a- fromPrimitivePersistValue _ PersistNull = Nothing- fromPrimitivePersistValue p x = Just $ fromPrimitivePersistValue p x+ toPrimitivePersistValue a = maybe PersistNull toPrimitivePersistValue a+ fromPrimitivePersistValue PersistNull = Nothing+ fromPrimitivePersistValue x = Just $ fromPrimitivePersistValue x instance (DbDescriptor db, PersistEntity v, PersistField v) => PrimitivePersistField (KeyForBackend db v) where- toPrimitivePersistValue p (KeyForBackend a) = toPrimitivePersistValue p a- fromPrimitivePersistValue p x = KeyForBackend (fromPrimitivePersistValue p x)+ toPrimitivePersistValue (KeyForBackend a) = toPrimitivePersistValue a+ fromPrimitivePersistValue x = KeyForBackend (fromPrimitivePersistValue x) -instance PrimitivePersistField a => PurePersistField a where+instance {-# OVERLAPPABLE #-} (PersistField a, PrimitivePersistField a) => PurePersistField a where toPurePersistValues = primToPurePersistValues fromPurePersistValues = primFromPurePersistValues -instance PrimitivePersistField a => SinglePersistField a where+instance {-# OVERLAPPABLE #-} (PersistField a, PrimitivePersistField a) => SinglePersistField a where toSinglePersistValue = primToSinglePersistValue fromSinglePersistValue = primFromSinglePersistValue instance NeverNull String+ instance NeverNull T.Text++instance NeverNull TL.Text+ instance NeverNull ByteString+ instance NeverNull Lazy.ByteString+ instance NeverNull Int+ instance NeverNull Int8+ instance NeverNull Int16+ instance NeverNull Int32+ instance NeverNull Int64+ instance NeverNull Word8+ instance NeverNull Word16+ instance NeverNull Word32+ instance NeverNull Word64+ instance NeverNull Double+ instance NeverNull Bool+ instance NeverNull Day+ instance NeverNull TimeOfDay+ instance NeverNull UTCTime+ instance NeverNull ZonedTime++instance NeverNull A.Value+ instance PrimitivePersistField (Key v u) => NeverNull (Key v u)+ instance NeverNull (KeyForBackend db v) readHelper :: Read a => PersistValue -> String -> a readHelper s errMessage = case s of PersistString str -> readHelper' str+ PersistText str -> readHelper' (T.unpack str) PersistByteString str -> readHelper' (unpack str) _ -> error $ "readHelper: " ++ errMessage where readHelper' str = case reads str of- (a, _):_ -> a- _ -> error $ "readHelper: " ++ errMessage+ (a, _) : _ -> a+ _ -> error $ "readHelper: " ++ errMessage instance PersistField ByteString where persistName _ = "ByteString"@@ -283,6 +328,12 @@ fromPersistValues = primFromPersistValue dbType _ _ = DbTypePrimitive DbBlob False Nothing Nothing +instance PersistField A.Value where+ persistName _ = "JsonValue"+ toPersistValues = primToPersistValue+ fromPersistValues = primFromPersistValue+ dbType _ _ = DbTypePrimitive DbBlob False Nothing Nothing+ instance PersistField String where persistName _ = "String" toPersistValues = primToPersistValue@@ -295,16 +346,22 @@ fromPersistValues = primFromPersistValue dbType _ _ = DbTypePrimitive DbString False Nothing Nothing +instance PersistField TL.Text where+ persistName _ = "Text"+ toPersistValues = primToPersistValue+ fromPersistValues = primFromPersistValue+ dbType _ _ = DbTypePrimitive DbString False Nothing Nothing+ instance PersistField Int where persistName _ = "Int" toPersistValues = primToPersistValue fromPersistValues = primFromPersistValue dbType _ a = DbTypePrimitive (if finiteBitSize a == 32 then DbInt32 else DbInt64) False Nothing Nothing where+ #if !MIN_VERSION_base(4, 7, 0) finiteBitSize = bitSize #endif - instance PersistField Int8 where persistName _ = "Int8" toPersistValues = primToPersistValue@@ -394,28 +451,28 @@ -- instance (SinglePersistField a, NeverNull a) => PersistField (Maybe a) where -- HANGS instance (PersistField a, NeverNull a) => PersistField (Maybe a) where persistName a = "Maybe" ++ delim : persistName ((undefined :: Maybe a -> a) a)- toPersistValues Nothing = return (PersistNull:)+ toPersistValues Nothing = pure (PersistNull :) toPersistValues (Just a) = toPersistValues a fromPersistValues [] = fail "fromPersistValues Maybe: empty list"- fromPersistValues (PersistNull:xs) = return (Nothing, xs)- fromPersistValues xs = fromPersistValues xs >>= \(x, xs') -> return (Just x, xs')+ fromPersistValues (PersistNull : xs) = pure (Nothing, xs)+ fromPersistValues xs = fromPersistValues xs >>= \(x, xs') -> pure (Just x, xs') dbType db a = case dbType db ((undefined :: Maybe a -> a) a) of DbTypePrimitive t _ def ref -> DbTypePrimitive t True def ref DbEmbedded (EmbeddedDef concatName [(field, DbTypePrimitive t _ def ref')]) ref -> DbEmbedded (EmbeddedDef concatName [(field, DbTypePrimitive t True def ref')]) ref t -> error $ "dbType " ++ persistName a ++ ": expected DbTypePrimitive or DbEmbedded with one field, got " ++ show t -instance (PersistField a) => PersistField [a] where+instance {-# OVERLAPPABLE #-} (PersistField a) => PersistField [a] where persistName a = "List" ++ delim : delim : persistName ((undefined :: [] a -> a) a) toPersistValues l = insertList l >>= toPersistValues fromPersistValues [] = fail "fromPersistValues []: empty list"- fromPersistValues (x:xs) = phantomDb >>= \p -> getList (fromPrimitivePersistValue p x) >>= \l -> return (l, xs)+ fromPersistValues (x : xs) = getList (fromPrimitivePersistValue x) >>= \l -> pure (l, xs) dbType db a = DbList (persistName a) $ dbType db ((undefined :: [] a -> a) a) instance PersistField () where persistName _ = "Unit" ++ [delim]- toPersistValues _ = return id- fromPersistValues xs = return ((), xs)+ toPersistValues _ = pure id+ fromPersistValues xs = pure ((), xs) dbType _ _ = DbEmbedded (EmbeddedDef False []) Nothing instance (PersistField a, PersistField b) => PersistField (a, b) where@@ -423,27 +480,27 @@ toPersistValues (a, b) = do a' <- toPersistValues a b' <- toPersistValues b- return $ a' . b'+ pure $ a' . b' fromPersistValues xs = do (a, rest0) <- fromPersistValues xs (b, rest1) <- fromPersistValues rest0- return ((a, b), rest1)+ pure ((a, b), rest1) dbType db a = DbEmbedded (EmbeddedDef False [("val0", dbType db ((undefined :: (a, b) -> a) a)), ("val1", dbType db ((undefined :: (a, b) -> b) a))]) Nothing- + instance (PersistField a, PersistField b, PersistField c) => PersistField (a, b, c) where persistName a = "Tuple3" ++ delim : delim : persistName ((undefined :: (a, b, c) -> a) a) ++ delim : persistName ((undefined :: (a, b, c) -> b) a) ++ delim : persistName ((undefined :: (a, b, c) -> c) a) toPersistValues (a, b, c) = do a' <- toPersistValues a b' <- toPersistValues b c' <- toPersistValues c- return $ a' . b' . c'+ pure $ a' . b' . c' fromPersistValues xs = do (a, rest0) <- fromPersistValues xs (b, rest1) <- fromPersistValues rest0 (c, rest2) <- fromPersistValues rest1- return ((a, b, c), rest2)+ pure ((a, b, c), rest2) dbType db a = DbEmbedded (EmbeddedDef False [("val0", dbType db ((undefined :: (a, b, c) -> a) a)), ("val1", dbType db ((undefined :: (a, b, c) -> b) a)), ("val2", dbType db ((undefined :: (a, b, c) -> c) a))]) Nothing- + instance (PersistField a, PersistField b, PersistField c, PersistField d) => PersistField (a, b, c, d) where persistName a = "Tuple4" ++ delim : delim : persistName ((undefined :: (a, b, c, d) -> a) a) ++ delim : persistName ((undefined :: (a, b, c, d) -> b) a) ++ delim : persistName ((undefined :: (a, b, c, d) -> c) a) ++ delim : persistName ((undefined :: (a, b, c, d) -> d) a) toPersistValues (a, b, c, d) = do@@ -451,15 +508,15 @@ b' <- toPersistValues b c' <- toPersistValues c d' <- toPersistValues d- return $ a' . b' . c' . d'+ pure $ a' . b' . c' . d' fromPersistValues xs = do (a, rest0) <- fromPersistValues xs (b, rest1) <- fromPersistValues rest0 (c, rest2) <- fromPersistValues rest1 (d, rest3) <- fromPersistValues rest2- return ((a, b, c, d), rest3)+ pure ((a, b, c, d), rest3) dbType db a = DbEmbedded (EmbeddedDef False [("val0", dbType db ((undefined :: (a, b, c, d) -> a) a)), ("val1", dbType db ((undefined :: (a, b, c, d) -> b) a)), ("val2", dbType db ((undefined :: (a, b, c, d) -> c) a)), ("val3", dbType db ((undefined :: (a, b, c, d) -> d) a))]) Nothing- + instance (PersistField a, PersistField b, PersistField c, PersistField d, PersistField e) => PersistField (a, b, c, d, e) where persistName a = "Tuple5" ++ delim : delim : persistName ((undefined :: (a, b, c, d, e) -> a) a) ++ delim : persistName ((undefined :: (a, b, c, d, e) -> b) a) ++ delim : persistName ((undefined :: (a, b, c, d, e) -> c) a) ++ delim : persistName ((undefined :: (a, b, c, d, e) -> d) a) ++ delim : persistName ((undefined :: (a, b, c, d, e) -> e) a) toPersistValues (a, b, c, d, e) = do@@ -468,14 +525,14 @@ c' <- toPersistValues c d' <- toPersistValues d e' <- toPersistValues e- return $ a' . b' . c' . d' . e'+ pure $ a' . b' . c' . d' . e' fromPersistValues xs = do (a, rest0) <- fromPersistValues xs (b, rest1) <- fromPersistValues rest0 (c, rest2) <- fromPersistValues rest1 (d, rest3) <- fromPersistValues rest2 (e, rest4) <- fromPersistValues rest3- return ((a, b, c, d, e), rest4)+ pure ((a, b, c, d, e), rest4) dbType db a = DbEmbedded (EmbeddedDef False [("val0", dbType db ((undefined :: (a, b, c, d, e) -> a) a)), ("val1", dbType db ((undefined :: (a, b, c, d, e) -> b) a)), ("val2", dbType db ((undefined :: (a, b, c, d, e) -> c) a)), ("val3", dbType db ((undefined :: (a, b, c, d, e) -> d) a)), ("val4", dbType db ((undefined :: (a, b, c, d, e) -> e) a))]) Nothing instance (DbDescriptor db, PersistEntity v, PersistField v) => PersistField (KeyForBackend db v) where@@ -487,62 +544,70 @@ instance (EntityConstr v c, PersistField a) => Projection (Field v c a) a where type ProjectionDb (Field v c a) db = () type ProjectionRestriction (Field v c a) r = r ~ RestrictionHolder v c- projectionExprs f = result where- result = (ExprField (fieldChain db f):)- db = (undefined :: ([UntypedExpr db r] -> [UntypedExpr db r]) -> proxy db) result+ projectionExprs f = result+ where+ result = (ExprField (fieldChain db f) :)+ db = (undefined :: ([UntypedExpr db r] -> [UntypedExpr db r]) -> proxy db) result projectionResult _ = fromPersistValues instance (EntityConstr v c, PersistField a) => Projection (SubField db v c a) a where type ProjectionDb (SubField db v c a) db' = db ~ db' type ProjectionRestriction (SubField db v c a) r = r ~ RestrictionHolder v c- projectionExprs f = result where- result = (ExprField (fieldChain db f):)- db = (undefined :: ([UntypedExpr db r] -> [UntypedExpr db r]) -> proxy db) result+ projectionExprs f = result+ where+ result = (ExprField (fieldChain db f) :)+ db = (undefined :: ([UntypedExpr db r] -> [UntypedExpr db r]) -> proxy db) result projectionResult _ = fromPersistValues instance PersistField a => Projection (Expr db r a) a where type ProjectionDb (Expr db r a) db' = db ~ db' type ProjectionRestriction (Expr db r a) r' = r ~ r'- projectionExprs (Expr e) = (e:)+ projectionExprs (Expr e) = (e :) projectionResult _ = fromPersistValues instance a ~ Bool => Projection (Cond db r) a where type ProjectionDb (Cond db r) db' = db ~ db' type ProjectionRestriction (Cond db r) r' = r ~ r'- projectionExprs cond = (ExprCond cond:)+ projectionExprs cond = (ExprCond cond :) projectionResult _ = fromPersistValues instance (EntityConstr v c, a ~ AutoKey v) => Projection (AutoKeyField v c) a where type ProjectionDb (AutoKeyField v c) db = () type ProjectionRestriction (AutoKeyField v c) r = r ~ RestrictionHolder v c- projectionExprs f = result where- result = (ExprField (fieldChain db f):)- db = (undefined :: ([UntypedExpr db r] -> [UntypedExpr db r]) -> proxy db) result+ projectionExprs f = result+ where+ result = (ExprField (fieldChain db f) :)+ db = (undefined :: ([UntypedExpr db r] -> [UntypedExpr db r]) -> proxy db) result projectionResult _ = fromPersistValues instance EntityConstr v c => Projection (c (ConstructorMarker v)) v where type ProjectionDb (c (ConstructorMarker v)) db = () type ProjectionRestriction (c (ConstructorMarker v)) r = r ~ RestrictionHolder v c- projectionExprs c = result where- result = ((map ExprField chains) ++)- chains = map (\f -> (f, [])) $ constrParams constr- e = entityDef db ((undefined :: c (ConstructorMarker v) -> v) c)- cNum = entityConstrNum ((undefined :: c (ConstructorMarker v) -> proxy v) c) c- constr = constructors e !! cNum- db = (undefined :: ([UntypedExpr db r] -> [UntypedExpr db r]) -> proxy db) result- projectionResult c xs = toSinglePersistValue cNum >>= \cNum' -> fromEntityPersistValues (cNum':xs) where- cNum = entityConstrNum ((undefined :: c (ConstructorMarker v) -> proxy v) c) c+ projectionExprs c = result+ where+ result = (map ExprField chains ++)+ chains = map (\f -> (f, [])) $ constrParams constr+ e = entityDef db ((undefined :: c (ConstructorMarker v) -> v) c)+ cNum = entityConstrNum ((undefined :: c (ConstructorMarker v) -> proxy v) c) c+ constr = constructors e !! cNum+ db = (undefined :: ([UntypedExpr db r] -> [UntypedExpr db r]) -> proxy db) result+ projectionResult c xs = toSinglePersistValue cNum >>= \cNum' -> fromEntityPersistValues (cNum' : xs)+ where+ cNum = entityConstrNum ((undefined :: c (ConstructorMarker v) -> proxy v) c) c -instance (PersistEntity v, IsUniqueKey k, k ~ Key v (Unique u))- => Projection (u (UniqueMarker v)) k where+instance+ (PersistEntity v, IsUniqueKey k, k ~ Key v (Unique u)) =>+ Projection (u (UniqueMarker v)) k+ where type ProjectionDb (u (UniqueMarker v)) db = () type ProjectionRestriction (u (UniqueMarker v)) (RestrictionHolder v' c) = v ~ v'- projectionExprs u = result where- result = ((map ExprField chains) ++)- uDef = constrUniques constr !! uniqueNum ((undefined :: u (UniqueMarker v) -> Key v (Unique u)) u)- chains = map (\f -> (f, [])) $ getUniqueFields uDef- constr = head $ constructors (entityDef db ((undefined :: u (UniqueMarker v) -> v) u))- db = (undefined :: ([UntypedExpr db r] -> [UntypedExpr db r]) -> proxy db) result+ projectionExprs u = result+ where+ result = (map ExprField chains ++)+ uDef = constrUniques constr !! uniqueNum ((undefined :: u (UniqueMarker v) -> Key v (Unique u)) u)+ chains = map (\f -> (f, [])) $ getUniqueFields uDef+ constr = head $ constructors (entityDef db ((undefined :: u (UniqueMarker v) -> v) u))+ db = (undefined :: ([UntypedExpr db r] -> [UntypedExpr db r]) -> proxy db) result projectionResult _ = fromPersistValues instance (Projection a1 a1', Projection a2 a2') => Projection (a1, a2) (a1', a2') where@@ -552,7 +617,7 @@ projectionResult (a', b') xs = do (a, rest0) <- projectionResult a' xs (b, rest1) <- projectionResult b' rest0- return ((a, b), rest1)+ pure ((a, b), rest1) instance (Projection a1 a1', Projection a2 a2', Projection a3 a3') => Projection (a1, a2, a3) (a1', a2', a3') where type ProjectionDb (a1, a2, a3) db = (ProjectionDb (a1, a2) db, ProjectionDb a3 db)@@ -562,7 +627,7 @@ (a, rest0) <- projectionResult a' xs (b, rest1) <- projectionResult b' rest0 (c, rest2) <- projectionResult c' rest1- return ((a, b, c), rest2)+ pure ((a, b, c), rest2) instance (Projection a1 a1', Projection a2 a2', Projection a3 a3', Projection a4 a4') => Projection (a1, a2, a3, a4) (a1', a2', a3', a4') where type ProjectionDb (a1, a2, a3, a4) db = (ProjectionDb (a1, a2, a3) db, ProjectionDb a4 db)@@ -573,7 +638,7 @@ (b, rest1) <- projectionResult b' rest0 (c, rest2) <- projectionResult c' rest1 (d, rest3) <- projectionResult d' rest2- return ((a, b, c, d), rest3)+ pure ((a, b, c, d), rest3) instance (Projection a1 a1', Projection a2 a2', Projection a3 a3', Projection a4 a4', Projection a5 a5') => Projection (a1, a2, a3, a4, a5) (a1', a2', a3', a4', a5') where type ProjectionDb (a1, a2, a3, a4, a5) db = (ProjectionDb (a1, a2, a3, a4) db, ProjectionDb a5 db)@@ -585,22 +650,26 @@ (c, rest2) <- projectionResult c' rest1 (d, rest3) <- projectionResult d' rest2 (e, rest4) <- projectionResult e' rest3- return ((a, b, c, d, e), rest4)+ pure ((a, b, c, d, e), rest4) instance (EntityConstr v c, a ~ AutoKey v) => Assignable (AutoKeyField v c) a+ instance (EntityConstr v c, PersistField a) => Assignable (SubField db v c a) a+ instance (EntityConstr v c, PersistField a) => Assignable (Field v c a) a+ instance (PersistEntity v, IsUniqueKey k, k ~ Key v (Unique u)) => Assignable (u (UniqueMarker v)) k instance (EntityConstr v c, a ~ AutoKey v) => FieldLike (AutoKeyField v c) a where- fieldChain db a = chain where- chain = ((name, dbType db k), [])- -- if it is Nothing, the name would not be used because the type will be () with no columns- name = maybe "will_be_ignored" id $ constrAutoKeyName $ constructors e !! cNum- k = (undefined :: AutoKeyField v c -> AutoKey v) a+ fieldChain db a = chain+ where+ chain = ((name, dbType db k), [])+ -- if it is Nothing, the name would not be used because the type will be () with no columns+ name = fromMaybe "will_be_ignored" $ constrAutoKeyName $ constructors e !! cNum+ k = (undefined :: AutoKeyField v c -> AutoKey v) a - e = entityDef db ((undefined :: AutoKeyField v c -> v) a)- cNum = entityConstrNum ((undefined :: AutoKeyField v c -> proxy v) a) ((undefined :: AutoKeyField v c -> c (ConstructorMarker v)) a)+ e = entityDef db ((undefined :: AutoKeyField v c -> v) a)+ cNum = entityConstrNum ((undefined :: AutoKeyField v c -> proxy v) a) ((undefined :: AutoKeyField v c -> c (ConstructorMarker v)) a) instance (EntityConstr v c, PersistField a) => FieldLike (SubField db v c a) a where fieldChain _ (SubField a) = a@@ -608,47 +677,47 @@ instance (EntityConstr v c, PersistField a) => FieldLike (Field v c a) a where fieldChain = entityFieldChain -instance (PersistEntity v, IsUniqueKey k, k ~ Key v (Unique u))- => FieldLike (u (UniqueMarker v)) k where- fieldChain db u = chain where- uDef = constrUniques constr !! uniqueNum ((undefined :: u (UniqueMarker v) -> Key v (Unique u)) u)- chain = (("will_be_ignored", DbEmbedded (EmbeddedDef True $ getUniqueFields uDef) Nothing), [])- constr = head $ constructors (entityDef db ((undefined :: u (UniqueMarker v) -> v) u))+instance+ (PersistEntity v, IsUniqueKey k, k ~ Key v (Unique u)) =>+ FieldLike (u (UniqueMarker v)) k+ where+ fieldChain db u = chain+ where+ uDef = constrUniques constr !! uniqueNum ((undefined :: u (UniqueMarker v) -> Key v (Unique u)) u)+ chain = (("will_be_ignored", DbEmbedded (EmbeddedDef True $ getUniqueFields uDef) Nothing), [])+ constr = head $ constructors (entityDef db ((undefined :: u (UniqueMarker v) -> v) u)) instance (PersistEntity v, EntityConstr' (IsSumType v) c) => EntityConstr v c where entityConstrNum v = entityConstrNum' $ (undefined :: proxy v -> IsSumType v) v+ class EntityConstr' flag c where- entityConstrNum' :: flag -> c (a :: * -> *) -> Int+ entityConstrNum' :: flag -> c (a :: Type -> Type) -> Int+ instance EntityConstr' HFalse c where entityConstrNum' _ _ = 0+ instance Constructor c => EntityConstr' HTrue c where entityConstrNum' _ = phantomConstrNum instance A.FromJSON PersistValue where- parseJSON (A.String t) = return $ PersistString $ T.unpack t-#if MIN_VERSION_aeson(0, 7, 0)- parseJSON (A.Number n) = return $- if fromInteger (floor n) == n- then PersistInt64 $ floor n- else PersistDouble $ fromRational $ toRational n-#else- parseJSON (A.Number (AN.I i)) = return $ PersistInt64 $ fromInteger i- parseJSON (A.Number (AN.D d)) = return $ PersistDouble d-#endif- parseJSON (A.Bool b) = return $ PersistBool b- parseJSON A.Null = return $ PersistNull+ parseJSON (A.String t) = pure $ PersistText t+ parseJSON (A.Number n) =+ pure $+ if fromInteger (floor n) == n+ then PersistInt64 $ floor n+ else PersistDouble $ fromRational $ toRational n+ parseJSON (A.Bool b) = pure $ PersistBool b+ parseJSON A.Null = pure PersistNull parseJSON a = fail $ "parseJSON PersistValue: unexpected " ++ show a instance A.ToJSON PersistValue where toJSON (PersistString t) = A.String $ T.pack t+ toJSON (PersistText t) = A.String t toJSON (PersistByteString b) = A.String $ T.decodeUtf8 $ B64.encode b toJSON (PersistInt64 i) = A.Number $ fromIntegral i- toJSON (PersistDouble d) = A.Number $-#if MIN_VERSION_aeson(0, 7, 0)- Data.Scientific.fromFloatDigits d-#else- AN.D d-#endif+ toJSON (PersistDouble d) =+ A.Number $+ Data.Scientific.fromFloatDigits d toJSON (PersistBool b) = A.Bool b toJSON (PersistTimeOfDay t) = A.String $ T.pack $ show t toJSON (PersistUTCTime u) = A.String $ T.pack $ show u@@ -658,7 +727,7 @@ toJSON a@(PersistCustom _ _) = error $ "toJSON: unexpected " ++ show a instance Read (Key v u) => A.FromJSON (Key v u) where- parseJSON a = fmap read $ A.parseJSON a+ parseJSON a = read <$> A.parseJSON a instance Show (Key v u) => A.ToJSON (Key v u) where toJSON k = A.toJSON $ show k
changelog view
@@ -1,3 +1,27 @@+0.12+* Suppport for GHC 9+* Drop support for GHC 8.0+* Refactor test suite and migrate it to HSpec++0.11+* Suppport for GHC 8.8+* Drop support for GHC 7.*++0.10+* Pass type information along the UntypedExpr+* Fix #57 (table indexes are ignored)++0.9.0+* Support for GHC 8.4++0.8.0.1+* New typeclass to allow transaction rollback through ExceptT++0.8+* Simplified signatures for PurePersistField and PrimitivePersistField+* Basic support for streaming API+* Support for GHC 8+ 0.7.0.3 * Add attoparsec dependency
groundhog.cabal view
@@ -1,14 +1,14 @@ name: groundhog-version: 0.7.0.3+version: 0.12.0 license: BSD3 license-file: LICENSE author: Boris Lykah <lykahb@gmail.com> maintainer: Boris Lykah <lykahb@gmail.com> synopsis: Type-safe datatype-database mapping library.-description: This library maps your datatypes to a relational model, in a way similar to what ORM libraries do in object-oriented programming. The mapping can be configured to work with almost any schema. Groundhog supports schema migrations, composite keys, advanced expressions in queries, and much more. See tutorial <https://www.fpcomplete.com/user/lykahb/groundhog> and examples <https://github.com/lykahb/groundhog/tree/master/examples> on GitHub.+description: This library maps your datatypes to a relational model, in a way similar to what ORM libraries do in object-oriented programming. The mapping can be configured to work with almost any schema. Groundhog supports schema migrations, composite keys, advanced expressions in queries, and much more. See tutorial <https://www.schoolofhaskell.com/user/lykahb/groundhog> and examples <https://github.com/lykahb/groundhog/tree/master/examples> on GitHub. category: Database stability: Stable-cabal-version: >= 1.6+cabal-version: >= 1.10 build-type: Simple homepage: http://github.com/lykahb/groundhog @@ -16,21 +16,23 @@ changelog library- build-depends: base >= 4 && < 5- , bytestring >= 0.9+ build-depends: base >= 4.5 && < 5+ , bytestring >= 0.10 , base64-bytestring- , transformers >= 0.2.1 && < 0.5+ , transformers >= 0.2.1 && < 0.6 , mtl >= 2.0 , time >= 1.1.4 , attoparsec >= 0.11- , aeson >= 0.5+ , aeson >= 0.7 , scientific , text >= 0.8- , blaze-builder >= 0.3 && < 0.5 , containers >= 0.2 , monad-control >= 0.3 && < 1.1- , monad-logger >= 0.3 && < 0.4 , transformers-base+ , resourcet >= 1.1.2+ , safe-exceptions+ , transformers-compat >= 0.3+ exposed-modules: Database.Groundhog Database.Groundhog.Core Database.Groundhog.Expression@@ -41,7 +43,8 @@ Database.Groundhog.Generic.PersistBackendHelpers Database.Groundhog.Instances ghc-options: -Wall- + default-language: Haskell2010+ source-repository head type: git location: git://github.com/lykahb/groundhog.git