{-# LANGUAGE CPP, FlexibleInstances, ScopedTypeVariables, MultiParamTypeClasses, FlexibleContexts, DataKinds, KindSignatures, TypeFamilies, DeriveDataTypeable #-}
#if __GLASGOW_HASKELL__ < 710
{-# LANGUAGE OverlappingInstances #-}
#endif
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE UndecidableSuperClasses #-}
#endif
-- |
-- Module: Database.PostgreSQL.Typed.Types
-- Copyright: 2015 Dylan Simon
-- 
-- Classes to support type inference, value encoding/decoding, and instances to support built-in PostgreSQL types.

module Database.PostgreSQL.Typed.Types 
  (
  -- * Basic types
    OID
  , PGValue(..)
  , PGValues
  , PGTypeID(..)
  , PGTypeEnv(..), unknownPGTypeEnv
  , PGName(..), pgNameBS, pgNameString
  , PGRecord(..)

  -- * Marshalling classes
  , PGType(..)
  , PGParameter(..)
  , PGColumn(..)
  , PGStringType
  , PGRecordType

  -- * Marshalling interface
  , pgEncodeParameter
  , pgEscapeParameter
  , pgDecodeColumn
  , pgDecodeColumnNotNull

  -- * Conversion utilities
  , pgQuote
  , pgDQuote
  , pgDQuoteFrom
  , parsePGDQuote
  , buildPGValue
  ) where

import qualified Codec.Binary.UTF8.String as UTF8
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>), (<$), (<*), (*>))
#endif
import Control.Arrow ((&&&))
#ifdef VERSION_aeson
import qualified Data.Aeson as JSON
#endif
import qualified Data.Attoparsec.ByteString as P (anyWord8)
import qualified Data.Attoparsec.ByteString.Char8 as P
import Data.Bits (shiftL, (.|.))
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as BSB
import qualified Data.ByteString.Builder.Prim as BSBP
import qualified Data.ByteString.Char8 as BSC
import Data.ByteString.Internal (c2w, w2c)
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.UTF8 as BSU
import Data.Char (isSpace, isDigit, digitToInt, intToDigit, toLower)
import Data.Data (Data)
import Data.Int
import Data.List (intersperse)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (mempty, mconcat)
#endif
import Data.Ratio ((%), numerator, denominator)
#ifdef VERSION_scientific
import Data.Scientific (Scientific)
#endif
import Data.String (IsString(..))
#ifdef VERSION_text
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
#endif
import qualified Data.Time as Time
#if MIN_VERSION_time(1,5,0)
import Data.Time (defaultTimeLocale)
#else
import System.Locale (defaultTimeLocale)
#endif
import Data.Typeable (Typeable)
#ifdef VERSION_uuid
import qualified Data.UUID as UUID
#endif
import Data.Word (Word8, Word32)
import GHC.TypeLits (Symbol, symbolVal, KnownSymbol)
import Numeric (readFloat)
#ifdef VERSION_postgresql_binary
#if MIN_VERSION_postgresql_binary(0,12,0)
import qualified PostgreSQL.Binary.Decoding as BinD
import qualified PostgreSQL.Binary.Encoding as BinE
#else
import qualified PostgreSQL.Binary.Decoder as BinD
import qualified PostgreSQL.Binary.Encoder as BinE
#endif
#endif

type PGTextValue = BS.ByteString
type PGBinaryValue = BS.ByteString
-- |A value passed to or from PostgreSQL in raw format.
data PGValue
  = PGNullValue
  | PGTextValue { PGValue -> PGTextValue
pgTextValue :: PGTextValue } -- ^ The standard text encoding format (also used for unknown formats)
  | PGBinaryValue { PGValue -> PGTextValue
pgBinaryValue :: PGBinaryValue } -- ^ Special binary-encoded data.  Not supported in all cases.
  deriving (Int -> PGValue -> ShowS
[PGValue] -> ShowS
PGValue -> String
(Int -> PGValue -> ShowS)
-> (PGValue -> String) -> ([PGValue] -> ShowS) -> Show PGValue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PGValue] -> ShowS
$cshowList :: [PGValue] -> ShowS
show :: PGValue -> String
$cshow :: PGValue -> String
showsPrec :: Int -> PGValue -> ShowS
$cshowsPrec :: Int -> PGValue -> ShowS
Show, PGValue -> PGValue -> Bool
(PGValue -> PGValue -> Bool)
-> (PGValue -> PGValue -> Bool) -> Eq PGValue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PGValue -> PGValue -> Bool
$c/= :: PGValue -> PGValue -> Bool
== :: PGValue -> PGValue -> Bool
$c== :: PGValue -> PGValue -> Bool
Eq)
-- |A list of (nullable) data values, e.g. a single row or query parameters.
type PGValues = [PGValue]

-- |Parameters that affect how marshalling happens.
-- Currenly we force all other relevant parameters at connect time.
-- Nothing values represent unknown.
data PGTypeEnv = PGTypeEnv
  { PGTypeEnv -> Maybe Bool
pgIntegerDatetimes :: Maybe Bool -- ^ If @integer_datetimes@ is @on@; only relevant for binary encoding.
  , PGTypeEnv -> Maybe PGTextValue
pgServerVersion :: Maybe BS.ByteString -- ^ The @server_version@ parameter
  } deriving (Int -> PGTypeEnv -> ShowS
[PGTypeEnv] -> ShowS
PGTypeEnv -> String
(Int -> PGTypeEnv -> ShowS)
-> (PGTypeEnv -> String)
-> ([PGTypeEnv] -> ShowS)
-> Show PGTypeEnv
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PGTypeEnv] -> ShowS
$cshowList :: [PGTypeEnv] -> ShowS
show :: PGTypeEnv -> String
$cshow :: PGTypeEnv -> String
showsPrec :: Int -> PGTypeEnv -> ShowS
$cshowsPrec :: Int -> PGTypeEnv -> ShowS
Show)

unknownPGTypeEnv :: PGTypeEnv
unknownPGTypeEnv :: PGTypeEnv
unknownPGTypeEnv = PGTypeEnv :: Maybe Bool -> Maybe PGTextValue -> PGTypeEnv
PGTypeEnv
  { pgIntegerDatetimes :: Maybe Bool
pgIntegerDatetimes = Maybe Bool
forall a. Maybe a
Nothing
  , pgServerVersion :: Maybe PGTextValue
pgServerVersion = Maybe PGTextValue
forall a. Maybe a
Nothing
  }

-- |A PostgreSQL literal identifier, generally corresponding to the \"name\" type (63-byte strings), but as it would be entered in a query, so may include double-quoting for special characters or schema-qualification.
newtype PGName = PGName
  { PGName -> [Word8]
pgNameBytes :: [Word8] -- ^Raw bytes of the identifier (should really be a 'BS.ByteString', but we need a working 'Data' instance for annotations).
  }
  deriving (PGName -> PGName -> Bool
(PGName -> PGName -> Bool)
-> (PGName -> PGName -> Bool) -> Eq PGName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PGName -> PGName -> Bool
$c/= :: PGName -> PGName -> Bool
== :: PGName -> PGName -> Bool
$c== :: PGName -> PGName -> Bool
Eq, Eq PGName
Eq PGName
-> (PGName -> PGName -> Ordering)
-> (PGName -> PGName -> Bool)
-> (PGName -> PGName -> Bool)
-> (PGName -> PGName -> Bool)
-> (PGName -> PGName -> Bool)
-> (PGName -> PGName -> PGName)
-> (PGName -> PGName -> PGName)
-> Ord PGName
PGName -> PGName -> Bool
PGName -> PGName -> Ordering
PGName -> PGName -> PGName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PGName -> PGName -> PGName
$cmin :: PGName -> PGName -> PGName
max :: PGName -> PGName -> PGName
$cmax :: PGName -> PGName -> PGName
>= :: PGName -> PGName -> Bool
$c>= :: PGName -> PGName -> Bool
> :: PGName -> PGName -> Bool
$c> :: PGName -> PGName -> Bool
<= :: PGName -> PGName -> Bool
$c<= :: PGName -> PGName -> Bool
< :: PGName -> PGName -> Bool
$c< :: PGName -> PGName -> Bool
compare :: PGName -> PGName -> Ordering
$ccompare :: PGName -> PGName -> Ordering
$cp1Ord :: Eq PGName
Ord, Typeable, Typeable PGName
DataType
Constr
Typeable PGName
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> PGName -> c PGName)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c PGName)
-> (PGName -> Constr)
-> (PGName -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c PGName))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c PGName))
-> ((forall b. Data b => b -> b) -> PGName -> PGName)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> PGName -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> PGName -> r)
-> (forall u. (forall d. Data d => d -> u) -> PGName -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> PGName -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> PGName -> m PGName)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> PGName -> m PGName)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> PGName -> m PGName)
-> Data PGName
PGName -> DataType
PGName -> Constr
(forall b. Data b => b -> b) -> PGName -> PGName
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> PGName -> c PGName
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c PGName
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> PGName -> u
forall u. (forall d. Data d => d -> u) -> PGName -> [u]
forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> PGName -> r
forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> PGName -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> PGName -> m PGName
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> PGName -> m PGName
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c PGName
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> PGName -> c PGName
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c PGName)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c PGName)
$cPGName :: Constr
$tPGName :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> PGName -> m PGName
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> PGName -> m PGName
gmapMp :: (forall d. Data d => d -> m d) -> PGName -> m PGName
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> PGName -> m PGName
gmapM :: (forall d. Data d => d -> m d) -> PGName -> m PGName
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> PGName -> m PGName
gmapQi :: Int -> (forall d. Data d => d -> u) -> PGName -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> PGName -> u
gmapQ :: (forall d. Data d => d -> u) -> PGName -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> PGName -> [u]
gmapQr :: (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> PGName -> r
$cgmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> PGName -> r
gmapQl :: (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> PGName -> r
$cgmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> PGName -> r
gmapT :: (forall b. Data b => b -> b) -> PGName -> PGName
$cgmapT :: (forall b. Data b => b -> b) -> PGName -> PGName
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c PGName)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c PGName)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c PGName)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c PGName)
dataTypeOf :: PGName -> DataType
$cdataTypeOf :: PGName -> DataType
toConstr :: PGName -> Constr
$ctoConstr :: PGName -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c PGName
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c PGName
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> PGName -> c PGName
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> PGName -> c PGName
$cp1Data :: Typeable PGName
Data)

-- |The literal identifier as used in a query.
pgNameBS :: PGName -> BS.ByteString
pgNameBS :: PGName -> PGTextValue
pgNameBS = [Word8] -> PGTextValue
BS.pack ([Word8] -> PGTextValue)
-> (PGName -> [Word8]) -> PGName -> PGTextValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGName -> [Word8]
pgNameBytes

-- |Applies utf-8 encoding.
instance IsString PGName where
  fromString :: String -> PGName
fromString = [Word8] -> PGName
PGName ([Word8] -> PGName) -> (String -> [Word8]) -> String -> PGName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Word8]
UTF8.encode
-- |Unquoted 'pgNameString'.
instance Show PGName where
  show :: PGName -> String
show = PGName -> String
pgNameString

-- |Reverses the 'IsString' instantce.
pgNameString :: PGName -> String
pgNameString :: PGName -> String
pgNameString = [Word8] -> String
UTF8.decode ([Word8] -> String) -> (PGName -> [Word8]) -> PGName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGName -> [Word8]
pgNameBytes

-- |A proxy type for PostgreSQL types.  The type argument should be an (internal) name of a database type, as per @format_type(OID)@ (usually the same as @\\dT+@).
-- When the type's namespace (schema) is not in @search_path@, this will be explicitly qualified, so you should be sure to have a consistent @search_path@ for all database connections.
-- The underlying 'Symbol' should be considered a lifted 'PGName'.
data PGTypeID (t :: Symbol) = PGTypeProxy

-- |A valid PostgreSQL type, its metadata, and corresponding Haskell representation.
-- For conversion the other way (from Haskell type to PostgreSQL), see 'Database.PostgreSQL.Typed.Dynamic.PGRep'.
-- Unfortunately any instances of this will be orphans.
class (KnownSymbol t
#if __GLASGOW_HASKELL__ >= 800
    , PGParameter t (PGVal t), PGColumn t (PGVal t)
#endif
    ) => PGType t where
  -- |The default, native Haskell representation of this type, which should be as close as possible to the PostgreSQL representation.
  type PGVal t :: *
  -- |The string name of this type: specialized version of 'symbolVal'.
  pgTypeName :: PGTypeID t -> PGName
  pgTypeName = String -> PGName
