{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PatternGuards, DataKinds, TypeOperators, UndecidableInstances, GeneralizedNewtypeDeriving #-}
module Database.Persist.Class.PersistField
    ( PersistField (..)
    , SomePersistField (..)
    , getPersistMap
    , OverflowNatural(..)
    ) where

import Control.Arrow (second)
import Control.Monad ((<=<))
import Control.Applicative ((<|>))
import qualified Data.Aeson as A
import Data.ByteString.Char8 (ByteString, unpack, readInt)
import qualified Data.ByteString.Lazy as L
import Data.Fixed
import Data.Int (Int8, Int16, Int32, Int64)
import qualified Data.IntMap as IM
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Read (double)
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Encoding.Error as TERR
import qualified Data.Text.Lazy as TL
import qualified Data.Vector as V
import Data.Word (Word, Word8, Word16, Word32, Word64)
import Numeric.Natural (Natural)
import Text.Blaze.Html
import Text.Blaze.Html.Renderer.Text (renderHtml)
import GHC.TypeLits

import Database.Persist.Types.Base

import Data.Time (Day(..), TimeOfDay, UTCTime,
    parseTimeM)
import Data.Time (defaultTimeLocale)

#ifdef HIGH_PRECISION_DATE
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
#endif


-- | This class teaches Persistent how to take a custom type and marshal it to and from a 'PersistValue', allowing it to be stored in a database.
--
-- ==== __Examples__
--
-- ===== Simple Newtype
--
-- You can use @newtype@ to add more type safety/readability to a basis type like 'ByteString'. In these cases, just derive 'PersistField' and @PersistFieldSql@:
--
-- @
-- {-\# LANGUAGE GeneralizedNewtypeDeriving #-}
--
-- newtype HashedPassword = HashedPassword 'ByteString'
--   deriving (Eq, Show, 'PersistField', PersistFieldSql)
-- @
--
-- ===== Smart Constructor Newtype
--
-- In this example, we create a 'PersistField' instance for a newtype following the "Smart Constructor" pattern.
--
-- @
-- {-\# LANGUAGE GeneralizedNewtypeDeriving #-}
-- import qualified "Data.Text" as T
-- import qualified "Data.Char" as C
--
-- -- | An American Social Security Number
-- newtype SSN = SSN 'Text'
--  deriving (Eq, Show, PersistFieldSql)
--
-- mkSSN :: 'Text' -> 'Either' 'Text' SSN
-- mkSSN t = if (T.length t == 9) && (T.all C.isDigit t)
--  then 'Right' $ SSN t
--  else 'Left' $ "Invalid SSN: " <> t
--
-- instance 'PersistField' SSN where
--   'toPersistValue' (SSN t) = 'PersistText' t
--   'fromPersistValue' ('PersistText' t) = mkSSN t
--   -- Handle cases where the database does not give us PersistText
--   'fromPersistValue' x = 'Left' $ "File.hs: When trying to deserialize an SSN: expected PersistText, received: " <> T.pack (show x)
-- @
--
-- Tips:
--
-- * This file contain dozens of 'PersistField' instances you can look at for examples.
-- * Typically custom 'PersistField' instances will only accept a single 'PersistValue' constructor in 'fromPersistValue'.
-- * Internal 'PersistField' instances accept a wide variety of 'PersistValue's to accomodate e.g. storing booleans as integers, booleans or strings.
-- * If you're making a custom instance and using a SQL database, you'll also need @PersistFieldSql@ to specify the type of the database column.
class PersistField a where
    toPersistValue :: a -> PersistValue
    fromPersistValue :: PersistValue -> Either T.Text a

#ifndef NO_OVERLAP
instance {-# OVERLAPPING #-} PersistField [Char] where
    toPersistValue :: [Char] -> PersistValue
toPersistValue = Text -> PersistValue
PersistText (Text -> PersistValue)
-> ([Char] -> Text) -> [Char] -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack
    fromPersistValue :: PersistValue -> Either Text [Char]
fromPersistValue (PersistText Text
s) = [Char] -> Either Text [Char]
forall a b. b -> Either a b
Right ([Char] -> Either Text [Char]) -> [Char] -> Either Text [Char]
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
s
    fromPersistValue (PersistByteString ByteString
bs) =
        [Char] -> Either Text [Char]
forall a b. b -> Either a b
Right ([Char] -> Either Text [Char]) -> [Char] -> Either Text [Char]
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
TE.decodeUtf8With OnDecodeError
TERR.lenientDecode ByteString
bs
    fromPersistValue (PersistInt64 Int64
i) = [Char] -> Either Text [Char]
forall a b. b -> Either a b
Right ([Char] -> Either Text [Char]) -> [Char] -> Either Text [Char]
forall a b. (a -> b) -> a -> b
$ Int64 -> [Char]
forall a. Show a => a -> [Char]
Prelude.show Int64
i
    fromPersistValue (PersistDouble Double
d) = [Char] -> Either Text [Char]
forall a b. b -> Either a b
Right ([Char] -> Either Text [Char]) -> [Char] -> Either Text [Char]
forall a b. (a -> b) -> a -> b
$ Double -> [Char]
forall a. Show a => a -> [Char]
Prelude.show Double
d
    fromPersistValue (PersistRational Rational
r) = [Char] -> Either Text [Char]
forall a b. b -> Either a b
Right ([Char] -> Either Text [Char]) -> [Char] -> Either Text [Char]
forall a b. (a -> b) -> a -> b
$ Rational -> [Char]
forall a. Show a => a -> [Char]
Prelude.show Rational
r
    fromPersistValue (PersistDay Day
d) = [Char] -> Either Text [Char]
forall a b. b -> Either a b
Right ([Char] -> Either Text [Char]) -> [Char] -> Either Text [Char]
forall a b. (a -> b) -> a -> b
$ Day -> [Char]
forall a. Show a => a -> [Char]
Prelude.show Day
d
    fromPersistValue (PersistTimeOfDay TimeOfDay
d) = [Char] -> Either Text [Char]
forall a b. b -> Either a b
Right ([Char] -> Either Text [Char]) -> [Char] -> Either Text [Char]
forall a b. (a -> b) -> a -> b
$ TimeOfDay -> [Char]
forall a. Show a => a -> [Char]
Prelude.show TimeOfDay
d
    fromPersistValue (PersistUTCTime UTCTime
d) = [Char] -> Either Text [Char]
forall a b. b -> Either a b
Right ([Char] -> Either Text [Char]) -> [Char] -> Either Text [Char]
forall a b. (a -> b) -> a -> b
$ UTCTime -> [Char]
forall a. Show a => a -> [Char]
Prelude.show UTCTime
d
    fromPersistValue PersistValue
PersistNull = Text -> Either Text [Char]
forall a b. a -> Either a b
Left (Text -> Either Text [Char]) -> Text -> Either Text [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
"Unexpected null"
    fromPersistValue (PersistBool Bool
b) = [Char] -> Either Text [Char]
forall a b. b -> Either a b
Right ([Char] -> Either Text [Char]) -> [Char] -> Either Text [Char]
forall a b. (a -> b) -> a -> b
$ Bool -> [Char]
forall a. Show a => a -> [Char]
Prelude.show Bool
b
    fromPersistValue (PersistList [PersistValue]
_) = Text -> Either Text [Char]
forall a b. a -> Either a b
Left (Text -> Either Text [Char]) -> Text -> Either Text [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
"Cannot convert PersistList to String"
    fromPersistValue (PersistMap [(Text, PersistValue)]
_) = Text -> Either Text [Char]
forall a b. a -> Either a b
Left (Text -> Either Text [Char]) -> Text -> Either Text [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
"Cannot convert PersistMap to String"
    fromPersistValue (PersistLiteral_ LiteralType
_ ByteString
_) = Text -> Either Text [Char]
forall a b. a -> Either a b
Left (Text -> Either Text [Char]) -> Text -> Either Text [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
"Cannot convert PersistLiteral_ to String"
    fromPersistValue (PersistArray [PersistValue]
_) = Text -> Either Text [Char]
forall a b. a -> Either a b
Left (Text -> Either Text [Char]) -> Text -> Either Text [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
"Cannot convert PersistArray to String"
    fromPersistValue (PersistObjectId ByteString
_) = Text -> Either Text [Char]
forall a b. a -> Either a b
Left (Text -> Either Text [Char]) -> Text -> Either Text [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
"Cannot convert PersistObjectId to String"
#endif

instance PersistField ByteString where
    toPersistValue :: ByteString -> PersistValue
toPersistValue = ByteString -> PersistValue
PersistByteString
    fromPersistValue :: PersistValue -> Either Text ByteString
fromPersistValue (PersistByteString ByteString
bs) = ByteString -> Either Text ByteString
forall a b. b -> Either a b
Right ByteString
bs
    fromPersistValue PersistValue
x = Text -> ByteString
TE.encodeUtf8 (Text -> ByteString) -> Either Text Text -> Either Text ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PersistValue -> Either Text Text
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
x

instance PersistField T.Text where
    toPersistValue :: Text -> PersistValue
toPersistValue = Text -> PersistValue
PersistText
    fromPersistValue :: PersistValue -> Either Text Text
fromPersistValue = PersistValue -> Either Text Text
fromPersistValueText

instance PersistField TL.Text where
    toPersistValue :: Text -> PersistValue
toPersistValue = Text -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue (Text -> PersistValue) -> (Text -> Text) -> Text -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.toStrict
    fromPersistValue :: PersistValue -> Either Text Text
fromPersistValue = (Text -> Text) -> Either Text Text -> Either Text Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
TL.fromStrict (Either Text Text -> Either Text Text)
-> (PersistValue -> Either Text Text)
-> PersistValue
-> Either Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PersistValue -> Either Text Text
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue

instance PersistField Html where
    toPersistValue :: Html -> PersistValue
toPersistValue = Text -> PersistValue
PersistText (Text -> PersistValue) -> (Html -> Text) -> Html -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.toStrict (Text -> Text) -> (Html -> Text) -> Html -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Text
renderHtml
    fromPersistValue :: PersistValue -> Either Text Html
fromPersistValue = (Text -> Html) -> Either Text Text -> Either Text Html
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Html
forall a. ToMarkup a => a -> Html
preEscapedToMarkup :: T.Text -> Html) (Either Text Text -> Either Text Html)
-> (PersistValue -> Either Text Text)
-> PersistValue
-> Either Text Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PersistValue -> Either Text Text
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue

instance PersistField Int where
    toPersistValue :: Int -> PersistValue
toPersistValue = Int64 -> PersistValue
PersistInt64 (Int64 -> PersistValue) -> (Int -> Int64) -> Int -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    fromPersistValue :: PersistValue -> Either Text Int
fromPersistValue (PersistInt64 Int64
i)  = Int -> Either Text Int
forall a b. b -> Either a b
Right (Int -> Either Text Int) -> Int -> Either Text Int
forall a b. (a -> b) -> a -> b
$ Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i
    fromPersistValue (PersistDouble Double
i) = Int -> Either Text Int
forall a b. b -> Either a b
Right (Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
truncate Double
i :: Int) -- oracle
    fromPersistValue PersistValue
x = Text -> Either Text Int
forall a b. a -> Either a b
Left (Text -> Either Text Int) -> Text -> Either Text Int
forall a b. (a -> b) -> a -> b
$ Text -> Text -> PersistValue -> Text
fromPersistValueError Text
"Int" Text
"integer" PersistValue
x

instance PersistField Int8 where
    toPersistValue :: Int8 -> PersistValue
toPersistValue = Int64 -> PersistValue
PersistInt64 (Int64 -> PersistValue) -> (Int8 -> Int64) -> Int8 -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int8 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    fromPersistValue :: PersistValue -> Either Text Int8
fromPersistValue (PersistInt64 Int64
i)  = Int8 -> Either Text Int8
forall a b. b -> Either a b
Right (Int8 -> Either Text Int8) -> Int8 -> Either Text Int8
forall a b. (a -> b) -> a -> b
$ Int64 -> Int8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i
    fromPersistValue (PersistDouble Double
i) = Int8 -> Either Text Int8
forall a b. b -> Either a b
Right (Double -> Int8
forall a b. (RealFrac a, Integral b) => a -> b
truncate Double
i :: Int8) -- oracle
    fromPersistValue (PersistByteString ByteString
bs) = case ByteString -> Maybe (Int, ByteString)
readInt ByteString
bs of  -- oracle
                                               Just (Int
i,ByteString
"") -> Int8 -> Either Text Int8
forall a b. b -> Either a b
Right (Int8 -> Either Text Int8) -> Int8 -> Either Text Int8
forall a b. (a -> b) -> a -> b
$ Int -> Int8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i
                                               Just (Int
i,ByteString
extra) -> Text -> Either Text Int8
forall a b. a -> Either a b
Left (Text -> Either Text Int8) -> Text -> Either Text Int8
forall a b. (a -> b) -> a -> b
$ Text -> ByteString -> Int -> ByteString -> Text
forall result.
Show result =>
Text -> ByteString -> result -> ByteString -> Text
extraInputError Text
"Int64" ByteString
bs Int
i ByteString
extra
                                               Maybe (Int, ByteString)
Nothing -> Text -> Either Text Int8
forall a b. a -> Either a b
Left (Text -> Either Text Int8) -> Text -> Either Text Int8
forall a b. (a -> b) -> a -> b
$ Text -> ByteString -> Text
intParseError Text
"Int64" ByteString
bs
    fromPersistValue PersistValue
x = Text -> Either Text Int8
forall a b. a -> Either a b
Left (Text -> Either Text Int8) -> Text -> Either Text Int8
forall a b. (a -> b) -> a -> b
$ Text -> Text -> PersistValue -> Text
fromPersistValueError Text
"Int8" Text
"integer" PersistValue
x

instance PersistField Int16 where
    toPersistValue :: Int16 -> PersistValue
toPersistValue = Int64 -> PersistValue
PersistInt64 (Int64 -> PersistValue)
-> (Int16 -> Int64) -> Int16 -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int16 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    fromPersistValue :: PersistValue -> Either Text Int16
fromPersistValue (PersistInt64 Int64
i)  = Int16 -> Either Text Int16
forall a b. b -> Either a b
Right (Int16 -> Either Text Int16) -> Int16 -> Either Text Int16
forall a b. (a -> b) -> a -> b
$ Int64 -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i
    fromPersistValue (PersistDouble Double
i) = Int16 -> Either Text Int16
forall a b. b -> Either a b
Right (Double -> Int16
forall a b. (RealFrac a, Integral b) => a -> b
truncate Double
i :: Int16) -- oracle
    fromPersistValue (PersistByteString ByteString
bs) = case ByteString -> Maybe (Int, ByteString)
readInt ByteString
bs of  -- oracle
                                               Just (Int
i,ByteString
"") -> Int16 -> Either Text Int16
forall a b. b -> Either a b
Right (Int16 -> Either Text Int16) -> Int16 -> Either Text Int16
forall a b. (a -> b) -> a -> b
$ Int -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i
                                               Just (Int
i,ByteString
extra) -> Text -> Either Text Int16
forall a b. a -> Either a b
Left (Text -> Either Text Int16) -> Text -> Either Text Int16
forall a b. (a -> b) -> a -> b
$ Text -> ByteString -> Int -> ByteString -> Text
forall result.
Show result =>
Text -> ByteString -> result -> ByteString -> Text
extraInputError Text
"Int64" ByteString
bs Int
i ByteString
extra
                                               Maybe (Int, ByteString)
Nothing -> Text -> Either Text Int16
forall a b. a -> Either a b
Left (Text -> Either Text Int16) -> Text -> Either Text Int16
forall a b. (a -> b) -> a -> b
$ Text -> ByteString -> Text
intParseError Text
"Int64" ByteString
bs
    fromPersistValue PersistValue
x = Text -> Either Text Int16
forall a b. a -> Either a b
Left (Text -> Either Text Int16) -> Text -> Either Text Int16
forall a b. (a -> b) -> a -> b
$ Text -> Text -> PersistValue -> Text
fromPersistValueError Text
"Int16" Text
"integer" PersistValue
x

instance PersistField Int32 where
    toPersistValue :: Int32 -> PersistValue
toPersistValue = Int64 -> PersistValue
PersistInt64 (Int64 -> PersistValue)
-> (Int32 -> Int64) -> Int32 -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    fromPersistValue :: PersistValue -> Either Text Int32
fromPersistValue (PersistInt64 Int64
i)  = Int32 -> Either Text Int32
forall a b. b -> Either a b
Right (Int32 -> Either Text Int32) -> Int32 -> Either Text Int32
forall a b. (a -> b) -> a -> b
$ Int64 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i
    fromPersistValue (PersistDouble Double
i) = Int32 -> Either Text Int32
forall a b. b -> Either a b
Right (Double -> Int32
forall a b. (RealFrac a, Integral b) => a -> b
truncate Double
i :: Int32) -- oracle
    fromPersistValue (PersistByteString ByteString
bs) = case ByteString -> Maybe (Int, ByteString)
readInt ByteString
bs of  -- oracle
                                               Just (Int
i,ByteString
"") -> Int32 -> Either Text Int32
forall a b. b -> Either a b
Right (Int32 -> Either Text Int32) -> Int32 -> Either Text Int32
forall a b. (a -> b) -> a -> b
$ Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i
                                               Just (Int
i,ByteString
extra) -> Text -> Either Text Int32
forall a b. a -> Either a b
Left (Text -> Either Text Int32) -> Text -> Either Text Int32
forall a b. (a -> b) -> a -> b
$ Text -> ByteString -> Int -> ByteString -> Text
forall result.
Show result =>
Text -> ByteString -> result -> ByteString -> Text
extraInputError Text
"Int64" ByteString
bs Int
i ByteString
extra
                                               Maybe (Int, ByteString)
Nothing -> Text -> Either Text Int32
forall a b. a -> Either a b
Left (Text -> Either Text Int32) -> Text -> Either Text Int32
forall a b. (a -> b) -> a -> b
$ Text -> ByteString -> Text
intParseError Text
"Int64" ByteString
bs
    fromPersistValue PersistValue
x = Text -> Either Text Int32
forall a b. a -> Either a b
Left (Text -> Either Text Int32) -> Text -> Either Text Int32
forall a b. (a -> b) -> a -> b
$ Text -> Text -> PersistValue -> Text
fromPersistValueError Text
"Int32" Text
"integer" PersistValue
x

instance PersistField Int64 where
    toPersistValue :: Int64 -> PersistValue
toPersistValue = Int64 -> PersistValue
PersistInt64
    fromPersistValue :: PersistValue -> Either Text Int64
fromPersistValue (PersistInt64 Int64
i)  = Int64 -> Either Text Int64
forall a b. b -> Either a b
Right Int64
i
    fromPersistValue (PersistDouble Double
i) = Int64 -> Either Text Int64
forall a b. b -> Either a b
Right (Double -> Int64
forall a b. (RealFrac a, Integral b) => a -> b
truncate Double
i :: Int64) -- oracle
    fromPersistValue (PersistByteString ByteString
bs) = case ByteString -> Maybe (Int, ByteString)
readInt ByteString
bs of  -- oracle
                                               Just (Int
i,ByteString
"") -> Int64 -> Either Text Int64
forall a b. b -> Either a b
Right (Int64 -> Either Text Int64) -> Int64 -> Either Text Int64
forall a b. (a -> b) -> a -> b
$ Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i
                                               Just (Int
i,ByteString
extra) -> Text -> Either Text Int64
forall a b. a -> Either a b
Left (Text -> Either Text Int64) -> Text -> Either Text Int64
forall a b. (a -> b) -> a -> b
$ Text -> ByteString -> Int -> ByteString -> Text
forall result.
Show result =>
Text -> ByteString -> result -> ByteString -> Text
extraInputError Text
"Int64" ByteString
bs Int
i ByteString
extra
                                               Maybe (Int, ByteString)
Nothing -> Text -> Either Text Int64
forall a b. a -> Either a b
Left (Text -> Either Text Int64) -> Text -> Either Text Int64
forall a b. (a -> b) -> a -> b
$ Text -> ByteString -> Text
intParseError Text
"Int64" ByteString
bs
    fromPersistValue PersistValue
x = Text -> Either Text Int64
forall a b. a -> Either a b
Left (Text -> Either Text Int64) -> Text -> Either Text Int64
forall a b. (a -> b) -> a -> b
$ Text -> Text -> PersistValue -> Text
fromPersistValueError Text
"Int64" Text
"integer" PersistValue
x

extraInputError :: (Show result)
                => Text -- ^ Haskell type
                -> ByteString -- ^ Original bytestring
                -> result -- ^ Integer result
                -> ByteString -- ^  Extra bytestring
                -> Text -- ^ Error message
extraInputError :: Text -> ByteString -> result -> ByteString -> Text
extraInputError Text
haskellType ByteString
original result
result ByteString
extra = [Text] -> Text
T.concat
    [ Text
"Parsed "
    , ByteString -> Text
TE.decodeUtf8 ByteString
original
    , Text
" into Haskell type `"
    , Text
haskellType
    , Text
"` with value"
    , [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ result -> [Char]
forall a. Show a => a -> [Char]
show result
result
    , Text
"but had extra input: "
    , ByteString -> Text
TE.decodeUtf8 ByteString
extra
    ]

intParseError :: Text -- ^ Haskell type
              -> ByteString -- ^ Original bytestring
              -> Text -- ^ Error message
intParseError :: Text -> ByteString -> Text
intParseError Text
haskellType ByteString
original = [Text] -> Text
T.concat
    [ Text
"Failed to parse Haskell type `"
    , Text
haskellType
    , Text
" from "
    , ByteString -> Text
TE.decodeUtf8 ByteString
original
    ]

instance PersistField Data.Word.Word where
    toPersistValue :: Word -> PersistValue
toPersistValue = Int64 -> PersistValue
PersistInt64 (Int64 -> PersistValue) -> (Word -> Int64) -> Word -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    fromPersistValue :: PersistValue -> Either Text Word
fromPersistValue (PersistInt64 Int64
i) = Word -> Either Text Word
forall a b. b -> Either a b
Right (Word -> Either Text Word) -> Word -> Either Text Word
forall a b. (a -> b) -> a -> b
$ Int64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i
    fromPersistValue PersistValue
x = Text -> Either Text Word
forall a b. a -> Either a b
Left (Text -> Either Text Word) -> Text -> Either Text Word
forall a b. (a -> b) -> a -> b
$ Text -> Text -> PersistValue -> Text
fromPersistValueError Text
"Word" Text
"integer" PersistValue
x

instance PersistField Word8 where
    toPersistValue :: Word8 -> PersistValue
toPersistValue = Int64 -> PersistValue
PersistInt64 (Int64 -> PersistValue)
-> (Word8 -> Int64) -> Word8 -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    fromPersistValue :: PersistValue -> Either Text Word8
fromPersistValue (PersistInt64 Int64
i) = Word8 -> Either Text Word8
forall a b. b -> Either a b
Right (Word8 -> Either Text Word8) -> Word8 -> Either Text Word8
forall a b. (a -> b) -> a -> b
$ Int64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i
    fromPersistValue PersistValue
x = Text -> Either Text Word8
forall a b. a -> Either a b
Left (Text -> Either Text Word8) -> Text -> Either Text Word8
forall a b. (a -> b) -> a -> b
$ Text -> Text -> PersistValue -> Text
fromPersistValueError Text
"Word8" Text
"integer" PersistValue
x

instance PersistField Word16 where
    toPersistValue :: Word16 -> PersistValue
toPersistValue = Int64 -> PersistValue
PersistInt64 (Int64 -> PersistValue)
-> (Word16 -> Int64) -> Word16 -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    fromPersistValue :: PersistValue -> Either Text Word16
fromPersistValue (PersistInt64 Int64
i) = Word16 -> Either Text Word16
forall a b. b -> Either a b
Right (Word16 -> Either Text Word16) -> Word16 -> Either Text Word16
forall a b. (a -> b) -> a -> b
$ Int64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i
    fromPersistValue PersistValue
x = Text -> Either Text Word16
forall a b. a -> Either a b
Left (Text -> Either Text Word16) -> Text -> Either Text Word16
forall a b. (a -> b) -> a -> b
$ Text -> Text -> PersistValue -> Text
fromPersistValueError Text
"Word16" Text
"integer" PersistValue
x

instance PersistField Word32 where
    toPersistValue :: Word32 -> PersistValue
toPersistValue = Int64 -> PersistValue
PersistInt64 (Int64 -> PersistValue)
-> (Word32 -> Int64) -> Word32 -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    fromPersistValue :: PersistValue -> Either Text Word32
fromPersistValue (PersistInt64 Int64
i) = Word32 -> Either Text Word32
forall a b. b -> Either a b
Right (Word32 -> Either Text Word32) -> Word32 -> Either Text Word32
forall a b. (a -> b) -> a -> b
$ Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i
    fromPersistValue PersistValue
x = Text -> Either Text Word32
forall a b. a -> Either a b
Left (Text -> Either Text Word32) -> Text -> Either Text Word32
forall a b. (a -> b) -> a -> b
$ Text -> Text -> PersistValue -> Text
fromPersistValueError Text
"Word32" Text
"integer" PersistValue
x

instance PersistField Word64 where
    toPersistValue :: Word64 -> PersistValue
toPersistValue = Int64 -> PersistValue
PersistInt64 (Int64 -> PersistValue)
-> (Word64 -> Int64) -> Word64 -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    fromPersistValue :: PersistValue -> Either Text Word64
fromPersistValue (PersistInt64 Int64
i) = Word64 -> Either Text Word64
forall a b. b -> Either a b
Right (Word64 -> Either Text Word64) -> Word64 -> Either Text Word64
forall a b. (a -> b) -> a -> b
$ Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i
    fromPersistValue PersistValue
x = Text -> Either Text Word64
forall a b. a -> Either a b
Left (Text -> Either Text Word64) -> Text -> Either Text Word64
forall a b. (a -> b) -> a -> b
$ Text -> Text -> PersistValue -> Text
fromPersistValueError Text
"Word64" Text
"integer" PersistValue
x

instance PersistField Double where
    toPersistValue :: Double -> PersistValue
toPersistValue = Double -> PersistValue
PersistDouble
    fromPersistValue :: PersistValue -> Either Text Double
fromPersistValue (PersistDouble Double
d) = Double -> Either Text Double
forall a b. b -> Either a b
Right Double
d
    fromPersistValue (PersistRational Rational
r) = Double -> Either Text Double
forall a b. b -> Either a b
Right (Double -> Either Text Double) -> Double -> Either Text Double
forall a b. (a -> b) -> a -> b
$ Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
r
    fromPersistValue (PersistInt64 Int64
i) = Double -> Either Text Double
forall a b. b -> Either a b
Right (Double -> Either Text Double) -> Double -> Either Text Double
forall a b. (a -> b) -> a -> b
$ Int64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i
    fromPersistValue PersistValue
x = Text -> Either Text Double
forall a b. a -> Either a b
Left (Text -> Either Text Double) -> Text -> Either Text Double
forall a b. (a -> b) -> a -> b
$ Text -> Text -> PersistValue -> Text
fromPersistValueError Text
"Double" Text
"double, rational, or integer" PersistValue
x

instance (HasResolution a) => PersistField (Fixed a) where
    toPersistValue :: Fixed a -> PersistValue
toPersistValue = Rational -> PersistValue
PersistRational (Rational -> PersistValue)
-> (Fixed a -> Rational) -> Fixed a -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fixed a -> Rational
forall a. Real a => a -> Rational
toRational
    fromPersistValue :: PersistValue -> Either Text (Fixed a)
fromPersistValue (PersistRational Rational
r) = Fixed a -> Either Text (Fixed a)
forall a b. b -> Either a b
Right (Fixed a -> Either Text (Fixed a))
-> Fixed a -> Either Text (Fixed a)
forall a b. (a -> b) -> a -> b
$ Rational -> Fixed a
forall a. Fractional a => Rational -> a
fromRational Rational
r
    fromPersistValue (PersistText Text
t) = case ReadS (Fixed a)
forall a. Read a => ReadS a
reads ReadS (Fixed a) -> ReadS (Fixed a)
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
t of --  NOTE: Sqlite can store rationals just as string
      [(Fixed a
a, [Char]
"")] -> Fixed a -> Either Text (Fixed a)
forall a b. b -> Either a b
Right Fixed a
a
      [(Fixed a, [Char])]
_ -> Text -> Either Text (Fixed a)
forall a b. a -> Either a b
Left (Text -> Either Text (Fixed a)) -> Text -> Either Text (Fixed a)
forall a b. (a -> b) -> a -> b
$ Text
"Can not read " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" as Fixed"
    fromPersistValue (PersistDouble Double
d) = Fixed a -> Either Text (Fixed a)
forall a b. b -> Either a b
Right (Fixed a -> Either Text (Fixed a))
-> Fixed a -> Either Text (Fixed a)
forall a b. (a -> b) -> a -> b
$ Double -> Fixed a
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
d
    fromPersistValue (PersistInt64 Int64
i) = Fixed a -> Either Text (Fixed a)
forall a b. b -> Either a b
Right (Fixed a -> Either Text (Fixed a))
-> Fixed a -> Either Text (Fixed a)
forall a b. (a -> b) -> a -> b
$ Int64 -> Fixed a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i
    fromPersistValue PersistValue
x = Text -> Either Text (Fixed a)
forall a b. a -> Either a b
Left (Text -> Either Text (Fixed a)) -> Text -> Either Text (Fixed a)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> PersistValue -> Text
fromPersistValueError Text
"Fixed" Text
"rational, string, double, or integer" PersistValue
x

instance PersistField Rational where
    toPersistValue :: Rational -> PersistValue
toPersistValue = Rational -> PersistValue
PersistRational
    fromPersistValue :: PersistValue -> Either Text Rational
fromPersistValue (PersistRational Rational
r) = Rational -> Either Text Rational
forall a b. b -> Either a b
Right Rational
r
    fromPersistValue (PersistDouble Double
d) = Rational -> Either Text Rational
forall a b. b -> Either a b
Right (Rational -> Either Text Rational)
-> Rational -> Either Text Rational
forall a b. (a -> b) -> a -> b
$ Double -> Rational
forall a. Real a => a -> Rational
toRational Double
d
    fromPersistValue (PersistText Text
t) = case ReadS Pico
forall a. Read a => ReadS a
reads ReadS Pico -> ReadS Pico
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
t of --  NOTE: Sqlite can store rationals just as string
      [(Pico
a, [Char]
"")] -> Rational -> Either Text Rational
forall a b. b -> Either a b
Right (Rational -> Either Text Rational)
-> Rational -> Either Text Rational
forall a b. (a -> b) -> a -> b
$ Pico -> Rational
forall a. Real a => a -> Rational
toRational (Pico
a :: Pico)
      [(Pico, [Char])]
_ -> Text -> Either Text Rational
forall a b. a -> Either a b
Left (Text -> Either Text Rational) -> Text -> Either Text Rational
forall a b. (a -> b) -> a -> b
$ Text
"Can not read " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" as Rational (Pico in fact)"
    fromPersistValue (PersistInt64 Int64
i) = Rational -> Either Text Rational
forall a b. b -> Either a b
Right (Rational -> Either Text Rational)
-> Rational -> Either Text Rational
forall a b. (a -> b) -> a -> b
$ Int64 -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i
    fromPersistValue (PersistByteString ByteString
bs) = case Reader Double
double Reader Double -> Reader Double
forall a b. (a -> b) -> a -> b
$ Char -> Text -> Text
T.cons Char
'0' (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
TE.decodeUtf8With OnDecodeError
TERR.lenientDecode ByteString
bs of
                                                Right (Double
ret,Text
"") -> Rational -> Either Text Rational
forall a b. b -> Either a b
Right (Rational -> Either Text Rational)
-> Rational -> Either Text Rational
forall a b. (a -> b) -> a -> b
$ Double -> Rational
forall a. Real a => a -> Rational
toRational Double
ret
                                                Right (Double
a,Text
b) -> Text -> Either Text Rational
forall a b. a -> Either a b
Left (Text -> Either Text Rational) -> Text -> Either Text Rational
forall a b. (a -> b) -> a -> b
$ Text
"Invalid bytestring[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
bs) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]: expected a double but returned " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack ((Double, Text) -> [Char]
forall a. Show a => a -> [Char]
show (Double
a,Text
b))
                                                Left [Char]
xs -> Text -> Either Text Rational
forall a b. a -> Either a b
Left (Text -> Either Text Rational) -> Text -> Either Text Rational
forall a b. (a -> b) -> a -> b
$ Text
"Invalid bytestring[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
bs) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]: expected a double but returned " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack ([Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
xs)
    fromPersistValue PersistValue
x = Text -> Either Text Rational
forall a b. a -> Either a b
Left (Text -> Either Text Rational) -> Text -> Either Text Rational
forall a b. (a -> b) -> a -> b
$ Text -> Text -> PersistValue -> Text
fromPersistValueError Text
"Rational" Text
"rational, double, string, integer, or bytestring" PersistValue
x

instance PersistField Bool where
    toPersistValue :: Bool -> PersistValue
toPersistValue = Bool -> PersistValue
PersistBool
    fromPersistValue :: PersistValue -> Either Text Bool
fromPersistValue (PersistBool Bool
b) = Bool -> Either Text Bool
forall a b. b -> Either a b
Right Bool
b
    fromPersistValue (PersistInt64 Int64
i) = Bool -> Either Text Bool
forall a b. b -> Either a b
Right (Bool -> Either Text Bool) -> Bool -> Either Text Bool
forall a b. (a -> b) -> a -> b
$ Int64
i Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Int64
0
    fromPersistValue (PersistByteString ByteString
i) = case ByteString -> Maybe (Int, ByteString)
readInt ByteString
i of
                                               Just (Int
0,ByteString
"") -> Bool -> Either Text Bool
forall a b. b -> Either a b
Right Bool
False
                                               Just (Int
1,ByteString
"") -> Bool -> Either Text Bool
forall a b. b -> Either a b
Right Bool
True
                                               Maybe (Int, ByteString)
xs -> Text -> Either Text Bool
forall a b. a -> Either a b
Left (Text -> Either Text Bool) -> Text -> Either Text Bool
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"Failed to parse Haskell type `Bool` from PersistByteString. Original value:" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
i [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
". Parsed by `readInt` as " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Maybe (Int, ByteString) -> [Char]
forall a. Show a => a -> [Char]
show Maybe (Int, ByteString)
xs) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
". Expected '1'."
    fromPersistValue PersistValue
x = Text -> Either Text Bool
forall a b. a -> Either a b
Left (Text -> Either Text Bool) -> Text -> Either Text Bool
forall a b. (a -> b) -> a -> b
$ Text -> Text -> PersistValue -> Text
fromPersistValueError Text
"Bool" Text
"boolean, integer, or bytestring of '1' or '0'" PersistValue
x

instance PersistField Day where
    toPersistValue :: Day -> PersistValue
toPersistValue = Day -> PersistValue
PersistDay
    fromPersistValue :: PersistValue -> Either Text Day
fromPersistValue (PersistDay Day
d) = Day -> Either Text Day
forall a b. b -> Either a b
Right Day
d
    fromPersistValue (PersistInt64 Int64
i) = Day -> Either Text Day
forall a b. b -> Either a b
Right (Day -> Either Text Day) -> Day -> Either Text Day
forall a b. (a -> b) -> a -> b
$ Integer -> Day
ModifiedJulianDay (Integer -> Day) -> Integer -> Day
forall a b. (a -> b) -> a -> b
$ Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger Int64
i
    fromPersistValue x :: PersistValue
x@(PersistText Text
t) =
        case ReadS Day
forall a. Read a => ReadS a
reads ReadS Day -> ReadS Day
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
t of
            (Day
d, [Char]
_):[(Day, [Char])]
_ -> Day -> Either Text Day
forall a b. b -> Either a b
Right Day
d
            [(Day, [Char])]
_ -> Text -> Either Text Day
forall a b. a -> Either a b
Left (Text -> Either Text Day) -> Text -> Either Text Day
forall a b. (a -> b) -> a -> b
$ Text -> PersistValue -> Text
forall a. Show a => Text -> a -> Text
fromPersistValueParseError Text
"Day" PersistValue
x
    fromPersistValue x :: PersistValue
x@(PersistByteString ByteString
s) =
        case ReadS Day
forall a. Read a => ReadS a
reads ReadS Day -> ReadS Day
forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
unpack ByteString
s of
            (Day
d, [Char]
_):[(Day, [Char])]
_ -> Day -> Either Text Day
forall a b. b -> Either a b
Right Day
d
            [(Day, [Char])]
_ -> Text -> Either Text Day
forall a b. a -> Either a b
Left (Text -> Either Text Day) -> Text -> Either Text Day
forall a b. (a -> b) -> a -> b
$ Text -> PersistValue -> Text
forall a. Show a => Text -> a -> Text
fromPersistValueParseError Text
"Day" PersistValue
x
    fromPersistValue PersistValue
x = Text -> Either Text Day
forall a b. a -> Either a b
Left (Text -> Either Text Day) -> Text -> Either Text Day
forall a b. (a -> b) -> a -> b
$ Text -> Text -> PersistValue -> Text
fromPersistValueError Text
"Day" Text
"day, integer, string or bytestring" PersistValue
x

instance PersistField TimeOfDay where
    toPersistValue :: TimeOfDay -> PersistValue
toPersistValue = TimeOfDay -> PersistValue
PersistTimeOfDay
    fromPersistValue :: PersistValue -> Either Text TimeOfDay
fromPersistValue (PersistTimeOfDay TimeOfDay
d) = TimeOfDay -> Either Text TimeOfDay
forall a b. b -> Either a b
Right TimeOfDay
d
    fromPersistValue x :: PersistValue
x@(PersistText Text
t) =
        case ReadS TimeOfDay
forall a. Read a => ReadS a
reads ReadS TimeOfDay -> ReadS TimeOfDay
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
t of
            (TimeOfDay
d, [Char]
_):[(TimeOfDay, [Char])]
_ -> TimeOfDay -> Either Text TimeOfDay
forall a b. b -> Either a b
Right TimeOfDay
d
            [(TimeOfDay, [Char])]
_ -> Text -> Either Text TimeOfDay
forall a b. a -> Either a b
Left (Text -> Either Text TimeOfDay) -> Text -> Either Text TimeOfDay
forall a b. (a -> b) -> a -> b
$ Text -> PersistValue -> Text
forall a. Show a => Text -> a -> Text
fromPersistValueParseError Text
"TimeOfDay" PersistValue
x
    fromPersistValue x :: PersistValue
x@(PersistByteString ByteString
s) =
        case ReadS TimeOfDay
forall a. Read a => ReadS a
reads ReadS TimeOfDay -> ReadS TimeOfDay
forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
unpack ByteString
s of
            (TimeOfDay
d, [Char]
_):[(TimeOfDay, [Char])]
_ -> TimeOfDay -> Either Text TimeOfDay
forall a b. b -> Either a b
Right TimeOfDay
d
            [(TimeOfDay, [Char])]
_ -> Text -> Either Text TimeOfDay
forall a b. a -> Either a b
Left (Text -> Either Text TimeOfDay) -> Text -> Either Text TimeOfDay
forall a b. (a -> b) -> a -> b
$ Text -> PersistValue -> Text
forall a. Show a => Text -> a -> Text
fromPersistValueParseError Text
"TimeOfDay" PersistValue
x
    fromPersistValue PersistValue
x = Text -> Either Text TimeOfDay
forall a b. a -> Either a b
Left (Text -> Either Text TimeOfDay) -> Text -> Either Text TimeOfDay
forall a b. (a -> b) -> a -> b
$ Text -> Text -> PersistValue -> Text
fromPersistValueError Text
"TimeOfDay" Text
"time, string, or bytestring" PersistValue
x

instance PersistField UTCTime where
    toPersistValue :: UTCTime -> PersistValue
toPersistValue = UTCTime -> PersistValue
PersistUTCTime
    fromPersistValue :: PersistValue -> Either Text UTCTime
fromPersistValue (PersistUTCTime UTCTime
d) = UTCTime -> Either Text UTCTime
forall a b. b -> Either a b
Right UTCTime
d
#ifdef HIGH_PRECISION_DATE
    fromPersistValue (PersistInt64 i)   = Right $ posixSecondsToUTCTime $ (/ (1000 * 1000 * 1000)) $ fromIntegral $ i
#endif
    fromPersistValue x :: PersistValue
x@(PersistText Text
t)  =
        let s :: [Char]
s = Text -> [Char]
T.unpack Text
t
        in
          case [(UTCTime, [Char])] -> Maybe (NonEmpty (UTCTime, [Char]))
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty (ReadS UTCTime
forall a. Read a => ReadS a
reads [Char]
s) of
            Maybe (NonEmpty (UTCTime, [Char]))
Nothing ->
                case [Char] -> Maybe UTCTime
parse8601 [Char]
s Maybe UTCTime -> Maybe UTCTime -> Maybe UTCTime
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Char] -> Maybe UTCTime
parsePretty [Char]
s of
                    Maybe UTCTime
Nothing -> Text -> Either Text UTCTime
forall a b. a -> Either a b
Left (Text -> Either Text UTCTime) -> Text -> Either Text UTCTime
forall a b. (a -> b) -> a -> b
$ Text -> PersistValue -> Text
forall a. Show a => Text -> a -> Text
fromPersistValueParseError Text
"UTCTime" PersistValue
x
                    Just UTCTime
x' -> UTCTime -> Either Text UTCTime
forall a b. b -> Either a b
Right UTCTime
x'
            Just NonEmpty (UTCTime, [Char])
matches ->
                -- The 'Read UTCTime' instance in newer versions of 'time' is
                -- more flexible when parsing UTCTime strings and will return
                -- UTCTimes with different microsecond parsings. The last result
                -- here contains the parsed UTCTime with as much microsecond
                -- precision parsed as posssible.
                UTCTime -> Either Text UTCTime
forall a b. b -> Either a b
Right (UTCTime -> Either Text UTCTime) -> UTCTime -> Either Text UTCTime
forall a b. (a -> b) -> a -> b
$ (UTCTime, [Char]) -> UTCTime
forall a b. (a, b) -> a
fst ((UTCTime, [Char]) -> UTCTime) -> (UTCTime, [Char]) -> UTCTime
forall a b. (a -> b) -> a -> b
$ NonEmpty (UTCTime, [Char]) -> (UTCTime, [Char])
forall a. NonEmpty a -> a
NonEmpty.last NonEmpty (UTCTime, [Char])
matches
      where
#if MIN_VERSION_time(1,5,0)
        parseTime' :: [Char] -> [Char] -> Maybe UTCTime
parseTime' = Bool -> TimeLocale -> [Char] -> [Char] -> Maybe UTCTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> [Char] -> [Char] -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale
#else
        parseTime' = parseTime defaultTimeLocale
#endif
        parse8601 :: [Char] -> Maybe UTCTime
parse8601 = [Char] -> [Char] -> Maybe UTCTime
parseTime' [Char]
"%FT%T%Q"
        parsePretty :: [Char] -> Maybe UTCTime
parsePretty = [Char] -> [Char] -> Maybe UTCTime
parseTime' [Char]
"%F %T%Q"
    fromPersistValue x :: PersistValue
x@(PersistByteString ByteString
s) =
        case ReadS UTCTime
forall a. Read a => ReadS a
reads ReadS UTCTime -> ReadS UTCTime
forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
unpack ByteString
s of
            (UTCTime
d, [Char]
_):[(UTCTime, [Char])]
_ -> UTCTime -> Either Text UTCTime
forall a b. b -> Either a b
Right UTCTime
d
            [(UTCTime, [Char])]
_ -> Text -> Either Text UTCTime
forall a b. a -> Either a b
Left (Text -> Either Text UTCTime) -> Text -> Either Text UTCTime
forall a b. (a -> b) -> a -> b
$ Text -> PersistValue -> Text
forall a. Show a => Text -> a -> Text
fromPersistValueParseError Text
"UTCTime" PersistValue
x

    fromPersistValue PersistValue
x = Text -> Either Text UTCTime
forall a b. a -> Either a b
Left (Text -> Either Text UTCTime) -> Text -> Either Text UTCTime
forall a b. (a -> b) -> a -> b
$ Text -> Text -> PersistValue -> Text
fromPersistValueError Text
"UTCTime" Text
"time, integer, string, or bytestring" PersistValue
x

-- | Prior to @persistent-2.11.0@, we provided an instance of
-- 'PersistField' for the 'Natural' type. This was in error, because
-- 'Natural' represents an infinite value, and databases don't have
-- reasonable types for this.
--
-- The instance for 'Natural' used the 'Int64' underlying type, which will
-- cause underflow and overflow errors. This type has the exact same code
-- in the instances, and will work seamlessly.
--
-- A more appropriate type for this is the 'Word' series of types from
-- "Data.Word". These have a bounded size, are guaranteed to be
-- non-negative, and are quite efficient for the database to store.
--
-- @since 2.11.0
newtype OverflowNatural = OverflowNatural { OverflowNatural -> Natural
unOverflowNatural :: Natural }
    deriving (OverflowNatural -> OverflowNatural -> Bool
(OverflowNatural -> OverflowNatural -> Bool)
-> (OverflowNatural -> OverflowNatural -> Bool)
-> Eq OverflowNatural
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OverflowNatural -> OverflowNatural -> Bool
$c/= :: OverflowNatural -> OverflowNatural -> Bool
== :: OverflowNatural -> OverflowNatural -> Bool
$c== :: OverflowNatural -> OverflowNatural -> Bool
Eq, Int -> OverflowNatural -> [Char] -> [Char]
[OverflowNatural] -> [Char] -> [Char]
OverflowNatural -> [Char]
(Int -> OverflowNatural -> [Char] -> [Char])
-> (OverflowNatural -> [Char])
-> ([OverflowNatural] -> [Char] -> [Char])
-> Show OverflowNatural
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [OverflowNatural] -> [Char] -> [Char]
$cshowList :: [OverflowNatural] -> [Char] -> [Char]
show :: OverflowNatural -> [Char]
$cshow :: OverflowNatural -> [Char]
showsPrec :: Int -> OverflowNatural -> [Char] -> [Char]
$cshowsPrec :: Int -> OverflowNatural -> [Char] -> [Char]
Show, Eq OverflowNatural
Eq OverflowNatural
-> (OverflowNatural -> OverflowNatural -> Ordering)
-> (OverflowNatural -> OverflowNatural -> Bool)
-> (OverflowNatural -> OverflowNatural -> Bool)
-> (OverflowNatural -> OverflowNatural -> Bool)
-> (OverflowNatural -> OverflowNatural -> Bool)
-> (OverflowNatural -> OverflowNatural -> OverflowNatural)
-> (OverflowNatural -> OverflowNatural -> OverflowNatural)
-> Ord OverflowNatural
OverflowNatural -> OverflowNatural -> Bool
OverflowNatural -> OverflowNatural -> Ordering
OverflowNatural -> OverflowNatural -> OverflowNatural
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: OverflowNatural -> OverflowNatural -> OverflowNatural
$cmin :: OverflowNatural -> OverflowNatural -> OverflowNatural
max :: OverflowNatural -> OverflowNatural -> OverflowNatural
$cmax :: OverflowNatural -> OverflowNatural -> OverflowNatural
>= :: OverflowNatural -> OverflowNatural -> Bool
$c>= :: OverflowNatural -> OverflowNatural -> Bool
> :: OverflowNatural -> OverflowNatural -> Bool
$c> :: OverflowNatural -> OverflowNatural -> Bool
<= :: OverflowNatural -> OverflowNatural -> Bool
$c<= :: OverflowNatural -> OverflowNatural -> Bool
< :: OverflowNatural -> OverflowNatural -> Bool
$c< :: OverflowNatural -> OverflowNatural -> Bool
compare :: OverflowNatural -> OverflowNatural -> Ordering
$ccompare :: OverflowNatural -> OverflowNatural -> Ordering
$cp1Ord :: Eq OverflowNatural
Ord, Integer -> OverflowNatural
OverflowNatural -> OverflowNatural
OverflowNatural -> OverflowNatural -> OverflowNatural
(OverflowNatural -> OverflowNatural -> OverflowNatural)
-> (OverflowNatural -> OverflowNatural -> OverflowNatural)
-> (OverflowNatural -> OverflowNatural -> OverflowNatural)
-> (OverflowNatural -> OverflowNatural)
-> (OverflowNatural -> OverflowNatural)
-> (OverflowNatural -> OverflowNatural)
-> (Integer -> OverflowNatural)
-> Num OverflowNatural
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> OverflowNatural
$cfromInteger :: Integer -> OverflowNatural
signum :: OverflowNatural -> OverflowNatural
$csignum :: OverflowNatural -> OverflowNatural
abs :: OverflowNatural -> OverflowNatural
$cabs :: OverflowNatural -> OverflowNatural
negate :: OverflowNatural -> OverflowNatural
$cnegate :: OverflowNatural -> OverflowNatural
* :: OverflowNatural -> OverflowNatural -> OverflowNatural
$c* :: OverflowNatural -> OverflowNatural -> OverflowNatural
- :: OverflowNatural -> OverflowNatural -> OverflowNatural
$c- :: OverflowNatural -> OverflowNatural -> OverflowNatural
+ :: OverflowNatural -> OverflowNatural -> OverflowNatural
$c+ :: OverflowNatural -> OverflowNatural -> OverflowNatural
Num)

instance
  TypeError
    ( 'Text "The instance of PersistField for the Natural type was removed."
    ':$$: 'Text "Please see the documentation for OverflowNatural if you want to "
    ':$$: 'Text "continue using the old behavior or want to see documentation on "
    ':$$: 'Text "why the instance was removed."
    ':$$: 'Text ""
    ':$$: 'Text "This error instance will be removed in a future release."
    )
  =>
    PersistField Natural
  where
    toPersistValue :: Natural -> PersistValue
toPersistValue = Natural -> PersistValue
forall a. HasCallStack => a
undefined
    fromPersistValue :: PersistValue -> Either Text Natural
fromPersistValue = PersistValue -> Either Text Natural
forall a. HasCallStack => a
undefined

instance PersistField OverflowNatural where
  toPersistValue :: OverflowNatural -> PersistValue
toPersistValue = (Int64 -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue :: Int64 -> PersistValue) (Int64 -> PersistValue)
-> (OverflowNatural -> Int64) -> OverflowNatural -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Int64)
-> (OverflowNatural -> Natural) -> OverflowNatural -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OverflowNatural -> Natural
unOverflowNatural
  fromPersistValue :: PersistValue -> Either Text OverflowNatural
fromPersistValue PersistValue
x = case (PersistValue -> Either Text Int64
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
x :: Either Text Int64) of
    Left Text
err -> Text -> Either Text OverflowNatural
forall a b. a -> Either a b
Left (Text -> Either Text OverflowNatural)
-> Text -> Either Text OverflowNatural
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Text
T.replace Text
"Int64" Text
"OverflowNatural" Text
err
    Right Int64
int -> OverflowNatural -> Either Text OverflowNatural
forall a b. b -> Either a b
Right (OverflowNatural -> Either Text OverflowNatural)
-> OverflowNatural -> Either Text OverflowNatural
forall a b. (a -> b) -> a -> b
$ Natural -> OverflowNatural
OverflowNatural (Natural -> OverflowNatural) -> Natural -> OverflowNatural
forall a b. (a -> b) -> a -> b
$ Int64 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
int -- TODO use bimap?

instance PersistField a => PersistField (Maybe a) where
    toPersistValue :: Maybe a -> PersistValue
toPersistValue Maybe a
Nothing = PersistValue
PersistNull
    toPersistValue (Just a
a) = a -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue a
a
    fromPersistValue :: PersistValue -> Either Text (Maybe a)
fromPersistValue PersistValue
PersistNull = Maybe a -> Either Text (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing
    fromPersistValue PersistValue
x = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Either Text a -> Either Text (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PersistValue -> Either Text a
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
x

instance {-# OVERLAPPABLE #-} PersistField a => PersistField [a] where
    toPersistValue :: [a] -> PersistValue
toPersistValue = [PersistValue] -> PersistValue
PersistList ([PersistValue] -> PersistValue)
-> ([a] -> [PersistValue]) -> [a] -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> PersistValue) -> [a] -> [PersistValue]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue
    fromPersistValue :: PersistValue -> Either Text [a]
fromPersistValue (PersistList [PersistValue]
l) = [PersistValue] -> Either Text [a]
forall a. PersistField a => [PersistValue] -> Either Text [a]
fromPersistList [PersistValue]
l
    fromPersistValue (PersistText Text
t) = PersistValue -> Either Text [a]
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue (ByteString -> PersistValue
PersistByteString (ByteString -> PersistValue) -> ByteString -> PersistValue
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
t)
    fromPersistValue (PersistByteString ByteString
bs)
        | Just [PersistValue]
values <- ByteString -> Maybe [PersistValue]
forall a. FromJSON a => ByteString -> Maybe a
A.decode' ([ByteString] -> ByteString
L.fromChunks [ByteString
bs]) = [PersistValue] -> Either Text [a]
forall a. PersistField a => [PersistValue] -> Either Text [a]
fromPersistList [PersistValue]
values
    -- avoid the need for a migration to fill in empty lists.
    -- also useful when Persistent is not the only one filling in the data
    fromPersistValue (PersistValue
PersistNull) = [a] -> Either Text [a]
forall a b. b -> Either a b
Right []
    fromPersistValue PersistValue
x = Text -> Either Text [a]
forall a b. a -> Either a b
Left (Text -> Either Text [a]) -> Text -> Either Text [a]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> PersistValue -> Text
fromPersistValueError Text
"List" Text
"list, string, bytestring or null" PersistValue
x

instance PersistField a => PersistField (V.Vector a) where
  toPersistValue :: Vector a -> PersistValue
toPersistValue = [a] -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue ([a] -> PersistValue)
-> (Vector a -> [a]) -> Vector a -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector a -> [a]
forall a. Vector a -> [a]
V.toList
  fromPersistValue :: PersistValue -> Either Text (Vector a)
fromPersistValue = (Text -> Either Text (Vector a))
-> ([a] -> Either Text (Vector a))
-> Either Text [a]
-> Either Text (Vector a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\Text
e -> Text -> Either Text (Vector a)
forall a b. a -> Either a b
Left (Text
"Failed to parse Haskell type `Vector`: " Text -> Text -> Text
`T.append` Text
e))
                            (Vector a -> Either Text (Vector a)
forall a b. b -> Either a b
Right (Vector a -> Either Text (Vector a))
-> ([a] -> Vector a) -> [a] -> Either Text (Vector a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Vector a
forall a. [a] -> Vector a
V.fromList) (Either Text [a] -> Either Text (Vector a))
-> (PersistValue -> Either Text [a])
-> PersistValue
-> Either Text (Vector a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PersistValue -> Either Text [a]
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue

instance (Ord a, PersistField a) => PersistField (S.Set a) where
    toPersistValue :: Set a -> PersistValue
toPersistValue = [PersistValue] -> PersistValue
PersistList ([PersistValue] -> PersistValue)
-> (Set a -> [PersistValue]) -> Set a -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> PersistValue) -> [a] -> [PersistValue]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue ([a] -> [PersistValue])
-> (Set a -> [a]) -> Set a -> [PersistValue]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> [a]
forall a. Set a -> [a]
S.toList
    fromPersistValue :: PersistValue -> Either Text (Set a)
fromPersistValue (PersistList [PersistValue]
list) =
      [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList ([a] -> Set a) -> Either Text [a] -> Either Text (Set a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PersistValue] -> Either Text [a]
forall a. PersistField a => [PersistValue] -> Either Text [a]
fromPersistList [PersistValue]
list
    fromPersistValue (PersistText Text
t) = PersistValue -> Either Text (Set a)
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue (ByteString -> PersistValue
PersistByteString (ByteString -> PersistValue) -> ByteString -> PersistValue
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
t)
    fromPersistValue (PersistByteString ByteString
bs)
        | Just [PersistValue]
values <- ByteString -> Maybe [PersistValue]
forall a. FromJSON a => ByteString -> Maybe a
A.decode' ([ByteString] -> ByteString
L.fromChunks [ByteString
bs]) =
            [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList ([a] -> Set a) -> Either Text [a] -> Either Text (Set a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PersistValue] -> Either Text [a]
forall a. PersistField a => [PersistValue] -> Either Text [a]
fromPersistList [PersistValue]
values
    fromPersistValue PersistValue
PersistNull = Set a -> Either Text (Set a)
forall a b. b -> Either a b
Right Set a
forall a. Set a
S.empty
    fromPersistValue PersistValue
x = Text -> Either Text (Set a)
forall a b. a -> Either a b
Left (Text -> Either Text (Set a)) -> Text -> Either Text (Set a)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> PersistValue -> Text
fromPersistValueError Text
"Set" Text
"list, string, bytestring or null" PersistValue
x

instance (PersistField a, PersistField b) => PersistField (a,b) where
    toPersistValue :: (a, b) -> PersistValue
toPersistValue (a
x,b
y) = [PersistValue] -> PersistValue
PersistList [a -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue a
x, b -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue b
y]
    fromPersistValue :: PersistValue -> Either Text (a, b)
fromPersistValue PersistValue
v =
        case PersistValue -> Either Text [PersistValue]
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
v of
            Right [PersistValue
x,PersistValue
y]  -> (,) (a -> b -> (a, b)) -> Either Text a -> Either Text (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PersistValue -> Either Text a
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
x Either Text (b -> (a, b)) -> Either Text b -> Either Text (a, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PersistValue -> Either Text b
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
y
            Left Text
e       -> Text -> Either Text (a, b)
forall a b. a -> Either a b
Left Text
e
            Either Text [PersistValue]
_            -> Text -> Either Text (a, b)
forall a b. a -> Either a b
Left (Text -> Either Text (a, b)) -> Text -> Either Text (a, b)
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"Expected 2 item PersistList, received: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PersistValue -> [Char]
forall a. Show a => a -> [Char]
show PersistValue
v

instance PersistField v => PersistField (IM.IntMap v) where
    toPersistValue :: IntMap v -> PersistValue
toPersistValue = [(Int, v)] -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue ([(Int, v)] -> PersistValue)
-> (IntMap v -> [(Int, v)]) -> IntMap v -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap v -> [(Int, v)]
forall a. IntMap a -> [(Int, a)]
IM.toList
    fromPersistValue :: PersistValue -> Either Text (IntMap v)
fromPersistValue = ([(Int, v)] -> IntMap v)
-> Either Text [(Int, v)] -> Either Text (IntMap v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Int, v)] -> IntMap v
forall a. [(Int, a)] -> IntMap a
IM.fromList (Either Text [(Int, v)] -> Either Text (IntMap v))
-> (PersistValue -> Either Text [(Int, v)])
-> PersistValue
-> Either Text (IntMap v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PersistValue -> Either Text [(Int, v)]
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue

instance PersistField v => PersistField (M.Map T.Text v) where
    toPersistValue :: Map Text v -> PersistValue
toPersistValue = [(Text, PersistValue)] -> PersistValue
PersistMap ([(Text, PersistValue)] -> PersistValue)
-> (Map Text v -> [(Text, PersistValue)])
-> Map Text v
-> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, v) -> (Text, PersistValue))
-> [(Text, v)] -> [(Text, PersistValue)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((v -> PersistValue) -> (Text, v) -> (Text, PersistValue)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second v -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue) ([(Text, v)] -> [(Text, PersistValue)])
-> (Map Text v -> [(Text, v)])
-> Map Text v
-> [(Text, PersistValue)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text v -> [(Text, v)]
forall k a. Map k a -> [(k, a)]
M.toList
    fromPersistValue :: PersistValue -> Either Text (Map Text v)
fromPersistValue = [(Text, PersistValue)] -> Either Text (Map Text v)
forall v.
PersistField v =>
[(Text, PersistValue)] -> Either Text (Map Text v)
fromPersistMap ([(Text, PersistValue)] -> Either Text (Map Text v))
-> (PersistValue -> Either Text [(Text, PersistValue)])
-> PersistValue
-> Either Text (Map Text v)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< PersistValue -> Either Text [(Text, PersistValue)]
getPersistMap

instance PersistField PersistValue where
    toPersistValue :: PersistValue -> PersistValue
toPersistValue = PersistValue -> PersistValue
forall a. a -> a
id
    fromPersistValue :: PersistValue -> Either Text PersistValue
fromPersistValue = PersistValue -> Either Text PersistValue
forall a b. b -> Either a b
Right

fromPersistList :: PersistField a => [PersistValue] -> Either T.Text [a]
fromPersistList :: [PersistValue] -> Either Text [a]
fromPersistList = (PersistValue -> Either Text a)
-> [PersistValue] -> Either Text [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PersistValue -> Either Text a
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue

fromPersistMap :: PersistField v
               => [(T.Text, PersistValue)]
               -> Either T.Text (M.Map T.Text v)
fromPersistMap :: [(Text, PersistValue)] -> Either Text (Map Text v)
fromPersistMap = (PersistValue -> Either Text v)
-> [(Text, v)]
-> [(Text, PersistValue)]
-> Either Text (Map Text v)
forall a t a b.
Ord a =>
(t -> Either a b) -> [(a, b)] -> [(a, t)] -> Either a (Map a b)
foldShortLeft PersistValue -> Either Text v
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue [] where
    -- a fold that short-circuits on Left.
    foldShortLeft :: (t -> Either a b) -> [(a, b)] -> [(a, t)] -> Either a (Map a b)
foldShortLeft t -> Either a b
f = [(a, b)] -> [(a, t)] -> Either a (Map a b)
go
      where
        go :: [(a, b)] -> [(a, t)] -> Either a (Map a b)
go [(a, b)]
acc [] = Map a b -> Either a (Map a b)
forall a b. b -> Either a b
Right (Map a b -> Either a (Map a b)) -> Map a b -> Either a (Map a b)
forall a b. (a -> b) -> a -> b
$ [(a, b)] -> Map a b
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(a, b)]
acc
        go [(a, b)]
acc ((a
k, t
v):[(a, t)]
kvs) =
          case t -> Either a b
f t
v of
            Left a
e   -> a -> Either a (Map a b)
forall a b. a -> Either a b
Left a
e
            Right b
v' -> [(a, b)] -> [(a, t)] -> Either a (Map a b)
go ((a
k,b
v')(a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
:[(a, b)]
acc) [(a, t)]
kvs

-- | FIXME Add documentation to that.
getPersistMap :: PersistValue -> Either T.Text [(T.Text, PersistValue)]
getPersistMap :: PersistValue -> Either Text [(Text, PersistValue)]
getPersistMap (PersistMap [(Text, PersistValue)]
kvs) = [(Text, PersistValue)] -> Either Text [(Text, PersistValue)]
forall a b. b -> Either a b
Right [(Text, PersistValue)]
kvs
getPersistMap (PersistText Text
t)  = PersistValue -> Either Text [(Text, PersistValue)]
getPersistMap (ByteString -> PersistValue
PersistByteString (ByteString -> PersistValue) -> ByteString -> PersistValue
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
t)
getPersistMap (PersistByteString ByteString
bs)
    | Just [(Text, PersistValue)]
pairs <- ByteString -> Maybe [(Text, PersistValue)]
forall a. FromJSON a => ByteString -> Maybe a
A.decode' ([ByteString] -> ByteString
L.fromChunks [ByteString
bs]) = [(Text, PersistValue)] -> Either Text [(Text, PersistValue)]
forall a b. b -> Either a b
Right [(Text, PersistValue)]
pairs
getPersistMap PersistValue
PersistNull = [(Text, PersistValue)] -> Either Text [(Text, PersistValue)]
forall a b. b -> Either a b
Right []
getPersistMap PersistValue
x = Text -> Either Text [(Text, PersistValue)]
forall a b. a -> Either a b
Left (Text -> Either Text [(Text, PersistValue)])
-> Text -> Either Text [(Text, PersistValue)]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> PersistValue -> Text
fromPersistValueError Text
"[(Text, PersistValue)]" Text
"map, string, bytestring or null" PersistValue
x

data SomePersistField = forall a. (PersistField a) => SomePersistField a
instance PersistField SomePersistField where
    toPersistValue :: SomePersistField -> PersistValue
toPersistValue (SomePersistField a
a) = a -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue a
a
    fromPersistValue :: PersistValue -> Either Text SomePersistField
fromPersistValue PersistValue
x = (Text -> SomePersistField)
-> Either Text Text -> Either Text SomePersistField
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> SomePersistField
forall a. PersistField a => a -> SomePersistField
SomePersistField (PersistValue -> Either Text Text
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
x :: Either Text Text)

instance PersistField Checkmark where
    toPersistValue :: Checkmark -> PersistValue
toPersistValue Checkmark
Active   = Bool -> PersistValue
PersistBool Bool
True
    toPersistValue Checkmark
Inactive = PersistValue
PersistNull
    fromPersistValue :: PersistValue -> Either Text Checkmark
fromPersistValue PersistValue
PersistNull         = Checkmark -> Either Text Checkmark
forall a b. b -> Either a b
Right Checkmark
Inactive
    fromPersistValue (PersistBool Bool
True)  = Checkmark -> Either Text Checkmark
forall a b. b -> Either a b
Right Checkmark
Active
    fromPersistValue (PersistInt64 Int64
1)    = Checkmark -> Either Text Checkmark
forall a b. b -> Either a b
Right Checkmark
Active
    fromPersistValue (PersistByteString ByteString
i) = case ByteString -> Maybe (Int, ByteString)
readInt ByteString
i of
                                               Just (Int
0,ByteString
"") -> Text -> Either Text Checkmark
forall a b. a -> Either a b
Left Text
"Failed to parse Haskell type `Checkmark`: found `0`, expected `1` or NULL"
                                               Just (Int
1,ByteString
"") -> Checkmark -> Either Text Checkmark
forall a b. b -> Either a b
Right Checkmark
Active
                                               Maybe (Int, ByteString)
xs -> Text -> Either Text Checkmark
forall a b. a -> Either a b
Left (Text -> Either Text Checkmark) -> Text -> Either Text Checkmark
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"Failed to parse Haskell type `Checkmark` from PersistByteString. Original value:" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
i [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
". Parsed by `readInt` as " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Maybe (Int, ByteString) -> [Char]
forall a. Show a => a -> [Char]
show Maybe (Int, ByteString)
xs) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
". Expected '1'."
    fromPersistValue (PersistBool Bool
False) =
      Text -> Either Text Checkmark
forall a b. a -> Either a b
Left (Text -> Either Text Checkmark) -> Text -> Either Text Checkmark
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
"PersistField Checkmark: found unexpected FALSE value"
    fromPersistValue PersistValue
other =
      Text -> Either Text Checkmark
forall a b. a -> Either a b
Left (Text -> Either Text Checkmark) -> Text -> Either Text Checkmark
forall a b. (a -> b) -> a -> b
$ Text -> Text -> PersistValue -> Text
fromPersistValueError Text
"Checkmark" Text
"boolean, integer, bytestring or null" PersistValue
other


fromPersistValueError :: Text -- ^ Haskell type, should match Haskell name exactly, e.g. "Int64"
                      -> Text -- ^ Database type(s), should appear different from Haskell name, e.g. "integer" or "INT", not "Int".
                      -> PersistValue -- ^ Incorrect value
                      -> Text -- ^ Error message
fromPersistValueError :: Text -> Text -> PersistValue -> Text
fromPersistValueError Text
haskellType Text
databaseType PersistValue
received = [Text] -> Text
T.concat
    [ Text
"Failed to parse Haskell type `"
    , Text
haskellType
    , Text
"`; expected "
    , Text
databaseType
    , Text
" from database, but received: "
    , [Char] -> Text
T.pack (PersistValue -> [Char]
forall a. Show a => a -> [Char]
show PersistValue
received)
    , Text
". Potential solution: Check that your database schema matches your Persistent model definitions."
    ]

fromPersistValueParseError :: (Show a)
                           => Text -- ^ Haskell type, should match Haskell name exactly, e.g. "Int64"
                           -> a -- ^ Received value
                           -> Text -- ^ Error message
fromPersistValueParseError :: Text -> a -> Text
fromPersistValueParseError Text
haskellType a
received = [Text] -> Text
T.concat
    [ Text
"Failed to parse Haskell type `"
    , Text
haskellType
    , Text
"`, but received "
    , [Char] -> Text
T.pack (a -> [Char]
forall a. Show a => a -> [Char]
show a
received)
    ]