{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE OverloadedStrings #-}

{- |
Module      : Database.DuckDB.Simple.FromField
Description : Conversion from DuckDB column values to Haskell types.
-}
module Database.DuckDB.Simple.FromField (
    Field (..),
    FieldValue (..),
    ResultError (..),
    FieldParser,
    FromField (..),
    returnError
) where

import Control.Exception (Exception, SomeException (..))
import qualified Data.ByteString as BS
import Data.Int (Int16, Int32, Int64, Int8)
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as TextEncoding
import Data.Time.Calendar (Day)
import Data.Time.Clock (UTCTime (..))
import Data.Time.LocalTime (LocalTime (..), TimeOfDay (..), localTimeToUTC, utc)
import Data.Word (Word16, Word32, Word64, Word8)
import Database.DuckDB.Simple.Types (Null (..))
import Database.DuckDB.Simple.Ok
import Data.Data (Typeable, Proxy (..), typeRep)

-- | Internal representation of a column value.
data FieldValue
    = FieldNull
    | FieldInt8 Int8
    | FieldInt16 Int16
    | FieldInt32 Int32
    | FieldInt64 Int64
    | FieldWord8 Word8
    | FieldWord16 Word16
    | FieldWord32 Word32
    | FieldWord64 Word64
    | FieldFloat Float
    | FieldDouble Double
    | FieldText Text
    | FieldBool Bool
    | FieldBlob BS.ByteString
    | FieldDate Day
    | FieldTime TimeOfDay
    | FieldTimestamp LocalTime
    -- TODO: HugeInt and UHugeInt support

    deriving (-- | FieldInteger Integer
              -- | FieldNatural Natural
              FieldValue -> FieldValue -> Bool
(FieldValue -> FieldValue -> Bool)
-> (FieldValue -> FieldValue -> Bool) -> Eq FieldValue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FieldValue -> FieldValue -> Bool
== :: FieldValue -> FieldValue -> Bool
$c/= :: FieldValue -> FieldValue -> Bool
/= :: FieldValue -> FieldValue -> Bool
Eq, Int -> FieldValue -> ShowS
[FieldValue] -> ShowS
FieldValue -> String
(Int -> FieldValue -> ShowS)
-> (FieldValue -> String)
-> ([FieldValue] -> ShowS)
-> Show FieldValue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FieldValue -> ShowS
showsPrec :: Int -> FieldValue -> ShowS
$cshow :: FieldValue -> String
show :: FieldValue -> String
$cshowList :: [FieldValue] -> ShowS
showList :: [FieldValue] -> ShowS
Show)

-- | Pattern synonym to make it easier to match on any integral type.
pattern FieldInt :: Int -> FieldValue
pattern $mFieldInt :: forall {r}. FieldValue -> (Int -> r) -> ((# #) -> r) -> r
$bFieldInt :: Int -> FieldValue
FieldInt i <- (fieldValueToInt -> Just i)
    where
        FieldInt Int
i = Int64 -> FieldValue
FieldInt64 (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)

fieldValueToInt :: FieldValue -> Maybe Int
fieldValueToInt :: FieldValue -> Maybe Int
fieldValueToInt (FieldInt8 Int8
i) = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int8
i)
fieldValueToInt (FieldInt16 Int16
i) = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
i)
fieldValueToInt (FieldInt32 Int32
i) = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
i)
fieldValueToInt (FieldInt64 Int64
i) = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i)
fieldValueToInt FieldValue
_ = Maybe Int
forall a. Maybe a
Nothing