forall a. IsString a => String -> a
fromString (String -> PGName)
-> (PGTypeID t -> String) -> PGTypeID t -> PGName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTypeID t -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal
  -- |Does this type support binary decoding?
  -- If so, 'pgDecodeBinary' must be implemented for every 'PGColumn' instance of this type.
  pgBinaryColumn :: PGTypeEnv -> PGTypeID t -> Bool
  pgBinaryColumn PGTypeEnv
_ PGTypeID t
_ = Bool
False

-- |A @PGParameter t a@ instance describes how to encode a PostgreSQL type @t@ from @a@.
class PGType t => PGParameter t a where
  -- |Encode a value to a PostgreSQL text representation.
  pgEncode :: PGTypeID t -> a -> PGTextValue
  -- |Encode a value to a (quoted) literal value for use in SQL statements.
  -- Defaults to a quoted version of 'pgEncode'
  pgLiteral :: PGTypeID t -> a -> BS.ByteString
  pgLiteral PGTypeID t
t = PGTextValue -> PGTextValue
pgQuote (PGTextValue -> PGTextValue)
-> (a -> PGTextValue) -> a -> PGTextValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTypeID t -> a -> PGTextValue
forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> PGTextValue
pgEncode PGTypeID t
t
  -- |Encode a value to a PostgreSQL representation.
  -- Defaults to the text representation by pgEncode
  pgEncodeValue :: PGTypeEnv -> PGTypeID t -> a -> PGValue
  pgEncodeValue PGTypeEnv
_ PGTypeID t
t = PGTextValue -> PGValue
PGTextValue (PGTextValue -> PGValue) -> (a -> PGTextValue) -> a -> PGValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTypeID t -> a -> PGTextValue
forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> PGTextValue
pgEncode PGTypeID t
t

-- |A @PGColumn t a@ instance describes how te decode a PostgreSQL type @t@ to @a@.
class PGType t => PGColumn t a where
  -- |Decode the PostgreSQL text representation into a value.
  pgDecode :: PGTypeID t -> PGTextValue -> a
  -- |Decode the PostgreSQL binary representation into a value.
  -- Only needs to be implemented if 'pgBinaryColumn' is true.
  pgDecodeBinary :: PGTypeEnv -> PGTypeID t -> PGBinaryValue -> a
  pgDecodeBinary PGTypeEnv
_ PGTypeID t
t PGTextValue
_ = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"pgDecodeBinary " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PGName -> String
forall a. Show a => a -> String
show (PGTypeID t -> PGName
forall (t :: Symbol). PGType t => PGTypeID t -> PGName
pgTypeName PGTypeID t
t) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": not supported"
  pgDecodeValue :: PGTypeEnv -> PGTypeID t -> PGValue -> a
  pgDecodeValue PGTypeEnv
_ PGTypeID t
t (PGTextValue PGTextValue
v) = PGTypeID t -> PGTextValue -> a
forall (t :: Symbol) a.
PGColumn t a =>
PGTypeID t -> PGTextValue -> a
pgDecode PGTypeID t
t PGTextValue
v
  pgDecodeValue PGTypeEnv
e PGTypeID t
t (PGBinaryValue PGTextValue
v) = PGTypeEnv -> PGTypeID t -> PGTextValue -> a
forall (t :: Symbol) a.
PGColumn t a =>
PGTypeEnv -> PGTypeID t -> PGTextValue -> a
pgDecodeBinary PGTypeEnv
e PGTypeID t
t PGTextValue
v
  pgDecodeValue PGTypeEnv
_ PGTypeID t
t PGValue
PGNullValue = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"NULL in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PGName -> String
forall a. Show a => a -> String
show (PGTypeID t -> PGName
forall (t :: Symbol). PGType t => PGTypeID t -> PGName
pgTypeName PGTypeID t
t) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" column (use Maybe or COALESCE)"

instance PGParameter t a => PGParameter t (Maybe a) where
  pgEncode :: PGTypeID t -> Maybe a -> PGTextValue
pgEncode PGTypeID t
t = PGTextValue -> (a -> PGTextValue) -> Maybe a -> PGTextValue
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> PGTextValue
forall a. HasCallStack => String -> a
error (String -> PGTextValue) -> String -> PGTextValue
forall a b. (a -> b) -> a -> b
$ String
"pgEncode " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PGName -> String
forall a. Show a => a -> String
show (PGTypeID t -> PGName
forall (t :: Symbol). PGType t => PGTypeID t -> PGName
pgTypeName PGTypeID t
t) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": Nothing") (PGTypeID t -> a -> PGTextValue
forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> PGTextValue
pgEncode PGTypeID t
t)
  pgLiteral :: PGTypeID t -> Maybe a -> PGTextValue
pgLiteral = PGTextValue -> (a -> PGTextValue) -> Maybe a -> PGTextValue
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> PGTextValue
BSC.pack String
"NULL") ((a -> PGTextValue) -> Maybe a -> PGTextValue)
-> (PGTypeID t -> a -> PGTextValue)
-> PGTypeID t
-> Maybe a
-> PGTextValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTypeID t -> a -> PGTextValue
forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> PGTextValue
pgLiteral
  pgEncodeValue :: PGTypeEnv -> PGTypeID t -> Maybe a -> PGValue
pgEncodeValue PGTypeEnv
e = PGValue -> (a -> PGValue) -> Maybe a -> PGValue
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PGValue
PGNullValue ((a -> PGValue) -> Maybe a -> PGValue)
-> (PGTypeID t -> a -> PGValue) -> PGTypeID t -> Maybe a -> PGValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTypeEnv -> PGTypeID t -> a -> PGValue
forall (t :: Symbol) a.
PGParameter t a =>
PGTypeEnv -> PGTypeID t -> a -> PGValue
pgEncodeValue PGTypeEnv
e

instance PGColumn t a => PGColumn t (Maybe a) where
  pgDecode :: PGTypeID t -> PGTextValue -> Maybe a
pgDecode PGTypeID t
t = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> (PGTextValue -> a) -> PGTextValue -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTypeID t -> PGTextValue -> a
forall (t :: Symbol) a.
PGColumn t a =>
PGTypeID t -> PGTextValue -> a
pgDecode PGTypeID t
t
  pgDecodeBinary :: PGTypeEnv -> PGTypeID t -> PGTextValue -> Maybe a
pgDecodeBinary PGTypeEnv
e PGTypeID t
t = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> (PGTextValue -> a) -> PGTextValue -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTypeEnv -> PGTypeID t -> PGTextValue -> a
forall (t :: Symbol) a.
PGColumn t a =>
PGTypeEnv -> PGTypeID t -> PGTextValue -> a
pgDecodeBinary PGTypeEnv
e PGTypeID t
t
  pgDecodeValue :: PGTypeEnv -> PGTypeID t -> PGValue -> Maybe a
pgDecodeValue PGTypeEnv
_ PGTypeID t
_ PGValue
PGNullValue = Maybe a
forall a. Maybe a
Nothing
  pgDecodeValue PGTypeEnv
e PGTypeID t
t PGValue
v = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ PGTypeEnv -> PGTypeID t -> PGValue -> a
forall (t :: Symbol) a.
PGColumn t a =>
PGTypeEnv -> PGTypeID t -> PGValue -> a
pgDecodeValue PGTypeEnv
e PGTypeID t
t PGValue
v

-- |Final parameter encoding function used when a (nullable) parameter is passed to a prepared query.
pgEncodeParameter :: PGParameter t a => PGTypeEnv -> PGTypeID t -> a -> PGValue
pgEncodeParameter :: PGTypeEnv -> PGTypeID t -> a -> PGValue
pgEncodeParameter = PGTypeEnv -> PGTypeID t -> a -> PGValue
forall (t :: Symbol) a.
PGParameter t a =>
PGTypeEnv -> PGTypeID t -> a -> PGValue
pgEncodeValue

-- |Final parameter escaping function used when a (nullable) parameter is passed to be substituted into a simple query.
pgEscapeParameter :: PGParameter t a => PGTypeEnv -> PGTypeID t -> a -> BS.ByteString
pgEscapeParameter :: PGTypeEnv -> PGTypeID t -> a -> PGTextValue
pgEscapeParameter PGTypeEnv
_ = PGTypeID t -> a -> PGTextValue
forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> PGTextValue
pgLiteral

-- |Final column decoding function used for a nullable result value.
pgDecodeColumn :: PGColumn t (Maybe a) => PGTypeEnv -> PGTypeID t -> PGValue -> Maybe a
pgDecodeColumn :: PGTypeEnv -> PGTypeID t -> PGValue -> Maybe a
pgDecodeColumn = PGTypeEnv -> PGTypeID t -> PGValue -> Maybe a
forall (t :: Symbol) a.
PGColumn t a =>
PGTypeEnv -> PGTypeID t -> PGValue -> a
pgDecodeValue

-- |Final column decoding function used for a non-nullable result value.
pgDecodeColumnNotNull :: PGColumn t a => PGTypeEnv -> PGTypeID t -> PGValue -> a
pgDecodeColumnNotNull :: PGTypeEnv -> PGTypeID t -> PGValue -> a
pgDecodeColumnNotNull = PGTypeEnv -> PGTypeID t -> PGValue -> a
forall (t :: Symbol) a.
PGColumn t a =>
PGTypeEnv -> PGTypeID t -> PGValue -> a
pgDecodeValue


pgQuoteUnsafe :: BS.ByteString -> BS.ByteString
pgQuoteUnsafe :: PGTextValue -> PGTextValue
pgQuoteUnsafe = (PGTextValue -> Char -> PGTextValue
`BSC.snoc` Char
'\'') (PGTextValue -> PGTextValue)
-> (PGTextValue -> PGTextValue) -> PGTextValue -> PGTextValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> PGTextValue -> PGTextValue
BSC.cons Char
'\''

-- |Produce a SQL string literal by wrapping (and escaping) a string with single quotes.
pgQuote :: BS.ByteString -> BS.ByteString
pgQuote :: PGTextValue -> PGTextValue
pgQuote PGTextValue
s
  | Char
'\0' Char -> PGTextValue -> Bool
`BSC.elem` PGTextValue
s = String -> PGTextValue
forall a. HasCallStack => String -> a
error String
"pgQuote: unhandled null in literal"
  | Bool
otherwise = PGTextValue -> PGTextValue
pgQuoteUnsafe (PGTextValue -> PGTextValue) -> PGTextValue -> PGTextValue
forall a b. (a -> b) -> a -> b
$ PGTextValue -> [PGTextValue] -> PGTextValue
BSC.intercalate (String -> PGTextValue
BSC.pack String
"''") ([PGTextValue] -> PGTextValue) -> [PGTextValue] -> PGTextValue
forall a b. (a -> b) -> a -> b
$ Char -> PGTextValue -> [PGTextValue]
BSC.split Char
'\'' PGTextValue
s

-- |Shorthand for @'BSL.toStrict' . 'BSB.toLazyByteString'@
buildPGValue :: BSB.Builder -> BS.ByteString
buildPGValue :: Builder -> PGTextValue
buildPGValue = ByteString -> PGTextValue
BSL.toStrict (ByteString -> PGTextValue)
-> (Builder -> ByteString) -> Builder -> PGTextValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
BSB.toLazyByteString

-- |Double-quote a value (e.g., as an identifier).
-- Does not properly handle unicode escaping (yet).
pgDQuote :: BS.ByteString -> BSB.Builder
pgDQuote :: PGTextValue -> Builder
pgDQuote PGTextValue
s = Builder
dq Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> BoundedPrim Word8 -> PGTextValue -> Builder
BSBP.primMapByteStringBounded BoundedPrim Word8
ec PGTextValue
s Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
dq where
  dq :: Builder
dq = Char -> Builder
BSB.char7 Char
'"'
  ec :: BoundedPrim Word8
ec = (Word8 -> Bool)
-> BoundedPrim Word8 -> BoundedPrim Word8 -> BoundedPrim Word8
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
BSBP.condB (\Word8
c -> Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'"' Bool -> Bool -> Bool
|| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'\\') BoundedPrim Word8
bs (FixedPrim Word8 -> BoundedPrim Word8
forall a. FixedPrim a -> BoundedPrim a
BSBP.liftFixedToBounded FixedPrim Word8
BSBP.word8)
  bs :: BoundedPrim Word8
