{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE UndecidableInstances #-}

module Preql.FromSql.Instances where

import           Preql.FromSql.Class
import           Preql.FromSql.TH
import           Preql.Wire.Errors
import           Preql.Wire.Internal        (applyDecoder)
import           Preql.Wire.Types

import qualified BinaryParser               as BP
import qualified Data.Aeson                 as JSON
import qualified Data.ByteString            as BS
import qualified Data.ByteString.Lazy       as BSL
import           Data.Int
import qualified Data.Text                  as T
import qualified Data.Text.Lazy             as TL
import           Data.Time                  (Day, TimeOfDay, UTCTime)
import           Data.UUID                  (UUID)
import qualified Database.PostgreSQL.LibPQ  as PQ
import           GHC.TypeNats
import qualified PostgreSQL.Binary.Decoding as PGB
import           Preql.Imports
import qualified Preql.Wire.TypeInfo.Static as OID

instance FromSqlField Bool where
    fromSqlField :: FieldDecoder Bool
fromSqlField = PgType -> BinaryParser Bool -> FieldDecoder Bool
forall a. PgType -> BinaryParser a -> FieldDecoder a
FieldDecoder (Oid -> PgType
Oid Oid
OID.boolOid) BinaryParser Bool
PGB.bool
instance FromSql Bool

instance FromSqlField Int16 where
    fromSqlField :: FieldDecoder Int16
fromSqlField = PgType -> BinaryParser Int16 -> FieldDecoder Int16
forall a. PgType -> BinaryParser a -> FieldDecoder a
FieldDecoder (Oid -> PgType
Oid Oid
OID.int2Oid) BinaryParser Int16
forall a. (Integral a, Bits a) => Value a
PGB.int
instance FromSql Int16

instance FromSqlField Int32 where
    fromSqlField :: FieldDecoder Int32
fromSqlField = PgType -> BinaryParser Int32 -> FieldDecoder Int32
forall a. PgType -> BinaryParser a -> FieldDecoder a
FieldDecoder (Oid -> PgType
Oid Oid
OID.int4Oid) BinaryParser Int32
forall a. (Integral a, Bits a) => Value a
PGB.int
instance FromSql Int32

instance FromSqlField Int64  where
    fromSqlField :: FieldDecoder Int64
fromSqlField = PgType -> BinaryParser Int64 -> FieldDecoder Int64
forall a. PgType -> BinaryParser a -> FieldDecoder a
FieldDecoder (Oid -> PgType
Oid Oid
OID.int8Oid) BinaryParser Int64
forall a. (Integral a, Bits a) => Value a
PGB.int
instance FromSql Int64

instance FromSqlField Float where
    fromSqlField :: FieldDecoder Float
fromSqlField = PgType -> BinaryParser Float -> FieldDecoder Float
forall a. PgType -> BinaryParser a -> FieldDecoder a
FieldDecoder (Oid -> PgType
Oid Oid
OID.float4Oid) BinaryParser Float
PGB.float4
instance FromSql Float

instance FromSqlField Double where
    fromSqlField :: FieldDecoder Double
fromSqlField = PgType -> BinaryParser Double -> FieldDecoder Double
forall a. PgType -> BinaryParser a -> FieldDecoder a
FieldDecoder (Oid -> PgType
Oid Oid
OID.float8Oid) BinaryParser Double
PGB.float8
instance FromSql Double

instance FromSqlField Char where
    fromSqlField :: FieldDecoder Char
fromSqlField = PgType -> BinaryParser Char -> FieldDecoder Char
forall a. PgType -> BinaryParser a -> FieldDecoder a
FieldDecoder (Oid -> PgType
Oid Oid
OID.charOid) BinaryParser Char
PGB.char
instance FromSql Char where fromSql :: RowDecoder (Width Char) Char
fromSql = FieldDecoder Char -> RowDecoder 1 Char
forall a. FieldDecoder a -> RowDecoder 1 a
notNull FieldDecoder Char
forall a. FromSqlField a => FieldDecoder a
fromSqlField

instance FromSqlField String where
    fromSqlField :: FieldDecoder String
fromSqlField = PgType -> BinaryParser String -> FieldDecoder String
forall a. PgType -> BinaryParser a -> FieldDecoder a
FieldDecoder (Oid -> PgType
Oid Oid
OID.textOid) (Text -> String
T.unpack (Text -> String) -> BinaryParser Text -> BinaryParser String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinaryParser Text
PGB.text_strict)
instance FromSql String

instance FromSqlField Text where
    fromSqlField :: FieldDecoder Text
fromSqlField = PgType -> BinaryParser Text -> FieldDecoder Text
forall a. PgType -> BinaryParser a -> FieldDecoder a
FieldDecoder (Oid -> PgType
Oid Oid
OID.textOid) BinaryParser Text
PGB.text_strict
instance FromSql Text

instance FromSqlField TL.Text where
    fromSqlField :: FieldDecoder Text
fromSqlField = PgType -> BinaryParser Text -> FieldDecoder Text
forall a. PgType -> BinaryParser a -> FieldDecoder a
FieldDecoder (Oid -> PgType
Oid Oid
OID.textOid) BinaryParser Text
PGB.text_lazy
instance FromSql TL.Text

-- | If you want to encode some more specific Haskell type via JSON,
-- it is more efficient to use 'Data.Aeson.encode' and
-- 'PostgreSQL.Binary.Encoding.jsonb_bytes' directly, rather than this
-- instance.
instance FromSqlField ByteString where
    fromSqlField :: FieldDecoder ByteString
fromSqlField = PgType -> BinaryParser ByteString -> FieldDecoder ByteString
forall a. PgType -> BinaryParser a -> FieldDecoder a
FieldDecoder (Oid -> PgType
Oid Oid
OID.byteaOid) (ByteString -> ByteString
BS.copy (ByteString -> ByteString)
-> BinaryParser ByteString -> BinaryParser ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinaryParser ByteString
BP.remainders)
instance FromSql ByteString

instance FromSqlField BSL.ByteString where
    fromSqlField :: FieldDecoder ByteString
fromSqlField = PgType -> BinaryParser ByteString -> FieldDecoder ByteString
forall a. PgType -> BinaryParser a -> FieldDecoder a
FieldDecoder (Oid -> PgType
Oid Oid
OID.byteaOid) (ByteString -> ByteString
BSL.fromStrict (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BS.copy (ByteString -> ByteString)
-> BinaryParser ByteString -> BinaryParser ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinaryParser ByteString
BP.remainders)
instance FromSql BSL.ByteString

-- TODO check for integer_datetimes setting
instance FromSqlField UTCTime where
    fromSqlField :: FieldDecoder UTCTime
fromSqlField = PgType -> BinaryParser UTCTime -> FieldDecoder UTCTime
forall a. PgType -> BinaryParser a -> FieldDecoder a
FieldDecoder (Oid -> PgType
Oid Oid
OID.timestamptzOid) BinaryParser UTCTime
PGB.timestamptz_int
instance FromSql UTCTime

instance FromSqlField Day where
    fromSqlField :: FieldDecoder Day
fromSqlField = PgType -> BinaryParser Day -> FieldDecoder Day
forall a. PgType -> BinaryParser a -> FieldDecoder a
FieldDecoder (Oid -> PgType
Oid Oid
OID.dateOid) BinaryParser Day
PGB.date
instance FromSql Day

instance FromSqlField TimeOfDay where
    fromSqlField :: FieldDecoder TimeOfDay
fromSqlField = PgType -> BinaryParser TimeOfDay -> FieldDecoder TimeOfDay
forall a. PgType -> BinaryParser a -> FieldDecoder a
FieldDecoder (Oid -> PgType
Oid Oid
OID.timeOid) BinaryParser TimeOfDay
PGB.time_int
instance FromSql TimeOfDay

instance FromSqlField TimeTZ where
    fromSqlField :: FieldDecoder TimeTZ
fromSqlField = PgType -> BinaryParser TimeTZ -> FieldDecoder TimeTZ
forall a. PgType -> BinaryParser a -> FieldDecoder a
FieldDecoder (Oid -> PgType
Oid Oid
OID.timetzOid) ((TimeOfDay -> TimeZone -> TimeTZ)
-> (TimeOfDay, TimeZone) -> TimeTZ
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TimeOfDay -> TimeZone -> TimeTZ
TimeTZ ((TimeOfDay, TimeZone) -> TimeTZ)
-> BinaryParser (TimeOfDay, TimeZone) -> BinaryParser TimeTZ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinaryParser (TimeOfDay, TimeZone)
PGB.timetz_int)
instance FromSql TimeTZ

instance FromSqlField UUID where
    fromSqlField :: FieldDecoder UUID
fromSqlField = PgType -> BinaryParser UUID -> FieldDecoder UUID
forall a. PgType -> BinaryParser a -> FieldDecoder a
FieldDecoder (Oid -> PgType
Oid Oid
OID.uuidOid) BinaryParser UUID
PGB.uuid
instance FromSql UUID

instance FromSqlField PQ.Oid where
    fromSqlField :: FieldDecoder Oid
fromSqlField = CUInt -> Oid
PQ.Oid (CUInt -> Oid) -> FieldDecoder CUInt -> FieldDecoder Oid
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PgType -> BinaryParser CUInt -> FieldDecoder CUInt
forall a. PgType -> BinaryParser a -> FieldDecoder a
FieldDecoder (Oid -> PgType
Oid Oid
OID.oidOid) BinaryParser CUInt
forall a. (Integral a, Bits a) => Value a
PGB.int
instance FromSql PQ.Oid

instance FromSqlField PgName where
    fromSqlField :: FieldDecoder PgName
fromSqlField = PgType -> BinaryParser PgName -> FieldDecoder PgName
forall a. PgType -> BinaryParser a -> FieldDecoder a
FieldDecoder (Oid -> PgType
Oid Oid
OID.nameOid) (Text -> PgName
PgName (Text -> PgName) -> BinaryParser Text -> BinaryParser PgName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinaryParser Text
PGB.text_strict)
instance FromSql PgName where fromSql :: RowDecoder (Width PgName) PgName
fromSql = FieldDecoder PgName -> RowDecoder 1 PgName
forall a. FieldDecoder a -> RowDecoder 1 a
notNull FieldDecoder PgName
forall a. FromSqlField a => FieldDecoder a
fromSqlField

-- | If you want to encode some more specific Haskell type via JSON,
-- it is more efficient to use 'fromSqlJsonField' rather than this
-- instance.
instance FromSqlField JSON.Value where
    fromSqlField :: FieldDecoder Value
fromSqlField = PgType -> BinaryParser Value -> FieldDecoder Value
forall a. PgType -> BinaryParser a -> FieldDecoder a
FieldDecoder (Oid -> PgType
Oid Oid
OID.jsonbOid) BinaryParser Value
PGB.jsonb_ast
instance FromSql JSON.Value

fromSqlJsonField :: JSON.FromJSON a => FieldDecoder a
fromSqlJsonField :: FieldDecoder a
fromSqlJsonField = PgType -> BinaryParser a -> FieldDecoder a
forall a. PgType -> BinaryParser a -> FieldDecoder a
FieldDecoder (Oid -> PgType
Oid Oid
OID.jsonbOid)
    ((ByteString -> Either Text a) -> BinaryParser a
forall a. (ByteString -> Either Text a) -> Value a
PGB.jsonb_bytes ((String -> Text) -> Either String a -> Either Text a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> Text
T.pack (Either String a -> Either Text a)
-> (ByteString -> Either String a) -> ByteString -> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
JSON.eitherDecode (ByteString -> Either String a)
-> (ByteString -> ByteString) -> ByteString -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.fromStrict))

-- Overlappable so applications can write Maybe for multi-field domain types
instance {-# OVERLAPPABLE #-} FromSqlField a => FromSql (Maybe a) where
    fromSql :: RowDecoder (Width (Maybe a)) (Maybe a)
fromSql = FieldDecoder a -> RowDecoder 1 (Maybe a)
forall a. FieldDecoder a -> RowDecoder 1 (Maybe a)
nullable FieldDecoder a
forall a. FromSqlField a => FieldDecoder a
fromSqlField

instance (FromSql a, FromSql b) => FromSql (a, b) where
    type Width (a, b) = Width a + Width b
    fromSql :: RowDecoder (Width (a, b)) (a, b)
fromSql = ((,) (a -> b -> (a, b))
-> RowDecoder (Width a) a -> RowDecoder (Width a) (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RowDecoder (Width a) a
forall a. FromSql a => RowDecoder (Width a) a
fromSql) RowDecoder (Width a) (b -> (a, b))
-> RowDecoder (Width b) b -> RowDecoder (Width a + Width b) (a, b)
forall (m :: Nat) a b (n :: Nat).
RowDecoder m (a -> b) -> RowDecoder n a -> RowDecoder (m + n) b
`applyDecoder` RowDecoder (Width b) b
forall a. FromSql a => RowDecoder (Width a) a
fromSql

instance (FromSql a, FromSql b, FromSql c) => FromSql (a, b, c) where
    type Width (a, b, c) = (Width a + Width b) + Width c
    fromSql :: RowDecoder (Width (a, b, c)) (a, b, c)
fromSql = ((,,) (a -> b -> c -> (a, b, c))
-> RowDecoder (Width a) a
-> RowDecoder (Width a) (b -> c -> (a, b, c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RowDecoder (Width a) a
forall a. FromSql a => RowDecoder (Width a) a
fromSql) RowDecoder (Width a) (b -> c -> (a, b, c))
-> RowDecoder (Width b) b
-> RowDecoder (Width a + Width b) (c -> (a, b, c))
forall (m :: Nat) a b (n :: Nat).
RowDecoder m (a -> b) -> RowDecoder n a -> RowDecoder (m + n) b
`applyDecoder` RowDecoder (Width b) b
forall a. FromSql a => RowDecoder (Width a) a
fromSql RowDecoder (Width a + Width b) (c -> (a, b, c))
-> RowDecoder (Width c) c
-> RowDecoder ((Width a + Width b) + Width c) (a, b, c)
forall (m :: Nat) a b (n :: Nat).
RowDecoder m (a -> b) -> RowDecoder n a -> RowDecoder (m + n) b
`applyDecoder` RowDecoder (Width c) c
forall a. FromSql a => RowDecoder (Width a) a
fromSql

-- The instances below all follow the pattern laid out by the tuple
-- instances above.  The ones above are written out without the macro
-- to illustrate the pattern.

$(deriveFromSqlTuple 4)
$(deriveFromSqlTuple 5)
$(deriveFromSqlTuple 6)
$(deriveFromSqlTuple 7)
$(deriveFromSqlTuple 8)
$(deriveFromSqlTuple 9)
$(deriveFromSqlTuple 10)
$(deriveFromSqlTuple 11)
$(deriveFromSqlTuple 12)
$(deriveFromSqlTuple 13)
$(deriveFromSqlTuple 14)
$(deriveFromSqlTuple 15)
$(deriveFromSqlTuple 16)
$(deriveFromSqlTuple 17)
$(deriveFromSqlTuple 18)
$(deriveFromSqlTuple 19)
$(deriveFromSqlTuple 20)
$(deriveFromSqlTuple 21)
$(deriveFromSqlTuple 22)
$(deriveFromSqlTuple 23)
$(deriveFromSqlTuple 24)
$(deriveFromSqlTuple 25)