{-# OPTIONS_GHC -fno-warn-orphans #-}

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}

module Database.Beam.Postgres.Types
  ( Postgres(..)
  , fromPgIntegral
  , fromPgScientificOrIntegral
  ) where

import           Database.Beam
import           Database.Beam.Backend
import           Database.Beam.Backend.Internal.Compat
import           Database.Beam.Migrate.Generics
import           Database.Beam.Migrate.SQL (BeamMigrateOnlySqlBackend)
import           Database.Beam.Postgres.Syntax
import           Database.Beam.Query.SQL92

import qualified Database.PostgreSQL.Simple.FromField as Pg
import qualified Database.PostgreSQL.Simple.HStore as Pg (HStoreMap, HStoreList)
import qualified Database.PostgreSQL.Simple.Types as Pg
import qualified Database.PostgreSQL.Simple.Range as Pg (PGRange)
import qualified Database.PostgreSQL.Simple.Time as Pg (Date, UTCTimestamp, ZonedTimestamp, LocalTimestamp)

import           Data.Aeson (Value)
import           Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as BL
import           Data.CaseInsensitive (CI)
import           Data.Int
import           Data.Proxy
import           Data.Ratio (Ratio)
import           Data.Scientific (Scientific, toBoundedInteger)
import           Data.Tagged
import           Data.Text (Text)
import qualified Data.Text.Lazy as TL
import           Data.Time (UTCTime, Day, TimeOfDay, LocalTime, NominalDiffTime, ZonedTime(..))
import           Data.UUID.Types (UUID)
import           Data.Vector (Vector)
import           Data.Word
import           GHC.TypeLits

-- | The Postgres backend type, used to parameterize 'MonadBeam'. See the
-- definitions there for more information. The corresponding query monad is
-- 'Pg'. See documentation for 'MonadBeam' and the
-- <https://haskell-beam.github/beam/ user guide> for more information on using
-- this backend.
data Postgres
  = Postgres

instance BeamBackend Postgres where
  type BackendFromField Postgres = Pg.FromField

instance HasSqlInTable Postgres where

instance Pg.FromField SqlNull where
  fromField :: FieldParser SqlNull
fromField Field
field Maybe ByteString
d = (Null -> SqlNull) -> Conversion Null -> Conversion SqlNull
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Null
Pg.Null -> SqlNull
SqlNull) (FieldParser Null
forall a. FromField a => FieldParser a
Pg.fromField Field
field Maybe ByteString
d)

-- | Deserialize integral fields, possibly downcasting from a larger numeric type
-- via 'Scientific' if we won't lose data, and then falling back to any integral
-- type via 'Integer'
fromPgScientificOrIntegral :: (Bounded a, Integral a) => FromBackendRowM Postgres a
fromPgScientificOrIntegral :: FromBackendRowM Postgres a
fromPgScientificOrIntegral = do
  Maybe a
sciVal <- (Maybe Scientific -> Maybe a)
-> FromBackendRowM Postgres (Maybe Scientific)
-> FromBackendRowM Postgres (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Scientific -> Maybe a
forall i. (Integral i, Bounded i) => Scientific -> Maybe i
toBoundedInteger (Scientific -> Maybe a) -> Maybe Scientific -> Maybe a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) FromBackendRowM Postgres (Maybe Scientific)
forall a be.
(Typeable a, BackendFromField be a) =>
FromBackendRowM be (Maybe a)
peekField
  case Maybe a
sciVal of
    Just a
sciVal' -> do
      a -> FromBackendRowM Postgres a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
sciVal'
    Maybe a
Nothing -> Integer -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> a)
-> FromBackendRowM Postgres Integer -> FromBackendRowM Postgres a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FromBackendRow Postgres Integer => FromBackendRowM Postgres Integer
forall be a. FromBackendRow be a => FromBackendRowM be a
fromBackendRow @Postgres @Integer

-- | Deserialize integral fields, possibly downcasting from a larger integral
-- type, but only if we won't lose data
fromPgIntegral :: forall a
                . (Pg.FromField a, Integral a, Typeable a)
               => FromBackendRowM Postgres a
fromPgIntegral :: FromBackendRowM Postgres a
fromPgIntegral = do
  Maybe a