bs = FixedPrim Word8 -> BoundedPrim Word8
forall a. FixedPrim a -> BoundedPrim a
BSBP.liftFixedToBounded (FixedPrim Word8 -> BoundedPrim Word8)
-> FixedPrim Word8 -> BoundedPrim Word8
forall a b. (a -> b) -> a -> b
$ ((,) Char
'\\') (Word8 -> (Char, Word8))
-> FixedPrim (Char, Word8) -> FixedPrim Word8
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
BSBP.>$< (FixedPrim Char
BSBP.char7 FixedPrim Char -> FixedPrim Word8 -> FixedPrim (Char, Word8)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
BSBP.>*< FixedPrim Word8
BSBP.word8)

-- |Double-quote a value if it's \"\", \"null\", or contains any whitespace, \'\"\', \'\\\', or the characters given in the first argument.
pgDQuoteFrom :: [Char] -> BS.ByteString -> BSB.Builder
pgDQuoteFrom :: String -> PGTextValue -> Builder
pgDQuoteFrom String
unsafe PGTextValue
s
  | PGTextValue -> Bool
BS.null PGTextValue
s Bool -> Bool -> Bool
|| (Char -> Bool) -> PGTextValue -> Bool
BSC.any (\Char
c -> Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\' Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
unsafe) PGTextValue
s Bool -> Bool -> Bool
|| (Char -> Char) -> PGTextValue -> PGTextValue
BSC.map Char -> Char
toLower PGTextValue
s PGTextValue -> PGTextValue -> Bool
forall a. Eq a => a -> a -> Bool
== String -> PGTextValue
BSC.pack String
"null" = PGTextValue -> Builder
pgDQuote PGTextValue
s
  | Bool
otherwise = PGTextValue -> Builder
BSB.byteString PGTextValue
s

-- |Parse double-quoted values ala 'pgDQuote'.
parsePGDQuote :: Bool -> [Char] -> (BS.ByteString -> Bool) -> P.Parser (Maybe BS.ByteString)
parsePGDQuote :: Bool
-> String -> (PGTextValue -> Bool) -> Parser (Maybe PGTextValue)
parsePGDQuote Bool
blank String
unsafe PGTextValue -> Bool
isnul = (PGTextValue -> Maybe PGTextValue
forall a. a -> Maybe a
Just (PGTextValue -> Maybe PGTextValue)
-> Parser PGTextValue PGTextValue -> Parser (Maybe PGTextValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PGTextValue PGTextValue
q) Parser (Maybe PGTextValue)
-> Parser (Maybe PGTextValue) -> Parser (Maybe PGTextValue)
forall a. Semigroup a => a -> a -> a
<> (PGTextValue -> Maybe PGTextValue
mnul (PGTextValue -> Maybe PGTextValue)
-> Parser PGTextValue PGTextValue -> Parser (Maybe PGTextValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PGTextValue PGTextValue
uq) where
  q :: Parser PGTextValue PGTextValue
q = Char -> Parser Char
P.char Char
'"' Parser Char
-> Parser PGTextValue PGTextValue -> Parser PGTextValue PGTextValue
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ([PGTextValue] -> PGTextValue
BS.concat ([PGTextValue] -> PGTextValue)
-> Parser PGTextValue [PGTextValue]
-> Parser PGTextValue PGTextValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PGTextValue [PGTextValue]
qs)
  qs :: Parser PGTextValue [PGTextValue]
qs = do
    PGTextValue
p <- (Char -> Bool) -> Parser PGTextValue PGTextValue
P.takeTill (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\')
    Char
e <- Parser Char
P.anyChar
    if Char
e Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"'
      then [PGTextValue] -> Parser PGTextValue [PGTextValue]
forall (m :: * -> *) a. Monad m => a -> m a
return [PGTextValue
p]
      else do
        Word8
c <- Parser Word8
P.anyWord8
        (PGTextValue
p PGTextValue -> [PGTextValue] -> [PGTextValue]
forall a. a -> [a] -> [a]
:) ([PGTextValue] -> [PGTextValue])
-> ([PGTextValue] -> [PGTextValue])
-> [PGTextValue]
-> [PGTextValue]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> PGTextValue
BS.singleton Word8
c PGTextValue -> [PGTextValue] -> [PGTextValue]
forall a. a -> [a] -> [a]
:) ([PGTextValue] -> [PGTextValue])
-> Parser PGTextValue [PGTextValue]
-> Parser PGTextValue [PGTextValue]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PGTextValue [PGTextValue]
qs
  uq :: Parser PGTextValue PGTextValue
uq = (if Bool
blank then (Char -> Bool) -> Parser PGTextValue PGTextValue
P.takeWhile else (Char -> Bool) -> Parser PGTextValue PGTextValue
P.takeWhile1) (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (Char
'"'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:String
unsafe))
  mnul :: PGTextValue -> Maybe PGTextValue
mnul PGTextValue
s
    | PGTextValue -> Bool
isnul PGTextValue
s = Maybe PGTextValue
forall a. Maybe a
Nothing
    | Bool
otherwise = PGTextValue -> Maybe PGTextValue
forall a. a -> Maybe a
Just PGTextValue
s

#ifdef VERSION_postgresql_binary
binEnc :: BinEncoder a -> a -> BS.ByteString
binEnc :: BinEncoder a -> a -> PGTextValue
binEnc = (Encoding -> PGTextValue) -> BinEncoder a -> a -> PGTextValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)
#if MIN_VERSION_postgresql_binary(0,12,0)
  Encoding -> PGTextValue
BinE.encodingBytes

type BinDecoder = BinD.Value
type BinEncoder a = a -> BinE.Encoding
#else
  buildPGValue

type BinDecoder = BinD.Decoder
type BinEncoder a = BinE.Encoder a
#endif

binDec :: PGType t => BinDecoder a -> PGTypeID t -> PGBinaryValue -> a
binDec :: BinDecoder a -> PGTypeID t -> PGTextValue -> a
binDec BinDecoder a
d PGTypeID t
t = (Text -> a) -> (a -> a) -> Either Text a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\Text
e -> String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"pgDecodeBinary " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PGName -> String
forall a. Show a => a -> String
show (PGTypeID t -> PGName
forall (t :: Symbol). PGType t => PGTypeID t -> PGName
pgTypeName PGTypeID t
t) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
e) a -> a
forall a. a -> a
id (Either Text a -> a)
-> (PGTextValue -> Either Text a) -> PGTextValue -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 
#if MIN_VERSION_postgresql_binary(0,12,0)
  BinDecoder a -> PGTextValue -> Either Text a
forall a. Value a -> PGTextValue -> Either Text a
BinD.valueParser
#else
  BinD.run
#endif
  BinDecoder a
d

#define BIN_COL pgBinaryColumn _ _ = True
#define BIN_ENC(F) pgEncodeValue _ _ = PGBinaryValue . binEnc (F)
#define BIN_DEC(F) pgDecodeBinary _ = binDec (F)
#else
#define BIN_COL
#define BIN_ENC(F)
#define BIN_DEC(F)
#endif

instance PGType "any" where
  type PGVal "any" = PGValue
instance PGType t => PGColumn t PGValue where
  pgDecode :: PGTypeID t -> PGTextValue -> PGValue
pgDecode PGTypeID t
_ = PGTextValue -> PGValue
PGTextValue
  pgDecodeBinary :: PGTypeEnv -> PGTypeID t -> PGTextValue -> PGValue
pgDecodeBinary PGTypeEnv
_ PGTypeID t
_ = PGTextValue -> PGValue
PGBinaryValue
  pgDecodeValue :: PGTypeEnv -> PGTypeID t -> PGValue -> PGValue
pgDecodeValue PGTypeEnv
_ PGTypeID t
_ = PGValue -> PGValue
forall a. a -> a
id
instance PGParameter "any" PGValue where
  pgEncode :: PGTypeID "any" -> PGValue -> PGTextValue
pgEncode PGTypeID "any"
_ (PGTextValue PGTextValue
v) = PGTextValue
v
  pgEncode PGTypeID "any"
_ PGValue
PGNullValue = String -> PGTextValue
forall a. HasCallStack => String -> a
error String
"pgEncode any: NULL"
  pgEncode PGTypeID "any"
_ (PGBinaryValue PGTextValue
_) = String -> PGTextValue
forall a. HasCallStack => String -> a
error String
"pgEncode any: binary"
  pgEncodeValue :: PGTypeEnv -> PGTypeID "any" -> PGValue -> PGValue
pgEncodeValue PGTypeEnv
_ PGTypeID "any"
_ = PGValue -> PGValue
forall a. a -> a
id

instance PGType "void" where
  type PGVal "void" = ()
instance PGParameter "void" () where
  pgEncode :: PGTypeID "void" -> () -> PGTextValue
pgEncode PGTypeID "void"
_ ()
_ = PGTextValue
BSC.empty
instance PGColumn "void" () where
  pgDecode :: PGTypeID "void" -> PGTextValue -> ()
pgDecode PGTypeID "void"
_ PGTextValue
_ = ()
  pgDecodeBinary :: PGTypeEnv -> PGTypeID "void" -> PGTextValue -> ()
pgDecodeBinary PGTypeEnv
_ PGTypeID "void"
_ PGTextValue
_ = ()
  pgDecodeValue :: PGTypeEnv -> PGTypeID "void" -> PGValue -> ()
pgDecodeValue PGTypeEnv
_ PGTypeID "void"
_ PGValue
_ = ()

instance PGType "boolean" where
  type PGVal "boolean" = Bool
  BIN_COL
instance PGParameter "boolean" Bool where
  pgEncode :: PGTypeID "boolean" -> Bool -> PGTextValue
pgEncode PGTypeID "boolean"
_ Bool
False = Char -> PGTextValue
BSC.singleton Char
'f'
  pgEncode PGTypeID "boolean"
_ Bool
True = Char -> PGTextValue
BSC.singleton Char
't'
  pgLiteral :: PGTypeID "boolean" -> Bool -> PGTextValue
pgLiteral PGTypeID "boolean"
_ Bool
False = String -> PGTextValue
BSC.pack String
"false"
  pgLiteral PGTypeID "boolean"
_ Bool
True = String -> PGTextValue
BSC.pack String
"true"
  BIN_ENC(BinE.bool)
instance PGColumn "boolean" Bool where
  pgDecode :: PGTypeID "boolean" -> PGTextValue -> Bool
pgDecode PGTypeID "boolean"
_ PGTextValue
s = case PGTextValue -> Char
BSC.head PGTextValue
s of
    Char
'f' -> Bool
False
    Char
't' -> Bool
True
    Char
c -> String -> Bool
forall a. HasCallStack => String -> a
error (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ String
"pgDecode boolean: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
c]
  BIN_DEC(BinD.bool)

type OID = Word32
instance PGType "oid" where
  type PGVal "oid" = OID
  BIN_COL
instance PGParameter "oid" OID where
  pgEncode :: PGTypeID "oid" -> OID -> PGTextValue
pgEncode PGTypeID "oid"
_ = String -> PGTextValue
BSC.pack (String -> PGTextValue) -> (OID -> String) -> OID -> PGTextValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OID -> String
forall a. Show a => a -> String
show
  pgLiteral :: PGTypeID "oid" -> OID -> PGTextValue
pgLiteral = PGTypeID "oid" -> OID -> PGTextValue
forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> PGTextValue
pgEncode
  BIN_ENC(BinE.int4_word32)
instance PGColumn "oid" OID where
  pgDecode :: PGTypeID "oid" -> PGTextValue -> OID
pgDecode PGTypeID "oid"
_ = String -> OID
forall a. Read a => String -> a
read (String -> OID) -> (PGTextValue -> String) -> PGTextValue -> OID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTextValue -> String
BSC.unpack
  BIN_DEC(BinD.int)

instance PGType "smallint" where
  type PGVal "smallint" = Int16
  BIN_COL
instance PGParameter "smallint" Int16 where
  pgEncode :: PGTypeID "smallint" -> Int16 -> PGTextValue
pgEncode PGTypeID "smallint"
_ = String -> PGTextValue
BSC.pack (String -> PGTextValue)
-> (Int16 -> String) -> Int16 -> PGTextValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int16 -> String
forall a. Show a => a -> String
show
  pgLiteral :: PGTypeID "smallint" -> Int16 -> PGTextValue
