{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PatternGuards, DataKinds, TypeOperators, UndecidableInstances, GeneralizedNewtypeDeriving #-}
module Database.Persist.Class.PersistField
    ( PersistField (..)
    , 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack
    fromPersistValue :: PersistValue -> Either Text [Char]
fromPersistValue (PersistText Text
s) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
s
    fromPersistValue (PersistByteString ByteString
bs) =
        forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
TE.decodeUtf8With OnDecodeError
TERR.lenientDecode ByteString
bs
    fromPersistValue (PersistInt64 Int64
i) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
Prelude.show Int64
i
    fromPersistValue (PersistDouble Double
d) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
Prelude.show Double
d
    fromPersistValue (PersistRational Rational
r) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
Prelude.show Rational
r
    fromPersistValue (PersistDay Day
d) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
Prelude.show Day
d
    fromPersistValue (PersistTimeOfDay TimeOfDay
d) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
Prelude.show TimeOfDay
d
    fromPersistValue (PersistUTCTime UTCTime
d) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
Prelude.show UTCTime
d
    fromPersistValue PersistValue
PersistNull = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
"Unexpected null"
    fromPersistValue (PersistBool Bool
b) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
Prelude.show Bool
b
    fromPersistValue (PersistList [PersistValue]
_) = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
"Cannot convert PersistList to String"
    fromPersistValue (PersistMap [(Text, PersistValue)]
_) = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
"Cannot convert PersistMap to String"
    fromPersistValue (PersistLiteral_ LiteralType
_ ByteString
_) = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
"Cannot convert PersistLiteral_ to String"
    fromPersistValue (PersistArray [PersistValue]
_) = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
"Cannot convert PersistArray to String"
    fromPersistValue (PersistObjectId ByteString
_) = forall a b. a -> Either a b
Left 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) = forall a b. b -> Either a b
Right ByteString
bs
    fromPersistValue PersistValue
x = Text -> ByteString
TE.encodeUtf8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall a. PersistField a => a -> PersistValue
toPersistValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.toStrict
    fromPersistValue :: PersistValue -> Either Text Text
fromPersistValue = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
TL.fromStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue

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

instance PersistField Int where
    toPersistValue :: Int -> PersistValue
toPersistValue = Int64 -> PersistValue
PersistInt64 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
    fromPersistValue :: PersistValue -> Either Text Int
fromPersistValue (PersistInt64 Int64
i)  = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i
    fromPersistValue (PersistDouble Double
i) = forall a b. b -> Either a b
Right (forall a b. (RealFrac a, Integral b) => a -> b
truncate Double
i :: Int) -- oracle
    fromPersistValue PersistValue
x = forall a b. a -> Either a b
Left 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
    fromPersistValue :: PersistValue -> Either Text Int8
fromPersistValue (PersistInt64 Int64
i)  = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i
    fromPersistValue (PersistDouble Double
i) = forall a b. b -> Either a b
Right (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
"") -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i
                                               Just (Int
i,ByteString
extra) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall result.
Show result =>
Text -> ByteString -> result -> ByteString -> Text
extraInputError Text
"Int64" ByteString
bs Int
i ByteString
extra
                                               Maybe (Int, ByteString)
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> ByteString -> Text
intParseError Text
"Int64" ByteString
bs
    fromPersistValue PersistValue
x = forall a b. a -> Either a b
Left 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
    fromPersistValue :: PersistValue -> Either Text Int16
fromPersistValue (PersistInt64 Int64
i)  = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i
    fromPersistValue (PersistDouble Double
i) = forall a b. b -> Either a b
Right (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
"") -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i
                                               Just (Int
i,ByteString
extra) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall result.
Show result =>
Text -> ByteString -> result -> ByteString -> Text
extraInputError Text
"Int64" ByteString
bs Int
i ByteString
extra
                                               Maybe (Int, ByteString)
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> ByteString -> Text
intParseError Text
"Int64" ByteString
bs
    fromPersistValue PersistValue
x = forall a b. a -> Either a b
Left 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
    fromPersistValue :: PersistValue -> Either Text Int32
fromPersistValue (PersistInt64 Int64
i)  = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i
    fromPersistValue (PersistDouble Double
i) = forall a b. b -> Either a b
Right (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
"") -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i
                                               Just (Int
i,ByteString
extra) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall result.
Show result =>
Text -> ByteString -> result -> ByteString -> Text
extraInputError Text
"Int64" ByteString
bs Int
i ByteString
extra
                                               Maybe (Int, ByteString)
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> ByteString -> Text
intParseError Text
"Int64" ByteString
bs
    fromPersistValue PersistValue
x = forall a b. a -> Either a b
Left 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)  = forall a b. b -> Either a b
Right Int64
i
    fromPersistValue (PersistDouble Double
i) = forall a b. b -> Either a b
Right (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
"") -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i
                                               Just (Int
i,ByteString
extra) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall result.
Show result =>
Text -> ByteString -> result -> ByteString -> Text
extraInputError Text
"Int64" ByteString
bs Int
i ByteString
extra
                                               Maybe (Int, ByteString)
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> ByteString -> Text
intParseError Text
"Int64" ByteString
bs
    fromPersistValue PersistValue
