{-# LANGUAGE TypeFamilies, GADTs, TypeSynonymInstances, OverlappingInstances, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, CPP, ConstraintKinds #-}
{-# 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, getUniqueFields)

import qualified Data.Aeson as A
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
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 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 qualified Data.Scientific
#else
import qualified Data.Attoparsec.Number as AN
#endif

instance (PersistField a', PersistField b') => Embedded (a', b') where
  data Selector (a', b') constr where
    Tuple2_0Selector :: Selector (a, b) a
    Tuple2_1Selector :: Selector (a, b) b
  selectorNum Tuple2_0Selector = 0
  selectorNum Tuple2_1Selector = 1

instance (PersistField a', PersistField b', PersistField c') => Embedded (a', b', c') where
  data Selector (a', b', c') constr where
    Tuple3_0Selector :: Selector (a, b, c) a
    Tuple3_1Selector :: Selector (a, b, c) b
    Tuple3_2Selector :: Selector (a, b, c) c
  selectorNum Tuple3_0Selector = 0
  selectorNum Tuple3_1Selector = 1
  selectorNum Tuple3_2Selector = 2

instance (PersistField a', PersistField b', PersistField c', PersistField d') => Embedded (a', b', c', d') where
  data Selector (a', b', c', d') constr where
    Tuple4_0Selector :: Selector (a, b, c, d) a
    Tuple4_1Selector :: Selector (a, b, c, d) b
    Tuple4_2Selector :: Selector (a, b, c, d) c
    Tuple4_3Selector :: Selector (a, b, c, d) d
  selectorNum Tuple4_0Selector = 0
  selectorNum Tuple4_1Selector = 1
  selectorNum Tuple4_2Selector = 2
  selectorNum Tuple4_3Selector = 3

instance (PersistField a', PersistField b', PersistField c', PersistField d', PersistField e') => Embedded (a', b', c', d', e') where
  data Selector (a', b', c', d', e') constr where
    Tuple5_0Selector :: Selector (a, b, c, d, e) a
    Tuple5_1Selector :: Selector (a, b, c, d, e) b
    Tuple5_2Selector :: Selector (a, b, c, d, e) c
    Tuple5_3Selector :: Selector (a, b, c, d, e) d
    Tuple5_4Selector :: Selector (a, b, c, d, e) e
  selectorNum Tuple5_0Selector = 0
  selectorNum Tuple5_1Selector = 1
  selectorNum Tuple5_2Selector = 2
  selectorNum Tuple5_3Selector = 3
  selectorNum Tuple5_4Selector = 4

instance PurePersistField () where
  toPurePersistValues _ = id
  fromPurePersistValues xs = ((), xs)

instance (PurePersistField a, PurePersistField b) => PurePersistField (a, b) where
  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 (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 (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 (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 = 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 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 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 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)

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)

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)

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)

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)

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)

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)

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)

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)

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)

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

instance PrimitivePersistField Day where
  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)

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)

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)

instance (PrimitivePersistField a, NeverNull a) => PrimitivePersistField (Maybe a) where
  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 (KeyForBackend a) = toPrimitivePersistValue a
  fromPrimitivePersistValue x = KeyForBackend (fromPrimitivePersistValue x)

instance (PersistField a, PrimitivePersistField a) => PurePersistField a where
  toPurePersistValues = primToPurePersistValues
  fromPurePersistValues = primFromPurePersistValues