pgLiteral = PGTypeID "smallint" -> Int16 -> PGTextValue
forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> PGTextValue
pgEncode
  BIN_ENC(BinE.int2_int16)
instance PGColumn "smallint" Int16 where
  pgDecode :: PGTypeID "smallint" -> PGTextValue -> Int16
pgDecode PGTypeID "smallint"
_ = String -> Int16
forall a. Read a => String -> a
read (String -> Int16)
-> (PGTextValue -> String) -> PGTextValue -> Int16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTextValue -> String
BSC.unpack
  BIN_DEC(BinD.int)

instance PGType "integer" where 
  type PGVal "integer" = Int32
  BIN_COL
instance PGParameter "integer" Int32 where
  pgEncode :: PGTypeID "integer" -> Int32 -> PGTextValue
pgEncode PGTypeID "integer"
_ = String -> PGTextValue
BSC.pack (String -> PGTextValue)
-> (Int32 -> String) -> Int32 -> PGTextValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> String
forall a. Show a => a -> String
show
  pgLiteral :: PGTypeID "integer" -> Int32 -> PGTextValue
pgLiteral = PGTypeID "integer" -> Int32 -> PGTextValue
forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> PGTextValue
pgEncode
  BIN_ENC(BinE.int4_int32)
instance PGColumn "integer" Int32 where
  pgDecode :: PGTypeID "integer" -> PGTextValue -> Int32
pgDecode PGTypeID "integer"
_ = String -> Int32
forall a. Read a => String -> a
read (String -> Int32)
-> (PGTextValue -> String) -> PGTextValue -> Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTextValue -> String
BSC.unpack
  BIN_DEC(BinD.int)

instance PGType "bigint" where
  type PGVal "bigint" = Int64
  BIN_COL
instance PGParameter "bigint" Int64 where
  pgEncode :: PGTypeID "bigint" -> Int64 -> PGTextValue
pgEncode PGTypeID "bigint"
_ = String -> PGTextValue
BSC.pack (String -> PGTextValue)
-> (Int64 -> String) -> Int64 -> PGTextValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> String
forall a. Show a => a -> String
show
  pgLiteral :: PGTypeID "bigint" -> Int64 -> PGTextValue
pgLiteral = PGTypeID "bigint" -> Int64 -> PGTextValue
forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> PGTextValue
pgEncode
  BIN_ENC(BinE.int8_int64)
instance PGColumn "bigint" Int64 where
  pgDecode :: PGTypeID "bigint" -> PGTextValue -> Int64
pgDecode PGTypeID "bigint"
_ = String -> Int64
forall a. Read a => String -> a
read (String -> Int64)
-> (PGTextValue -> String) -> PGTextValue -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTextValue -> String
BSC.unpack
  BIN_DEC(BinD.int)

instance PGType "real" where
  type PGVal "real" = Float
  BIN_COL
instance PGParameter "real" Float where
  pgEncode :: PGTypeID "real" -> Float -> PGTextValue
pgEncode PGTypeID "real"
_ = String -> PGTextValue
BSC.pack (String -> PGTextValue)
-> (Float -> String) -> Float -> PGTextValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> String
forall a. Show a => a -> String
show
  pgLiteral :: PGTypeID "real" -> Float -> PGTextValue
pgLiteral = PGTypeID "real" -> Float -> PGTextValue
forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> PGTextValue
pgEncode
  BIN_ENC(BinE.float4)
instance PGColumn "real" Float where
  pgDecode :: PGTypeID "real" -> PGTextValue -> Float
pgDecode PGTypeID "real"
_ = String -> Float
forall a. Read a => String -> a
read (String -> Float)
-> (PGTextValue -> String) -> PGTextValue -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTextValue -> String
BSC.unpack
  BIN_DEC(BinD.float4)
instance PGColumn "real" Double where
  pgDecode :: PGTypeID "real" -> PGTextValue -> Double
pgDecode PGTypeID "real"
_ = String -> Double
forall a. Read a => String -> a
read (String -> Double)
-> (PGTextValue -> String) -> PGTextValue -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTextValue -> String
BSC.unpack
  BIN_DEC(realToFrac <$> BinD.float4)

instance PGType "double precision" where
  type PGVal "double precision" = Double
  BIN_COL
instance PGParameter "double precision" Double where
  pgEncode :: PGTypeID "double precision" -> Double -> PGTextValue
pgEncode PGTypeID "double precision"
_ = String -> PGTextValue
BSC.pack (String -> PGTextValue)
-> (Double -> String) -> Double -> PGTextValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> String
forall a. Show a => a -> String
show
  pgLiteral :: PGTypeID "double precision" -> Double -> PGTextValue
pgLiteral = PGTypeID "double precision" -> Double -> PGTextValue
forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> PGTextValue
pgEncode
  BIN_ENC(BinE.float8)
instance PGParameter "double precision" Float where
  pgEncode :: PGTypeID "double precision" -> Float -> PGTextValue
pgEncode PGTypeID "double precision"
_ = String -> PGTextValue
BSC.pack (String -> PGTextValue)
-> (Float -> String) -> Float -> PGTextValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> String
forall a. Show a => a -> String
show
  pgLiteral :: PGTypeID "double precision" -> Float -> PGTextValue
pgLiteral = PGTypeID "double precision" -> Float -> PGTextValue
forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> PGTextValue
pgEncode
  BIN_ENC(BinE.float8 . realToFrac)
instance PGColumn "double precision" Double where
  pgDecode :: PGTypeID "double precision" -> PGTextValue -> Double
pgDecode PGTypeID "double precision"
_ = String -> Double
forall a. Read a => String -> a
read (String -> Double)
-> (PGTextValue -> String) -> PGTextValue -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTextValue -> String
BSC.unpack
  BIN_DEC(BinD.float8)

-- XXX need real encoding as text
-- but then no one should be using this type really...
instance PGType "\"char\"" where
  type PGVal "\"char\"" = Word8
  BIN_COL
instance PGParameter "\"char\"" Word8 where
  pgEncode :: PGTypeID "\"char\"" -> Word8 -> PGTextValue
pgEncode PGTypeID "\"char\""
_ = Word8 -> PGTextValue
BS.singleton
  pgEncodeValue :: PGTypeEnv -> PGTypeID "\"char\"" -> Word8 -> PGValue
pgEncodeValue PGTypeEnv
_ PGTypeID "\"char\""
_ = PGTextValue -> PGValue
PGBinaryValue (PGTextValue -> PGValue)
-> (Word8 -> PGTextValue) -> Word8 -> PGValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> PGTextValue
BS.singleton
instance PGColumn "\"char\"" Word8 where
  pgDecode :: PGTypeID "\"char\"" -> PGTextValue -> Word8
pgDecode PGTypeID "\"char\""
_ = PGTextValue -> Word8
BS.head
  pgDecodeBinary :: PGTypeEnv -> PGTypeID "\"char\"" -> PGTextValue -> Word8
pgDecodeBinary PGTypeEnv
_ PGTypeID "\"char\""
_ = PGTextValue -> Word8
BS.head
instance PGParameter "\"char\"" Char where
  pgEncode :: PGTypeID "\"char\"" -> Char -> PGTextValue
pgEncode PGTypeID "\"char\""
_ = Char -> PGTextValue
BSC.singleton
  pgEncodeValue :: PGTypeEnv -> PGTypeID "\"char\"" -> Char -> PGValue
pgEncodeValue PGTypeEnv
_ PGTypeID "\"char\""
_ = PGTextValue -> PGValue
PGBinaryValue (PGTextValue -> PGValue)
-> (Char -> PGTextValue) -> Char -> PGValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> PGTextValue
BSC.singleton
instance PGColumn "\"char\"" Char where
  pgDecode :: PGTypeID "\"char\"" -> PGTextValue -> Char
pgDecode PGTypeID "\"char\""
_ = PGTextValue -> Char
BSC.head
  pgDecodeBinary :: PGTypeEnv -> PGTypeID "\"char\"" -> PGTextValue -> Char
pgDecodeBinary PGTypeEnv
_ PGTypeID "\"char\""
_ = PGTextValue -> Char
BSC.head


class PGType t => PGStringType t

instance PGStringType t => PGParameter t String where
  pgEncode :: PGTypeID t -> String -> PGTextValue
pgEncode PGTypeID t
_ = String -> PGTextValue
BSU.fromString
  BIN_ENC(BinE.text_strict . T.pack)
instance PGStringType t => PGColumn t String where
  pgDecode :: PGTypeID t -> PGTextValue -> String
pgDecode PGTypeID t
_ = PGTextValue -> String
BSU.toString
  BIN_DEC(T.unpack <$> BinD.text_strict)