x = forall a b. a -> Either a b
Left 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 :: forall result.
Show result =>
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 forall a b. (a -> b) -> a -> b
$ 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
    fromPersistValue :: PersistValue -> Either Text Word
fromPersistValue (PersistInt64 Int64
i) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i
    fromPersistValue PersistValue
x = forall a b. a -> Either a b
Left 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
    fromPersistValue :: PersistValue -> Either Text Word8
fromPersistValue (PersistInt64 Int64
i) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i
    fromPersistValue PersistValue
x = forall a b. a -> Either a b
Left 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
    fromPersistValue :: PersistValue -> Either Text Word16
fromPersistValue (PersistInt64 Int64
i) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i
    fromPersistValue PersistValue
x = forall a b. a -> Either a b
Left 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
    fromPersistValue :: PersistValue -> Either Text Word32
fromPersistValue (PersistInt64 Int64
i) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i
    fromPersistValue PersistValue
x = forall a b. a -> Either a b
Left 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
    fromPersistValue :: PersistValue -> Either Text Word64
fromPersistValue (PersistInt64 Int64
i) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i
    fromPersistValue PersistValue
x = forall a b. a -> Either a b
Left 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) = forall a b. b -> Either a b
Right Double
d
    fromPersistValue (PersistRational Rational
r) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. Fractional a => Rational -> a
fromRational Rational
r
    fromPersistValue (PersistInt64 Int64
i) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i
    fromPersistValue PersistValue
x = forall a b. a -> Either a b
Left 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Real a => a -> Rational
toRational
    fromPersistValue :: PersistValue -> Either Text (Fixed a)
fromPersistValue (PersistRational Rational
r) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. Fractional a => Rational -> a
fromRational Rational
r
    fromPersistValue (PersistText Text
t) = case forall a. Read a => ReadS a
reads 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]
"")] -> forall a b. b -> Either a b
Right Fixed a
a
      [(Fixed a, [Char])]
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Can not read " forall a. Semigroup a => a -> a -> a
<> Text
t forall a. Semigroup a => a -> a -> a
<> Text
" as Fixed"
    fromPersistValue (PersistDouble Double
d) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
d
    fromPersistValue (PersistInt64 Int64
i) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i
    fromPersistValue PersistValue
x = forall a b. a -> Either a b
Left 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) = forall a b. b -> Either a b
Right Rational
r
    fromPersistValue (PersistDouble Double
d) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. Real a => a -> Rational
toRational Double
d
    fromPersistValue (PersistText Text
t) = case forall a. Read a => ReadS a
reads 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]
"")] -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. Real a => a -> Rational
toRational (Pico
a :: Pico)
      [(Pico, [Char])]
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Can not read " forall a. Semigroup a => a -> a -> a
<> Text
t forall a. Semigroup a => a -> a -> a
<> Text
" as Rational (Pico in fact)"
    fromPersistValue (PersistInt64 Int64
i) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i
    fromPersistValue (PersistByteString ByteString
bs) = case Reader Double
double forall a b. (a -> b) -> a -> b
$ Char -> Text -> Text
T.cons Char
'0' forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
TE.decodeUtf8With OnDecodeError
TERR.lenientDecode ByteString
bs of
                                                Right (Double
ret,Text
"") -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. Real a => a -> Rational
toRational Double
ret
                                                Right (Double
a,Text
b) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Invalid bytestring[" forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (forall a. Show a => a -> [Char]
show ByteString
bs) forall a. Semigroup a => a -> a -> a
<> Text
"]: expected a double but returned " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (forall a. Show a => a -> [Char]
show (Double
a,Text
b))
                                                Left [Char]
