module Sq.Decoders
   ( Decode (..)
   , ErrDecode (..)
   , decodeRefine
   , DecodeDefault (..)
   , decodeMaybe
   , decodeEither
   , decodeSizedIntegral
   , decodeBinary
   , decodeRead
   , decodeAeson
   ) where

import Control.Applicative
import Control.Exception.Safe qualified as Ex
import Control.Monad
import Control.Monad.Catch qualified as Ex (MonadThrow (..))
import Control.Monad.Trans.Reader
import Data.Aeson qualified as Ae
import Data.Aeson.Types qualified as Ae
import Data.Bifunctor
import Data.Binary.Get qualified as Bin
import Data.Bits
import Data.ByteString qualified as B
import Data.ByteString.Builder.Prim.Internal (caseWordSize_32_64)
import Data.ByteString.Lazy qualified as BL
import Data.Int
import Data.Text qualified as T
import Data.Text.Lazy qualified as TL
import Data.Text.Unsafe qualified as T
import Data.Time qualified as Time
import Data.Time.Clock.POSIX qualified as Time
import Data.Time.Format.ISO8601 qualified as Time
import Data.Word
import Database.SQLite3 qualified as S
import GHC.Float (double2Float, float2Double)
import GHC.Stack
import Numeric.Natural
import Text.Read (readEither, readMaybe)

import Sq.Null (Null)

--------------------------------------------------------------------------------

-- | How to decode a single SQLite column value into a Haskell value of type
-- @a@.
newtype Decode a
   = -- | Decode a 'S.SQLData' value into a value of type @a@.
     Decode (S.SQLData -> Either ErrDecode a)
   deriving
      ((forall a b. (a -> b) -> Decode a -> Decode b)
-> (forall a b. a -> Decode b -> Decode a) -> Functor Decode
forall a b. a -> Decode b -> Decode a
forall a b. (a -> b) -> Decode a -> Decode b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Decode a -> Decode b
fmap :: forall a b. (a -> b) -> Decode a -> Decode b
$c<$ :: forall a b. a -> Decode b -> Decode a
<$ :: forall a b. a -> Decode b -> Decode a
Functor, Functor Decode
Functor Decode =>
(forall a. a -> Decode a)
-> (forall a b. Decode (a -> b) -> Decode a -> Decode b)
-> (forall a b c.
    (a -> b -> c) -> Decode a -> Decode b -> Decode c)
-> (forall a b. Decode a -> Decode b -> Decode b)
-> (forall a b. Decode a -> Decode b -> Decode a)
-> Applicative Decode
forall a. a -> Decode a
forall a b. Decode a -> Decode b -> Decode a
forall a b. Decode a -> Decode b -> Decode b
forall a b. Decode (a -> b) -> Decode a -> Decode b
forall a b c. (a -> b -> c) -> Decode a -> Decode b -> Decode c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> Decode a
pure :: forall a. a -> Decode a
$c<*> :: forall a b. Decode (a -> b) -> Decode a -> Decode b
<*> :: forall a b. Decode (a -> b) -> Decode a -> Decode b
$cliftA2 :: forall a b c. (a -> b -> c) -> Decode a -> Decode b -> Decode c
liftA2 :: forall a b c. (a -> b -> c) -> Decode a -> Decode b -> Decode c
$c*> :: forall a b. Decode a -> Decode b -> Decode b
*> :: forall a b. Decode a -> Decode b -> Decode b
$c<* :: forall a b. Decode a -> Decode b -> Decode a
<* :: forall a b. Decode a -> Decode b -> Decode a
Applicative, Applicative Decode
Applicative Decode =>
(forall a b. Decode a -> (a -> Decode b) -> Decode b)
-> (forall a b. Decode a -> Decode b -> Decode b)
-> (forall a. a -> Decode a)
-> Monad Decode
forall a. a -> Decode a
forall a b. Decode a -> Decode b -> Decode b
forall a b. Decode a -> (a -> Decode b) -> Decode b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. Decode a -> (a -> Decode b) -> Decode b
>>= :: forall a b. Decode a -> (a -> Decode b) -> Decode b
$c>> :: forall a b. Decode a -> Decode b -> Decode b
>> :: forall a b. Decode a -> Decode b -> Decode b
$creturn :: forall a. a -> Decode a
return :: forall a. a -> Decode a
Monad)
      via ReaderT S.SQLData (Either ErrDecode)

-- | @'mempty' = 'pure' 'mempty'@
instance (Monoid a) => Monoid (Decode a) where
   mempty :: Decode a
