{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Database.SQLite.Simple.FromField
(
FromField(..)
, FieldParser
, ResultError(..)
, Field
, fieldData
, returnError
) where
import Control.Exception (SomeException(..), Exception)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as LB
import Data.Int (Int8, Int16, Int32, Int64)
import Data.Time (UTCTime, Day)
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import Data.Typeable (Typeable, typeOf)
import Data.Word (Word8, Word16, Word32, Word64)
import GHC.Float (double2Float)
import Database.SQLite3 as Base
import Database.SQLite.Simple.Types
import Database.SQLite.Simple.Internal
import Database.SQLite.Simple.Ok
import Database.SQLite.Simple.Time
data ResultError = Incompatible { ResultError -> String
errSQLType :: String
, ResultError -> String
errHaskellType :: String
, ResultError -> String
errMessage :: String }
| UnexpectedNull { errSQLType :: String
, errHaskellType :: String
, errMessage :: String }
| ConversionFailed { errSQLType :: String
, errHaskellType :: String
, errMessage :: String }
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
left :: Exception a => a -> Ok b
left :: forall a b. Exception a => a -> Ok b
left = [SomeException] -> Ok b
forall a. [SomeException] -> Ok a
Errors ([SomeException] -> Ok b) -> (a -> [SomeException]) -> a -> Ok b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SomeException -> [SomeException] -> [SomeException]
forall a. a -> [a] -> [a]
:[]) (SomeException -> [SomeException])
-> (a -> SomeException) -> a -> [SomeException]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SomeException
forall e. Exception e => e -> SomeException
SomeException
type FieldParser a = Field -> Ok a
class FromField a where
fromField :: FieldParser a
instance (FromField a) => FromField (Maybe a) where
fromField :: FieldParser (Maybe a)
fromField (Field SQLData
SQLNull Int
_) = Maybe a -> Ok (Maybe a)
forall a. a -> Ok a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
fromField Field
f = 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
f
instance FromField Null where
fromField :: FieldParser Null
fromField (Field SQLData
SQLNull Int
_) = Null -> Ok Null
forall a. a -> Ok a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Null
Null
fromField Field
f = (String -> String -> String -> ResultError)
-> Field -> String -> Ok Null
forall a err.
(Typeable a, Exception err) =>
(String -> String -> String -> err) -> Field -> String -> Ok a
returnError String -> String -> String -> ResultError
ConversionFailed Field
f String
"data is not null"
takeInt :: (Num a, Typeable a) => Field -> Ok a
takeInt :: forall a. (Num a, Typeable a) => Field -> Ok a
takeInt (Field (SQLInteger Int64
i) Int
_) = a -> Ok a
forall a. a -> Ok a
Ok (a -> Ok a) -> (Int64 -> a) -> Int64 -> Ok a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Ok a) -> Int64 -> Ok a
forall a b. (a -> b) -> a -> b
$ Int64
i
takeInt Field
f = (String -> String -> String -> ResultError)
-> Field -> String -> Ok a
forall a err.
(Typeable a, Exception err) =>
(String -> String -> String -> err) -> Field -> String -> Ok a
returnError String -> String -> String -> ResultError
ConversionFailed Field
f String
"need an int"
instance FromField Int8 where
fromField :: FieldParser Int8
fromField = FieldParser Int8
forall a. (Num a, Typeable a) => Field -> Ok a
takeInt
instance FromField Int16 where
fromField :: FieldParser Int16
fromField = FieldParser Int16
forall a. (Num a, Typeable a) => Field -> Ok a
takeInt
instance FromField Int32 where
fromField :: FieldParser Int32
fromField = FieldParser Int32
forall a. (Num a, Typeable a) => Field -> Ok a
takeInt
instance FromField Int where
fromField :: FieldParser Int
fromField = FieldParser Int
forall a. (Num a, Typeable a) => Field -> Ok a
takeInt
instance FromField Int64 where
fromField :: FieldParser Int64
fromField = FieldParser Int64
forall a. (Num a, Typeable a) => Field -> Ok a
takeInt
instance FromField Integer where
fromField :: FieldParser Integer
fromField = FieldParser Integer
forall a. (Num a, Typeable a) => Field -> Ok a
takeInt
instance FromField Word8 where
fromField :: FieldParser Word8
fromField = FieldParser Word8
forall a. (Num a, Typeable a) => Field -> Ok a
takeInt
instance FromField Word16 where
fromField :: FieldParser Word16
fromField = FieldParser Word16
forall a. (Num a, Typeable a) => Field -> Ok a
takeInt
instance FromField Word32 where
fromField :: FieldParser Word32
fromField = FieldParser Word32
forall a. (Num a, Typeable a) => Field -> Ok a
takeInt
instance FromField Word64 where
fromField :: FieldParser Word64
fromField = FieldParser Word64
forall a. (Num a, Typeable a) => Field -> Ok a
takeInt
instance FromField Word where
fromField :: FieldParser Word
fromField = FieldParser Word
forall a. (Num a, Typeable a) => Field -> Ok a
takeInt
instance FromField Double where
fromField :: FieldParser Double
fromField (Field (SQLFloat Double
flt) Int
_) = Double -> Ok Double
forall a. a -> Ok a
Ok Double
flt
fromField Field
f = (String -> String -> String -> ResultError)
-> Field -> String -> Ok Double
forall a err.
(Typeable a, Exception err) =>
(String -> String -> String -> err) -> Field -> String -> Ok a
returnError String -> String -> String -> ResultError
ConversionFailed Field
f String
"expecting an SQLFloat column type"
instance FromField Float where
fromField :: FieldParser Float
fromField (Field (SQLFloat Double
flt) Int
_) = Float -> Ok Float
forall a. a -> Ok a
Ok (Float -> Ok Float) -> (Double -> Float) -> Double -> Ok Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Float
double2Float (Double -> Ok Float) -> Double -> Ok Float
forall a b. (a -> b) -> a -> b
$ Double
flt
fromField Field
f = (String -> String -> String -> ResultError)
-> Field -> String -> Ok Float
forall a err.
(Typeable a, Exception err) =>
(String -> String -> String -> err) -> Field -> String -> Ok a
returnError String -> String -> String -> ResultError
ConversionFailed Field
f String
"expecting an SQLFloat column type"
instance FromField Bool where
fromField :: FieldParser Bool
fromField f :: Field
f@(Field (SQLInteger Int64
b) Int
_)
| (Int64
b Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0) Bool -> Bool -> Bool
|| (Int64
b Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
1) = Bool -> Ok Bool
forall a. a -> Ok a
Ok (Int64
b Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Int64
0)
| Bool
otherwise = (String -> String -> String -> ResultError)
-> Field -> String -> Ok Bool
forall a err.
(Typeable a, Exception err) =>
(String -> String -> String -> err) -> Field -> String -> Ok a
returnError String -> String -> String -> ResultError
ConversionFailed Field
f (String
"bool must be 0 or 1, got " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int64 -> String
forall a. Show a => a -> String
show Int64
b)
fromField Field
f = (String -> String -> String -> ResultError)
-> Field -> String -> Ok Bool
forall a err.
(Typeable a, Exception err) =>
(String -> String -> String -> err) -> Field -> String -> Ok a
returnError String -> String -> String -> ResultError
ConversionFailed Field
f String
"expecting an SQLInteger column type"
instance FromField T.Text where
fromField :: FieldParser Text
fromField (Field (SQLText Text
txt) Int
_) = Text -> Ok Text
forall a. a -> Ok a
Ok Text
txt
fromField Field
f = (String -> String -> String -> ResultError)
-> Field -> String -> Ok Text
forall a err.
(Typeable a, Exception err) =>
(String -> String -> String -> err) -> Field -> String -> Ok a
returnError String -> String -> String -> ResultError
ConversionFailed Field
f String
"need a text"
instance FromField LT.Text where
fromField :: FieldParser Text
fromField (Field (SQLText Text
txt) Int
_) = Text -> Ok Text
forall a. a -> Ok a
Ok (Text -> Ok Text) -> (Text -> Text) -> Text -> Ok Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
LT.fromStrict (Text -> Ok Text) -> Text -> Ok Text
forall a b. (a -> b) -> a -> b
$ Text
txt
fromField Field
f = (String -> String -> String -> ResultError)
-> Field -> String -> Ok Text
forall a err.
(Typeable a, Exception err) =>
(String -> String -> String -> err) -> Field -> String -> Ok a
returnError String -> String -> String -> ResultError
ConversionFailed Field
f String
"need a text"
instance FromField [Char] where
fromField :: FieldParser String
fromField (Field (SQLText Text
t) Int
_) = String -> Ok String
forall a. a -> Ok a
Ok (String -> Ok String) -> String -> Ok String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t
fromField Field
f = (String -> String -> String -> ResultError)
-> Field -> String -> Ok String
forall a err.
(Typeable a, Exception err) =>
(String -> String -> String -> err) -> Field -> String -> Ok a
returnError String -> String -> String -> ResultError
ConversionFailed Field
f String
"expecting SQLText column type"
instance FromField ByteString where
fromField :: FieldParser ByteString
fromField (Field (SQLBlob ByteString
blb) Int
_) = ByteString -> Ok ByteString
forall a. a -> Ok a
Ok ByteString
blb
fromField Field
f = (String -> String -> String -> ResultError)
-> Field -> String -> Ok ByteString
forall a err.
(Typeable a, Exception err) =>
(String -> String -> String -> err) -> Field -> String -> Ok a
returnError String -> String -> String -> ResultError
ConversionFailed Field
f String
"expecting SQLBlob column type"
instance FromField LB.ByteString where
fromField :: FieldParser ByteString
fromField (Field (SQLBlob ByteString
blb) Int
_) = ByteString -> Ok ByteString
forall a. a -> Ok a
Ok (ByteString -> Ok ByteString)
-> ([ByteString] -> ByteString) -> [ByteString] -> Ok ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
LB.fromChunks ([ByteString] -> Ok ByteString) -> [ByteString] -> Ok ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString
blb]
fromField Field
f = (String -> String -> String -> ResultError)
-> Field -> String -> Ok ByteString
forall a err.
(Typeable a, Exception err) =>
(String -> String -> String -> err) -> Field -> String -> Ok a
returnError String -> String -> String -> ResultError
ConversionFailed Field
f String
"expecting SQLBlob column type"
instance FromField UTCTime where
fromField :: FieldParser UTCTime
fromField f :: Field
f@(Field (SQLText Text
t) Int
_) =
case Text -> Either String UTCTime
parseUTCTime Text
t of
Right UTCTime
t -> UTCTime -> Ok UTCTime
forall a. a -> Ok a
Ok UTCTime
t
Left String
e -> (String -> String -> String -> ResultError)
-> Field -> String -> Ok UTCTime
forall a err.
(Typeable a, Exception err) =>
(String -> String -> String -> err) -> Field -> String -> Ok a
returnError String -> String -> String -> ResultError
ConversionFailed Field
f (String
"couldn't parse UTCTime field: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e)
fromField Field
f = (String -> String -> String -> ResultError)
-> Field -> String -> Ok UTCTime
forall a err.
(Typeable a, Exception err) =>
(String -> String -> String -> err) -> Field -> String -> Ok a
returnError String -> String -> String -> ResultError
ConversionFailed Field
f String
"expecting SQLText column type"
instance FromField Day where
fromField :: FieldParser Day
fromField f :: Field
f@(Field (SQLText Text
t) Int
_) =
case Text -> Either String Day
parseDay Text
t of
Right Day
t -> Day -> Ok Day
forall a. a -> Ok a
Ok Day
t
Left String
e -> (String -> String -> String -> ResultError)
-> Field -> String -> Ok Day
forall a err.
(Typeable a, Exception err) =>
(String -> String -> String -> err) -> Field -> String -> Ok a
returnError String -> String -> String -> ResultError
ConversionFailed Field
f (String
"couldn't parse Day field: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e)
fromField Field
f = (String -> String -> String -> ResultError)
-> Field -> String -> Ok Day
forall a err.
(Typeable a, Exception err) =>
(String -> String -> String -> err) -> Field -> String -> Ok a
returnError String -> String -> String -> ResultError
ConversionFailed Field
f String
"expecting SQLText column type"
instance FromField SQLData where
fromField :: FieldParser SQLData
fromField Field
f = SQLData -> Ok SQLData
forall a. a -> Ok a
Ok (Field -> SQLData
fieldData Field
f)
fieldTypename :: Field -> String
fieldTypename :: Field -> String
fieldTypename = ByteString -> String
B.unpack (ByteString -> String) -> (Field -> ByteString) -> Field -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQLData -> ByteString
gettypename (SQLData -> ByteString)
-> (Field -> SQLData) -> Field -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> SQLData
result
fieldData :: Field -> SQLData
fieldData :: Field -> SQLData
fieldData = Field -> SQLData
result
returnError :: forall a err . (Typeable a, Exception err)
=> (String -> String -> String -> err)
-> Field -> String -> Ok a
returnError :: forall a err.
(Typeable a, Exception err) =>
(String -> String -> String -> err) -> Field -> String -> Ok a
returnError String -> String -> String -> err
mkErr Field
f = err -> Ok a
forall a b. Exception a => a -> Ok b
left (err -> Ok a) -> (String -> err) -> String -> Ok a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> err
mkErr (Field -> String
fieldTypename Field
f)
(TypeRep -> String
forall a. Show a => a -> String
show (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (a
forall a. HasCallStack => a
undefined :: a)))