instance
#if __GLASGOW_HASKELL__ >= 710
    {-# OVERLAPPABLE #-}
#endif
    PGStringType t => PGParameter t BS.ByteString where
  pgEncode :: PGTypeID t -> PGTextValue -> PGTextValue
pgEncode PGTypeID t
_ = PGTextValue -> PGTextValue
forall a. a -> a
id
  BIN_ENC(BinE.text_strict . TE.decodeUtf8)
instance
#if __GLASGOW_HASKELL__ >= 710
    {-# OVERLAPPABLE #-}
#endif
    PGStringType t => PGColumn t BS.ByteString where
  pgDecode :: PGTypeID t -> PGTextValue -> PGTextValue
pgDecode PGTypeID t
_ = PGTextValue -> PGTextValue
forall a. a -> a
id
  BIN_DEC(TE.encodeUtf8 <$> BinD.text_strict)

instance
#if __GLASGOW_HASKELL__ >= 710
    {-# OVERLAPPABLE #-}
#endif
    PGStringType t => PGParameter t PGName where
  pgEncode :: PGTypeID t -> PGName -> PGTextValue
pgEncode PGTypeID t
_ = PGName -> PGTextValue
pgNameBS
  BIN_ENC(BinE.text_strict . TE.decodeUtf8 . pgNameBS)
instance
#if __GLASGOW_HASKELL__ >= 710
    {-# OVERLAPPABLE #-}
#endif
    PGStringType t => PGColumn t PGName where
  pgDecode :: PGTypeID t -> PGTextValue -> PGName
pgDecode PGTypeID t
_ = [Word8] -> PGName
PGName ([Word8] -> PGName)
-> (PGTextValue -> [Word8]) -> PGTextValue -> PGName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTextValue -> [Word8]
BS.unpack
  BIN_DEC(PGName PGTypeEnv
. BS.unpack . TE.encodeUtf8 <$> BinD.text_strict)

instance
#if __GLASGOW_HASKELL__ >= 710
    {-# OVERLAPPABLE #-}
#endif
    PGStringType t => PGParameter t BSL.ByteString where
  pgEncode :: PGTypeID t -> ByteString -> PGTextValue
pgEncode PGTypeID t
_ = ByteString -> PGTextValue
BSL.toStrict
  BIN_ENC(BinE.text_lazy . TLE.decodeUtf8)
instance
#if __GLASGOW_HASKELL__ >= 710
    {-# OVERLAPPABLE #-}
#endif
    PGStringType t => PGColumn t BSL.ByteString where
  pgDecode :: PGTypeID t -> PGTextValue -> ByteString
pgDecode PGTypeID t
_ = PGTextValue -> ByteString
BSL.fromStrict
  BIN_DEC(TLE.encodeUtf8 <$> BinD.text_lazy)

#ifdef VERSION_text
instance PGStringType t => PGParameter t T.Text where
  pgEncode :: PGTypeID t -> Text -> PGTextValue
pgEncode PGTypeID t
_ = Text -> PGTextValue
TE.encodeUtf8
  BIN_ENC(BinE.text_strict)
instance PGStringType t => PGColumn t T.Text where
  pgDecode :: PGTypeID t -> PGTextValue -> Text
pgDecode PGTypeID t
_ = PGTextValue -> Text
TE.decodeUtf8
  BIN_DEC(BinD.text_strict)

instance PGStringType t => PGParameter t TL.Text where
  pgEncode :: PGTypeID t -> Text -> PGTextValue
pgEncode PGTypeID t
_ = ByteString -> PGTextValue
BSL.toStrict (ByteString -> PGTextValue)
-> (Text -> ByteString) -> Text -> PGTextValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TLE.encodeUtf8
  BIN_ENC(BinE.text_lazy)
instance PGStringType t => PGColumn t TL.Text where
  pgDecode :: PGTypeID t -> PGTextValue -> Text
pgDecode PGTypeID t
_ = Text -> Text
TL.fromStrict (Text -> Text) -> (PGTextValue -> Text) -> PGTextValue -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTextValue -> Text
TE.decodeUtf8
  BIN_DEC(BinD.text_lazy)
#define PGVALSTRING T.Text
#else
#define PGVALSTRING String
#endif

instance PGType "text" where
  type PGVal "text" = PGVALSTRING
  BIN_COL
instance PGType "character varying" where
  type PGVal "character varying" = PGVALSTRING
  BIN_COL
instance PGType "name" where
  type PGVal "name" = PGVALSTRING
  BIN_COL
instance PGType "bpchar" where
  type PGVal "bpchar" = PGVALSTRING
  BIN_COL
instance PGStringType "text"
instance PGStringType "character varying"
instance PGStringType "name" -- limit 63 characters; not strictly textsend but essentially the same
instance PGStringType "bpchar" -- blank padded


encodeBytea :: BSB.Builder -> PGTextValue
encodeBytea :: Builder -> PGTextValue
encodeBytea Builder
h = Builder -> PGTextValue
buildPGValue (Builder -> PGTextValue) -> Builder -> PGTextValue
forall a b. (a -> b) -> a -> b
$ String -> Builder
BSB.string7 String
"\\x" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
h

decodeBytea :: PGTextValue -> [Word8]
decodeBytea :: PGTextValue -> [Word8]
decodeBytea PGTextValue
s
  | String
sm String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"\\x" = String -> [Word8]
forall a. HasCallStack => String -> a
error (String -> [Word8]) -> String -> [Word8]
forall a b. (a -> b) -> a -> b
$ String
"pgDecode bytea: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
sm
  | Bool
otherwise = [Word8] -> [Word8]
pd ([Word8] -> [Word8]) -> [Word8] -> [Word8]
forall a b. (a -> b) -> a -> b
$ PGTextValue -> [Word8]
BS.unpack PGTextValue
d where
  (PGTextValue
m, PGTextValue
d) = Int -> PGTextValue -> (PGTextValue, PGTextValue)
BS.splitAt Int
2 PGTextValue
s
  sm :: String
sm = PGTextValue -> String
BSC.unpack PGTextValue
m
  pd :: [Word8] -> [Word8]
pd [] = []
  pd (Word8
h:Word8
l:[Word8]
r) = (Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
shiftL (Word8 -> Word8
unhex Word8
h) Int
4 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8 -> Word8
unhex Word8
l) Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Word8] -> [Word8]
pd [Word8]
r
  pd [Word8
x] = String -> [Word8]
forall a. HasCallStack => String -> a
error (String -> [Word8]) -> String -> [Word8]
forall a b. (a -> b) -> a -> b
$ String
"pgDecode bytea: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
x
  unhex :: Word8 -> Word8
unhex = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Word8 -> Int) -> Word8 -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
digitToInt (Char -> Int) -> (Word8 -> Char) -> Word8 -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Char
w2c

instance PGType "bytea" where
  type PGVal "bytea" = BS.ByteString
  BIN_COL
instance
#if __GLASGOW_HASKELL__ >= 710
    {-# OVERLAPPING #-}
#endif
    PGParameter "bytea" BSL.ByteString where
  pgEncode :: PGTypeID "bytea" -> ByteString -> PGTextValue
pgEncode PGTypeID "bytea"
_ = Builder -> PGTextValue
encodeBytea (Builder -> PGTextValue)
-> (ByteString -> Builder) -> ByteString -> PGTextValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
BSB.lazyByteStringHex
  pgLiteral :: PGTypeID "bytea" -> ByteString -> PGTextValue
pgLiteral PGTypeID "bytea"
t = PGTextValue -> PGTextValue
pgQuoteUnsafe (PGTextValue -> PGTextValue)
-> (ByteString -> PGTextValue) -> ByteString -> PGTextValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTypeID "bytea" -> ByteString -> PGTextValue
forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> PGTextValue
pgEncode PGTypeID "bytea"
t
  BIN_ENC(BinE.bytea_lazy)
instance
#if __GLASGOW_HASKELL__ >= 710
    {-# OVERLAPPING #-}
#endif
    PGColumn "bytea" BSL.ByteString where
  pgDecode :: PGTypeID "bytea" -> PGTextValue -> ByteString
pgDecode PGTypeID "bytea"
_ = [Word8] -> ByteString
BSL.pack ([Word8] -> ByteString)
-> (PGTextValue -> [Word8]) -> PGTextValue -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTextValue -> [Word8]
decodeBytea
  BIN_DEC(BinD.bytea_lazy)
instance
#if __GLASGOW_HASKELL__ >= 710
    {-# OVERLAPPING #-}
#endif
    PGParameter "bytea" BS.ByteString where
  pgEncode :: PGTypeID "bytea" -> PGTextValue -> PGTextValue
pgEncode PGTypeID "bytea"
_ = Builder -> PGTextValue
encodeBytea (Builder -> PGTextValue)
-> (PGTextValue -> Builder) -> PGTextValue -> PGTextValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTextValue -> Builder
BSB.byteStringHex
  pgLiteral :: PGTypeID "bytea" -> PGTextValue -> PGTextValue
pgLiteral PGTypeID "bytea"
t = PGTextValue -> PGTextValue
pgQuoteUnsafe (PGTextValue -> PGTextValue)
-> (PGTextValue -> PGTextValue) -> PGTextValue -> PGTextValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTypeID "bytea" -> PGTextValue -> PGTextValue
forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> PGTextValue
pgEncode PGTypeID "bytea"
t
  BIN_ENC(BinE.bytea_strict)
instance
#if __GLASGOW_HASKELL__ >= 710
    {-# OVERLAPPING #-}
#endif
    PGColumn "bytea" BS.ByteString where
  pgDecode :: PGTypeID "bytea" -> PGTextValue -> PGTextValue
pgDecode PGTypeID "bytea"
_ = [Word8] -> PGTextValue
BS.pack ([Word8] -> PGTextValue)
-> (PGTextValue -> [Word8]) -> PGTextValue -> PGTextValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTextValue -> [Word8]
decodeBytea
  BIN_DEC(BinD.bytea_strict)

readTime :: Time.ParseTime t => String -> String -> t
readTime :: String -> String -> t
readTime =
#if MIN_VERSION_time(1,5,0)
  Bool -> TimeLocale -> String -> String -> t
forall t.
ParseTime t =>
Bool -> TimeLocale -> String -> String -> t
Time.parseTimeOrError Bool
False
#else
  Time.readTime
#endif
    TimeLocale
defaultTimeLocale

instance PGType "date" where
  type PGVal "date" = Time.Day
  BIN_COL
instance PGParameter "date" Time.Day where
  pgEncode :: PGTypeID "date" -> Day -> PGTextValue
pgEncode PGTypeID "date"
_ = String -> PGTextValue
BSC.pack (String -> PGTextValue) -> (Day -> String) -> Day -> PGTextValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> String
Time.showGregorian
  pgLiteral :: PGTypeID "date" -> Day -> PGTextValue
pgLiteral PGTypeID "date"
t = PGTextValue -> PGTextValue
pgQuoteUnsafe (PGTextValue -> PGTextValue)
-> (Day -> PGTextValue) -> Day -> PGTextValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTypeID "date" -> Day -> PGTextValue
forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> PGTextValue
pgEncode PGTypeID "date"
t
  BIN_ENC(BinE.date)
instance PGColumn "date" Time.Day where
  pgDecode :: PGTypeID "date" -> PGTextValue -> Day
pgDecode PGTypeID "date"
_ = String -> String -> Day
forall t. ParseTime t => String -> String -> t
readTime String
"%F" (String -> Day) -> (PGTextValue -> String) -> PGTextValue -> Day
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTextValue -> String
BSC.unpack
  BIN_DEC(BinD.date)

binColDatetime :: PGTypeEnv -> PGTypeID t -> Bool
#ifdef VERSION_postgresql_binary
binColDatetime :: PGTypeEnv -> PGTypeID t -> Bool
binColDatetime PGTypeEnv{ pgIntegerDatetimes :: PGTypeEnv -> Maybe Bool
pgIntegerDatetimes = Just Bool
_ } PGTypeID t
_ = Bool
True
#endif
binColDatetime PGTypeEnv
_ PGTypeID t
_ = Bool
False

#ifdef VERSION_postgresql_binary
binEncDatetime :: PGParameter t a => BinEncoder a -> BinEncoder a -> PGTypeEnv -> PGTypeID t -> a -> PGValue
binEncDatetime :: BinEncoder a
-> BinEncoder a -> PGTypeEnv -> PGTypeID t -> a -> PGValue
binEncDatetime BinEncoder a
_ BinEncoder a
ff PGTypeEnv{ pgIntegerDatetimes :: PGTypeEnv -> Maybe Bool
pgIntegerDatetimes = Just Bool
False } PGTypeID t
_ = PGTextValue -> PGValue
PGBinaryValue (PGTextValue -> PGValue) -> (a -> PGTextValue) -> a -> PGValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BinEncoder a -> a -> PGTextValue
forall a. BinEncoder a -> a -> PGTextValue
binEnc BinEncoder a
ff
binEncDatetime BinEncoder a
fi BinEncoder a
_ PGTypeEnv{ pgIntegerDatetimes :: PGTypeEnv -> Maybe Bool
pgIntegerDatetimes = Just Bool
True } PGTypeID t
_ = PGTextValue -> PGValue
PGBinaryValue (PGTextValue -> PGValue) -> (a -> PGTextValue) -> a -> PGValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BinEncoder a -> a -> PGTextValue
forall a. BinEncoder a -> a -> PGTextValue
binEnc BinEncoder a
fi
binEncDatetime BinEncoder a
_ BinEncoder a
_ PGTypeEnv{ pgIntegerDatetimes :: PGTypeEnv -> Maybe Bool
pgIntegerDatetimes = Maybe Bool
Nothing } PGTypeID t
t = PGTextValue -> PGValue
PGTextValue (PGTextValue -> PGValue) -> (a -> PGTextValue) -> a -> PGValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTypeID t -> a -> PGTextValue
forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> PGTextValue
pgEncode PGTypeID t
t

binDecDatetime :: PGColumn t a => BinDecoder a -> BinDecoder a -> PGTypeEnv -> PGTypeID t -> PGBinaryValue -> a
binDecDatetime :: BinDecoder a
-> BinDecoder a -> PGTypeEnv -> PGTypeID t -> PGTextValue -> a
binDecDatetime BinDecoder a
_ BinDecoder a
ff PGTypeEnv{ pgIntegerDatetimes :: PGTypeEnv -> Maybe Bool
pgIntegerDatetimes = Just Bool
False } = BinDecoder a -> PGTypeID t -> PGTextValue -> a
forall (t :: Symbol) a.
PGType t =>
BinDecoder a -> PGTypeID t -> PGTextValue -> a
binDec BinDecoder a
ff
binDecDatetime BinDecoder a
fi BinDecoder a
_ PGTypeEnv{ pgIntegerDatetimes :: PGTypeEnv -> Maybe Bool
pgIntegerDatetimes = Just Bool
True } = BinDecoder a -> PGTypeID t -> PGTextValue -> a
forall (t :: Symbol) a.
PGType t =>
BinDecoder a -> PGTypeID t -> PGTextValue -> a
binDec BinDecoder a
fi
binDecDatetime BinDecoder a
_ BinDecoder a
_ PGTypeEnv{ pgIntegerDatetimes :: PGTypeEnv -> Maybe Bool
pgIntegerDatetimes = Maybe Bool
Nothing } = String -> PGTypeID t -> PGTextValue -> a
forall a. HasCallStack => String -> a
error String
"pgDecodeBinary: unknown integer_datetimes value"
#endif

-- PostgreSQL uses "[+-]HH[:MM]" timezone offsets, while "%z" uses "+HHMM" by default.
-- readTime can successfully parse both formats, but PostgreSQL needs the colon.
fixTZ :: String -> String
fixTZ :: ShowS
fixTZ String
"" = String
""
fixTZ [Char
'+',Char
h1,Char
h2] | Char -> Bool
isDigit Char
h1 Bool -> Bool -> Bool
&& Char -> Bool
isDigit Char
h2 = [Char
'+',Char
h1,Char
h2,Char
':',Char
'0',Char
'0']
fixTZ [Char
'-',Char
h1,Char
h2] | Char -> Bool
isDigit Char
h1 Bool -> Bool -> Bool
&& Char -> Bool
isDigit Char
h2 = [Char
'-',Char
h1,Char
h2,Char
':',Char
'0',Char
'0']
fixTZ [Char
'+',Char
h1,Char
h2,Char
m1,Char
m2] | Char -> Bool
isDigit Char
h1 Bool -> Bool -> Bool
&& Char -> Bool
isDigit Char
h2 Bool -> Bool -> Bool
&& Char -> Bool
isDigit Char
m1 Bool -> Bool -> Bool
&& Char -> Bool
isDigit Char
m2 = [Char
'+',Char
h1,Char
h2,Char
':',Char
m1,Char
m2]
fixTZ [Char
'-',Char
h1,Char
h2,Char
m1,Char
m2] | Char -> Bool
isDigit Char
h1 Bool -> Bool -> Bool
&& Char -> Bool
isDigit Char
h2 Bool -> Bool -> Bool
&& Char -> Bool
isDigit Char
m1 Bool -> Bool -> Bool
&& Char -> Bool
isDigit Char
m2 = [Char
'-',Char
h1,Char
h2,Char
':',Char
m1,Char
m2]
fixTZ (Char
c:String
s) = Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:ShowS
fixTZ String
s

instance PGType "time without time zone" where
  type PGVal "time without time zone" = Time.TimeOfDay
  pgBinaryColumn :: PGTypeEnv -> PGTypeID "time without time zone" -> Bool
pgBinaryColumn = PGTypeEnv -> PGTypeID "time without time zone" -> Bool
forall (t :: Symbol). PGTypeEnv -> PGTypeID t -> Bool
binColDatetime
instance PGParameter "time without time zone" Time.TimeOfDay where
  pgEncode :: PGTypeID "time without time zone" -> TimeOfDay -> PGTextValue
pgEncode PGTypeID "time without time zone"
_ = String -> PGTextValue
BSC.pack (String -> PGTextValue)
-> (TimeOfDay -> String) -> TimeOfDay -> PGTextValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeLocale -> String -> TimeOfDay -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
Time.formatTime TimeLocale
defaultTimeLocale String
"%T%Q"
  pgLiteral :: PGTypeID "time without time zone" -> TimeOfDay -> PGTextValue
pgLiteral PGTypeID "time without time zone"
t = PGTextValue -> PGTextValue
pgQuoteUnsafe (PGTextValue -> PGTextValue)
-> (TimeOfDay -> PGTextValue) -> TimeOfDay -> PGTextValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTypeID "time without time zone" -> TimeOfDay -> PGTextValue
forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> PGTextValue
pgEncode PGTypeID "time without time zone"
t
#ifdef VERSION_postgresql_binary
  pgEncodeValue :: PGTypeEnv
-> PGTypeID "time without time zone" -> TimeOfDay -> PGValue
pgEncodeValue = BinEncoder TimeOfDay
-> BinEncoder TimeOfDay
-> PGTypeEnv
-> PGTypeID "time without time zone"
-> TimeOfDay
-> PGValue
forall (t :: Symbol) a.
PGParameter t a =>
BinEncoder a
-> BinEncoder a -> PGTypeEnv -> PGTypeID t -> a -> PGValue
binEncDatetime BinEncoder TimeOfDay
BinE.time_int BinEncoder TimeOfDay
BinE.time_float
#endif
instance PGColumn "time without time zone" Time.TimeOfDay where
  pgDecode :: PGTypeID "time without time zone" -> PGTextValue -> TimeOfDay
pgDecode PGTypeID "time without time zone"
_ = String -> String -> TimeOfDay
forall t. ParseTime t => String -> String -> t
readTime String
"%T%Q" (String -> TimeOfDay)
-> (PGTextValue -> String) -> PGTextValue -> TimeOfDay
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTextValue -> String
BSC.unpack
#ifdef VERSION_postgresql_binary
  pgDecodeBinary :: PGTypeEnv
-> PGTypeID "time without time zone" -> PGTextValue -> TimeOfDay
pgDecodeBinary = BinDecoder TimeOfDay
-> BinDecoder TimeOfDay
-> PGTypeEnv
-> PGTypeID "time without time zone"
-> PGTextValue
-> TimeOfDay
forall (t :: Symbol) a.
PGColumn t a =>
BinDecoder a
-> BinDecoder a -> PGTypeEnv -> PGTypeID t -> PGTextValue -> a
binDecDatetime BinDecoder TimeOfDay
BinD.time_int BinDecoder TimeOfDay
BinD.time_float
#endif

instance PGType "time with time zone" where
  type PGVal "time with time zone" = (Time.TimeOfDay, Time.TimeZone)
  pgBinaryColumn :: PGTypeEnv -> PGTypeID "time with time zone" -> Bool
pgBinaryColumn = PGTypeEnv -> PGTypeID "time with time zone" -> Bool
forall (t :: Symbol). PGTypeEnv -> PGTypeID t -> Bool
binColDatetime
instance PGParameter "time with time zone" (Time.TimeOfDay, Time.TimeZone) where
  pgEncode :: PGTypeID "time with time zone"
-> (TimeOfDay, TimeZone) -> PGTextValue
pgEncode PGTypeID "time with time zone"
_ (TimeOfDay
t, TimeZone
z) = String -> PGTextValue
BSC.pack (String -> PGTextValue) -> String -> PGTextValue
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> TimeOfDay -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
Time.formatTime TimeLocale
defaultTimeLocale String
"%T%Q" TimeOfDay
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
fixTZ (TimeLocale -> String -> TimeZone -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
Time.formatTime TimeLocale
defaultTimeLocale String
"%z" TimeZone
z)
  pgLiteral :: PGTypeID "time with time zone"
-> (TimeOfDay, TimeZone) -> PGTextValue
pgLiteral PGTypeID "time with time zone"
t = PGTextValue -> PGTextValue
pgQuoteUnsafe (PGTextValue -> PGTextValue)
-> ((TimeOfDay, TimeZone) -> PGTextValue)
-> (TimeOfDay, TimeZone)
-> PGTextValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTypeID "time with time zone"
-> (TimeOfDay, TimeZone) -> PGTextValue
forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> PGTextValue
pgEncode PGTypeID "time with time zone"
t
#ifdef VERSION_postgresql_binary
  pgEncodeValue :: PGTypeEnv
-> PGTypeID "time with time zone"
-> (TimeOfDay, TimeZone)
-> PGValue
pgEncodeValue = BinEncoder (TimeOfDay, TimeZone)
-> BinEncoder (TimeOfDay, TimeZone)
-> PGTypeEnv
-> PGTypeID "time with time zone"
-> (TimeOfDay, TimeZone)
-> PGValue
forall (t :: Symbol) a.
PGParameter t a =>
BinEncoder a
-> BinEncoder a -> PGTypeEnv -> PGTypeID t -> a -> PGValue
binEncDatetime BinEncoder (TimeOfDay, TimeZone)
BinE.timetz_int BinEncoder (TimeOfDay, TimeZone)
BinE.timetz_float
#endif
instance PGColumn "time with time zone" (Time.TimeOfDay, Time.TimeZone) where
  pgDecode :: PGTypeID "time with time zone"
-> PGTextValue -> (TimeOfDay, TimeZone)
pgDecode PGTypeID "time with time zone"
_ = (LocalTime -> TimeOfDay
Time.localTimeOfDay (LocalTime -> TimeOfDay)
-> (ZonedTime -> LocalTime) -> ZonedTime -> TimeOfDay
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ZonedTime -> LocalTime
Time.zonedTimeToLocalTime (ZonedTime -> TimeOfDay)
-> (ZonedTime -> TimeZone) -> ZonedTime -> (TimeOfDay, TimeZone)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ZonedTime -> TimeZone
Time.zonedTimeZone) (ZonedTime -> (TimeOfDay, TimeZone))
-> (PGTextValue -> ZonedTime)
-> PGTextValue
-> (TimeOfDay, TimeZone)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> ZonedTime
forall t. ParseTime t => String -> String -> t
readTime String
"%T%Q%z" (String -> ZonedTime)
-> (PGTextValue -> String) -> PGTextValue -> ZonedTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
fixTZ ShowS -> (PGTextValue -> String) -> PGTextValue -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTextValue -> String
BSC.unpack
#ifdef VERSION_postgresql_binary
  pgDecodeBinary :: PGTypeEnv
-> PGTypeID "time with time zone"
-> PGTextValue
-> (TimeOfDay, TimeZone)
pgDecodeBinary = BinDecoder (TimeOfDay, TimeZone)
-> BinDecoder (TimeOfDay, TimeZone)
-> PGTypeEnv
-> PGTypeID "time with time zone"
-> PGTextValue
-> (TimeOfDay, TimeZone)
forall (t :: Symbol) a.
PGColumn t a =>
BinDecoder a
-> BinDecoder a -> PGTypeEnv -> PGTypeID t -> PGTextValue -> a
binDecDatetime BinDecoder (TimeOfDay, TimeZone)
BinD.timetz_int BinDecoder (TimeOfDay, TimeZone)
BinD.timetz_float
#endif

instance PGType "timestamp without time zone" where
  type PGVal "timestamp without time zone" = Time.LocalTime
  pgBinaryColumn :: PGTypeEnv -> PGTypeID "timestamp without time zone" -> Bool
pgBinaryColumn = PGTypeEnv -> PGTypeID "timestamp without time zone" -> Bool
forall (t :: Symbol). PGTypeEnv -> PGTypeID t -> Bool
binColDatetime
instance PGParameter "timestamp without time zone" Time.LocalTime where
  pgEncode :: PGTypeID "timestamp without time zone" -> LocalTime -> PGTextValue
pgEncode PGTypeID "timestamp without time zone"
_ = String -> PGTextValue
BSC.pack (String -> PGTextValue)
-> (LocalTime -> String) -> LocalTime -> PGTextValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeLocale -> String -> LocalTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
Time.formatTime TimeLocale
defaultTimeLocale String
"%F %T%Q"
  pgLiteral :: PGTypeID "timestamp without time zone" -> LocalTime -> PGTextValue
pgLiteral PGTypeID "timestamp without time zone"
t = PGTextValue -> PGTextValue
pgQuoteUnsafe (PGTextValue -> PGTextValue)
-> (LocalTime -> PGTextValue) -> LocalTime -> PGTextValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTypeID "timestamp without time zone" -> LocalTime -> PGTextValue
forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> PGTextValue
pgEncode PGTypeID "timestamp without time zone"
t
#ifdef VERSION_postgresql_binary
  pgEncodeValue :: PGTypeEnv
-> PGTypeID "timestamp without time zone" -> LocalTime -> PGValue
pgEncodeValue = BinEncoder LocalTime
-> BinEncoder LocalTime
-> PGTypeEnv
-> PGTypeID "timestamp without time zone"
-> LocalTime
-> PGValue
forall (t :: Symbol) a.
PGParameter t a =>
BinEncoder a
-> BinEncoder a -> PGTypeEnv -> PGTypeID t -> a -> PGValue
binEncDatetime BinEncoder LocalTime
BinE.timestamp_int BinEncoder LocalTime
BinE.timestamp_float
#endif
instance PGColumn "timestamp without time zone" Time.LocalTime where
  pgDecode :: PGTypeID "timestamp without time zone" -> PGTextValue -> LocalTime
pgDecode PGTypeID "timestamp without time zone"
_ = String -> String -> LocalTime
forall t. ParseTime t => String -> String -> t
readTime String
"%F %T%Q" (String -> LocalTime)
-> (PGTextValue -> String) -> PGTextValue -> LocalTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTextValue -> String
BSC.unpack
#ifdef VERSION_postgresql_binary
  pgDecodeBinary :: PGTypeEnv
-> PGTypeID "timestamp without time zone"
-> PGTextValue
-> LocalTime
pgDecodeBinary = BinDecoder LocalTime
-> BinDecoder LocalTime
-> PGTypeEnv
-> PGTypeID "timestamp without time zone"
-> PGTextValue
-> LocalTime
forall (t :: Symbol) a.
PGColumn t a =>
BinDecoder a
-> BinDecoder a -> PGTypeEnv -> PGTypeID t -> PGTextValue -> a
binDecDatetime BinDecoder LocalTime
BinD.timestamp_int BinDecoder LocalTime
BinD.timestamp_float
#endif

instance PGType "timestamp with time zone" where
  type PGVal "timestamp with time zone" = Time.UTCTime
  pgBinaryColumn :: PGTypeEnv -> PGTypeID "timestamp with time zone" -> Bool
pgBinaryColumn = PGTypeEnv -> PGTypeID "timestamp with time zone" -> Bool
forall (t :: Symbol). PGTypeEnv -> PGTypeID t -> Bool
binColDatetime
instance PGParameter "timestamp with time zone" Time.UTCTime where
  pgEncode :: PGTypeID "timestamp with time zone" -> UTCTime -> PGTextValue
pgEncode PGTypeID "timestamp with time zone"
_ = String -> PGTextValue
BSC.pack (String -> PGTextValue)
-> (UTCTime -> String) -> UTCTime -> PGTextValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
fixTZ ShowS -> (UTCTime -> String) -> UTCTime -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
Time.formatTime TimeLocale
defaultTimeLocale String
"%F %T%Q%z"
  -- pgLiteral t = pgQuoteUnsafe . pgEncode t
#ifdef VERSION_postgresql_binary
  pgEncodeValue :: PGTypeEnv
-> PGTypeID "timestamp with time zone" -> UTCTime -> PGValue
pgEncodeValue = BinEncoder UTCTime
-> BinEncoder UTCTime
-> PGTypeEnv
-> PGTypeID "timestamp with time zone"
-> UTCTime
-> PGValue
forall (t :: Symbol) a.
PGParameter t a =>
BinEncoder a
-> BinEncoder a -> PGTypeEnv -> PGTypeID t -> a -> PGValue
binEncDatetime BinEncoder UTCTime
BinE.timestamptz_int BinEncoder UTCTime
BinE.timestamptz_float
#endif
instance PGColumn "timestamp with time zone" Time.UTCTime where
  pgDecode :: PGTypeID "timestamp with time zone" -> PGTextValue -> UTCTime
pgDecode PGTypeID "timestamp with time zone"
_ = String -> String -> UTCTime
forall t. ParseTime t => String -> String -> t
readTime String
"%F %T%Q%z" (String -> UTCTime)
-> (PGTextValue -> String) -> PGTextValue -> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
fixTZ ShowS -> (PGTextValue -> String) -> PGTextValue -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTextValue -> String
BSC.unpack
#ifdef VERSION_postgresql_binary
  pgDecodeBinary :: PGTypeEnv
-> PGTypeID "timestamp with time zone" -> PGTextValue -> UTCTime
pgDecodeBinary = BinDecoder UTCTime
-> BinDecoder UTCTime
-> PGTypeEnv
-> PGTypeID "timestamp with time zone"
-> PGTextValue
-> UTCTime
forall (t :: Symbol) a.
PGColumn t a =>
BinDecoder a
-> BinDecoder a -> PGTypeEnv -> PGTypeID t -> PGTextValue -> a
binDecDatetime BinDecoder UTCTime
BinD.timestamptz_int BinDecoder UTCTime
BinD.timestamptz_float
#endif

instance PGType "interval" where
  type PGVal "interval" = Time.DiffTime
  pgBinaryColumn :: PGTypeEnv -> PGTypeID "interval" -> Bool
pgBinaryColumn = PGTypeEnv -> PGTypeID "interval" -> Bool
forall (t :: Symbol). PGTypeEnv -> PGTypeID t -> Bool
binColDatetime
instance PGParameter "interval" Time.DiffTime where
  pgEncode :: PGTypeID "interval" -> DiffTime -> PGTextValue
pgEncode PGTypeID "interval"
_ = String -> PGTextValue
BSC.pack (String -> PGTextValue)
-> (DiffTime -> String) -> DiffTime -> PGTextValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffTime -> String
forall a. Show a => a -> String
show
  pgLiteral :: PGTypeID "interval" -> DiffTime -> PGTextValue
pgLiteral PGTypeID "interval"
t = PGTextValue -> PGTextValue
pgQuoteUnsafe (PGTextValue -> PGTextValue)
-> (DiffTime -> PGTextValue) -> DiffTime -> PGTextValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTypeID "interval" -> DiffTime -> PGTextValue
forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> PGTextValue
pgEncode PGTypeID "interval"
t
#ifdef VERSION_postgresql_binary
  pgEncodeValue :: PGTypeEnv -> PGTypeID "interval" -> DiffTime -> PGValue
pgEncodeValue = BinEncoder DiffTime
-> BinEncoder DiffTime
-> PGTypeEnv
-> PGTypeID "interval"
-> DiffTime
-> PGValue
forall (t :: Symbol) a.
PGParameter t a =>
BinEncoder a
-> BinEncoder a -> PGTypeEnv -> PGTypeID t -> a -> PGValue
binEncDatetime BinEncoder DiffTime
BinE.interval_int BinEncoder DiffTime
BinE.interval_float
#endif
-- |Representation of DiffTime as interval.
-- PostgreSQL stores months and days separately in intervals, but DiffTime does not.
-- We collapse all interval fields into seconds
instance PGColumn "interval" Time.DiffTime where
  pgDecode :: PGTypeID "interval" -> PGTextValue -> DiffTime
pgDecode PGTypeID "interval"
_ PGTextValue
a = (String -> DiffTime)
-> (Scientific -> DiffTime) -> Either String Scientific -> DiffTime
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> DiffTime
forall a. HasCallStack => String -> a
error (String -> DiffTime) -> ShowS -> String -> DiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"pgDecode interval (" String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ShowS
forall a. [a] -> [a] -> [a]
++ (String
"): " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PGTextValue -> String
BSC.unpack PGTextValue
a))) Scientific -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Either String Scientific -> DiffTime)
-> Either String Scientific -> DiffTime
forall a b. (a -> b) -> a -> b
$ Parser Scientific -> PGTextValue -> Either String Scientific
forall a. Parser a -> PGTextValue -> Either String a
P.parseOnly Parser Scientific
ps PGTextValue
a where
    ps :: Parser Scientific
ps = do
      Char
_ <- Char -> Parser Char
P.char Char
'P'
      Scientific
d <- [(Char, Scientific)] -> Parser Scientific
units [(Char
'Y', Scientific
12Scientific -> Scientific -> Scientific
forall a. Num a => a -> a -> a
*Scientific
month), (Char
'M', Scientific
month), (Char
'W', Scientific
7Scientific -> Scientific -> Scientific
forall a. Num a => a -> a -> a
*Scientific
day), (Char
'D', Scientific
day)]
      ((Scientific
d Scientific -> Scientific -> Scientific
forall a. Num a => a -> a -> a
+) (Scientific -> Scientific)
-> Parser Scientific -> Parser Scientific
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Scientific
pt) Parser Scientific -> Parser Scientific -> Parser Scientific
forall a. Semigroup a => a -> a -> a
<> (Scientific
d Scientific -> Parser PGTextValue () -> Parser Scientific
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser PGTextValue ()
forall t. Chunk t => Parser t ()
P.endOfInput)
    pt :: Parser Scientific
pt = do
      Char
_ <- Char -> Parser Char
P.char Char
'T'
      Scientific
t <- [(Char, Scientific)] -> Parser Scientific
units [(Char
'H', Scientific
3600), (Char
'M', Scientific
60), (Char
'S', Scientific
1)]
      Parser PGTextValue ()
forall t. Chunk t => Parser t ()
P.endOfInput
      Scientific -> Parser Scientific
forall (m :: * -> *) a. Monad m => a -> m a
return Scientific
t
    units :: [(Char, Scientific)] -> Parser Scientific
units [(Char, Scientific)]
l = ([Scientific] -> Scientific)
-> Parser PGTextValue [Scientific] -> Parser Scientific
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Scientific] -> Scientific
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (Parser PGTextValue [Scientific] -> Parser Scientific)
-> Parser PGTextValue [Scientific] -> Parser Scientific
forall a b. (a -> b) -> a -> b
$ Parser Scientific -> Parser PGTextValue [Scientific]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.many' (Parser Scientific -> Parser PGTextValue [Scientific])
-> Parser Scientific -> Parser PGTextValue [Scientific]
forall a b. (a -> b) -> a -> b
$ do
      Scientific
x <- Parser Scientific -> Parser Scientific
forall a. Num a => Parser a -> Parser a
P.signed Parser Scientific
P.scientific
      Scientific
u <- [Parser Scientific] -> Parser Scientific
forall (f :: * -> *) a. Alternative f => [f a] -> f a
P.choice ([Parser Scientific] -> Parser Scientific)
-> [Parser Scientific] -> Parser Scientific
forall a b. (a -> b) -> a -> b
$ ((Char, Scientific) -> Parser Scientific)
-> [(Char, Scientific)] -> [Parser Scientific]
forall a b. (a -> b) -> [a] -> [b]
map (\(Char
c, Scientific
u) -> Scientific
u Scientific -> Parser Char -> Parser Scientific
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Char
P.char Char
c) [(Char, Scientific)]
l
      Scientific -> Parser Scientific
forall (m :: * -> *) a. Monad m => a -> m a
return (Scientific -> Parser Scientific)
-> Scientific -> Parser Scientific
forall a b. (a -> b) -> a -> b
$ Scientific
x Scientific -> Scientific -> Scientific
forall a. Num a => a -> a -> a
* Scientific
u
    day :: Scientific
day = Scientific
86400
    month :: Scientific
month = Scientific
2629746
#ifdef VERSION_postgresql_binary
  pgDecodeBinary :: PGTypeEnv -> PGTypeID "interval" -> PGTextValue -> DiffTime
pgDecodeBinary = BinDecoder DiffTime
-> BinDecoder DiffTime
-> PGTypeEnv
-> PGTypeID "interval"
-> PGTextValue
-> DiffTime
forall (t :: Symbol) a.
PGColumn t a =>
BinDecoder a
-> BinDecoder a -> PGTypeEnv -> PGTypeID t -> PGTextValue -> a
binDecDatetime BinDecoder DiffTime
BinD.interval_int BinDecoder DiffTime
BinD.interval_float
#endif

instance PGType "numeric" where
  type PGVal "numeric" = 
#ifdef VERSION_scientific
    Scientific
#else
    Rational
#endif
  BIN_COL
instance PGParameter "numeric" Rational where
  pgEncode :: PGTypeID "numeric" -> Rational -> PGTextValue
pgEncode PGTypeID "numeric"
_ Rational
r
    | Rational -> Integer
forall a. Ratio a -> a
denominator Rational
r Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 = String -> PGTextValue
BSC.pack String
"NaN" -- this can't happen
    | Bool
otherwise = String -> PGTextValue
BSC.pack (String -> PGTextValue) -> String -> PGTextValue
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
30 (Rational -> String
showRational (Rational
r Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ (Rational
10 Rational -> Int -> Rational
forall a b. (Fractional a, Integral b) => a -> b -> a
^^ Int
e))) String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'e' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
e where
    e :: Int
e = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double
forall a. Floating a => a -> a -> a
logBase (Double
10 :: Double) (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (Rational -> Double) -> Rational -> Double
forall a b. (a -> b) -> a -> b
$ Rational -> Rational
forall a. Num a => a -> a
abs Rational
r :: Int -- not great, and arbitrarily truncate somewhere
  pgLiteral :: PGTypeID "numeric" -> Rational -> PGTextValue
pgLiteral PGTypeID "numeric"
_ Rational
r
    | Rational -> Integer
forall a. Ratio a -> a
denominator Rational
r Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 = String -> PGTextValue
BSC.pack String
"'NaN'" -- this can't happen
    | Bool
otherwise = String -> PGTextValue
BSC.pack (String -> PGTextValue) -> String -> PGTextValue
forall a b. (a -> b) -> a -> b
$ Char
'(' Char -> ShowS
forall a. a -> [a] -> [a]
: Integer -> String
forall a. Show a => a -> String
show (Rational -> Integer
forall a. Ratio a -> a
numerator Rational
r) String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'/' Char -> ShowS
forall a. a -> [a] -> [a]
: Integer -> String
forall a. Show a => a -> String
show (Rational -> Integer
forall a. Ratio a -> a
denominator Rational
r) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"::numeric)"
  BIN_ENC(BinE.numeric . realToFrac)
-- |High-precision representation of Rational as numeric.
-- Unfortunately, numeric has an NaN, while Rational does not.
-- NaN numeric values will produce exceptions.
instance PGColumn "numeric" Rational where
  pgDecode :: PGTypeID "numeric" -> PGTextValue -> Rational
pgDecode PGTypeID "numeric"
_ PGTextValue
bs
    | String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"NaN" = Integer
0 Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
0 -- this won't work
    | Bool
otherwise = [(Rational, String)] -> Rational
ur ([(Rational, String)] -> Rational)
-> [(Rational, String)] -> Rational
forall a b. (a -> b) -> a -> b
$ ReadS Rational
forall a. RealFrac a => ReadS a
readFloat String
s where
    ur :: [(Rational, String)] -> Rational
ur [(Rational
x,String
"")] = Rational
x
    ur [(Rational, String)]
_ = String -> Rational
forall a. HasCallStack => String -> a
error (String -> Rational) -> String -> Rational
forall a b. (a -> b) -> a -> b
$ String
"pgDecode numeric: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
    s :: String
s = PGTextValue -> String
BSC.unpack PGTextValue
bs
  BIN_DEC(realToFrac <$> BinD.numeric)

-- This will produce infinite(-precision) strings
showRational :: Rational -> String
showRational :: Rational -> String
showRational Rational
r = Integer -> String
forall a. Show a => a -> String
show (Integer
ri :: Integer) String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'.' Char -> ShowS
forall a. a -> [a] -> [a]
: Rational -> String
forall t. RealFrac t => t -> String
frac (Rational -> Rational
forall a. Num a => a -> a
abs Rational
rf) where
  (Integer
ri, Rational
rf) = Rational -> (Integer, Rational)
forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction Rational
r
  frac :: t -> String
frac t
0 = String
""
  frac t
f = Int -> Char
intToDigit Int
i Char -> ShowS
forall a. a -> [a] -> [a]
: t -> String
frac t
f' where (Int
i, t
f') = t -> (Int, t)
forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction (t
10 t -> t -> t
forall a. Num a => a -> a -> a
* t
f)

#ifdef VERSION_scientific
instance PGParameter "numeric" Scientific where
  pgEncode :: PGTypeID "numeric" -> Scientific -> PGTextValue
pgEncode PGTypeID "numeric"
_ = String -> PGTextValue
BSC.pack (String -> PGTextValue)
-> (Scientific -> String) -> Scientific -> PGTextValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> String
forall a. Show a => a -> String
show
  pgLiteral :: PGTypeID "numeric" -> Scientific -> PGTextValue
pgLiteral = PGTypeID "numeric" -> Scientific -> PGTextValue
forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> PGTextValue
pgEncode
  BIN_ENC(BinE.numeric)
instance PGColumn "numeric" Scientific where
  pgDecode :: PGTypeID "numeric" -> PGTextValue -> Scientific
pgDecode PGTypeID "numeric"
_ = String -> Scientific
forall a. Read a => String -> a
read (String -> Scientific)
-> (PGTextValue -> String) -> PGTextValue -> Scientific
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTextValue -> String
BSC.unpack
  BIN_DEC(BinD.numeric)
#endif

#ifdef VERSION_uuid
instance PGType "uuid" where
  type PGVal "uuid" = UUID.UUID
  BIN_COL
instance PGParameter "uuid" UUID.UUID where
  pgEncode :: PGTypeID "uuid" -> UUID -> PGTextValue
pgEncode PGTypeID "uuid"
_ = UUID -> PGTextValue
UUID.toASCIIBytes
  pgLiteral :: PGTypeID "uuid" -> UUID -> PGTextValue
pgLiteral PGTypeID "uuid"
t = PGTextValue -> PGTextValue
pgQuoteUnsafe (PGTextValue -> PGTextValue)
-> (UUID -> PGTextValue) -> UUID -> PGTextValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTypeID "uuid" -> UUID -> PGTextValue
forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> PGTextValue
pgEncode PGTypeID "uuid"
t
  BIN_ENC(BinE.uuid)
instance PGColumn "uuid" UUID.UUID where
  pgDecode :: PGTypeID "uuid" -> PGTextValue -> UUID
pgDecode PGTypeID "uuid"
_ PGTextValue
u = UUID -> Maybe UUID -> UUID
forall a. a -> Maybe a -> a
fromMaybe (String -> UUID
forall a. HasCallStack => String -> a
error (String -> UUID) -> String -> UUID
forall a b. (a -> b) -> a -> b
$ String
"pgDecode uuid: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PGTextValue -> String
BSC.unpack PGTextValue
u) (Maybe UUID -> UUID) -> Maybe UUID -> UUID
forall a b. (a -> b) -> a -> b
$ PGTextValue -> Maybe UUID
UUID.fromASCIIBytes PGTextValue
u
  BIN_DEC(BinD.uuid)
#endif

-- |Generic class of composite (row or record) types.
newtype PGRecord = PGRecord [Maybe PGTextValue]
class PGType t => PGRecordType t
instance PGRecordType t => PGParameter t PGRecord where
  pgEncode :: PGTypeID t -> PGRecord -> PGTextValue
pgEncode PGTypeID t
_ (PGRecord [Maybe PGTextValue]
l) =
    Builder -> PGTextValue
buildPGValue (Builder -> PGTextValue) -> Builder -> PGTextValue
forall a b. (a -> b) -> a -> b
$ Char -> Builder
BSB.char7 Char
'(' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat (Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse (Char -> Builder
BSB.char7 Char
',') ([Builder] -> [Builder]) -> [Builder] -> [Builder]
forall a b. (a -> b) -> a -> b
$ (Maybe PGTextValue -> Builder) -> [Maybe PGTextValue] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (Builder -> (PGTextValue -> Builder) -> Maybe PGTextValue -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
forall a. Monoid a => a
mempty (String -> PGTextValue -> Builder
pgDQuoteFrom String
"(),")) [Maybe PGTextValue]
l) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
BSB.char7 Char
')'
  pgLiteral :: PGTypeID t -> PGRecord -> PGTextValue
pgLiteral PGTypeID t
_ (PGRecord [Maybe PGTextValue]
l) =
    String -> PGTextValue
BSC.pack String
"ROW(" PGTextValue -> PGTextValue -> PGTextValue
forall a. Semigroup a => a -> a -> a
<> PGTextValue -> [PGTextValue] -> PGTextValue
BS.intercalate (Char -> PGTextValue
BSC.singleton Char
',') ((Maybe PGTextValue -> PGTextValue)
-> [Maybe PGTextValue] -> [PGTextValue]
forall a b. (a -> b) -> [a] -> [b]
map (PGTextValue
-> (PGTextValue -> PGTextValue) -> Maybe PGTextValue -> PGTextValue
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> PGTextValue
BSC.pack String
"NULL") PGTextValue -> PGTextValue
pgQuote) [Maybe PGTextValue]
l) PGTextValue -> Char -> PGTextValue
`BSC.snoc` Char
')'
instance PGRecordType t => PGColumn t PGRecord where
  pgDecode :: PGTypeID t -> PGTextValue -> PGRecord
pgDecode PGTypeID t
_ PGTextValue
a = (String -> PGRecord)
-> ([Maybe PGTextValue] -> PGRecord)
-> Either String [Maybe PGTextValue]
-> PGRecord
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> PGRecord
forall a. HasCallStack => String -> a
error (String -> PGRecord) -> ShowS -> String -> PGRecord
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"pgDecode record (" String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ShowS
forall a. [a] -> [a] -> [a]
++ (String
"): " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PGTextValue -> String
BSC.unpack PGTextValue
a))) [Maybe PGTextValue] -> PGRecord
PGRecord (Either String [Maybe PGTextValue] -> PGRecord)
-> Either String [Maybe PGTextValue] -> PGRecord
forall a b. (a -> b) -> a -> b
$ Parser [Maybe PGTextValue]
-> PGTextValue -> Either String [Maybe PGTextValue]
forall a. Parser a -> PGTextValue -> Either String a
P.parseOnly Parser [Maybe PGTextValue]
pa PGTextValue
a where
    pa :: Parser [Maybe PGTextValue]
pa = Char -> Parser Char
P.char Char
'(' Parser Char
-> Parser [Maybe PGTextValue] -> Parser [Maybe PGTextValue]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser (Maybe PGTextValue)
-> Parser Char -> Parser [Maybe PGTextValue]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
P.sepBy Parser (Maybe PGTextValue)
el (Char -> Parser Char
P.char Char
',') Parser [Maybe PGTextValue]
-> Parser Char -> Parser [Maybe PGTextValue]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
P.char Char
')' Parser [Maybe PGTextValue]
-> Parser PGTextValue () -> Parser [Maybe PGTextValue]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser PGTextValue ()
forall t. Chunk t => Parser t ()
P.endOfInput
    el :: Parser (Maybe PGTextValue)
el = Bool
-> String -> (PGTextValue -> Bool) -> Parser (Maybe PGTextValue)
parsePGDQuote Bool
True String
"()," PGTextValue -> Bool
BS.null

instance PGType "record" where
  type PGVal "record" = PGRecord
-- |The generic anonymous record type, as created by @ROW@.
-- In this case we can not know the types, and in fact, PostgreSQL does not accept values of this type regardless (except as literals).
instance PGRecordType "record"

#ifdef VERSION_aeson
instance PGType "json" where
  type PGVal "json" = JSON.Value
  BIN_COL
instance PGParameter "json" JSON.Value where
  pgEncode :: PGTypeID "json" -> Value -> PGTextValue
pgEncode PGTypeID "json"
_ = ByteString -> PGTextValue
BSL.toStrict (ByteString -> PGTextValue)
-> (Value -> ByteString) -> Value -> PGTextValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
JSON.encode
  BIN_ENC(BinE.json_ast)
instance PGColumn "json" JSON.Value where
  pgDecode :: PGTypeID "json" -> PGTextValue -> Value
pgDecode PGTypeID "json"
_ PGTextValue
j = (String -> Value)
-> (Value -> Value) -> Either String Value -> Value
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Value
forall a. HasCallStack => String -> a
error (String -> Value) -> ShowS -> String -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"pgDecode json (" String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ShowS
forall a. [a] -> [a] -> [a]
++ (String
"): " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PGTextValue -> String
BSC.unpack PGTextValue
j))) Value -> Value
forall a. a -> a
id (Either String Value -> Value) -> Either String Value -> Value
forall a b. (a -> b) -> a -> b
$ Parser Value -> PGTextValue -> Either String Value
forall a. Parser a -> PGTextValue -> Either String a
P.parseOnly Parser Value
JSON.json PGTextValue
j
  BIN_DEC(BinD.json_ast)