mempty = a -> Decode a
forall a. a -> Decode a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty
   {-# INLINE mempty #-}

-- | @('<>') == 'liftA2' ('<>')@
instance (Semigroup a) => Semigroup (Decode a) where
   <> :: Decode a -> Decode a -> Decode a
(<>) = (a -> a -> a) -> Decode a -> Decode a -> Decode a
forall a b c. (a -> b -> c) -> Decode a -> Decode b -> Decode c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>)
   {-# INLINE (<>) #-}

instance Ex.MonadThrow Decode where
   throwM :: forall e a. (HasCallStack, Exception e) => e -> Decode a
throwM = (SQLData -> Either ErrDecode a) -> Decode a
forall a. (SQLData -> Either ErrDecode a) -> Decode a
Decode ((SQLData -> Either ErrDecode a) -> Decode a)
-> (e -> SQLData -> Either ErrDecode a) -> e -> Decode a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either ErrDecode a -> SQLData -> Either ErrDecode a
forall a b. a -> b -> a
const (Either ErrDecode a -> SQLData -> Either ErrDecode a)
-> (e -> Either ErrDecode a) -> e -> SQLData -> Either ErrDecode a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrDecode -> Either ErrDecode a
forall a b. a -> Either a b
Left (ErrDecode -> Either ErrDecode a)
-> (e -> ErrDecode) -> e -> Either ErrDecode a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> ErrDecode
ErrDecode_Fail (SomeException -> ErrDecode)
-> (e -> SomeException) -> e -> ErrDecode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> SomeException
forall e. Exception e => e -> SomeException
Ex.toException

instance MonadFail Decode where
   fail :: forall a. String -> Decode a
fail = String -> Decode a
forall (m :: * -> *) a.
(MonadThrow m, HasCallStack) =>
String -> m a
Ex.throwString
   {-# INLINE fail #-}

-- | Leftmost result on success, rightmost error on failure.
instance Alternative Decode where
   empty :: forall a. Decode a
empty = String -> Decode a
forall a. String -> Decode a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"empty"
   {-# INLINE empty #-}
   <|> :: forall a. Decode a -> Decode a -> Decode a
(<|>) = Decode a -> Decode a -> Decode a
forall a. Decode a -> Decode a -> Decode a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
   {-# INLINE (<|>) #-}

-- | Leftmost result on success, rightmost error on failure.
instance MonadPlus Decode where
   mzero :: forall a. Decode a
mzero = String -> Decode a
forall a. String -> Decode a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"mzero"
   {-# INLINE mzero #-}
   mplus :: forall a. Decode a -> Decode a -> Decode a
mplus (Decode SQLData -> Either ErrDecode a
l) (Decode SQLData -> Either ErrDecode a
r) = (SQLData -> Either ErrDecode a) -> Decode a
forall a. (SQLData -> Either ErrDecode a) -> Decode a
Decode \SQLData
s ->
      (ErrDecode -> Either ErrDecode a)
-> (a -> Either ErrDecode a)
-> Either ErrDecode a
-> Either ErrDecode a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\ErrDecode
_ -> SQLData -> Either ErrDecode a
r SQLData
s) a -> Either ErrDecode a
forall a. a -> Either ErrDecode a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SQLData -> Either ErrDecode a
l SQLData
s)
   {-# INLINE mplus #-}

-- | See v'Decode'.
data ErrDecode
   = -- | Received 'S.ColumnType', expected 'S.ColumnType's.
     ErrDecode_Type S.ColumnType [S.ColumnType]
   | ErrDecode_Fail Ex.SomeException
   deriving stock (Int -> ErrDecode -> ShowS
[ErrDecode] -> ShowS
ErrDecode -> String
(Int -> ErrDecode -> ShowS)
-> (ErrDecode -> String)
-> ([ErrDecode] -> ShowS)
-> Show ErrDecode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ErrDecode -> ShowS
showsPrec :: Int -> ErrDecode -> ShowS
$cshow :: ErrDecode -> String
show :: ErrDecode -> String
$cshowList :: [ErrDecode] -> ShowS
showList :: [ErrDecode] -> ShowS
Show)
   deriving anyclass (Show ErrDecode
Typeable ErrDecode
(Typeable ErrDecode, Show ErrDecode) =>
(ErrDecode -> SomeException)
-> (SomeException -> Maybe ErrDecode)
-> (ErrDecode -> String)
-> Exception ErrDecode
SomeException -> Maybe ErrDecode
ErrDecode -> String
ErrDecode -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: ErrDecode -> SomeException
toException :: ErrDecode -> SomeException
$cfromException :: SomeException -> Maybe ErrDecode
fromException :: SomeException -> Maybe ErrDecode
$cdisplayException :: ErrDecode -> String
displayException :: ErrDecode -> String
Ex.Exception)

--------------------------------------------------------------------------------

sqlDataColumnType :: S.SQLData -> S.ColumnType
sqlDataColumnType :: SQLData -> ColumnType
sqlDataColumnType = \case
   S.SQLInteger Int64
_ -> ColumnType
S.IntegerColumn
   S.SQLFloat Double
_ -> ColumnType
S.FloatColumn
   S.SQLText Text
_ -> ColumnType
S.TextColumn
   S.SQLBlob ByteString
_ -> ColumnType
S.BlobColumn
   SQLData
S.SQLNull -> ColumnType
S.NullColumn

--------------------------------------------------------------------------------

-- | A convenience function for refining a 'Decode'r through a function that
-- may fail with a 'String' error message. The 'CallStack' is preserved.
--
-- If you need a more sophisticated refinement, use the 'Decode' constructor.
decodeRefine
   :: (HasCallStack)
   => (a -> Either String b)
   -> Decode a
   -> Decode b
decodeRefine :: forall a b.
HasCallStack =>
(a -> Either String b) -> Decode a -> Decode b
decodeRefine a -> Either String b
f (Decode SQLData -> Either ErrDecode a
g) = (SQLData -> Either ErrDecode b) -> Decode b
forall a. (SQLData -> Either ErrDecode a) -> Decode a
Decode \SQLData
raw -> do
   a
a <- SQLData -> Either ErrDecode a
g SQLData
raw
   case a -> Either String b
f a
a of
      Right b
b -> b -> Either ErrDecode b
forall a b. b -> Either a b
Right b
b
      Left String
s -> (SomeException -> ErrDecode)
-> Either SomeException b -> Either ErrDecode b
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first SomeException -> ErrDecode
ErrDecode_Fail (String -> Either SomeException b
forall (m :: * -> *) a.
(MonadThrow m, HasCallStack) =>
String -> m a
Ex.throwString String
s)

--------------------------------------------------------------------------------
-- Core decodes

-- | Default way to decode a SQLite value into a Haskell value of type @a@.
--
-- If there there exist also a 'Sq.EncodeDefault' instance for @a@, then it
-- must roundtrip with the 'Sq.DecodeDefault' instance for @a@.
class DecodeDefault a where
   -- | Default way to decode a SQLite value into a Haskell value of type @a@.
   decodeDefault :: Decode a

-- | Literal 'S.SQLData' 'Decode'.
instance DecodeDefault S.SQLData where
   decodeDefault :: Decode SQLData
decodeDefault = (SQLData -> Either ErrDecode SQLData) -> Decode SQLData
forall a. (SQLData -> Either ErrDecode a) -> Decode a
Decode SQLData -> Either ErrDecode SQLData
forall a b. b -> Either a b
Right
   {-# INLINE decodeDefault #-}

-- | 'S.IntegerColumn'.
instance DecodeDefault Int64 where
   decodeDefault :: Decode Int64
decodeDefault = (SQLData -> Either ErrDecode Int64) -> Decode Int64
forall a. (SQLData -> Either ErrDecode a) -> Decode a
Decode \case
      S.SQLInteger Int64
x -> Int64 -> Either ErrDecode Int64
forall a b. b -> Either a b
Right Int64
x
      SQLData
x -> ErrDecode -> Either ErrDecode Int64
forall a b. a -> Either a b
Left (ErrDecode -> Either ErrDecode Int64)
-> ErrDecode -> Either ErrDecode Int64
forall a b. (a -> b) -> a -> b
$ ColumnType -> [ColumnType] -> ErrDecode
ErrDecode_Type (SQLData -> ColumnType
sqlDataColumnType SQLData
x) [ColumnType
S.IntegerColumn]

-- | 'S.FloatColumn'.
instance DecodeDefault Double where
   decodeDefault :: Decode Double
decodeDefault = (SQLData -> Either ErrDecode Double) -> Decode Double
forall a. (SQLData -> Either ErrDecode a) -> Decode a
Decode \case
      S.SQLFloat Double
x -> Double -> Either ErrDecode Double
forall a b. b -> Either a b
Right Double
x
      SQLData
x -> ErrDecode -> Either ErrDecode Double
forall a b. a -> Either a b
Left (ErrDecode -> Either ErrDecode Double)
-> ErrDecode -> Either ErrDecode Double
forall a b. (a -> b) -> a -> b
$ ColumnType -> [ColumnType] -> ErrDecode
ErrDecode_Type (SQLData -> ColumnType
sqlDataColumnType SQLData
x) [ColumnType
S.FloatColumn]

-- | 'S.TextColumn'.
instance DecodeDefault T.Text where
   decodeDefault :: Decode Text
decodeDefault = (SQLData -> Either ErrDecode Text) -> Decode Text
forall a. (SQLData -> Either ErrDecode a) -> Decode a
Decode \case
      S.SQLText Text
x -> Text -> Either ErrDecode Text
forall a b. b -> Either a b
Right Text
x
      SQLData
x -> ErrDecode -> Either ErrDecode Text
forall a b. a -> Either a b
Left (ErrDecode -> Either ErrDecode Text)
-> ErrDecode -> Either ErrDecode Text
forall a b. (a -> b) -> a -> b
$ ColumnType -> [ColumnType] -> ErrDecode
ErrDecode_Type (SQLData -> ColumnType
sqlDataColumnType SQLData
x) [ColumnType
S.TextColumn]

-- | 'S.BlobColumn'.
instance DecodeDefault B.ByteString where
   decodeDefault :: Decode ByteString
decodeDefault = (SQLData -> Either ErrDecode ByteString) -> Decode ByteString
forall a. (SQLData -> Either ErrDecode a) -> Decode a
Decode \case
      S.SQLBlob ByteString
x -> ByteString -> Either ErrDecode ByteString
forall a b. b -> Either a b
Right ByteString
x
      SQLData
x -> ErrDecode -> Either ErrDecode ByteString
forall a b. a -> Either a b
Left (ErrDecode -> Either ErrDecode ByteString)
-> ErrDecode -> Either ErrDecode ByteString
forall a b. (a -> b) -> a -> b
$ ColumnType -> [ColumnType] -> ErrDecode
ErrDecode_Type (SQLData -> ColumnType
sqlDataColumnType SQLData
x) [ColumnType
S.BlobColumn]

-- | 'S.NullColumn'.
instance DecodeDefault Null where
   decodeDefault :: Decode Null
decodeDefault = (SQLData -> Either ErrDecode Null) -> Decode Null
forall a. (SQLData -> Either ErrDecode a) -> Decode a
Decode \case
      SQLData
S.SQLNull -> Null -> Either ErrDecode Null
forall a b. b -> Either a b
Right Null
forall a. Monoid a => a
mempty
      SQLData
x -> ErrDecode -> Either ErrDecode Null
forall a b. a -> Either a b
Left (ErrDecode -> Either ErrDecode Null)
-> ErrDecode -> Either ErrDecode Null
forall a b. (a -> b) -> a -> b
$ ColumnType -> [ColumnType] -> ErrDecode
ErrDecode_Type (SQLData -> ColumnType
sqlDataColumnType SQLData
x) [ColumnType
S.NullColumn]

--------------------------------------------------------------------------------
-- Extra decodes

-- | 'S.TextColumn'.
instance DecodeDefault TL.Text where
   decodeDefault :: Decode Text
decodeDefault = Text -> Text
TL.fromStrict (Text -> Text) -> Decode Text -> Decode Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decode Text
forall a. DecodeDefault a => Decode a
decodeDefault
   {-# INLINE decodeDefault #-}

-- | 'S.TextColumn'.
instance DecodeDefault Char where
   decodeDefault :: Decode Char
decodeDefault = ((Text -> Either String Char) -> Decode Text -> Decode Char)
-> Decode Text -> (Text -> Either String Char) -> Decode Char
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Text -> Either String Char) -> Decode Text -> Decode Char
forall a b.
HasCallStack =>
(a -> Either String b) -> Decode a -> Decode b
decodeRefine Decode Text
forall a. DecodeDefault a => Decode a
decodeDefault \Text
t ->
      if Text -> Int
T.length Text
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
         then Char -> Either String Char
forall a b. b -> Either a b
Right (Text -> Char
T.unsafeHead Text
t)
         else String -> Either String Char
forall a b. a -> Either a b
Left String
"Expected single character string"

-- | 'S.TextColumn'.
instance DecodeDefault String where
   decodeDefault :: Decode String
decodeDefault = Text -> String
T.unpack (Text -> String) -> Decode Text -> Decode String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decode Text
forall a. DecodeDefault a => Decode a
decodeDefault
   {-# INLINE decodeDefault #-}

-- | 'S.BlobColumn'.
instance DecodeDefault BL.ByteString where
   decodeDefault :: Decode ByteString
decodeDefault = ByteString -> ByteString
BL.fromStrict (ByteString -> ByteString)
-> Decode ByteString -> Decode ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decode ByteString
forall a. DecodeDefault a => Decode a
decodeDefault
   {-# INLINE decodeDefault #-}

-- | See 'decodeMaybe'.
instance (DecodeDefault a) => DecodeDefault (Maybe a) where
   decodeDefault :: Decode (Maybe a)
decodeDefault = Decode a -> Decode (Maybe a)
forall a. Decode a -> Decode (Maybe a)
decodeMaybe Decode a
forall a. DecodeDefault a => Decode a
decodeDefault
   {-# INLINE decodeDefault #-}

-- | Attempt to decode @a@ first, otherwise attempt decode
-- a 'S.NullColumn' as 'Nothing'.
decodeMaybe :: Decode a -> Decode (Maybe a)
decodeMaybe :: forall a. Decode a -> Decode (Maybe a)
decodeMaybe Decode a
da = (a -> Maybe a) -> Decode a -> Decode (Maybe a)
forall a b. (a -> b) -> Decode a -> Decode b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just Decode a
da Decode (Maybe a) -> Decode (Maybe a) -> Decode (Maybe a)
forall a. Decode a -> Decode a -> Decode a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Null -> Maybe a) -> Decode Null -> Decode (Maybe a)
forall a b. (a -> b) -> Decode a -> Decode b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Null
_ -> Maybe a
forall a. Maybe a
Nothing) (forall a. DecodeDefault a => Decode a
decodeDefault @Null)
{-# INLINE decodeMaybe #-}

-- | See 'decodeEither'.
instance
   (DecodeDefault a, DecodeDefault b)
   => DecodeDefault (Either a b)
   where
   decodeDefault :: Decode (Either a b)
decodeDefault = Decode a -> Decode b -> Decode (Either a b)
forall a b. Decode a -> Decode b -> Decode (Either a b)
decodeEither Decode a
forall a. DecodeDefault a => Decode a
decodeDefault Decode b
forall a. DecodeDefault a => Decode a
decodeDefault
   {-# INLINE decodeDefault #-}

-- | @
-- 'decodeEither' da db = fmap 'Left' da '<|>' fmap 'Right' db
-- @
decodeEither :: Decode a -> Decode b -> Decode (Either a b)
decodeEither :: forall a b. Decode a -> Decode b -> Decode (Either a b)
decodeEither Decode a
da Decode b
db = (a -> Either a b) -> Decode a -> Decode (Either a b)
forall a b. (a -> b) -> Decode a -> Decode b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either a b
forall a b. a -> Either a b
Left Decode a
da Decode (Either a b) -> Decode (Either a b) -> Decode (Either a b)
forall a. Decode a -> Decode a -> Decode a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (b -> Either a b) -> Decode b -> Decode (Either a b)
forall a b. (a -> b) -> Decode a -> Decode b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Either a b
forall a b. b -> Either a b
Right Decode b
db
{-# INLINE decodeEither #-}

-- | 'S.IntegerColumn', 'S.FloatColumn', 'S.TextColumn'
-- depicting a literal integer.
instance DecodeDefault Integer where
   decodeDefault :: Decode Integer
decodeDefault = (SQLData -> Either ErrDecode Integer) -> Decode Integer
forall a. (SQLData -> Either ErrDecode a) -> Decode a
Decode \case
      S.SQLInteger Int64
i -> Integer -> Either ErrDecode Integer
forall a b. b -> Either a b
Right (Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i)
      S.SQLFloat Double
d
         | Bool -> Bool
not (Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
d Bool -> Bool -> Bool
|| Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
d)
         , (Integer
i, Double
0) <- Double -> (Integer, Double)
forall b. Integral b => Double -> (b, Double)
forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction Double
d ->
            Integer -> Either ErrDecode Integer
forall a b. b -> Either a b
Right Integer
i
         | Bool
otherwise -> (SomeException -> ErrDecode)
-> Either SomeException Integer -> Either ErrDecode Integer
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first SomeException -> ErrDecode
ErrDecode_Fail do
            String -> Either SomeException Integer
forall (m :: * -> *) a.
(MonadThrow m, HasCallStack) =>
String -> m a
Ex.throwString String
"Not an integer"
      S.SQLText Text
t
         | Just Integer
i <- String -> Maybe Integer
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
T.unpack Text
t) -> Integer -> Either ErrDecode Integer
forall a b. b -> Either a b
Right Integer
i
         | Bool
otherwise -> (SomeException -> ErrDecode)
-> Either SomeException Integer -> Either ErrDecode Integer
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first SomeException -> ErrDecode
ErrDecode_Fail do
            String -> Either SomeException Integer
forall (m :: * -> *) a.
(MonadThrow m, HasCallStack) =>
String -> m a
Ex.throwString String
"Not an integer"
      SQLData
x -> ErrDecode -> Either ErrDecode Integer
forall a b. a -> Either a b
Left (ErrDecode -> Either ErrDecode Integer)
-> ErrDecode -> Either ErrDecode Integer
forall a b. (a -> b) -> a -> b
$ ColumnType -> [ColumnType] -> ErrDecode
ErrDecode_Type (SQLData -> ColumnType
sqlDataColumnType SQLData
x) do
         [ColumnType
S.IntegerColumn, ColumnType
S.FloatColumn, ColumnType
S.TextColumn]

-- | 'S.IntegerColumn'.
decodeSizedIntegral :: (Integral a, Bits a) => Decode a
decodeSizedIntegral :: forall a. (Integral a, Bits a) => Decode a
decodeSizedIntegral = do
   Integer
i <- forall a. DecodeDefault a => Decode a
decodeDefault @Integer
   case Integer -> Maybe a
forall a b.
(Integral a, Integral b, Bits a, Bits b) =>
a -> Maybe b
toIntegralSized Integer
i of
      Just a
a -> a -> Decode a
forall a. a -> Decode a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
      Maybe a
Nothing -> String -> Decode a
forall a. String -> Decode a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Integral overflow or underflow"

-- | 'S.IntegerColumn'.
instance DecodeDefault Int8 where
   decodeDefault :: Decode Int8
decodeDefault = Decode Int8
forall a. (Integral a, Bits a) => Decode a
decodeSizedIntegral
   {-# INLINE decodeDefault #-}

-- | 'S.IntegerColumn'.
instance DecodeDefault Word8 where
   decodeDefault :: Decode Word8
decodeDefault = Decode Word8
forall a. (Integral a, Bits a) => Decode a
decodeSizedIntegral
   {-# INLINE decodeDefault #-}

-- | 'S.IntegerColumn'.
instance DecodeDefault Int16 where
   decodeDefault :: Decode Int16
decodeDefault = Decode Int16
forall a. (Integral a, Bits a) => Decode a
decodeSizedIntegral
   {-# INLINE decodeDefault #-}

-- | 'S.IntegerColumn'.
instance DecodeDefault Word16 where
   decodeDefault :: Decode Word16
decodeDefault = Decode Word16
forall a. (Integral a, Bits a) => Decode a
decodeSizedIntegral
   {-# INLINE decodeDefault #-}

-- | 'S.IntegerColumn'.
instance DecodeDefault Int32 where
   decodeDefault :: Decode Int32
decodeDefault = Decode Int32
forall a. (Integral a, Bits a) => Decode a
decodeSizedIntegral
   {-# INLINE decodeDefault #-}

-- | 'S.IntegerColumn'.
instance DecodeDefault Word32 where
   decodeDefault :: Decode Word32
decodeDefault = Decode Word32
forall a. (Integral a, Bits a) => Decode a
decodeSizedIntegral
   {-# INLINE decodeDefault #-}

-- | 'S.IntegerColumn' if it fits in 'Int64', otherwise 'S.TextColumn'.
instance DecodeDefault Word where
   decodeDefault :: Decode Word
decodeDefault = Decode Word
forall a. (Integral a, Bits a) => Decode a
decodeSizedIntegral
   {-# INLINE decodeDefault #-}

-- | 'S.IntegerColumn' if it fits in 'Int64', otherwise 'S.TextColumn'.
instance DecodeDefault Word64 where
   decodeDefault :: Decode Word64
decodeDefault = Decode Word64
forall a. (Integral a, Bits a) => Decode a
decodeSizedIntegral
   {-# INLINE decodeDefault #-}

-- | 'S.IntegerColumn'.
instance DecodeDefault Int where
   decodeDefault :: Decode Int
decodeDefault =
      Decode Int -> Decode Int -> Decode Int
forall a. a -> a -> a
caseWordSize_32_64
         Decode Int
forall a. (Integral a, Bits a) => Decode a
decodeSizedIntegral
         (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int) -> Decode Int64 -> Decode Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. DecodeDefault a => Decode a
decodeDefault @Int64)
   {-# INLINE decodeDefault #-}

-- | 'S.IntegerColumn' if it fits in 'Int64', otherwise 'S.TextColumn'.
instance DecodeDefault Natural where
   decodeDefault :: Decode Natural
decodeDefault = Decode Natural
forall a. (Integral a, Bits a) => Decode a
decodeSizedIntegral
   {-# INLINE decodeDefault #-}

-- | 'S.IntegerColumn' and 'S.FloatColumn' only.
--
-- @0@ is 'False', every other number is 'True'.
instance DecodeDefault Bool where
   decodeDefault :: Decode Bool
decodeDefault = (SQLData -> Either ErrDecode Bool) -> Decode Bool
forall a. (SQLData -> Either ErrDecode a) -> Decode a
Decode \case
      S.SQLInteger Int64
x -> Bool -> Either ErrDecode Bool
forall a b. b -> Either a b
Right (Int64
x Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Int64
0)
      S.SQLFloat Double
x -> Bool -> Either ErrDecode Bool
forall a b. b -> Either a b
Right (Double
x Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
0)
      SQLData
x ->
         ErrDecode -> Either ErrDecode Bool
forall a b. a -> Either a b
Left (ErrDecode -> Either ErrDecode Bool)
-> ErrDecode -> Either ErrDecode Bool
forall a b. (a -> b) -> a -> b
$
            ColumnType -> [ColumnType] -> ErrDecode
ErrDecode_Type
               (SQLData -> ColumnType
sqlDataColumnType SQLData
x)
               [ColumnType
S.IntegerColumn, ColumnType
S.FloatColumn]

-- | Like for 'Time.ZonedTime'.
instance DecodeDefault Time.UTCTime where
   decodeDefault :: Decode UTCTime
decodeDefault = ZonedTime -> UTCTime
Time.zonedTimeToUTC (ZonedTime -> UTCTime) -> Decode ZonedTime -> Decode UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decode ZonedTime
forall a. DecodeDefault a => Decode a
decodeDefault
   {-# INLINE decodeDefault #-}

-- | 'S.TextColumn' ('Time.ISO8601', or seconds since Epoch with optional decimal
-- part of up to picosecond precission), or 'S.Integer' (seconds since Epoch).
--
-- TODO: Currently precission over picoseconds is successfully parsed but
-- silently floored. This is an issue in "Data.Time.Format.ISO8601". Fix.
instance DecodeDefault Time.ZonedTime where
   decodeDefault :: Decode ZonedTime
decodeDefault = (SQLData -> Either ErrDecode ZonedTime) -> Decode ZonedTime
forall a. (SQLData -> Either ErrDecode a) -> Decode a
Decode \case
      S.SQLText (Text -> String
T.unpack -> String
s)
         | Just ZonedTime
zt <- String -> Maybe ZonedTime
forall (m :: * -> *) t. (MonadFail m, ISO8601 t) => String -> m t
Time.iso8601ParseM String
s -> ZonedTime -> Either ErrDecode ZonedTime
forall a b. b -> Either a b
Right ZonedTime
zt
         | Just UTCTime
u <- String -> Maybe UTCTime
forall (m :: * -> *) t. (MonadFail m, ISO8601 t) => String -> m t
Time.iso8601ParseM String
s ->
            ZonedTime -> Either ErrDecode ZonedTime
forall a b. b -> Either a b
Right (ZonedTime -> Either ErrDecode ZonedTime)
-> ZonedTime -> Either ErrDecode ZonedTime
forall a b. (a -> b) -> a -> b
$ TimeZone -> UTCTime -> ZonedTime
Time.utcToZonedTime TimeZone
Time.utc UTCTime
u
         | Just UTCTime
u <- Bool -> TimeLocale -> String -> String -> Maybe UTCTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
Time.parseTimeM Bool
False TimeLocale
Time.defaultTimeLocale String
"%s%Q" String
s ->
            ZonedTime -> Either ErrDecode ZonedTime
forall a b. b -> Either a b
Right (ZonedTime -> Either ErrDecode ZonedTime)
-> ZonedTime -> Either ErrDecode ZonedTime
forall a b. (a -> b) -> a -> b
$ TimeZone -> UTCTime -> ZonedTime
Time.utcToZonedTime TimeZone
Time.utc UTCTime
u
         | Bool
otherwise -> (SomeException -> ErrDecode)
-> Either SomeException ZonedTime -> Either ErrDecode ZonedTime
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first SomeException -> ErrDecode
ErrDecode_Fail do
            String -> Either SomeException ZonedTime
forall (m :: * -> *) a.
(MonadThrow m, HasCallStack) =>
String -> m a
Ex.throwString (String -> Either SomeException ZonedTime)
-> String -> Either SomeException ZonedTime
forall a b. (a -> b) -> a -> b
$ String
"Invalid timestamp: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall a. Show a => a -> String
show String
s
      S.SQLInteger Int64
i ->
         ZonedTime -> Either ErrDecode ZonedTime
forall a b. b -> Either a b
Right (ZonedTime -> Either ErrDecode ZonedTime)
-> ZonedTime -> Either ErrDecode ZonedTime
forall a b. (a -> b) -> a -> b
$
            TimeZone -> UTCTime -> ZonedTime
Time.utcToZonedTime TimeZone
Time.utc (UTCTime -> ZonedTime) -> UTCTime -> ZonedTime
forall a b. (a -> b) -> a -> b
$
               POSIXTime -> UTCTime
Time.posixSecondsToUTCTime (POSIXTime -> UTCTime) -> POSIXTime -> UTCTime
forall a b. (a -> b) -> a -> b
$
                  Int64 -> POSIXTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i
      SQLData
x ->
         ErrDecode -> Either ErrDecode ZonedTime
forall a b. a -> Either a b
Left (ErrDecode -> Either ErrDecode ZonedTime)
-> ErrDecode -> Either ErrDecode ZonedTime
forall a b. (a -> b) -> a -> b
$
            ColumnType -> [ColumnType] -> ErrDecode
ErrDecode_Type
               (SQLData -> ColumnType
sqlDataColumnType SQLData
x)
               [ColumnType
S.IntegerColumn, ColumnType
S.TextColumn]

-- | 'Time.ISO8601' in a @'S.TextColumn'.
instance DecodeDefault Time.LocalTime where
   decodeDefault :: Decode LocalTime
decodeDefault = Decode String
forall a. DecodeDefault a => Decode a
decodeDefault Decode String -> (String -> Decode LocalTime) -> Decode LocalTime
forall a b. Decode a -> (a -> Decode b) -> Decode b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Decode LocalTime
forall (m :: * -> *) t. (MonadFail m, ISO8601 t) => String -> m t
Time.iso8601ParseM
   {-# INLINE decodeDefault #-}

-- | 'Time.ISO8601' in a @'S.TextColumn'.
instance DecodeDefault Time.Day where
   decodeDefault :: Decode Day
decodeDefault = Decode String
forall a. DecodeDefault a => Decode a
decodeDefault Decode String -> (String -> Decode Day) -> Decode Day
forall a b. Decode a -> (a -> Decode b) -> Decode b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Decode Day
forall (m :: * -> *) t. (MonadFail m, ISO8601 t) => String -> m t
Time.iso8601ParseM
   {-# INLINE decodeDefault #-}

-- | 'Time.ISO8601' in a @'S.TextColumn'.
--
-- TODO: Currently precission over picoseconds is successfully parsed but
-- silently floored. This is an issue in "Data.Time.Format.ISO8601". Fix.
instance DecodeDefault Time.TimeOfDay where
   decodeDefault :: Decode TimeOfDay
decodeDefault = Decode String
forall a. DecodeDefault a => Decode a
decodeDefault Decode String -> (String -> Decode TimeOfDay) -> Decode TimeOfDay
forall a b. Decode a -> (a -> Decode b) -> Decode b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Decode TimeOfDay
forall (m :: * -> *) t. (MonadFail m, ISO8601 t) => String -> m t
Time.iso8601ParseM
   {-# INLINE decodeDefault #-}

-- | 'Time.ISO8601' in a @'S.TextColumn'.
--
-- TODO: Currently precission over picoseconds is successfully parsed but
-- silently floored. This is an issue in "Data.Time.Format.ISO8601". Fix.
instance DecodeDefault Time.CalendarDiffDays where
   decodeDefault :: Decode CalendarDiffDays
decodeDefault = Decode String
forall a. DecodeDefault a => Decode a
decodeDefault Decode String
-> (String -> Decode CalendarDiffDays) -> Decode CalendarDiffDays
forall a b. Decode a -> (a -> Decode b) -> Decode b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Decode CalendarDiffDays
forall (m :: * -> *) t. (MonadFail m, ISO8601 t) => String -> m t
Time.iso8601ParseM
   {-# INLINE decodeDefault #-}

-- | 'Time.ISO8601' in a @'S.TextColumn'.
--
-- TODO: Currently precission over picoseconds is successfully parsed but
-- silently floored. This is an issue in "Data.Time.Format.ISO8601". Fix.
instance DecodeDefault Time.CalendarDiffTime where
   decodeDefault :: Decode CalendarDiffTime
decodeDefault = Decode String
forall a. DecodeDefault a => Decode a
decodeDefault Decode String
-> (String -> Decode CalendarDiffTime) -> Decode CalendarDiffTime
forall a b. Decode a -> (a -> Decode b) -> Decode b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Decode CalendarDiffTime
forall (m :: * -> *) t. (MonadFail m, ISO8601 t) => String -> m t
Time.iso8601ParseM
   {-# INLINE decodeDefault #-}

-- | 'Time.ISO8601' in a @'S.TextColumn'.
instance DecodeDefault Time.TimeZone where
   decodeDefault :: Decode TimeZone
decodeDefault = Decode String
forall a. DecodeDefault a => Decode a
decodeDefault Decode String -> (String -> Decode TimeZone) -> Decode TimeZone
forall a b. Decode a -> (a -> Decode b) -> Decode b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Decode TimeZone
forall (m :: * -> *) t. (MonadFail m, ISO8601 t) => String -> m t
Time.iso8601ParseM
   {-# INLINE decodeDefault #-}

-- | 'S.FloatColumn'.
instance DecodeDefault Float where
   decodeDefault :: Decode Float
decodeDefault = ((Double -> Either String Float) -> Decode Double -> Decode Float)
-> Decode Double -> (Double -> Either String Float) -> Decode Float
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Double -> Either String Float) -> Decode Double -> Decode Float
forall a b.
HasCallStack =>
(a -> Either String b) -> Decode a -> Decode b
decodeRefine Decode Double
forall a. DecodeDefault a => Decode a
decodeDefault \Double
d -> do
      let f :: Float
f = Double -> Float
double2Float Double
d
      if Float -> Double
float2Double Float
f Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
d
         then Float -> Either String Float
forall a b. b -> Either a b
Right Float
f
         else String -> Either String Float
forall a b. a -> Either a b
Left String
"Lossy conversion from Double to Float"

--------------------------------------------------------------------------------

-- | 'S.BlobColumn'.
decodeBinary :: Bin.Get a -> Decode a
decodeBinary :: forall a. Get a -> Decode a
decodeBinary Get a
ga = ((ByteString -> Either String a) -> Decode ByteString -> Decode a)
-> Decode ByteString -> (ByteString -> Either String a) -> Decode a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ByteString -> Either String a) -> Decode ByteString -> Decode a
forall a b.
HasCallStack =>
(a -> Either String b) -> Decode a -> Decode b
decodeRefine (forall a. DecodeDefault a => Decode a
decodeDefault @BL.ByteString) \ByteString
bl ->
   case Get a
-> ByteString
-> Either (ByteString, Int64, String) (ByteString, Int64, a)
forall a.
Get a
-> ByteString
-> Either (ByteString, Int64, String) (ByteString, Int64, a)
Bin.runGetOrFail Get a
ga ByteString
bl of
      Right (ByteString
_, Int64
_, a
a) -> a -> Either String a
forall a b. b -> Either a b
Right a
a
      Left (ByteString
_, Int64
_, String
s) -> String -> Either String a
forall a b. a -> Either a b
Left String
s

-- | 'S.TextColumn'.
decodeRead :: (Prelude.Read a) => Decode a
decodeRead :: forall a. Read a => Decode a
decodeRead = (String -> Either String a) -> Decode String -> Decode a
forall a b.
HasCallStack =>
(a -> Either String b) -> Decode a -> Decode b
decodeRefine String -> Either String a
forall a. Read a => String -> Either String a
readEither (forall a. DecodeDefault a => Decode a
decodeDefault @String)
{-# INLINE decodeRead #-}

-- | 'S.TextColumn'.
decodeAeson :: forall a. (Ae.Value -> Ae.Parser a) -> Decode a
decodeAeson :: forall a. (Value -> Parser a) -> Decode a
decodeAeson Value -> Parser a
p =
   (Text -> Either String a) -> Decode Text -> Decode a
forall a b.
HasCallStack =>
(a -> Either String b) -> Decode a -> Decode b
decodeRefine
      (Text -> Either String Value
forall a. FromJSON a => Text -> Either String a
Ae.eitherDecodeStrictText (Text -> Either String Value)
-> (Value -> Either String a) -> Text -> Either String a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (Value -> Parser a) -> Value -> Either String a
forall a b. (a -> Parser b) -> a -> Either String b
Ae.parseEither Value -> Parser a
p)
      (forall a. DecodeDefault a => Decode a
decodeDefault @T.Text)
{-# INLINE decodeAeson #-}