val <- FromBackendRowM Postgres (Maybe a)
forall a be.
(Typeable a, BackendFromField be a) =>
FromBackendRowM be (Maybe a)
peekField
  case Maybe a
val of
    Just a
val' -> do
      a -> FromBackendRowM Postgres a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
val'
    Maybe a
Nothing -> do
      Integer
val' <- (BackendFromField Postgres Integer, Typeable Integer) =>
FromBackendRowM Postgres Integer
forall be a.
(BackendFromField be a, Typeable a) =>
FromBackendRowM be a
parseOneField @Postgres @Integer
      let val'' :: a
val'' = Integer -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
val'
      if a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
val'' Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
val'
        then a -> FromBackendRowM Postgres a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
val''
        else String -> FromBackendRowM Postgres a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"Data loss while downsizing Integral type. "
                          , String
"Make sure your Haskell types are wide enough for your data" ])

-- Default FromBackendRow instances for all postgresql-simple FromField instances
instance FromBackendRow Postgres SqlNull
instance FromBackendRow Postgres Bool
instance FromBackendRow Postgres Char
instance FromBackendRow Postgres Double
instance FromBackendRow Postgres Int16 where
  fromBackendRow :: FromBackendRowM Postgres Int16
fromBackendRow = FromBackendRowM Postgres Int16
forall a.
(FromField a, Integral a, Typeable a) =>
FromBackendRowM Postgres a
fromPgIntegral
instance FromBackendRow Postgres Int32 where
  fromBackendRow :: FromBackendRowM Postgres Int32
fromBackendRow = FromBackendRowM Postgres Int32
forall a.
(FromField a, Integral a, Typeable a) =>
FromBackendRowM Postgres a
fromPgIntegral
instance FromBackendRow Postgres Int64 where
  fromBackendRow :: FromBackendRowM Postgres Int64
fromBackendRow = FromBackendRowM Postgres Int64
forall a.
(FromField a, Integral a, Typeable a) =>
FromBackendRowM Postgres a
fromPgIntegral

instance TypeError (PreferExplicitSize Int Int32) => FromBackendRow Postgres Int where
  fromBackendRow :: FromBackendRowM Postgres Int
fromBackendRow = FromBackendRowM Postgres Int
forall a.
(FromField a, Integral a, Typeable a) =>
FromBackendRowM Postgres a
fromPgIntegral

-- Word values are serialized as SQL @NUMBER@ types to guarantee full domain coverage.
-- However, we want them te be serialized/deserialized as whichever type makes sense
instance FromBackendRow Postgres Word16 where
  fromBackendRow :: FromBackendRowM Postgres Word16
fromBackendRow = FromBackendRowM Postgres Word16
forall a. (Bounded a, Integral a) => FromBackendRowM Postgres a
fromPgScientificOrIntegral
instance FromBackendRow Postgres Word32 where
  fromBackendRow :: FromBackendRowM Postgres Word32
fromBackendRow = FromBackendRowM Postgres Word32
forall a. (Bounded a, Integral a) => FromBackendRowM Postgres a
fromPgScientificOrIntegral
instance FromBackendRow Postgres Word64 where
  fromBackendRow :: FromBackendRowM Postgres Word64
fromBackendRow = FromBackendRowM Postgres Word64
forall a. (Bounded a, Integral a) => FromBackendRowM Postgres a
fromPgScientificOrIntegral

instance TypeError (PreferExplicitSize Word Word32) => FromBackendRow Postgres Word where
  fromBackendRow :: FromBackendRowM Postgres Word
fromBackendRow = FromBackendRowM Postgres Word
forall a. (Bounded a, Integral a) => FromBackendRowM Postgres a
fromPgScientificOrIntegral

instance FromBackendRow Postgres Integer
instance FromBackendRow Postgres ByteString
instance FromBackendRow Postgres Scientific
instance FromBackendRow Postgres BL.ByteString
instance FromBackendRow Postgres Text
instance FromBackendRow Postgres UTCTime
instance FromBackendRow Postgres Value
instance FromBackendRow Postgres TL.Text
instance FromBackendRow Postgres Pg.Oid
instance FromBackendRow Postgres LocalTime where
  fromBackendRow :: FromBackendRowM Postgres LocalTime
fromBackendRow =
    FromBackendRowM Postgres (Maybe LocalTime)
