module Database.Groundhog.Core
(
PersistEntity(..)
, PersistValue(..)
, PersistField(..)
, Key(..)
, Cond(..)
, Update(..)
, (=.), (&&.), (||.), (==.), (/=.), (<.), (<=.), (>.), (>=.)
, wrapPrim
, toArith
, Expression(..)
, Primitive(..)
, HasOrder
, Numeric
, NeverNull
, Arith(..)
, Expr(..)
, Order(..)
, DbType(..)
, NamedType
, namedType
, getName
, getType
, EntityDef(..)
, ConstructorDef(..)
, Constructor(..)
, Constraint
, SingleMigration
, NamedMigrations
, Migration
, PersistBackend(..)
, RowPopper
, DbPersist(..)
, runDbPersist
) where
import Control.Applicative(Applicative)
import Control.Monad(liftM, liftM2, liftM3, liftM4, liftM5)
import Control.Monad.Trans.Class(MonadTrans(..))
import Control.Monad.IO.Class(MonadIO(..))
import Control.Monad.IO.Control (MonadControlIO)
import Control.Monad.Trans.Reader(ReaderT, runReaderT)
import Control.Monad.Trans.State(StateT)
import Data.Bits(bitSize)
import Data.ByteString.Char8 (ByteString, unpack)
import Data.Enumerator(Enumerator)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Encoding.Error as T
import Data.Int (Int8, Int16, Int32, Int64)
import Data.Word (Word8, Word16, Word32, Word64)
import Data.Map(Map)
import Data.Time(Day, TimeOfDay, UTCTime)
import Unsafe.Coerce(unsafeCoerce)
class PersistField v => PersistEntity v where
data Fields v :: * -> * -> *
entityDef :: v -> EntityDef
toPersistValues :: PersistBackend m => v -> m [PersistValue]
fromPersistValues :: PersistBackend m => [PersistValue] -> m v
getConstraints :: v -> (Int, [(String, [(String, PersistValue)])])
showField :: Fields v c a -> String
eqField :: Fields v c a -> Fields v c a -> Bool
instance PersistEntity v => Show (Fields v c a) where show = showField
instance PersistEntity v => Eq (Fields v c a) where (==) = eqField
data PersistEntity v => Key v = Key Int64 deriving Show
data Any
type family MoreSpecific a b
type instance MoreSpecific Any a = a
type instance MoreSpecific a Any = a
type instance MoreSpecific a a = a
type instance MoreSpecific Any Any = Any
class TypesCastV x y z | x y -> z
instance (x ~ y, MoreSpecific x y ~ z) => TypesCastV x y z
instance TypesCastV Any x x
instance TypesCastV x Any x
instance TypesCastV Any Any Any
class TypesEqualC x y
instance TypesEqualC x x
instance TypesEqualC Any x
instance TypesEqualC x Any
instance TypesEqualC Any Any
class TypesCastC x y z | x y -> z
instance (TypesEqualC x y, MoreSpecific x y ~ z) => TypesCastC x y z
class (Expression a, Expression b) => TypeCast a b v c | a b -> v, a b -> c
instance (Expression a, Expression b, TypesCastV (FuncV a) (FuncV b) v, TypesCastC (FuncC a) (FuncC b) c) => TypeCast a b v c
data Cond v c =
And (Cond v c) (Cond v c)
| Or (Cond v c) (Cond v c)
| Not (Cond v c)
| forall a.(HasOrder a, PersistField a) => Lesser (Expr v c a) (Expr v c a)
| forall a.(HasOrder a, PersistField a) => Greater (Expr v c a) (Expr v c a)
| forall a.(PersistField a) => Equals (Expr v c a) (Expr v c a)
| forall a.(PersistField a) => NotEquals (Expr v c a) (Expr v c a)
| KeyIs (Key v)
data Update v c = forall a.Update (Fields v c a) (Expr v c a)
data Order v c = forall a.HasOrder a => Asc (Fields v c a)
| forall a.HasOrder a => Desc (Fields v c a)
infixr 3 =.
(=.) ::
( Expression a
, TypesCastV v (FuncV a) v
, TypesCastC c (FuncC a) c)
=> Fields v c (FuncA a) -> a -> Update v c
f =. a = Update f (unsafeCoerceExpr $ wrap a)
(&&.) :: (TypesCastV v1 v2 v3, TypesCastC c1 c2 c3) =>
Cond v1 c1 -> Cond v2 c2 -> Cond v3 c3
(||.) :: (TypesCastV v1 v2 v3, TypesCastC c1 c2 c3) =>
Cond v1 c1 -> Cond v2 c2 -> Cond v3 c3
infixr 3 &&.
a &&. b = And (unsafeCoerce a) (unsafeCoerce b)
infixr 2 ||.
a ||. b = Or (unsafeCoerce a) (unsafeCoerce b)
unsafeCoerceExpr :: Expr v1 c1 a -> Expr v2 c2 a
unsafeCoerceExpr = unsafeCoerce
(==.), (/=.) ::
( TypeCast a b v c
, FuncA a ~ FuncA b
, PersistField (FuncA a))
=> a -> b -> Cond v c
(<.), (<=.), (>.), (>=.) ::
( TypeCast a b v c
, FuncA a ~ FuncA b
, PersistField (FuncA a)
, HasOrder (FuncA a))
=> a -> b -> Cond v c
infix 4 ==., <., <=., >., >=.
a ==. b = Equals (unsafeCoerceExpr $ wrap a) (unsafeCoerceExpr $ wrap b)
a /=. b = NotEquals (unsafeCoerceExpr $ wrap a) (unsafeCoerceExpr $ wrap b)
a <. b = Lesser (unsafeCoerceExpr $ wrap a) (unsafeCoerceExpr $ wrap b)
a <=. b = Not $ a >. b
a >. b = Greater (unsafeCoerceExpr $ wrap a) (unsafeCoerceExpr $ wrap b)
a >=. b = Not $ a <. b
newtype Monad m => DbPersist conn m a = DbPersist { unDbPersist :: ReaderT conn m a }
deriving (Monad, MonadIO, Functor, Applicative, MonadControlIO, MonadTrans)
runDbPersist :: Monad m => DbPersist conn m a -> conn -> m a
runDbPersist = runReaderT.unDbPersist
class Monad m => PersistBackend m where
insert :: PersistEntity v => v -> m (Key v)
insertBy :: PersistEntity v => v -> m (Either (Key v) (Key v))
replace :: PersistEntity v => Key v -> v -> m ()
selectEnum :: (PersistEntity v, Constructor c)
=> Cond v c
-> [Order v c]
-> Int
-> Int
-> Enumerator (Key v, v) m a
selectAllEnum :: PersistEntity v => Enumerator (Key v, v) m a
select :: (PersistEntity v, Constructor c)
=> Cond v c
-> [Order v c]
-> Int
-> Int
-> m [(Key v, v)]
selectAll :: PersistEntity v => m [(Key v, v)]
get :: PersistEntity v => Key v -> 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 => Key v -> m ()
count :: (PersistEntity v, Constructor c) => Cond v c -> m Int
countAll :: PersistEntity v => v -> m Int
migrate :: PersistEntity v => v -> Migration m
executeRaw :: Bool
-> String
-> [PersistValue]
-> m ()
queryRaw :: Bool
-> String
-> [PersistValue]
-> (RowPopper m -> m a)
-> m a
insertTuple :: NamedType -> [PersistValue] -> m Int64
getTuple :: NamedType -> Int64 -> m [PersistValue]
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, String)]
data EntityDef = EntityDef {
entityName :: String
, typeParams :: [NamedType]
, constructors :: [ConstructorDef]
} deriving (Show, Eq)
data ConstructorDef = ConstructorDef {
constrNum :: Int
, constrName :: String
, constrParams :: [(String, NamedType)]
, constrConstrs :: [Constraint]
} deriving (Show, Eq)
class Constructor a where
phantomConstrName :: a -> String
phantomConstrNum :: a -> Int
type Constraint = (String, [String])
data DbType = DbString
| DbInt32
| DbInt64
| DbReal
| DbBool
| DbDay
| DbTime
| DbDayTime
| DbBlob
| DbMaybe NamedType
| DbList NamedType
| DbTuple Int [NamedType]
| DbEntity EntityDef
deriving Show
data NamedType = forall v.PersistField v => NamedType v
namedType :: PersistField v => v -> NamedType
namedType = NamedType
getName :: NamedType -> String
getName (NamedType v) = persistName v
getType :: NamedType -> DbType
getType (NamedType v) = dbType v
instance Show NamedType where
show (NamedType v) = show (dbType v)
instance Eq NamedType where
(NamedType v1) == (NamedType v2) = persistName v1 == persistName v2
data PersistValue = PersistString String
| PersistByteString ByteString
| PersistInt64 Int64
| PersistDouble Double
| PersistBool Bool
| PersistDay Day
| PersistTimeOfDay TimeOfDay
| PersistUTCTime UTCTime
| PersistNull
deriving (Show, Eq)
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)
| ArithField (Fields v c a)
| Lit Int64
deriving instance Eq (Fields v c a) => Eq (Arith v c a)
deriving instance Show (Fields v c a) => Show (Arith v c a)
instance (Eq (Fields v c a), Show (Fields v c a), 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 :: Fields v c a -> Arith v c a
toArith = ArithField
class Numeric a
class HasOrder a
class NeverNull a
class Primitive a where
toPrim :: a -> PersistValue
fromPrim :: PersistValue -> a
data Expr v c a where
ExprPrim :: Primitive a => a -> Expr v c a
ExprField :: PersistEntity v => Fields v c a -> Expr v c a
ExprArith :: PersistEntity v => Arith v c a -> Expr v c a
ExprPlain :: Primitive a => a -> Expr v c (FuncA a)
class Expression a where
type FuncV a; type FuncC a; type FuncA a
wrap :: a -> Expr (FuncV a) (FuncC a) (FuncA a)
wrapPrim :: Primitive a => a -> Expr Any Any a
wrapPrim = ExprPrim
class PersistField a where
persistName :: a -> String
toPersistValue :: PersistBackend m => a -> m PersistValue
fromPersistValue :: PersistBackend m => PersistValue -> m a
dbType :: a -> DbType
instance Numeric Int
instance Numeric Int8
instance Numeric Int16
instance Numeric Int32
instance Numeric Int64
instance Numeric Word8
instance Numeric Word16
instance Numeric Word32
instance Numeric Word64
instance Numeric Double
instance HasOrder Int
instance HasOrder Int8
instance HasOrder Int16
instance HasOrder Int32
instance HasOrder Int64
instance HasOrder Word8
instance HasOrder Word16
instance HasOrder Word32
instance HasOrder Word64
instance HasOrder Double
instance HasOrder Bool
instance HasOrder Day
instance HasOrder TimeOfDay
instance HasOrder UTCTime
instance Primitive String where
toPrim = PersistString
fromPrim (PersistString s) = s
fromPrim (PersistByteString bs) = T.unpack $ T.decodeUtf8With T.lenientDecode bs
fromPrim (PersistInt64 i) = show i
fromPrim (PersistDouble d) = show d
fromPrim (PersistDay d) = show d
fromPrim (PersistTimeOfDay d) = show d
fromPrim (PersistUTCTime d) = show d
fromPrim (PersistBool b) = show b
fromPrim PersistNull = error "Unexpected null"
instance Primitive T.Text where
toPrim = PersistString . T.unpack
fromPrim (PersistByteString bs) = T.decodeUtf8With T.lenientDecode bs
fromPrim x = T.pack $ fromPrim x
instance Primitive ByteString where
toPrim = PersistByteString
fromPrim (PersistByteString a) = a
fromPrim x = T.encodeUtf8 . T.pack $ fromPrim x
instance Primitive Int where
toPrim = PersistInt64 . fromIntegral
fromPrim (PersistInt64 a) = fromIntegral a
fromPrim x = error $ "Expected Integer, received: " ++ show x
instance Primitive Int8 where
toPrim = PersistInt64 . fromIntegral
fromPrim (PersistInt64 a) = fromIntegral a
fromPrim x = error $ "Expected Integer, received: " ++ show x
instance Primitive Int16 where
toPrim = PersistInt64 . fromIntegral
fromPrim (PersistInt64 a) = fromIntegral a
fromPrim x = error $ "Expected Integer, received: " ++ show x
instance Primitive Int32 where
toPrim = PersistInt64 . fromIntegral
fromPrim (PersistInt64 a) = fromIntegral a
fromPrim x = error $ "Expected Integer, received: " ++ show x
instance Primitive Int64 where
toPrim = PersistInt64
fromPrim (PersistInt64 a) = a
fromPrim x = error $ "Expected Integer, received: " ++ show x
instance Primitive Word8 where
toPrim = PersistInt64 . fromIntegral
fromPrim (PersistInt64 a) = fromIntegral a
fromPrim x = error $ "Expected Integer, received: " ++ show x
instance Primitive Word16 where
toPrim = PersistInt64 . fromIntegral
fromPrim (PersistInt64 a) = fromIntegral a
fromPrim x = error $ "Expected Integer, received: " ++ show x
instance Primitive Word32 where
toPrim = PersistInt64 . fromIntegral
fromPrim (PersistInt64 a) = fromIntegral a
fromPrim x = error $ "Expected Integer, received: " ++ show x
instance Primitive Word64 where
toPrim = PersistInt64 . fromIntegral
fromPrim (PersistInt64 a) = fromIntegral a
fromPrim x = error $ "Expected Integer, received: " ++ show x
instance Primitive Double where
toPrim = PersistDouble
fromPrim (PersistDouble a) = a
fromPrim x = error $ "Expected Double, received: " ++ show x
instance Primitive Bool where
toPrim = PersistBool
fromPrim (PersistBool a) = a
fromPrim (PersistInt64 i) = i /= 0
fromPrim x = error $ "Expected Bool, received: " ++ show x
instance Primitive Day where
toPrim = PersistDay
fromPrim (PersistDay a) = a
fromPrim x = readHelper x ("Expected Day, received: " ++ show x)
instance Primitive TimeOfDay where
toPrim = PersistTimeOfDay
fromPrim (PersistTimeOfDay a) = a
fromPrim x = readHelper x ("Expected TimeOfDay, received: " ++ show x)
instance Primitive UTCTime where
toPrim = PersistUTCTime
fromPrim (PersistUTCTime a) = a
fromPrim x = readHelper x ("Expected UTCTime, received: " ++ show x)
instance Primitive (Key a) where
toPrim (Key a) = PersistInt64 a
fromPrim (PersistInt64 a) = Key a
fromPrim x = error $ "Expected Integer(entity key), received: " ++ show x
instance (Primitive a, NeverNull a) => Primitive (Maybe a) where
toPrim = maybe PersistNull toPrim
fromPrim PersistNull = Nothing
fromPrim x = Just $ fromPrim x
instance NeverNull String
instance NeverNull T.Text
instance NeverNull ByteString
instance NeverNull Int
instance NeverNull Int64
instance NeverNull Double
instance NeverNull Bool
instance NeverNull Day
instance NeverNull TimeOfDay
instance NeverNull UTCTime
instance NeverNull (Key a)
instance NeverNull [a]
instance NeverNull (a, b)
instance NeverNull (a, b, c)
instance NeverNull (a, b, c, d)
instance NeverNull (a, b, c, d, e)
instance PersistEntity a => NeverNull a
instance Expression (Expr v c a) where
type FuncV (Expr v c a) = v
type FuncC (Expr v c a) = c
type FuncA (Expr v c a) = a
wrap = id
instance PersistEntity v => Expression (Fields v c a) where
type FuncV (Fields v c a) = v
type FuncC (Fields v c a) = c
type FuncA (Fields v c a) = a
wrap = ExprField
instance PersistEntity v => Expression (Arith v c a) where
type FuncV (Arith v c a) = v
type FuncC (Arith v c a) = c
type FuncA (Arith v c a) = a
wrap = ExprArith
instance (Expression a, Primitive a, NeverNull a) => Expression (Maybe a) where
type FuncV (Maybe a) = Any
type FuncC (Maybe a) = Any
type FuncA (Maybe a) = (Maybe (FuncA a))
wrap = ExprPlain
instance Expression (Key a) where
type FuncV (Key a) = Any; type FuncC (Key a) = Any; type FuncA (Key a) = a
wrap = ExprPlain
instance Expression Int where
type FuncV Int = Any; type FuncC Int = Any; type FuncA Int = Int
wrap = ExprPrim
instance Expression Int8 where
type FuncV Int8 = Any; type FuncC Int8 = Any; type FuncA Int8 = Int8
wrap = ExprPrim
instance Expression Int16 where
type FuncV Int16 = Any; type FuncC Int16 = Any; type FuncA Int16 = Int16
wrap = ExprPrim
instance Expression Int32 where
type FuncV Int32 = Any; type FuncC Int32 = Any; type FuncA Int32 = Int32
wrap = ExprPrim
instance Expression Int64 where
type FuncV Int64 = Any; type FuncC Int64 = Any; type FuncA Int64 = Int64
wrap = ExprPrim
instance Expression Word8 where
type FuncV Word8 = Any; type FuncC Word8 = Any; type FuncA Word8 = Word8
wrap = ExprPrim
instance Expression Word16 where
type FuncV Word16 = Any; type FuncC Word16 = Any; type FuncA Word16 = Word16
wrap = ExprPrim
instance Expression Word32 where
type FuncV Word32 = Any; type FuncC Word32 = Any; type FuncA Word32 = Word32
wrap = ExprPrim
instance Expression Word64 where
type FuncV Word64 = Any; type FuncC Word64 = Any; type FuncA Word64 = Word64
wrap = ExprPrim
instance Expression String where
type FuncV String = Any; type FuncC String = Any; type FuncA String = String
wrap = ExprPrim
instance Expression ByteString where
type FuncV ByteString = Any; type FuncC ByteString = Any; type FuncA ByteString = ByteString
wrap = ExprPrim
instance Expression T.Text where
type FuncV T.Text = Any; type FuncC T.Text = Any; type FuncA T.Text = T.Text
wrap = ExprPrim
instance Expression Bool where
type FuncV Bool = Any; type FuncC Bool = Any; type FuncA Bool = Bool
wrap = ExprPrim
readHelper :: Read a => PersistValue -> String -> a
readHelper s errMessage = case s of
PersistString str -> readHelper' str
PersistByteString str -> readHelper' (unpack str)
_ -> error errMessage
where
readHelper' str = case reads str of
(a, _):_ -> a
_ -> error errMessage
instance PersistField ByteString where
persistName _ = "ByteString"
toPersistValue = return . toPrim
fromPersistValue = return . fromPrim
dbType _ = DbBlob
instance PersistField String where
persistName _ = "String"
toPersistValue = return . toPrim
fromPersistValue = return . fromPrim
dbType _ = DbString
instance PersistField T.Text where
persistName _ = "Text"
toPersistValue = return . toPrim
fromPersistValue = return . fromPrim
dbType _ = DbString
instance PersistField Int where
persistName _ = "Int"
toPersistValue = return . toPrim
fromPersistValue = return . fromPrim
dbType a = if bitSize a == 32 then DbInt32 else DbInt64
instance PersistField Int8 where
persistName _ = "Int8"
toPersistValue = return . toPrim
fromPersistValue = return . fromPrim
dbType _ = DbInt64
instance PersistField Int16 where
persistName _ = "Int16"
toPersistValue = return . toPrim
fromPersistValue = return . fromPrim
dbType _ = DbInt64
instance PersistField Int32 where
persistName _ = "Int32"
toPersistValue = return . toPrim
fromPersistValue = return . fromPrim
dbType _ = DbInt64
instance PersistField Int64 where
persistName _ = "Int64"
toPersistValue = return . toPrim
fromPersistValue = return . fromPrim
dbType _ = DbInt64
instance PersistField Word8 where
persistName _ = "Word8"
toPersistValue = return . toPrim
fromPersistValue = return . fromPrim
dbType _ = DbInt64
instance PersistField Word16 where
persistName _ = "Word16"
toPersistValue = return . toPrim
fromPersistValue = return . fromPrim
dbType _ = DbInt64
instance PersistField Word32 where
persistName _ = "Word32"
toPersistValue = return . toPrim
fromPersistValue = return . fromPrim
dbType _ = DbInt64
instance PersistField Word64 where
persistName _ = "Word64"
toPersistValue = return . toPrim
fromPersistValue = return . fromPrim
dbType _ = DbInt64
instance PersistField Double where
persistName _ = "Double"
toPersistValue = return . PersistDouble
fromPersistValue = return . fromPrim
dbType _ = DbReal
instance PersistField Bool where
persistName _ = "Bool"
toPersistValue = return . PersistBool
fromPersistValue = return . fromPrim
dbType _ = DbBool
instance PersistField Day where
persistName _ = "Day"
toPersistValue = return . PersistDay
fromPersistValue = return . fromPrim
dbType _ = DbDay
instance PersistField TimeOfDay where
persistName _ = "TimeOfDay"
toPersistValue = return . PersistTimeOfDay
fromPersistValue = return . fromPrim
dbType _ = DbTime
instance PersistField UTCTime where
persistName _ = "UTCTime"
toPersistValue = return . PersistUTCTime
fromPersistValue = return . fromPrim
dbType _ = DbDayTime
instance (PersistField a, NeverNull a) => PersistField (Maybe a) where
persistName (_ :: Maybe a) = "Maybe$" ++ persistName (undefined :: a)
toPersistValue = maybe (return PersistNull) toPersistValue
fromPersistValue PersistNull = return Nothing
fromPersistValue x = liftM Just $ fromPersistValue x
dbType (_ :: Maybe a) = DbMaybe $ namedType (undefined :: a)
instance (PersistEntity a) => PersistField (Key a) where
persistName (_ :: Key a) = "Key$" ++ persistName (undefined :: a)
toPersistValue (Key a) = return $ PersistInt64 a
fromPersistValue = return . fromPrim
dbType (_ :: Key a) = DbEntity $ entityDef (undefined :: a)
instance (PersistField a) => PersistField [a] where
persistName (_ :: [a]) = "List$$" ++ persistName (undefined :: a)
toPersistValue l = insertList l >>= toPersistValue
fromPersistValue k = getList (fromPrim k)
dbType (_ :: [a]) = DbList $ namedType (undefined :: a)
instance (PersistField a, PersistField b) => PersistField (a, b) where
persistName (_ :: (a, b)) = "Tuple2$$" ++ persistName (undefined :: a) ++ "$" ++ persistName (undefined :: b)
toPersistValue x@(a, b) = do
vals <- sequence [toPersistValue a, toPersistValue b]
liftM PersistInt64 $ insertTuple (namedType x) vals
fromPersistValue (PersistInt64 key) = do
[a, b] <- getTuple (namedType (undefined :: (a, b))) key
liftM2 (,) (fromPersistValue a) (fromPersistValue b)
fromPersistValue x = fail $ "Expected Integer(tuple key), received: " ++ show x
dbType (_ :: (a, b)) = DbTuple 2 [namedType (undefined :: a), namedType (undefined :: b)]
instance (PersistField a, PersistField b, PersistField c) => PersistField (a, b, c) where
persistName (_ :: (a, b, c)) = "Tuple3$$" ++ persistName (undefined :: a) ++ "$" ++ persistName (undefined :: b) ++ "$" ++ persistName (undefined :: c)
toPersistValue x@(a, b, c) = do
vals <- sequence [toPersistValue a, toPersistValue b, toPersistValue c]
liftM PersistInt64 $ insertTuple (namedType x) vals
fromPersistValue (PersistInt64 key) = do
[a, b, c] <- getTuple (namedType (undefined :: (a, b, c))) key
liftM3 (,,) (fromPersistValue a) (fromPersistValue b) (fromPersistValue c)
fromPersistValue x = fail $ "Expected Integer(tuple key), received: " ++ show x
dbType (_ :: (a, b, c)) = DbTuple 3 [namedType (undefined :: a), namedType (undefined :: b), namedType (undefined :: c)]
instance (PersistField a, PersistField b, PersistField c, PersistField d) => PersistField (a, b, c, d) where
persistName (_ :: (a, b, c, d)) = "Tuple4$$" ++ persistName (undefined :: a) ++ "$" ++ persistName (undefined :: b) ++ "$" ++ persistName (undefined :: c) ++ "$" ++ persistName (undefined :: d)
toPersistValue x@(a, b, c, d) = do
vals <- sequence [toPersistValue a, toPersistValue b, toPersistValue c, toPersistValue d]
liftM PersistInt64 $ insertTuple (namedType x) vals
fromPersistValue (PersistInt64 key) = do
[a, b, c, d] <- getTuple (namedType (undefined :: (a, b, c, d))) key
liftM4 (,,,) (fromPersistValue a) (fromPersistValue b) (fromPersistValue c) (fromPersistValue d)
fromPersistValue x = fail $ "Expected Integer(tuple key), received: " ++ show x
dbType (_ :: (a, b, c, d)) = DbTuple 4 [namedType (undefined :: a), namedType (undefined :: b), namedType (undefined :: c), namedType (undefined :: d)]
instance (PersistField a, PersistField b, PersistField c, PersistField d, PersistField e) => PersistField (a, b, c, d, e) where
persistName (_ :: (a, b, c, d, e)) = "Tuple5$$" ++ persistName (undefined :: a) ++ "$" ++ persistName (undefined :: b) ++ "$" ++ persistName (undefined :: c) ++ "$" ++ persistName (undefined :: d) ++ "$" ++ persistName (undefined :: e)
toPersistValue x@(a, b, c, d, e) = do
vals <- sequence [toPersistValue a, toPersistValue b, toPersistValue c, toPersistValue d, toPersistValue e]
liftM PersistInt64 $ insertTuple (namedType x) vals
fromPersistValue (PersistInt64 key) = do
[a, b, c, d, e] <- getTuple (namedType (undefined :: (a, b, c, d, e))) key
liftM5 (,,,,) (fromPersistValue a) (fromPersistValue b) (fromPersistValue c) (fromPersistValue d) (fromPersistValue e)
fromPersistValue x = fail $ "Expected Integer(tuple key), received: " ++ show x
dbType (_ :: (a, b, c, d, e)) = DbTuple 5 [namedType (undefined :: a), namedType (undefined :: b), namedType (undefined :: c), namedType (undefined :: d), namedType (undefined :: e)]