-- | Pattern synonym to make it easier to match on any word size
pattern FieldWord :: Word -> FieldValue
pattern $mFieldWord :: forall {r}. FieldValue -> (Word -> r) -> ((# #) -> r) -> r
$bFieldWord :: Word -> FieldValue
FieldWord i <- (fieldValueToWord -> Just i)
    where
        FieldWord Word
i = Word64 -> FieldValue
FieldWord64 (Word -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
i)

fieldValueToWord :: FieldValue -> Maybe Word
fieldValueToWord :: FieldValue -> Maybe Word
fieldValueToWord (FieldWord8 Word8
i) = Word -> Maybe Word
forall a. a -> Maybe a
Just (Word8 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
i)
fieldValueToWord (FieldWord16 Word16
i) = Word -> Maybe Word
forall a. a -> Maybe a
Just (Word16 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
i)
fieldValueToWord (FieldWord32 Word32
i) = Word -> Maybe Word
forall a. a -> Maybe a
Just (Word32 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
i)
fieldValueToWord (FieldWord64 Word64
i) = Word -> Maybe Word
forall a. a -> Maybe a
Just (Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i)
fieldValueToWord FieldValue
_ = Maybe Word
forall a. Maybe a
Nothing

-- | Metadata for a single column in a row.
data Field = Field
    { Field -> Text
fieldName :: Text
    , Field -> Int
fieldIndex :: Int
    , Field -> FieldValue
fieldValue :: FieldValue
    }
    deriving (Field -> Field -> Bool
(Field -> Field -> Bool) -> (Field -> Field -> Bool) -> Eq Field
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Field -> Field -> Bool
== :: Field -> Field -> Bool
$c/= :: Field -> Field -> Bool
/= :: Field -> Field -> Bool
Eq, Int -> Field -> ShowS
[Field] -> ShowS
Field -> String
(Int -> Field -> ShowS)
-> (Field -> String) -> ([Field] -> ShowS) -> Show Field
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Field -> ShowS
showsPrec :: Int -> Field -> ShowS
$cshow :: Field -> String
show :: Field -> String
$cshowList :: [Field] -> ShowS
showList :: [Field] -> ShowS
Show)

-- | Exception thrown if conversion from a SQL value to a Haskell
-- value fails.
data ResultError = Incompatible { ResultError -> Text
errSQLType :: Text
                                , ResultError -> Text
errSQLField :: Text
                                , ResultError -> Text
errHaskellType :: Text
                                , ResultError -> Text
errMessage :: Text }
                 -- ^ The SQL and Haskell types are not compatible.
                 | UnexpectedNull { errSQLType :: Text
                                  , errSQLField :: Text
                                  , errHaskellType :: Text
                                  , errMessage :: Text }
                 -- ^ A SQL @NULL@ was encountered when the Haskell
                 -- type did not permit it.
                 | ConversionFailed { errSQLType :: Text
                                    , errSQLField :: Text
                                    , errHaskellType :: Text
                                    , errMessage :: Text }
                 -- ^ The SQL value could not be parsed, or could not
                 -- be represented as a valid Haskell value, or an
                 -- unexpected low-level error occurred (e.g. mismatch
                 -- between metadata and actual data in a row).
                   deriving (ResultError -> ResultError -> Bool
(ResultError -> ResultError -> Bool)
-> (ResultError -> ResultError -> Bool) -> Eq ResultError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ResultError -> ResultError -> Bool
== :: ResultError -> ResultError -> Bool
$c/= :: ResultError -> ResultError -> Bool
/= :: ResultError -> ResultError -> Bool
Eq, Int -> ResultError -> ShowS
[ResultError] -> ShowS
ResultError -> String
(Int -> ResultError -> ShowS)
-> (ResultError -> String)
-> ([ResultError] -> ShowS)
-> Show ResultError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ResultError -> ShowS
showsPrec :: Int -> ResultError -> ShowS
$cshow :: ResultError -> String
show :: ResultError -> String
$cshowList :: [ResultError] -> ShowS
showList :: [ResultError] -> ShowS
Show, Typeable)

instance Exception ResultError



-- | Parser used by 'FromField' instances and utilities such as
-- 'Database.DuckDB.Simple.FromRow.fieldWith'. The supplied 'Field' contains
-- column metadata and an already-decoded 'FieldValue'; callers should return
-- 'Ok' on success or 'Errors' (typically wrapping a 'ResultError') when the
-- conversion fails.
type FieldParser a = Field -> Ok a

-- | Types that can be constructed from a DuckDB column.
class FromField a where
    fromField :: FieldParser a

instance FromField FieldValue where
    fromField :: FieldParser FieldValue
fromField Field{FieldValue
fieldValue :: Field -> FieldValue
fieldValue :: FieldValue
fieldValue} = FieldValue -> Ok FieldValue
forall a. a -> Ok a
Ok FieldValue
fieldValue

instance FromField Null where
    fromField :: FieldParser Null
fromField f :: Field
f@Field{FieldValue
fieldValue :: Field -> FieldValue
fieldValue :: FieldValue
fieldValue} =
        case FieldValue
fieldValue of
            FieldValue
FieldNull -> Null -> Ok Null
forall a. a -> Ok a
Ok Null
Null
            FieldValue
_ ->  (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok Null
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
Incompatible Field
f Text
"expected NULL"

instance FromField Bool where
    fromField :: FieldParser Bool
fromField f :: Field
f@Field{FieldValue
fieldValue :: Field -> FieldValue
fieldValue :: FieldValue
fieldValue} =
        case FieldValue
fieldValue of
            FieldBool Bool
b -> Bool -> Ok Bool
forall a. a -> Ok a
Ok Bool
b
            FieldInt Int
i -> Bool -> Ok Bool
forall a. a -> Ok a
Ok (Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0)
            FieldValue
FieldNull -> (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok Bool
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
UnexpectedNull Field
f Text
""
            FieldValue
_ -> (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok Bool
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
Incompatible Field
f Text
""

instance FromField Int8 where
    fromField :: FieldParser Int8
fromField f :: Field
f@Field{FieldValue
fieldValue :: Field -> FieldValue
fieldValue :: FieldValue
fieldValue} =
        case FieldValue
fieldValue of
            FieldInt Int
i -> Int8 -> Ok Int8
forall a. a -> Ok a
Ok (Int -> Int8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)
            FieldValue
FieldNull -> (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok Int8
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
UnexpectedNull Field
f Text
""
            FieldValue
_ -> (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok Int8
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
Incompatible Field
f Text
""

instance FromField Int64 where
    fromField :: FieldParser Int64
fromField f :: Field
f@Field{FieldValue
fieldValue :: Field -> FieldValue
fieldValue :: FieldValue
fieldValue} =
        case FieldValue
fieldValue of
            FieldInt Int
i -> Int64 -> Ok Int64
forall a. a -> Ok a
Ok (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)
            FieldValue
FieldNull -> (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok Int64
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
UnexpectedNull Field
f Text
""
            FieldValue
_ -> (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok Int64
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
Incompatible Field
f Text
""

instance FromField Int32 where
    fromField :: FieldParser Int32
fromField f :: Field
f@Field{FieldValue
fieldValue :: Field -> FieldValue
fieldValue :: FieldValue
fieldValue} =
        case FieldValue
fieldValue of
            FieldInt Int
i -> Field -> Int -> Ok Int32
forall a.
(Integral a, Bounded a, Typeable a) =>
Field -> Int -> Ok a
boundedIntegral Field
f Int
i
            FieldValue
FieldNull -> (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok Int32
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
UnexpectedNull Field
f Text
""
            FieldValue
_ -> (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok Int32
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
Incompatible Field
f Text
""

instance FromField Int16 where
    fromField :: FieldParser Int16
fromField f :: Field
f@Field{FieldValue
fieldValue :: Field -> FieldValue
fieldValue :: FieldValue
fieldValue} =
        case FieldValue
fieldValue of
            FieldInt Int
i -> Field -> Int -> Ok Int16
forall a.
(Integral a, Bounded a, Typeable a) =>
Field -> Int -> Ok a
boundedIntegral Field
f Int
i
            FieldValue
FieldNull -> (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok Int16
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
UnexpectedNull Field
f Text
""
            FieldValue
_ -> (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok Int16
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
Incompatible Field
f Text
""

instance FromField Int where
    fromField :: FieldParser Int
fromField f :: Field
f@Field{FieldValue
fieldValue :: Field -> FieldValue
fieldValue :: FieldValue
fieldValue} =
        case FieldValue
fieldValue of
            FieldInt Int
i -> Field -> Int -> Ok Int
forall a.
(Integral a, Bounded a, Typeable a) =>
Field -> Int -> Ok a
boundedIntegral Field
f Int
i
            FieldValue
FieldNull -> (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok Int
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
UnexpectedNull Field
f Text
""
            FieldValue
_ -> (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok Int
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
Incompatible Field
f Text
""

instance FromField Word64 where
    fromField :: FieldParser Word64
fromField f :: Field
f@Field{FieldValue
fieldValue :: Field -> FieldValue
fieldValue :: FieldValue
fieldValue} =
        case FieldValue
fieldValue of
            FieldInt Int
i
                | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 -> Word64 -> Ok Word64
forall a. a -> Ok a
Ok (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)
                | Bool
otherwise ->
                     (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok Word64
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
ConversionFailed Field
f Text
"negative value cannot be converted to unsigned integer"
            FieldWord Word
w -> Word64 -> Ok Word64
forall a. a -> Ok a
Ok (Word -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
w)
            FieldValue
FieldNull -> (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok Word64
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
UnexpectedNull Field
f Text
""
            FieldValue
_ -> (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok Word64
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
Incompatible Field
f Text
""

instance FromField Word32 where
    fromField :: FieldParser Word32
fromField f :: Field
f@Field{FieldValue
fieldValue :: Field -> FieldValue
fieldValue :: FieldValue
fieldValue} =
        case FieldValue
fieldValue of
            FieldInt Int
i
                | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 -> Field -> Int -> Ok Word32
forall a.
(Integral a, Bounded a, Typeable a) =>
Field -> Int -> Ok a
boundedIntegral Field
f Int
i
                | Bool
otherwise ->
                    (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok Word32
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
ConversionFailed Field
f Text
"negative value cannot be converted to unsigned integer"
            FieldWord Word
w -> Word32 -> Ok Word32
forall a. a -> Ok a
Ok (Word -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
w)
            FieldValue
FieldNull -> (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok Word32
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
UnexpectedNull Field
f Text
""
            FieldValue
_ -> (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok Word32
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
Incompatible Field
f Text
""

instance FromField Word16 where
    fromField :: FieldParser Word16
fromField f :: Field
f@Field{FieldValue
fieldValue :: Field -> FieldValue
fieldValue :: FieldValue
fieldValue} =
        case FieldValue
fieldValue of
            FieldInt Int
i
                | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 -> Field -> Int -> Ok Word16
forall a.
(Integral a, Bounded a, Typeable a) =>
Field -> Int -> Ok a
boundedIntegral Field
f Int
i
                | Bool
otherwise ->
                    (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok Word16
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
ConversionFailed Field
f Text
"negative value cannot be converted to unsigned integer"
            FieldWord Word
w -> Word16 -> Ok Word16
forall a. a -> Ok a
Ok (Word -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
w)
            FieldValue
FieldNull -> (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok Word16
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
UnexpectedNull Field
f Text
""
            FieldValue
_ -> (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok Word16
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
Incompatible Field
f Text
""

instance FromField Word8 where
    fromField :: FieldParser Word8
fromField f :: Field
f@Field{FieldValue
fieldValue :: Field -> FieldValue
fieldValue :: FieldValue
fieldValue} =
        case FieldValue
fieldValue of
            FieldInt Int
i
                | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 -> Field -> Int -> Ok Word8
forall a.
(Integral a, Bounded a, Typeable a) =>
Field -> Int -> Ok a
boundedIntegral Field
f Int
i
                | Bool
otherwise ->
                    (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok Word8
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
ConversionFailed Field
f Text
"negative value cannot be converted to unsigned integer"
            FieldWord Word
w -> Word8 -> Ok Word8
forall a. a -> Ok a
Ok (Word -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
w)
            FieldValue
FieldNull -> (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok Word8
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
UnexpectedNull Field
f Text
""
            FieldValue
_ -> (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok Word8
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
Incompatible Field
f Text
""

instance FromField Double where
    fromField :: FieldParser Double
fromField f :: Field
f@Field{FieldValue
fieldValue :: Field -> FieldValue
fieldValue :: FieldValue
fieldValue} =
        case FieldValue
fieldValue of
            FieldDouble Double
d -> Double -> Ok Double
forall a. a -> Ok a
Ok Double
d
            FieldInt Int
i -> Double -> Ok Double
forall a. a -> Ok a
Ok (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)
            FieldValue
FieldNull -> (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok Double
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
UnexpectedNull Field
f Text
""
            FieldValue
_ -> (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok Double
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
Incompatible Field
f Text
""

instance FromField Float where
    fromField :: FieldParser Float
fromField Field
field =
        case (FieldParser Double
forall a. FromField a => FieldParser a
fromField Field
field :: Ok Double) of
            Errors [SomeException]
err -> [SomeException] -> Ok Float
forall a. [SomeException] -> Ok a
Errors [SomeException]
err
            Ok Double
d -> Float -> Ok Float
forall a. a -> Ok a
Ok (Double -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
d)

instance FromField Text where
    fromField :: FieldParser Text
fromField f :: Field
f@Field{FieldValue
fieldValue :: Field -> FieldValue
fieldValue :: FieldValue
fieldValue} =
        case FieldValue
fieldValue of
            FieldText Text
t -> Text -> Ok Text
forall a. a -> Ok a
Ok Text
t
            FieldInt Int
i -> Text -> Ok Text
forall a. a -> Ok a
Ok (String -> Text
Text.pack (Int -> String
forall a. Show a => a -> String
show Int
i))
            FieldDouble Double
d -> Text -> Ok Text
forall a. a -> Ok a
Ok (String -> Text
Text.pack (Double -> String
forall a. Show a => a -> String
show Double
d))
            FieldBool Bool
b -> Text -> Ok Text
forall a. a -> Ok a
Ok (if Bool
b then String -> Text
Text.pack String
"1" else String -> Text
Text.pack String
"0")
            FieldValue
FieldNull -> (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok Text
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
UnexpectedNull Field
f Text
""
            FieldValue
_ -> (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok Text
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
Incompatible Field
f Text
""

instance FromField String where
    fromField :: FieldParser String
fromField Field
field = Text -> String
Text.unpack (Text -> String) -> Ok Text -> Ok String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldParser Text
forall a. FromField a => FieldParser a
fromField Field
field

instance FromField BS.ByteString where
    fromField :: FieldParser ByteString
fromField f :: Field
f@Field{FieldValue
fieldValue :: Field -> FieldValue
fieldValue :: FieldValue
fieldValue} =
        case FieldValue
fieldValue of
            FieldBlob ByteString
bs -> ByteString -> Ok ByteString
forall a. a -> Ok a
Ok ByteString
bs
            FieldText Text
t -> ByteString -> Ok ByteString
forall a. a -> Ok a
Ok (Text -> ByteString
TextEncoding.encodeUtf8 Text
t)
            FieldValue
FieldNull -> (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok ByteString
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
UnexpectedNull Field
f Text
""
            FieldValue
_ -> (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok ByteString
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
Incompatible Field
f Text
""

instance FromField Day where
    fromField :: FieldParser Day
fromField f :: Field
f@Field{FieldValue
fieldValue :: Field -> FieldValue
fieldValue :: FieldValue
fieldValue} =
        case FieldValue
fieldValue of
            FieldDate Day
day -> Day -> Ok Day
forall a. a -> Ok a
Ok Day
day
            FieldTimestamp LocalTime{Day
localDay :: Day
localDay :: LocalTime -> Day
localDay} -> Day -> Ok Day
forall a. a -> Ok a
Ok Day
localDay
            FieldValue
FieldNull -> (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok Day
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
UnexpectedNull Field
f Text
""
            FieldValue
_ -> (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok Day
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
Incompatible Field
f Text
""

instance FromField TimeOfDay where
    fromField :: FieldParser TimeOfDay
fromField f :: Field
f@Field{FieldValue
fieldValue :: Field -> FieldValue
fieldValue :: FieldValue
fieldValue} =
        case FieldValue
fieldValue of
            FieldTime TimeOfDay
tod -> TimeOfDay -> Ok TimeOfDay
forall a. a -> Ok a
Ok TimeOfDay
tod
            FieldTimestamp LocalTime{TimeOfDay
localTimeOfDay :: TimeOfDay
localTimeOfDay :: LocalTime -> TimeOfDay
localTimeOfDay} -> TimeOfDay -> Ok TimeOfDay
forall a. a -> Ok a
Ok TimeOfDay
localTimeOfDay
            FieldValue
FieldNull -> (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok TimeOfDay
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
UnexpectedNull Field
f Text
""
            FieldValue
_ -> (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok TimeOfDay
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
Incompatible Field
f Text
""

instance FromField LocalTime where
    fromField :: FieldParser LocalTime
fromField f :: Field
f@Field{ FieldValue
fieldValue :: Field -> FieldValue
fieldValue :: FieldValue
fieldValue} =
        case FieldValue
fieldValue of
            FieldTimestamp LocalTime
ts -> LocalTime -> Ok LocalTime
forall a. a -> Ok a
Ok LocalTime
ts
            FieldDate Day
day -> LocalTime -> Ok LocalTime
forall a. a -> Ok a
Ok (Day -> TimeOfDay -> LocalTime
LocalTime Day
day TimeOfDay
midnight)
            FieldValue
FieldNull -> (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok LocalTime
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
UnexpectedNull Field
f Text
""
            FieldValue
_ -> (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok LocalTime
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
Incompatible Field
f Text
""
      where
        midnight :: TimeOfDay
midnight = Int -> Int -> Pico -> TimeOfDay
TimeOfDay Int
0 Int
0 Pico
0

instance FromField UTCTime where
    fromField :: FieldParser UTCTime
fromField Field
field =
        case FieldParser LocalTime
forall a. FromField a => FieldParser a
fromField Field
field of
            Ok (LocalTime
timestamp :: LocalTime) -> UTCTime -> Ok UTCTime
forall a. a -> Ok a
Ok (TimeZone -> LocalTime -> UTCTime
localTimeToUTC TimeZone
utc LocalTime
timestamp)
            Errors [SomeException]
errs -> [SomeException] -> Ok UTCTime
forall a. [SomeException] -> Ok a
Errors [SomeException]
errs

instance (FromField a) => FromField (Maybe a) where
    fromField :: FieldParser (Maybe a)
fromField Field{fieldValue :: Field -> FieldValue
fieldValue = FieldValue
FieldNull} = Maybe a -> Ok (Maybe a)
forall a. a -> Ok a
Ok Maybe a
forall a. Maybe a
Nothing
    fromField Field
field = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Ok a -> Ok (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldParser a
forall a. FromField a => FieldParser a
fromField Field
field

-- | Helper for bounded integral conversions.
boundedIntegral :: forall a. (Integral a, Bounded a, Typeable a) => Field -> Int -> Ok a
boundedIntegral :: forall a.
(Integral a, Bounded a, Typeable a) =>
Field -> Int -> Ok a
boundedIntegral f :: Field
f@Field{} Int
i
    | Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< a -> Integer
forall a. Integral a => a -> Integer
toInteger (a
forall a. Bounded a => a
minBound :: a) =
        (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok a
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
ConversionFailed Field
f Text
"integer value out of bounds"
    | Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> a -> Integer
forall a. Integral a => a -> Integer
toInteger (a
forall a. Bounded a => a
maxBound :: a) =
        (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok a
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
ConversionFailed Field
f Text
"integer value out of bounds"
    | Bool
otherwise = a -> Ok a
forall a. a -> Ok a
Ok (Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)

-- | Helper to construct a ResultError with field context.
-- based on postgresql-simple's implementation
returnError :: forall b. (Typeable b) => (Text -> Text -> Text -> Text -> ResultError) -> Field -> Text -> Ok b
returnError :: forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
mkError Field{FieldValue
fieldValue :: Field -> FieldValue
fieldValue :: FieldValue
fieldValue, Text
fieldName :: Field -> Text
fieldName :: Text
fieldName} Text
msg =
    [SomeException] -> Ok b
forall a. [SomeException] -> Ok a
Errors [ResultError -> SomeException
forall e. Exception e => e -> SomeException
SomeException (ResultError -> SomeException) -> ResultError -> SomeException
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Text -> ResultError
mkError (FieldValue -> Text
fieldValueTypeName FieldValue
fieldValue)
                                    Text
fieldName
                                    (String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TypeRep -> String
forall a. Show a => a -> String
show (Proxy b -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy b
forall {k} (t :: k). Proxy t
Proxy :: Proxy b)))
                                    Text
msg]


fieldValueTypeName :: FieldValue -> Text
fieldValueTypeName :: FieldValue -> Text
fieldValueTypeName = \case
    FieldValue
FieldNull -> Text
"NULL"
    FieldInt8{} -> Text
"INT1"
    FieldInt16{} -> Text
"INT2"
    FieldInt32{} -> Text
"INT4"
    FieldInt64{} -> Text
"INT8"
    FieldWord8{} -> Text
"UTINYINT"
    FieldWord16{} -> Text
"USMALLINT"
    FieldWord32{} -> Text
"UINTEGER"
    FieldWord64{} -> Text
"UBIGINT"
    FieldFloat{} -> Text
"FLOAT"
    FieldDouble{} -> Text
"DOUBLE"
    FieldText{} -> Text
"TEXT"
    FieldBool{} -> Text
"BOOLEAN"
    FieldBlob{} -> Text
"BLOB"
    FieldDate{} -> Text
"DATE"
    FieldTime{} -> Text
"TIME"
    FieldTimestamp{} -> Text
"TIMESTAMP"

-- TODO: Not supported yet
-- FieldInteger{} -> "HUGEINT"
-- FieldNatural{} -> "UHUGEINT"