instance (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 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

instance PersistField ByteString where
  persistName _ = "ByteString"
  toPersistValues = primToPersistValue
  fromPersistValues = primFromPersistValue
  dbType _ _ = DbTypePrimitive DbBlob False Nothing Nothing

instance PersistField Lazy.ByteString where
  persistName _ = "ByteString"
  toPersistValues = primToPersistValue
  fromPersistValues = primFromPersistValue
  dbType _ _ = DbTypePrimitive DbBlob False Nothing Nothing

instance PersistField String where
  persistName _ = "String"
  toPersistValues = primToPersistValue
  fromPersistValues = primFromPersistValue
  dbType _ _ = DbTypePrimitive DbString False Nothing Nothing

instance PersistField T.Text where
  persistName _ = "Text"
  toPersistValues = primToPersistValue
  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
  fromPersistValues = primFromPersistValue
  dbType _ _ = DbTypePrimitive DbInt32 False Nothing Nothing

instance PersistField Int16 where
  persistName _ = "Int16"
  toPersistValues = primToPersistValue
  fromPersistValues = primFromPersistValue
  dbType _ _ = DbTypePrimitive DbInt32 False Nothing Nothing

instance PersistField Int32 where
  persistName _ = "Int32"
  toPersistValues = primToPersistValue
  fromPersistValues = primFromPersistValue
  dbType _ _ = DbTypePrimitive DbInt32 False Nothing Nothing

instance PersistField Int64 where
  persistName _ = "Int64"
  toPersistValues = primToPersistValue
  fromPersistValues = primFromPersistValue
  dbType _ _ = DbTypePrimitive DbInt64 False Nothing Nothing

instance PersistField Word8 where
  persistName _ = "Word8"
  toPersistValues = primToPersistValue
  fromPersistValues = primFromPersistValue
  dbType _ _ = DbTypePrimitive DbInt32 False Nothing Nothing

instance PersistField Word16 where
  persistName _ = "Word16"
  toPersistValues = primToPersistValue
  fromPersistValues = primFromPersistValue
  dbType _ _ = DbTypePrimitive DbInt32 False Nothing Nothing

instance PersistField Word32 where
  persistName _ = "Word32"
  toPersistValues = primToPersistValue
  fromPersistValues = primFromPersistValue
  dbType _ _ = DbTypePrimitive DbInt64 False Nothing Nothing

instance PersistField Word64 where
  persistName _ = "Word64"
  toPersistValues = primToPersistValue
  fromPersistValues = primFromPersistValue
  dbType _ _ = DbTypePrimitive DbInt64 False Nothing Nothing

instance PersistField Double where
  persistName _ = "Double"
  toPersistValues = primToPersistValue
  fromPersistValues = primFromPersistValue
  dbType _ _ = DbTypePrimitive DbReal False Nothing Nothing

instance PersistField Bool where
  persistName _ = "Bool"
  toPersistValues = primToPersistValue
  fromPersistValues = primFromPersistValue
  dbType _ _ = DbTypePrimitive DbBool False Nothing Nothing

instance PersistField Day where
  persistName _ = "Day"
  toPersistValues = primToPersistValue
  fromPersistValues = primFromPersistValue
  dbType _ _ = DbTypePrimitive DbDay False Nothing Nothing

instance PersistField TimeOfDay where
  persistName _ = "TimeOfDay"
  toPersistValues = primToPersistValue
  fromPersistValues = primFromPersistValue
  dbType _ _ = DbTypePrimitive DbTime False Nothing Nothing

instance PersistField UTCTime where
  persistName _ = "UTCTime"
  toPersistValues = primToPersistValue
  fromPersistValues = primFromPersistValue
  dbType _ _ = DbTypePrimitive DbDayTime False Nothing Nothing

instance PersistField ZonedTime where
  persistName _ = "ZonedTime"
  toPersistValues = primToPersistValue
  fromPersistValues = primFromPersistValue
  dbType _ _ = DbTypePrimitive DbDayTimeZoned False Nothing Nothing

-- There is a weird bug in GHC 7.4.1 which causes program to hang. See ticket 7126.
-- instance (PersistField a, NeverNull a) => PersistField (Maybe a) where -- OK
-- 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 (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')
  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
  persistName a = "List" ++ delim : delim : persistName ((undefined :: [] a -> a) a)
  toPersistValues l = insertList l >>= toPersistValues
  fromPersistValues [] = fail "fromPersistValues []: empty list"
  fromPersistValues (x:xs) = getList (fromPrimitivePersistValue x) >>= \l -> return (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)
  dbType _ _ = DbEmbedded (EmbeddedDef False []) Nothing

instance (PersistField a, PersistField b) => PersistField (a, b) where
  persistName a = "Tuple2" ++ delim : delim : persistName ((undefined :: (a, b) -> a) a) ++ delim : persistName ((undefined :: (a, b) -> b) a)
  toPersistValues (a, b) = do
    a' <- toPersistValues a
    b' <- toPersistValues b
    return $ a' . b'
  fromPersistValues xs = do
    (a, rest0) <- fromPersistValues xs
    (b, rest1) <- fromPersistValues rest0
    return ((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'
  fromPersistValues xs = do
    (a, rest0) <- fromPersistValues xs
    (b, rest1) <- fromPersistValues rest0
    (c, rest2) <- fromPersistValues rest1
    return ((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
    a' <- toPersistValues a
    b' <- toPersistValues b
    c' <- toPersistValues c
    d' <- toPersistValues d
    return $ 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)
  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
    a' <- toPersistValues a
    b' <- toPersistValues b
    c' <- toPersistValues c
    d' <- toPersistValues d
    e' <- toPersistValues e
    return $ 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)
  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
  persistName a = "KeyForBackend" ++ delim : persistName ((undefined :: KeyForBackend db v -> v) a)
  toPersistValues = primToPersistValue
  fromPersistValues = primFromPersistValue
  dbType db a = dbType db ((undefined :: KeyForBackend db v -> DefaultKey v) a)

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
  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
  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:)
  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:)
  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
  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

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
  projectionResult _ = fromPersistValues

instance (Projection a1 a1', Projection a2 a2') => Projection (a1, a2) (a1', a2') where
  type ProjectionDb (a1, a2) db = (ProjectionDb a1 db, ProjectionDb a2 db)
  type ProjectionRestriction (a1, a2) r = (ProjectionRestriction a1 r, ProjectionRestriction a2 r)
  projectionExprs (a1, a2) = projectionExprs a1 . projectionExprs a2
  projectionResult (a', b') xs = do
    (a, rest0) <- projectionResult a' xs
    (b, rest1) <- projectionResult b' rest0
    return ((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)
  type ProjectionRestriction (a1, a2, a3) r = (ProjectionRestriction (a1, a2) r, ProjectionRestriction a3 r)
  projectionExprs (a1, a2, a3) = projectionExprs a1 . projectionExprs a2 . projectionExprs a3
  projectionResult (a', b', c') xs = do
    (a, rest0) <- projectionResult a' xs
    (b, rest1) <- projectionResult b' rest0
    (c, rest2) <- projectionResult c' rest1
    return ((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)
  type ProjectionRestriction (a1, a2, a3, a4) r = (ProjectionRestriction (a1, a2, a3) r, ProjectionRestriction a4 r)
  projectionExprs (a1, a2, a3, a4) = projectionExprs a1 . projectionExprs a2 . projectionExprs a3 . projectionExprs a4
  projectionResult (a', b', c', d') xs = do
    (a, rest0) <- projectionResult a' xs
    (b, rest1) <- projectionResult b' rest0
    (c, rest2) <- projectionResult c' rest1
    (d, rest3) <- projectionResult d' rest2
    return ((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)
  type ProjectionRestriction (a1, a2, a3, a4, a5) r = (ProjectionRestriction (a1, a2, a3, a4) r, ProjectionRestriction a5 r)
  projectionExprs (a1, a2, a3, a4, a5) = projectionExprs a1 . projectionExprs a2 . projectionExprs a3 . projectionExprs a4 . projectionExprs a5
  projectionResult (a', b', c', d', e') xs = do
    (a, rest0) <- projectionResult a' xs
    (b, rest1) <- projectionResult b' rest0
    (c, rest2) <- projectionResult c' rest1
    (d, rest3) <- projectionResult d' rest2
    (e, rest4) <- projectionResult e' rest3
    return ((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

    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

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, 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
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 $ PersistText 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 = 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 (PersistBool b) = A.Bool b
  toJSON (PersistTimeOfDay t) = A.String $ T.pack $ show t
  toJSON (PersistUTCTime u) = A.String $ T.pack $ show u
  toJSON (PersistDay d) = A.String $ T.pack $ show d
  toJSON (PersistZonedTime (ZT z)) = A.String $ T.pack $ show z
  toJSON PersistNull = A.Null
  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

instance Show (Key v u) => A.ToJSON (Key v u) where
  toJSON k = A.toJSON $ show k