instance PGType "jsonb" where
  type PGVal "jsonb" = JSON.Value
  BIN_COL
instance PGParameter "jsonb" JSON.Value where
  pgEncode :: PGTypeID "jsonb" -> Value -> PGTextValue
pgEncode PGTypeID "jsonb"
_ = ByteString -> PGTextValue
BSL.toStrict (ByteString -> PGTextValue)
-> (Value -> ByteString) -> Value -> PGTextValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
JSON.encode
  BIN_ENC(BinE.jsonb_ast)
instance PGColumn "jsonb" JSON.Value where
  pgDecode :: PGTypeID "jsonb" -> PGTextValue -> Value
pgDecode PGTypeID "jsonb"
_ PGTextValue
j = (String -> Value)
-> (Value -> Value) -> Either String Value -> Value
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Value
forall a. HasCallStack => String -> a
error (String -> Value) -> ShowS -> String -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"pgDecode jsonb (" String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ShowS
forall a. [a] -> [a] -> [a]
++ (String
"): " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PGTextValue -> String
BSC.unpack PGTextValue
j))) Value -> Value
forall a. a -> a
id (Either String Value -> Value) -> Either String Value -> Value
forall a b. (a -> b) -> a -> b
$ Parser Value -> PGTextValue -> Either String Value
forall a. Parser a -> PGTextValue -> Either String a
P.parseOnly Parser Value
JSON.json PGTextValue
j
  BIN_DEC(BinD.jsonb_ast)
#endif

{-
--, ( 142,  143, "xml",         ?)
--, ( 600, 1017, "point",       ?)
--, ( 650,  651, "cidr",        ?)
--, ( 790,  791, "money",       Centi? Fixed?)
--, ( 829, 1040, "macaddr",     ?)
--, ( 869, 1041, "inet",        ?)
--, (1266, 1270, "timetz",      ?)
--, (1560, 1561, "bit",         Bool?)
--, (1562, 1563, "varbit",      ?)
-}