xs -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Invalid bytestring[" forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (forall a. Show a => a -> [Char]
show ByteString
bs) forall a. Semigroup a => a -> a -> a
<> Text
"]: expected a double but returned " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (forall a. Show a => a -> [Char]
show [Char]
xs)
    fromPersistValue PersistValue
x = forall a b. a -> Either a b
Left 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) = forall a b. b -> Either a b
Right Bool
b
    fromPersistValue (PersistInt64 Int64
i) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Int64
i 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
"") -> forall a b. b -> Either a b
Right Bool
False
                                               Just (Int
1,ByteString
"") -> forall a b. b -> Either a b
Right Bool
True
                                               Maybe (Int, ByteString)
xs -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ [Char]
"Failed to parse Haskell type `Bool` from PersistByteString. Original value:" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show ByteString
i forall a. [a] -> [a] -> [a]
++ [Char]
". Parsed by `readInt` as " forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> [Char]
show Maybe (Int, ByteString)
xs) forall a. [a] -> [a] -> [a]
++ [Char]
". Expected '1'."
    fromPersistValue PersistValue
x = forall a b. a -> Either a b
Left 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) = forall a b. b -> Either a b
Right Day
d
    fromPersistValue (PersistInt64 Int64
i) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Integer -> Day
ModifiedJulianDay forall a b. (a -> b) -> a -> b
$ forall a. Integral a => a -> Integer
toInteger Int64
i
    fromPersistValue x :: PersistValue
x@(PersistText Text
t) =
        case forall a. Read a => ReadS a
reads forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
t of
            (Day
d, [Char]
_):[(Day, [Char])]
_ -> forall a b. b -> Either a b
Right Day
d
            [(Day, [Char])]
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Show a => Text -> a -> Text
fromPersistValueParseError Text
"Day" PersistValue
x
    fromPersistValue x :: PersistValue
x@(PersistByteString ByteString
s) =
        case forall a. Read a => ReadS a
reads forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
unpack ByteString
s of
            (Day
d, [Char]
_):[(Day, [Char])]
_ -> forall a b. b -> Either a b
Right Day
d
            [(Day, [Char])]
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Show a => Text -> a -> Text
fromPersistValueParseError Text
"Day" PersistValue
x
    fromPersistValue PersistValue
x = forall a b. a -> Either a b
Left 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) = forall a b. b -> Either a b
Right TimeOfDay
d
    fromPersistValue x :: PersistValue
x@(PersistText Text
t) =
        case forall a. Read a => ReadS a
reads forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
t of
            (TimeOfDay
d, [Char]
_):[(TimeOfDay, [Char])]
_ -> forall a b. b -> Either a b
Right TimeOfDay
d
            [(TimeOfDay, [Char])]
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Show a => Text -> a -> Text
fromPersistValueParseError Text
"TimeOfDay" PersistValue
x
    fromPersistValue x :: PersistValue
x@(PersistByteString ByteString
s) =
        case forall a. Read a => ReadS a
reads forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
unpack ByteString
s of
            (TimeOfDay
d, [Char]
_):[(TimeOfDay, [Char])]
_ -> forall a b. b -> Either a b
Right TimeOfDay
d
            [(TimeOfDay, [Char])]
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Show a => Text -> a -> Text
fromPersistValueParseError Text
"TimeOfDay" PersistValue
x
    fromPersistValue PersistValue
x = forall a b. a -> Either a b
Left 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) = 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 forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty (forall a. Read a => ReadS a
reads [Char]
s) of
            Maybe (NonEmpty (UTCTime, [Char]))
Nothing ->
                case [Char] -> Maybe UTCTime
parse8601 [Char]
s forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Char] -> Maybe UTCTime
parsePretty [Char]
s of
                    Maybe UTCTime
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Show a => Text -> a -> Text
fromPersistValueParseError Text
"UTCTime" PersistValue
x
                    Just UTCTime
