module Database.Groundhog.Core
(
PersistEntity(..)
, PersistValue(..)
, PersistField(..)
, SinglePersistField(..)
, PurePersistField(..)
, PrimitivePersistField(..)
, Embedded(..)
, Projection(..)
, RestrictionHolder
, Unique
, KeyForBackend(..)
, BackendSpecific
, ConstructorMarker
, UniqueMarker
, Proxy
, HFalse
, HTrue
, ZT (..)
, delim
, Cond(..)
, ExprRelation(..)
, Update(..)
, (~>)
, toArith
, FieldLike(..)
, SubField(..)
, AutoKeyField(..)
, FieldChain
, NeverNull
, Numeric
, Arith(..)
, Expr(..)
, Order(..)
, HasSelectOptions(..)
, SelectOptions(..)
, limitTo
, offsetBy
, orderBy
, DbType(..)
, EntityDef(..)
, EmbeddedDef(..)
, ConstructorDef(..)
, Constructor(..)
, IsUniqueKey(..)
, UniqueDef(..)
, UniqueType(..)
, SingleMigration
, NamedMigrations
, Migration
, PersistBackend(..)
, DbDescriptor(..)
, RowPopper
, DbPersist(..)
, runDbPersist
) where
import Control.Applicative (Applicative)
import Control.Monad.Base (MonadBase (liftBase))
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)
import Control.Monad.Trans.State (StateT)
import Control.Monad (liftM)
import Data.ByteString.Char8 (ByteString)
import Data.Int (Int64)
import Data.Map (Map)
import Data.Time (Day, TimeOfDay, UTCTime)
import Data.Time.LocalTime (ZonedTime, zonedTimeToUTC, zonedTimeToLocalTime, zonedTimeZone)
class (PersistField v, PurePersistField (AutoKey v)) => PersistEntity v where
data Field v :: ((* -> *) -> *) -> * -> *
data Key v :: * -> *
type AutoKey v
type DefaultKey v
entityDef :: v -> EntityDef
toEntityPersistValues :: PersistBackend m => v -> m ([PersistValue] -> [PersistValue])
fromEntityPersistValues :: PersistBackend m => [PersistValue] -> m (v, [PersistValue])
getUniques :: DbDescriptor db => Proxy db -> v -> (Int, [(String, [PersistValue] -> [PersistValue])])
entityFieldChain :: Field v c a -> FieldChain
data Unique (u :: (* -> *) -> *)
data BackendSpecific
data ConstructorMarker v a
data UniqueMarker v a
data KeyForBackend db v = (DbDescriptor db, PersistEntity v) => KeyForBackend (AutoKeyType db)
data Proxy a
data HFalse
data HTrue
data Cond v (c :: (* -> *) -> *) =
And (Cond v c) (Cond v c)
| Or (Cond v c) (Cond v c)
| Not (Cond v c)
| forall a b . Compare ExprRelation (Expr v c a) (Expr v c b)
data ExprRelation = Eq | Ne | Gt | Lt | Ge | Le deriving Show
data Update v c = forall f a b . (FieldLike f (RestrictionHolder v c) a) => Update f (Expr v c b)
data Order v c = forall a f . (FieldLike f (RestrictionHolder v c) a) => Asc f
| forall a f . (FieldLike f (RestrictionHolder v c) a) => Desc f
type FieldChain = ((String, DbType), [(String, EmbeddedDef)])
class Projection f r a => FieldLike f r a | f -> r a where
fieldChain :: f -> FieldChain
class PersistField v => Embedded v where
data Selector v :: * -> *
selectorNum :: Selector v a -> Int
infixl 5 ~>
(~>) :: (PersistEntity v, Constructor c, FieldLike f (RestrictionHolder v c) a, Embedded a) => f -> Selector a a' -> SubField v c a'
field ~> sel = case fieldChain field of
((name, typ), prefix) -> case typ of
DbEmbedded emb@(EmbeddedDef _ ts) -> SubField (ts !! selectorNum sel, (name, emb):prefix)
DbEntity (Just (emb@(EmbeddedDef _ ts), _)) _ -> SubField (ts !! selectorNum sel, (name, emb):prefix)
other -> error $ "(~>): cannot get subfield of non-embedded type " ++ show other
newtype SubField v (c :: (* -> *) -> *) a = SubField ((String, DbType), [(String, EmbeddedDef)])
data AutoKeyField v c where
AutoKeyField :: (PersistEntity v, Constructor c) => AutoKeyField v c
data RestrictionHolder v (c :: (* -> *) -> *)
class Projection p r a | p -> r a where
projectionFieldChains :: p -> [FieldChain] -> [FieldChain]
projectionResult :: PersistBackend m => p -> [PersistValue] -> m (a, [PersistValue])
data SelectOptions v c hasLimit hasOffset hasOrder = SelectOptions {
condOptions :: Cond v c
, limitOptions :: Maybe Int
, offsetOptions :: Maybe Int
, orderOptions :: [Order v c]
}
class HasSelectOptions a v c | a -> v c where
type HasLimit a
type HasOffset a
type HasOrder a
getSelectOptions :: a -> SelectOptions v c (HasLimit a) (HasOffset a) (HasOrder a)
instance HasSelectOptions (Cond v c) v c where
type HasLimit (Cond v c) = HFalse
type HasOffset (Cond v c) = HFalse
type HasOrder (Cond v c) = HFalse
getSelectOptions a = SelectOptions a Nothing Nothing []
instance HasSelectOptions (SelectOptions v c hasLimit hasOffset hasOrder) v c where
type HasLimit (SelectOptions v c hasLimit hasOffset hasOrder) = hasLimit
type HasOffset (SelectOptions v c hasLimit hasOffset hasOrder) = hasOffset
type HasOrder (SelectOptions v c hasLimit hasOffset hasOrder) = hasOrder
getSelectOptions = id
limitTo :: (HasSelectOptions a v c, HasLimit a ~ HFalse) => a -> Int -> SelectOptions v c HTrue (HasOffset a) (HasOrder a)
limitTo opts lim = case getSelectOptions opts of
SelectOptions c _ off ord -> SelectOptions c (Just lim) off ord
offsetBy :: (HasSelectOptions a v c, HasOffset a ~ HFalse) => a -> Int -> SelectOptions v c (HasLimit a) HTrue (HasOrder a)
offsetBy opts off = case getSelectOptions opts of
SelectOptions c lim _ ord -> SelectOptions c lim (Just off) ord
orderBy :: (HasSelectOptions a v c, HasOrder a ~ HFalse) => a -> [Order v c] -> SelectOptions v c (HasLimit a) (HasOffset a) HTrue
orderBy opts ord = case getSelectOptions opts of
SelectOptions c lim off _ -> SelectOptions c lim off ord
newtype Monad m => DbPersist conn m a = DbPersist { unDbPersist :: ReaderT conn m a }
deriving (Monad, MonadIO, Functor, Applicative, MonadTrans)
instance MonadBase IO m => MonadBase IO (DbPersist conn m) where
liftBase = lift . liftBase
instance MonadTransControl (DbPersist conn) where
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
instance MonadBaseControl IO m => MonadBaseControl IO (DbPersist conn m) where
newtype StM (DbPersist conn m) a = StMSP {unStMSP :: ComposeSt (DbPersist conn) m a}
liftBaseWith = defaultLiftBaseWith StMSP
restoreM = defaultRestoreM unStMSP
runDbPersist :: Monad m => DbPersist conn m a -> conn -> m a
runDbPersist = runReaderT . unDbPersist
class PrimitivePersistField (AutoKeyType a) => DbDescriptor a where
type AutoKeyType a
class (Monad m, DbDescriptor (PhantomDb m)) => PersistBackend m where
type PhantomDb m
insert :: PersistEntity v => v -> m (AutoKey v)
insertBy :: (PersistEntity v, IsUniqueKey (Key v (Unique u))) => u (UniqueMarker v) -> v -> m (Either (AutoKey v) (AutoKey v))
insertByAll :: PersistEntity v => v -> m (Either (AutoKey v) (AutoKey v))
replace :: (PersistEntity v, PrimitivePersistField (Key v BackendSpecific)) => Key v BackendSpecific -> v -> m ()
select :: (PersistEntity v, Constructor c, HasSelectOptions opts v c)
=> opts -> m [v]
selectAll :: PersistEntity v => m [(AutoKey v, v)]
get :: (PersistEntity v, PrimitivePersistField (Key v BackendSpecific)) => Key v BackendSpecific -> m (Maybe v)
getBy :: (PersistEntity v, IsUniqueKey (Key v (Unique u))) => Key v (Unique u) -> m (Maybe v)
update :: (PersistEntity v, Constructor c) => [Update v c] -> Cond v c -> m ()
delete :: (PersistEntity v, Constructor c) => Cond v c -> m ()
deleteByKey :: (PersistEntity v, PrimitivePersistField (Key v BackendSpecific)) => Key v BackendSpecific -> m ()
count :: (PersistEntity v, Constructor c) => Cond v c -> m Int
countAll :: PersistEntity v => v -> m Int
project :: (PersistEntity v, Constructor c, Projection p (RestrictionHolder v c) a', HasSelectOptions opts v c)
=> p
-> opts
-> m [a']
migrate :: PersistEntity v => v -> Migration m
executeRaw :: Bool
-> String
-> [PersistValue]
-> m ()
queryRaw :: Bool
-> String
-> [PersistValue]
-> (RowPopper m -> m a)
-> m a
insertList :: PersistField a => [a] -> m Int64
getList :: PersistField a => Int64 -> m [a]
type RowPopper m = m (Maybe [PersistValue])
type Migration m = StateT NamedMigrations m ()
type NamedMigrations = Map String SingleMigration
type SingleMigration = Either [String] [(Bool, Int, String)]
data EntityDef = EntityDef {
entityName :: String
, typeParams :: [DbType]
, constructors :: [ConstructorDef]
} deriving (Show, Eq)
data ConstructorDef = ConstructorDef {
constrNum :: Int
, constrName :: String
, constrAutoKeyName :: Maybe String
, constrParams :: [(String, DbType)]
, constrUniques :: [UniqueDef]
} deriving (Show, Eq)
class Constructor c where
phantomConstrName :: c (a :: * -> *) -> String
phantomConstrNum :: c (a :: * -> *) -> Int
class (Constructor (UniqueConstr uKey), PurePersistField uKey) => IsUniqueKey uKey where
type UniqueConstr uKey :: (* -> *) -> *
extractUnique :: uKey ~ Key v u => v -> uKey
uniqueNum :: uKey -> Int
data UniqueDef = UniqueDef {
uniqueName :: String
, uniqueType :: UniqueType
, uniqueFields :: [(String, DbType)]
} deriving (Show, Eq)
data UniqueType = UniqueConstraint | UniqueIndex deriving (Show, Eq)
data DbType = DbString
| DbInt32
| DbInt64
| DbReal
| DbBool
| DbDay
| DbTime
| DbDayTime
| DbDayTimeZoned
| DbBlob
| DbOther String
| DbMaybe DbType
| DbList String DbType
| DbEmbedded EmbeddedDef
| DbEntity (Maybe (EmbeddedDef, String)) EntityDef
deriving (Eq, Show)
data EmbeddedDef = EmbeddedDef Bool [(String, DbType)] deriving (Eq, Show)
data PersistValue = PersistString String
| PersistByteString ByteString
| PersistInt64 Int64
| PersistDouble Double
| PersistBool Bool
| PersistDay Day
| PersistTimeOfDay TimeOfDay
| PersistUTCTime UTCTime
| PersistZonedTime ZT
| PersistNull
deriving (Eq, Show)
newtype ZT = ZT ZonedTime deriving (Show, Read)
instance Eq ZT where
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
data Arith v c a =
Plus (Arith v c a) (Arith v c a)
| Minus (Arith v c a) (Arith v c a)
| Mult (Arith v c a) (Arith v c a)
| Abs (Arith v c a)
| forall f . (FieldLike f (RestrictionHolder v c) a) => ArithField f
| Lit Int64
instance (PersistEntity v, Constructor c) => Eq (Arith v c a) where
(Plus a1 b1) == (Plus a2 b2) = a1 == a2 && b1 == b2
(Minus a1 b1) == (Minus a2 b2) = a1 == a2 && b1 == b2
(Mult a1 b1) == (Mult a2 b2) = a1 == a2 && b1 == b2
(Abs a) == (Abs b) = a == b
(ArithField a) == (ArithField b) = fieldChain a == fieldChain b
(Lit a) == (Lit b) = a == b
_ == _ = False
instance (PersistEntity v, Constructor c) => Show (Arith v c a) where
show (Plus a b) = "Plus (" ++ show a ++ ") (" ++ show b ++ ")"
show (Minus a b) = "Minus (" ++ show a ++ ") (" ++ show b ++ ")"
show (Mult a b) = "Mult (" ++ show a ++ ") (" ++ show b ++ ")"
show (Abs a) = "Abs (" ++ show a ++ ")"
show (ArithField a) = "ArithField " ++ show (fieldChain a)
show (Lit a) = "Lit " ++ show a
instance (PersistEntity v, Constructor c, Numeric a) => Num (Arith v c a) where
a + b = Plus a b
a b = Minus a b
a * b = Mult a b
abs = Abs
signum = error "no signum"
fromInteger = Lit . fromInteger
toArith :: (PersistEntity v, FieldLike f (RestrictionHolder v c) a') => f -> Arith v c a'
toArith = ArithField
class Numeric a
class NeverNull a
data Expr v c a where
ExprField :: (PersistEntity v, FieldLike f (RestrictionHolder v c) a') => f -> Expr v c f
ExprArith :: PersistEntity v => Arith v c a -> Expr v c (Arith v c a)
ExprPure :: forall v c a . PurePersistField a => a -> Expr v c a
class PersistField a where
persistName :: a -> String
toPersistValues :: PersistBackend m => a -> m ([PersistValue] -> [PersistValue])
fromPersistValues :: PersistBackend m => [PersistValue] -> m (a, [PersistValue])
dbType :: a -> DbType
class PersistField a => SinglePersistField a where
toSinglePersistValue :: PersistBackend m => a -> m PersistValue
fromSinglePersistValue :: PersistBackend m => PersistValue -> m a
class PersistField a => PurePersistField a where
toPurePersistValues :: DbDescriptor db => Proxy db -> a -> ([PersistValue] -> [PersistValue])
fromPurePersistValues :: DbDescriptor db => Proxy db -> [PersistValue] -> (a, [PersistValue])
class (SinglePersistField a, PurePersistField a) => PrimitivePersistField a where
toPrimitivePersistValue :: DbDescriptor db => Proxy db -> a -> PersistValue
fromPrimitivePersistValue :: DbDescriptor db => Proxy db -> PersistValue -> a
delim :: Char
delim = '#'