forall a be.
(Typeable a, BackendFromField be a) =>
FromBackendRowM be (Maybe a)
peekField FromBackendRowM Postgres (Maybe LocalTime)
-> (Maybe LocalTime -> FromBackendRowM Postgres LocalTime)
-> FromBackendRowM Postgres LocalTime
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    \case
      Just (LocalTime
x :: LocalTime) -> LocalTime -> FromBackendRowM Postgres LocalTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure LocalTime
x

      -- Also accept 'TIMESTAMP WITH TIME ZONE'. Considered as
      -- 'LocalTime', because postgres always returns times in the
      -- server timezone, regardless of type.
      Maybe LocalTime
Nothing ->
        FromBackendRowM Postgres (Maybe ZonedTime)
forall a be.
(Typeable a, BackendFromField be a) =>
FromBackendRowM be (Maybe a)
peekField FromBackendRowM Postgres (Maybe ZonedTime)
-> (Maybe ZonedTime -> FromBackendRowM Postgres LocalTime)
-> FromBackendRowM Postgres LocalTime
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        \case
          Just (ZonedTime
x :: ZonedTime) -> LocalTime -> FromBackendRowM Postgres LocalTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ZonedTime -> LocalTime
zonedTimeToLocalTime ZonedTime
x)
          Maybe ZonedTime
Nothing -> String -> FromBackendRowM Postgres LocalTime
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"'TIMESTAMP WITH TIME ZONE' or 'TIMESTAMP WITHOUT TIME ZONE' required for LocalTime"
instance FromBackendRow Postgres TimeOfDay
instance FromBackendRow Postgres Day
instance FromBackendRow Postgres UUID
instance FromBackendRow Postgres Pg.Null
instance FromBackendRow Postgres Pg.Date
instance FromBackendRow Postgres Pg.ZonedTimestamp
instance FromBackendRow Postgres Pg.UTCTimestamp
instance FromBackendRow Postgres Pg.LocalTimestamp
instance FromBackendRow Postgres Pg.HStoreMap
instance FromBackendRow Postgres Pg.HStoreList
instance FromBackendRow Postgres [Char]
instance FromBackendRow Postgres (Ratio Integer)
instance FromBackendRow Postgres (CI Text)
instance FromBackendRow Postgres (CI TL.Text)
instance (Pg.FromField a, Typeable a) => FromBackendRow Postgres (Vector a) where
  fromBackendRow :: FromBackendRowM Postgres (Vector a)
fromBackendRow = do
      Maybe SqlNull
isNull <- FromBackendRowM Postgres (Maybe SqlNull)
forall a be.
(Typeable a, BackendFromField be a) =>
FromBackendRowM be (Maybe a)
peekField
      case Maybe SqlNull
isNull of
        Just SqlNull