x' -> 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.
                forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ 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' = 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 forall a. Read a => ReadS a
reads forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
unpack ByteString
s of
            (UTCTime
d, [Char]
_):[(UTCTime, [Char])]
_ -> forall a b. b -> Either a b
Right UTCTime
d
            [(UTCTime, [Char])]
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Show a => Text -> a -> Text
fromPersistValueParseError Text
"UTCTime" PersistValue
x

    fromPersistValue PersistValue
x = forall a b. a -> Either a b
Left 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
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 -> ShowS
[OverflowNatural] -> ShowS
OverflowNatural -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [OverflowNatural] -> ShowS
$cshowList :: [OverflowNatural] -> ShowS
show :: OverflowNatural -> [Char]
$cshow :: OverflowNatural -> [Char]
showsPrec :: Int -> OverflowNatural -> ShowS
$cshowsPrec :: Int -> OverflowNatural -> ShowS
Show, Eq 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
Ord, Integer -> OverflowNatural
OverflowNatural -> OverflowNatural
OverflowNatural -> OverflowNatural -> 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 = forall a. HasCallStack => a
undefined
    fromPersistValue :: PersistValue -> Either Text Natural
fromPersistValue = forall a. HasCallStack => a
undefined

instance PersistField OverflowNatural where
  toPersistValue :: OverflowNatural -> PersistValue
toPersistValue = (forall a. PersistField a => a -> PersistValue
toPersistValue :: Int64 -> PersistValue) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. OverflowNatural -> Natural
unOverflowNatural
  fromPersistValue :: PersistValue -> Either Text OverflowNatural
fromPersistValue PersistValue
x = case (forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
x :: Either Text Int64) of
    Left Text
err -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Text
T.replace Text
"Int64" Text
"OverflowNatural" Text
err
    Right Int64
int -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Natural -> OverflowNatural
OverflowNatural forall a b. (a -> b) -> a -> b
$ 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) = forall a. PersistField a => a -> PersistValue
toPersistValue a
a
    fromPersistValue :: PersistValue -> Either Text (Maybe a)
fromPersistValue PersistValue
PersistNull = forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
    fromPersistValue PersistValue
x = forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. PersistField a => a -> PersistValue
toPersistValue
    fromPersistValue :: PersistValue -> Either Text [a]
fromPersistValue (PersistList [PersistValue]
l) = forall a. PersistField a => [PersistValue] -> Either Text [a]
fromPersistList [PersistValue]
l
    fromPersistValue (PersistText Text
t) = forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue (ByteString -> PersistValue
PersistByteString forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
t)
    fromPersistValue (PersistByteString ByteString
bs)
        | Just [PersistValue]
values <- forall a. FromJSON a => ByteString -> Maybe a
A.decode' ([ByteString] -> ByteString
L.fromChunks [ByteString
bs]) = 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) = forall a b. b -> Either a b
Right []
    fromPersistValue PersistValue
x = forall a b. a -> Either a b
Left 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 = forall a. PersistField a => a -> PersistValue
toPersistValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Vector a -> [a]
V.toList
  fromPersistValue :: PersistValue -> Either Text (Vector a)
fromPersistValue = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\Text
e -> forall a b. a -> Either a b
Left (Text
"Failed to parse Haskell type `Vector`: " Text -> Text -> Text
`T.append` Text
e))
                            (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Vector a
V.fromList) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. PersistField a => a -> PersistValue
toPersistValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
S.toList
    fromPersistValue :: PersistValue -> Either Text (Set a)
fromPersistValue (PersistList [PersistValue]
list) =
      forall a. Ord a => [a] -> Set a
S.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. PersistField a => [PersistValue] -> Either Text [a]
fromPersistList [PersistValue]
list
    fromPersistValue (PersistText Text
t) = forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue (ByteString -> PersistValue
PersistByteString forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
t)
    fromPersistValue (PersistByteString ByteString
bs)
        | Just [PersistValue]
values <- forall a. FromJSON a => ByteString -> Maybe a
A.decode' ([ByteString] -> ByteString
L.fromChunks [ByteString
bs]) =
            forall a. Ord a => [a] -> Set a
