{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}

------------------------------------------------------------------------------
-- |
-- Module:      Database.SQLite.Simple.FromField
-- Copyright:   (c) 2011 MailRank, Inc.
--              (c) 2011-2012 Leon P Smith
--              (c) 2012-2013 Janne Hellsten
-- License:     BSD3
-- Maintainer:  Janne Hellsten <jjhellst@gmail.com>
-- Portability: portable
--
-- The 'FromField' typeclass, for converting a single value in a row
-- returned by a SQL query into a more useful Haskell representation.
--
-- A Haskell numeric type is considered to be compatible with all
-- SQLite numeric types that are less accurate than it. For instance,
-- the Haskell 'Double' type is compatible with the SQLite's 32-bit
-- @Int@ type because it can represent a @Int@ exactly. On the other hand,
-- since a 'Double' might lose precision if representing a 64-bit @BigInt@,
-- the two are /not/ considered compatible.
--
------------------------------------------------------------------------------

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

-- | Exception thrown if conversion from a SQL value to a Haskell
-- value fails.
data ResultError = Incompatible { ResultError -> String
errSQLType :: String
                                , ResultError -> String
errHaskellType :: String
                                , ResultError -> String
errMessage :: String }
                 -- ^ The SQL and Haskell types are not compatible.
                 | UnexpectedNull { errSQLType :: String
                                  , errHaskellType :: String
                                  , errMessage :: String }
                 -- ^ A SQL @NULL@ was encountered when the Haskell
                 -- type did not permit it.
                 | ConversionFailed { errSQLType :: String
                                    , errHaskellType :: String
                                    , errMessage :: String }
                 -- ^ 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

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

-- | A type that may be converted from a SQL type.
class FromField a where
    fromField :: FieldParser a
    -- ^ Convert a SQL value to a Haskell value.
    --
    -- Returns a list of exceptions if the conversion fails.  In the case of
    -- library instances,  this will usually be a single 'ResultError',  but
    -- may be a 'UnicodeException'.
    --
    -- Implementations of 'fromField' should not retain any references to
    -- the 'Field' nor the 'ByteString' arguments after the result has
    -- been evaluated to WHNF.  Such a reference causes the entire
    -- @LibPQ.'PQ.Result'@ to be retained.
    --
    -- For example,  the instance for 'ByteString' uses 'B.copy' to avoid
    -- such a reference,  and that using bytestring functions such as 'B.drop'
    -- and 'B.takeWhile' alone will also trigger this memory leak.

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

-- | Return the actual SQL data for a database field.  This allows
-- user-defined 'FromField' instances to access the SQL data
-- associated with a field being parsed.
fieldData :: Field -> SQLData
fieldData :: Field -> SQLData
fieldData = Field -> SQLData
result

-- | Given one of the constructors from 'ResultError',  the field,
--   and an 'errMessage',  this fills in the other fields in the
--   exception value and returns it in a 'Left . SomeException'
--   constructor.
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)))