SqlNull -> Vector a -> FromBackendRowM Postgres (Vector a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Vector a
forall a. Monoid a => a
mempty
        Maybe SqlNull
Nothing -> (BackendFromField Postgres (Vector a), Typeable (Vector a)) =>
FromBackendRowM Postgres (Vector a)
forall be a.
(BackendFromField be a, Typeable a) =>
FromBackendRowM be a
parseOneField @Postgres @(Vector a)
instance (Pg.FromField a, Typeable a) => FromBackendRow Postgres (Pg.PGArray a)
instance FromBackendRow Postgres (Pg.Binary ByteString)
instance FromBackendRow Postgres (Pg.Binary BL.ByteString)
instance (Pg.FromField a, Typeable a) => FromBackendRow Postgres (Pg.PGRange a)
instance (Pg.FromField a, Pg.FromField b, Typeable a, Typeable b) => FromBackendRow Postgres (Either a b)

instance BeamSqlBackend Postgres
instance BeamMigrateOnlySqlBackend Postgres
type instance BeamSqlBackendSyntax Postgres = PgCommandSyntax

instance BeamSqlBackendIsString Postgres String
instance BeamSqlBackendIsString Postgres Text

instance HasQBuilder Postgres where
  buildSqlQuery :: Text -> Q Postgres db s a -> BeamSqlBackendSelectSyntax Postgres
buildSqlQuery = Bool
-> Text -> Q Postgres db s a -> BeamSqlBackendSelectSyntax Postgres
forall be (db :: (* -> *) -> *) s a.
(BeamSqlBackend be, Projectible be a) =>
Bool -> Text -> Q be db s a -> BeamSqlBackendSelectSyntax be
buildSql92Query' Bool
True

-- * Instances for 'HasDefaultSqlDataType'

instance HasDefaultSqlDataType Postgres ByteString where
  defaultSqlDataType :: Proxy ByteString
-> Proxy Postgres -> Bool -> BeamSqlBackendDataTypeSyntax Postgres
defaultSqlDataType Proxy ByteString
_ Proxy Postgres
_ Bool
_ = BeamSqlBackendDataTypeSyntax Postgres
PgDataTypeSyntax
pgByteaType

instance HasDefaultSqlDataType Postgres LocalTime where
  defaultSqlDataType :: Proxy LocalTime
-> Proxy Postgres -> Bool -> BeamSqlBackendDataTypeSyntax Postgres
defaultSqlDataType Proxy LocalTime
_ Proxy Postgres
_ Bool
_ = Maybe Word -> Bool -> PgDataTypeSyntax
forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe Word -> Bool -> dataType
timestampType Maybe Word
forall a. Maybe a
Nothing Bool
False

instance HasDefaultSqlDataType Postgres UTCTime where
  defaultSqlDataType :: Proxy UTCTime
-> Proxy Postgres -> Bool -> BeamSqlBackendDataTypeSyntax Postgres
defaultSqlDataType Proxy UTCTime
_ Proxy Postgres
_ Bool
_ = Maybe Word -> Bool -> PgDataTypeSyntax
forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe Word -> Bool -> dataType
timestampType Maybe Word
forall a. Maybe a
Nothing Bool
True

instance HasDefaultSqlDataType Postgres (SqlSerial Int16) where
  defaultSqlDataType :: Proxy (SqlSerial Int16)
-> Proxy Postgres -> Bool -> BeamSqlBackendDataTypeSyntax Postgres
defaultSqlDataType Proxy (SqlSerial Int16)
_ Proxy Postgres
_ Bool
False = BeamSqlBackendDataTypeSyntax Postgres
PgDataTypeSyntax
pgSmallSerialType
  defaultSqlDataType Proxy (SqlSerial Int16)
_ Proxy Postgres
_ Bool
_ = BeamSqlBackendDataTypeSyntax Postgres
forall dataType. IsSql92DataTypeSyntax dataType => dataType
smallIntType

instance HasDefaultSqlDataType Postgres (SqlSerial Int32) where
  defaultSqlDataType :: Proxy (SqlSerial Int32)
-> Proxy Postgres -> Bool -> BeamSqlBackendDataTypeSyntax Postgres
defaultSqlDataType Proxy (SqlSerial Int32)
_ Proxy Postgres
_ Bool
False = BeamSqlBackendDataTypeSyntax Postgres
PgDataTypeSyntax
pgSerialType
  defaultSqlDataType Proxy (SqlSerial Int32)
_ Proxy Postgres
_ Bool
_ = BeamSqlBackendDataTypeSyntax Postgres
forall dataType. IsSql92DataTypeSyntax dataType => dataType
intType

instance HasDefaultSqlDataType Postgres (SqlSerial Int64) where
  defaultSqlDataType :: Proxy (SqlSerial Int64)
-> Proxy Postgres -> Bool -> BeamSqlBackendDataTypeSyntax Postgres
defaultSqlDataType Proxy (SqlSerial Int64)
_ Proxy Postgres
_ Bool
False = BeamSqlBackendDataTypeSyntax Postgres
PgDataTypeSyntax
pgBigSerialType
  defaultSqlDataType Proxy (SqlSerial Int64)
_ Proxy Postgres
_ Bool
_ = BeamSqlBackendDataTypeSyntax Postgres
forall dataType. IsSql2008BigIntDataTypeSyntax dataType => dataType
bigIntType

instance TypeError (PreferExplicitSize Int Int32) => HasDefaultSqlDataType Postgres (SqlSerial Int) where
  defaultSqlDataType :: Proxy (SqlSerial Int)
-> Proxy Postgres -> Bool -> BeamSqlBackendDataTypeSyntax Postgres
defaultSqlDataType Proxy (SqlSerial Int)
_ = Proxy (SqlSerial Int32)
-> Proxy Postgres -> Bool -> BeamSqlBackendDataTypeSyntax Postgres
forall be ty.
HasDefaultSqlDataType be ty =>
Proxy ty -> Proxy be -> Bool -> BeamSqlBackendDataTypeSyntax be
defaultSqlDataType (Proxy (SqlSerial Int32)
forall k (t :: k). Proxy t
Proxy @(SqlSerial Int32))

instance HasDefaultSqlDataType Postgres UUID where
  defaultSqlDataType :: Proxy UUID
-> Proxy Postgres -> Bool -> BeamSqlBackendDataTypeSyntax Postgres
defaultSqlDataType Proxy UUID
_ Proxy Postgres
_ Bool
_ = BeamSqlBackendDataTypeSyntax Postgres
PgDataTypeSyntax
pgUuidType

-- * Instances for 'HasSqlEqualityCheck'

#define PG_HAS_EQUALITY_CHECK(ty)                                 \
  instance HasSqlEqualityCheck Postgres (ty);           \
  instance HasSqlQuantifiedEqualityCheck Postgres (ty);

PG_HAS_EQUALITY_CHECK(Bool)
PG_HAS_EQUALITY_CHECK(Double)
PG_HAS_EQUALITY_CHECK(Float)
PG_HAS_EQUALITY_CHECK(Int8)
PG_HAS_EQUALITY_CHECK(Int16)
PG_HAS_EQUALITY_CHECK(Int32)
PG_HAS_EQUALITY_CHECK(Int64)
PG_HAS_EQUALITY_CHECK(Integer)
PG_HAS_EQUALITY_CHECK(Word8)
PG_HAS_EQUALITY_CHECK(Word16)
PG_HAS_EQUALITY_CHECK(Word32)
PG_HAS_EQUALITY_CHECK(Word64)
PG_HAS_EQUALITY_CHECK(Text)
PG_HAS_EQUALITY_CHECK(TL.Text)
PG_HAS_EQUALITY_CHECK(UTCTime)
PG_HAS_EQUALITY_CHECK(Value)
PG_HAS_EQUALITY_CHECK(Pg.Oid)
PG_HAS_EQUALITY_CHECK(LocalTime)
PG_HAS_EQUALITY_CHECK(ZonedTime)
PG_HAS_EQUALITY_CHECK(TimeOfDay)
PG_HAS_EQUALITY_CHECK(NominalDiffTime)
PG_HAS_EQUALITY_CHECK(Day)
PG_HAS_EQUALITY_CHECK(UUID)
PG_HAS_EQUALITY_CHECK([Char])
PG_HAS_EQUALITY_CHECK(Pg.HStoreMap)
PG_HAS_EQUALITY_CHECK(Pg.HStoreList)
PG_HAS_EQUALITY_CHECK(Pg.Date)
PG_HAS_EQUALITY_CHECK(Pg.ZonedTimestamp)
PG_HAS_EQUALITY_CHECK(Pg.LocalTimestamp)
PG_HAS_EQUALITY_CHECK(Pg.UTCTimestamp)
PG_HAS_EQUALITY_CHECK(Scientific)
PG_HAS_EQUALITY_CHECK(ByteString)
PG_HAS_EQUALITY_CHECK(BL.ByteString)
PG_HAS_EQUALITY_CHECK(Vector a)
PG_HAS_EQUALITY_CHECK(CI Text)
PG_HAS_EQUALITY_CHECK(CI TL.Text)

instance TypeError (PreferExplicitSize Int Int32) => HasSqlEqualityCheck Postgres Int
instance TypeError (PreferExplicitSize Int Int32) => HasSqlQuantifiedEqualityCheck Postgres Int
instance TypeError (PreferExplicitSize Word Word32) => HasSqlEqualityCheck Postgres Word
instance TypeError (PreferExplicitSize Word Word32) => HasSqlQuantifiedEqualityCheck Postgres Word

instance HasSqlEqualityCheck Postgres a =>
  HasSqlEqualityCheck Postgres (Tagged t a)
instance HasSqlQuantifiedEqualityCheck Postgres a =>
  HasSqlQuantifiedEqualityCheck Postgres (Tagged t a)