S.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. PersistField a => [PersistValue] -> Either Text [a]
fromPersistList [PersistValue]
values
    fromPersistValue PersistValue
PersistNull = forall a b. b -> Either a b
Right forall a. Set a
S.empty
    fromPersistValue PersistValue
x = forall a b. a -> Either a b
Left 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 [forall a. PersistField a => a -> PersistValue
toPersistValue a
x, forall a. PersistField a => a -> PersistValue
toPersistValue b
y]
    fromPersistValue :: PersistValue -> Either Text (a, b)
fromPersistValue PersistValue
v =
        case forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
v of
            Right [PersistValue
x,PersistValue
y]  -> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
y
            Left Text
e       -> forall a b. a -> Either a b
Left Text
e
            Either Text [PersistValue]
_            -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ [Char]
"Expected 2 item PersistList, received: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show PersistValue
v

instance PersistField v => PersistField (IM.IntMap v) where
    toPersistValue :: IntMap v -> PersistValue
toPersistValue = forall a. PersistField a => a -> PersistValue
toPersistValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IntMap a -> [(Int, a)]
IM.toList
    fromPersistValue :: PersistValue -> Either Text (IntMap v)
fromPersistValue = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [(Int, a)] -> IntMap a
IM.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall a. PersistField a => a -> PersistValue
toPersistValue) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
M.toList
    fromPersistValue :: PersistValue -> Either Text (Map Text v)
fromPersistValue = forall v.
PersistField v =>
[(Text, PersistValue)] -> Either Text (Map Text v)
fromPersistMap 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 = forall a. a -> a
id
    fromPersistValue :: PersistValue -> Either Text PersistValue
fromPersistValue = forall a b. b -> Either a b
Right

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

fromPersistMap :: PersistField v
               => [(T.Text, PersistValue)]
               -> Either T.Text (M.Map T.Text v)
fromPersistMap :: forall v.
PersistField v =>
[(Text, PersistValue)] -> Either Text (Map Text v)
fromPersistMap = forall {a} {t} {a} {b}.
Ord a =>
(t -> Either a b) -> [(a, b)] -> [(a, t)] -> Either a (Map a b)
foldShortLeft 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 [] = forall a b. b -> Either a b
Right forall a b. (a -> b) -> 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   -> 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')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) = forall a b. b -> Either a b
Right [(Text, PersistValue)]
kvs
getPersistMap (PersistText Text
t)  = PersistValue -> Either Text [(Text, PersistValue)]
getPersistMap (ByteString -> PersistValue
PersistByteString forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
t)
getPersistMap (PersistByteString ByteString
bs)
    | Just [(Text, PersistValue)]
pairs <- forall a. FromJSON a => ByteString -> Maybe a
A.decode' ([ByteString] -> ByteString
L.fromChunks [ByteString
bs]) = forall a b. b -> Either a b
Right [(Text, PersistValue)]
pairs
getPersistMap PersistValue
PersistNull = forall a b. b -> Either a b
Right []
getPersistMap PersistValue
x = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> Text -> PersistValue -> Text
fromPersistValueError Text
"[(Text, PersistValue)]" Text
"map, string, bytestring or null" PersistValue
x

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         = forall a b. b -> Either a b
Right Checkmark
Inactive
    fromPersistValue (PersistBool Bool
True)  = forall a b. b -> Either a b
Right Checkmark
Active
    fromPersistValue (PersistInt64 Int64
1)    = 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
"") -> 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
"") -> forall a b. b -> Either a b
Right Checkmark
Active
                                               Maybe (Int, ByteString)
xs -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ [Char]
"Failed to parse Haskell type `Checkmark` from PersistByteString. Original value:" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show ByteString
i forall a. [a] -> [a] -> [a]
++ [Char]
". Parsed by `readInt` as " forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> [Char]
show Maybe (Int, ByteString)
xs) forall a. [a] -> [a] -> [a]
++ [Char]
". Expected '1'."
    fromPersistValue (PersistBool Bool
False) =
      forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
"PersistField Checkmark: found unexpected FALSE value"
    fromPersistValue PersistValue
other =
      forall a b. a -> Either a b
Left 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 (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 :: forall a. Show a => 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 (forall a. Show a => a -> [Char]
show a
received)
    ]