Types.hs

{-# LANGUAGE CPP, FlexibleInstances, OverlappingInstances, ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, DataKinds, KindSignatures, TypeFamilies, UndecidableInstances #-}
-- |
-- 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
  , PGTypeName(..)
  , PGTypeEnv(..)
  , unknownPGTypeEnv
  , PGRecord(..)

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

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

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

import Control.Applicative ((<$>), (<$))
import Control.Monad (mzero)
import Data.Bits (shiftL, (.|.))
import Data.ByteString.Internal (w2c)
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)
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.UTF8 as BSU
import Data.Char (isSpace, isDigit, digitToInt, intToDigit, toLower)
import Data.Int
import Data.List (intersperse, intercalate)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>), mconcat, mempty)
import Data.Ratio ((%), numerator, denominator)
#ifdef USE_SCIENTIFIC
import Data.Scientific (Scientific)
#endif
#ifdef USE_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
#ifdef USE_UUID
import qualified Data.UUID as UUID
#endif
import Data.Word (Word8, Word32)
import GHC.TypeLits (Symbol, symbolVal, KnownSymbol)
import Numeric (readFloat)
#ifdef USE_BINARY
-- import qualified PostgreSQLBinary.Array as BinA
import qualified PostgreSQLBinary.Decoder as BinD
import qualified PostgreSQLBinary.Encoder as BinE
#endif
import System.Locale (defaultTimeLocale)
import qualified Text.Parsec as P
import Text.Parsec.Token (naturalOrFloat, makeTokenParser, GenLanguageDef(..))

type PGTextValue = BS.ByteString
type PGBinaryValue = BS.ByteString
-- |A value passed to or from PostgreSQL in raw format.
data PGValue
  = PGNullValue
  | PGTextValue { pgTextValue :: PGTextValue } -- ^ The standard text encoding format (also used for unknown formats)
  | PGBinaryValue { pgBinaryValue :: PGBinaryValue } -- ^ Special binary-encoded data.  Not supported in all cases.
  deriving (Show, 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
  { pgIntegerDatetimes :: Maybe Bool -- ^ If @integer_datetimes@ is @on@; only relevant for binary encoding.
  }

unknownPGTypeEnv :: PGTypeEnv
unknownPGTypeEnv = PGTypeEnv
  { pgIntegerDatetimes = Nothing
  }

-- |A proxy type for PostgreSQL types.  The type argument should be an (internal) name of a database type (see @\\dT+@).
data PGTypeName (t :: Symbol) = PGTypeProxy

-- |A valid PostgreSQL type.
-- This is just an indicator class: no implementation is needed.
-- Unfortunately this will generate orphan instances wherever used.
class KnownSymbol t => PGType t where
  pgTypeName :: PGTypeName t -> String
  pgTypeName = symbolVal
  -- |Does this type support binary decoding?
  -- If so, 'pgDecodeBinary' must be implemented for every 'PGColumn' instance of this type.
  pgBinaryColumn :: PGTypeEnv -> PGTypeName t -> Bool
  pgBinaryColumn _ _ = 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 :: PGTypeName t -> a -> PGTextValue
  -- |Encode a value to a (quoted) literal value for use in SQL statements.
  -- Defaults to a quoted version of 'pgEncode'
  pgLiteral :: PGTypeName t -> a -> String
  pgLiteral t = pgQuote . BSU.toString . pgEncode t
  -- |Encode a value to a PostgreSQL representation.
  -- Defaults to the text representation by pgEncode
  pgEncodeValue :: PGTypeEnv -> PGTypeName t -> a -> PGValue
  pgEncodeValue _ t = PGTextValue . pgEncode 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 :: PGTypeName t -> PGTextValue -> a
  -- |Decode the PostgreSQL binary representation into a value.
  -- Only needs to be implemented if 'pgBinaryColumn' is true.
  pgDecodeBinary :: PGTypeEnv -> PGTypeName t -> PGBinaryValue -> a
  pgDecodeBinary _ t _ = error $ "pgDecodeBinary " ++ pgTypeName t ++ ": not supported"
  pgDecodeValue :: PGTypeEnv -> PGTypeName t -> PGValue -> a
  pgDecodeValue _ t (PGTextValue v) = pgDecode t v
  pgDecodeValue e t (PGBinaryValue v) = pgDecodeBinary e t v
  pgDecodeValue _ t PGNullValue = error $ "NULL in " ++ pgTypeName t ++ " column (use Maybe or COALESCE)"

instance PGParameter t a => PGParameter t (Maybe a) where
  pgEncode t = maybe (error $ "pgEncode " ++ pgTypeName t ++ ": Nothing") (pgEncode t)
  pgLiteral = maybe "NULL" . pgLiteral
  pgEncodeValue e = maybe PGNullValue . pgEncodeValue e

instance PGColumn t a => PGColumn t (Maybe a) where
  pgDecode t = Just . pgDecode t
  pgDecodeBinary e t = Just . pgDecodeBinary e t
  pgDecodeValue _ _ PGNullValue = Nothing
  pgDecodeValue e t v = Just $ pgDecodeValue e t v


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

-- |Final parameter escaping function used when a (nullable) parameter is passed to be substituted into a simple query.
pgEscapeParameter :: PGParameter t a => PGTypeEnv -> PGTypeName t -> a -> String
pgEscapeParameter _ = pgLiteral

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

-- |Final column decoding function used for a non-nullable result value.
pgDecodeColumnNotNull :: PGColumn t a => PGTypeEnv -> PGTypeName t -> PGValue -> a
pgDecodeColumnNotNull = pgDecodeValue


pgQuoteUnsafe :: String -> String
pgQuoteUnsafe s = '\'' : s ++ "'"

-- |Produce a SQL string literal by wrapping (and escaping) a string with single quotes.
pgQuote :: String -> String
pgQuote = ('\'':) . es where
  es "" = "'"
  es (c@'\'':r) = c:c:es r
  es (c:r) = c:es r

buildPGValue :: BSB.Builder -> BS.ByteString
buildPGValue = BSL.toStrict . BSB.toLazyByteString

-- |Double-quote a value if it's \"\", \"null\", or contains any whitespace, \'\"\', \'\\\', or the characters given in the first argument.
-- Checking all these things may not be worth it.  We could just double-quote everything.
pgDQuote :: String -> BS.ByteString -> BSB.Builder
pgDQuote unsafe s
  | BS.null s || BSC.any (\c -> isSpace c || c == '"' || c == '\\' || c `elem` unsafe) s || BSC.map toLower s == BSC.pack "null" =
    dq <> BSBP.primMapByteStringBounded ec s <> dq
  | otherwise = BSB.byteString s where
  dq = BSB.char7 '"'
  ec = BSBP.condB (\c -> c == c2w '"' || c == c2w '\\') bs (BSBP.liftFixedToBounded BSBP.word8)
  bs = BSBP.liftFixedToBounded $ ((,) '\\') BSBP.>$< (BSBP.char7 BSBP.>*< BSBP.word8)

-- |Parse double-quoted values ala 'pgDQuote'.
parsePGDQuote :: P.Stream s m Char => String -> (String -> Bool) -> P.ParsecT s u m (Maybe String)
parsePGDQuote unsafe isnul = (Just <$> q P.<|> mnul <$> uq) where
  q = P.between (P.char '"') (P.char '"') $
    P.many $ (P.char '\\' >> P.anyChar) P.<|> P.noneOf "\\\""
  uq = P.many (P.noneOf ('"':'\\':unsafe))
  mnul s
    | isnul s = Nothing
    | otherwise = Just s

#ifdef USE_BINARY
binDec :: PGType t => BinD.D a -> PGTypeName t -> PGBinaryValue -> a
binDec d t = either (\e -> error $ "pgDecodeBinary " ++ pgTypeName t ++ ": " ++ show e) id . d

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

instance PGType "boolean" where BIN_COL
instance PGParameter "boolean" Bool where
  pgEncode _ False = BSC.singleton 'f'
  pgEncode _ True = BSC.singleton 't'
  pgLiteral _ False = "false"
  pgLiteral _ True = "true"
  BIN_ENC(BinE.bool)
instance PGColumn "boolean" Bool where
  pgDecode _ s = case BSC.head s of
    'f' -> False
    't' -> True
    c -> error $ "pgDecode boolean: " ++ [c]
  BIN_DEC(binDec BinD.bool)

type OID = Word32
instance PGType "oid" where BIN_COL
instance PGParameter "oid" OID where
  pgEncode _ = BSC.pack . show
  pgLiteral _ = show
  BIN_ENC(BinE.int4 . Right)
instance PGColumn "oid" OID where
  pgDecode _ = read . BSC.unpack
  BIN_DEC(binDec BinD.int)

instance PGType "smallint" where BIN_COL
instance PGParameter "smallint" Int16 where
  pgEncode _ = BSC.pack . show
  pgLiteral _ = show
  BIN_ENC(BinE.int2. Left)
instance PGColumn "smallint" Int16 where
  pgDecode _ = read . BSC.unpack
  BIN_DEC(binDec BinD.int)

instance PGType "integer" where BIN_COL
instance PGParameter "integer" Int32 where
  pgEncode _ = BSC.pack . show
  pgLiteral _ = show
  BIN_ENC(BinE.int4 . Left)
instance PGColumn "integer" Int32 where
  pgDecode _ = read . BSC.unpack
  BIN_DEC(binDec BinD.int)

instance PGType "bigint" where BIN_COL
instance PGParameter "bigint" Int64 where
  pgEncode _ = BSC.pack . show
  pgLiteral _ = show
  BIN_ENC(BinE.int8 . Left)
instance PGColumn "bigint" Int64 where
  pgDecode _ = read . BSC.unpack
  BIN_DEC(binDec BinD.int)

instance PGType "real" where BIN_COL
instance PGParameter "real" Float where
  pgEncode _ = BSC.pack . show
  pgLiteral _ = show
  BIN_ENC(BinE.float4)
instance PGColumn "real" Float where
  pgDecode _ = read . BSC.unpack
  BIN_DEC(binDec BinD.float4)

instance PGType "double precision" where BIN_COL
instance PGParameter "double precision" Double where
  pgEncode _ = BSC.pack . show
  pgLiteral _ = show
  BIN_ENC(BinE.float8)
instance PGColumn "double precision" Double where
  pgDecode _ = read . BSC.unpack
  BIN_DEC(binDec BinD.float8)

instance PGType "\"char\"" where BIN_COL
instance PGParameter "\"char\"" Char where
  pgEncode _ = BSC.singleton
  BIN_ENC(BinE.char)
instance PGColumn "\"char\"" Char where
  pgDecode _ = BSC.head
  BIN_DEC(binDec BinD.char)


class PGType t => PGStringType t

instance PGStringType t => PGParameter t String where
  pgEncode _ = BSU.fromString
  BIN_ENC(BinE.text . Left . T.pack)
instance PGStringType t => PGColumn t String where
  pgDecode _ = BSU.toString
  BIN_DEC((T.unpack .) . binDec BinD.text)

instance PGStringType t => PGParameter t BS.ByteString where
  pgEncode _ = id
  BIN_ENC(BinE.text . Left . TE.decodeUtf8)
instance PGStringType t => PGColumn t BS.ByteString where
  pgDecode _ = id
  BIN_DEC((TE.encodeUtf8 .) . binDec BinD.text)

instance PGStringType t => PGParameter t BSL.ByteString where
  pgEncode _ = BSL.toStrict
  BIN_ENC(BinE.text . Right . TLE.decodeUtf8)
instance PGStringType t => PGColumn t BSL.ByteString where
  pgDecode _ = BSL.fromStrict
  BIN_DEC((BSL.fromStrict .) . (TE.encodeUtf8 .) . binDec BinD.text)

#ifdef USE_TEXT
instance PGStringType t => PGParameter t T.Text where
  pgEncode _ = TE.encodeUtf8
  BIN_ENC(BinE.text . Left)
instance PGStringType t => PGColumn t T.Text where
  pgDecode _ = TE.decodeUtf8
  BIN_DEC(binDec BinD.text)

instance PGStringType t => PGParameter t TL.Text where
  pgEncode _ = BSL.toStrict . TLE.encodeUtf8
  BIN_ENC(BinE.text . Right)
instance PGStringType t => PGColumn t TL.Text where
  pgDecode _ = TL.fromStrict . TE.decodeUtf8
  BIN_DEC((TL.fromStrict .) . binDec BinD.text)
#endif

instance PGType "text" where BIN_COL
instance PGType "character varying" where BIN_COL
instance PGType "name" where BIN_COL
instance PGType "bpchar" where 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 h = buildPGValue $ BSB.string7 "\\x" <> h

decodeBytea :: PGTextValue -> [Word8]
decodeBytea s
  | sm /= "\\x" = error $ "pgDecode bytea: " ++ sm
  | otherwise = pd $ BS.unpack d where
  (m, d) = BS.splitAt 2 s
  sm = BSC.unpack m
  pd [] = []
  pd (h:l:r) = (shiftL (unhex h) 4 .|. unhex l) : pd r
  pd [x] = error $ "pgDecode bytea: " ++ show x
  unhex = fromIntegral . digitToInt . w2c

instance PGType "bytea" where BIN_COL
instance PGParameter "bytea" BSL.ByteString where
  pgEncode _ = encodeBytea . BSB.lazyByteStringHex
  pgLiteral t = pgQuoteUnsafe . BSC.unpack . pgEncode t
  BIN_ENC(BinE.bytea . Right)
instance PGColumn "bytea" BSL.ByteString where
  pgDecode _ = BSL.pack . decodeBytea
  BIN_DEC((BSL.fromStrict .) . binDec BinD.bytea)
instance PGParameter "bytea" BS.ByteString where
  pgEncode _ = encodeBytea . BSB.byteStringHex
  pgLiteral t = pgQuoteUnsafe . BSC.unpack . pgEncode t
  BIN_ENC(BinE.bytea . Left)
instance PGColumn "bytea" BS.ByteString where
  pgDecode _ = BS.pack . decodeBytea
  BIN_DEC(binDec BinD.bytea)

instance PGType "date" where BIN_COL
instance PGParameter "date" Time.Day where
  pgEncode _ = BSC.pack . Time.showGregorian
  pgLiteral _ = pgQuoteUnsafe . Time.showGregorian
  BIN_ENC(BinE.date)
instance PGColumn "date" Time.Day where
  pgDecode _ = Time.readTime defaultTimeLocale "%F" . BSC.unpack
  BIN_DEC(binDec BinD.date)

binColDatetime :: PGTypeEnv -> PGTypeName t -> Bool
#ifdef USE_BINARY
binColDatetime PGTypeEnv{ pgIntegerDatetimes = Just _ } _ = True
#endif
binColDatetime _ _ = False

#ifdef USE_BINARY
binEncDatetime :: PGParameter t a => (Bool -> a -> PGBinaryValue) -> PGTypeEnv -> PGTypeName t -> a -> PGValue
binEncDatetime f e t = maybe (PGTextValue . pgEncode t) ((PGBinaryValue .) . f) (pgIntegerDatetimes e)

binDecDatetime :: PGColumn t a => (Bool -> BinD.D a) -> PGTypeEnv -> PGTypeName t -> PGBinaryValue -> a
binDecDatetime f e = binDec $ f $ fromMaybe (error "pgDecodeBinary: unknown integer_datetimes value") $ pgIntegerDatetimes e
#endif

instance PGType "time without time zone" where
  pgBinaryColumn = binColDatetime
instance PGParameter "time without time zone" Time.TimeOfDay where
  pgEncode _ = BSC.pack . Time.formatTime defaultTimeLocale "%T%Q"
  pgLiteral _ = pgQuoteUnsafe . Time.formatTime defaultTimeLocale "%T%Q"
#ifdef USE_BINARY
  pgEncodeValue = binEncDatetime BinE.time
#endif
instance PGColumn "time without time zone" Time.TimeOfDay where
  pgDecode _ = Time.readTime defaultTimeLocale "%T%Q" . BSC.unpack
#ifdef USE_BINARY
  pgDecodeBinary = binDecDatetime BinD.time
#endif

instance PGType "timestamp without time zone" where
  pgBinaryColumn = binColDatetime
instance PGParameter "timestamp without time zone" Time.LocalTime where
  pgEncode _ = BSC.pack . Time.formatTime defaultTimeLocale "%F %T%Q"
  pgLiteral _ = pgQuoteUnsafe . Time.formatTime defaultTimeLocale "%F %T%Q"
#ifdef USE_BINARY
  pgEncodeValue = binEncDatetime BinE.timestamp
#endif
instance PGColumn "timestamp without time zone" Time.LocalTime where
  pgDecode _ = Time.readTime defaultTimeLocale "%F %T%Q" . BSC.unpack
#ifdef USE_BINARY
  pgDecodeBinary = binDecDatetime BinD.timestamp
#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 "" = ""
fixTZ ['+',h1,h2] | isDigit h1 && isDigit h2 = ['+',h1,h2,':','0','0']
fixTZ ['-',h1,h2] | isDigit h1 && isDigit h2 = ['-',h1,h2,':','0','0']
fixTZ ['+',h1,h2,m1,m2] | isDigit h1 && isDigit h2 && isDigit m1 && isDigit m2 = ['+',h1,h2,':',m1,m2]
fixTZ ['-',h1,h2,m1,m2] | isDigit h1 && isDigit h2 && isDigit m1 && isDigit m2 = ['-',h1,h2,':',m1,m2]
fixTZ (c:s) = c:fixTZ s

instance PGType "timestamp with time zone" where
  pgBinaryColumn = binColDatetime
instance PGParameter "timestamp with time zone" Time.UTCTime where
  pgEncode _ = BSC.pack . fixTZ . Time.formatTime defaultTimeLocale "%F %T%Q%z"
  pgLiteral _ = pgQuote{-Unsafe-} . fixTZ . Time.formatTime defaultTimeLocale "%F %T%Q%z"
#ifdef USE_BINARY
  pgEncodeValue = binEncDatetime BinE.timestamptz
#endif
instance PGColumn "timestamp with time zone" Time.UTCTime where
  pgDecode _ = Time.readTime defaultTimeLocale "%F %T%Q%z" . fixTZ . BSC.unpack
#ifdef USE_BINARY
  pgDecodeBinary = binDecDatetime BinD.timestamptz
#endif

instance PGType "interval" where
  pgBinaryColumn = binColDatetime
instance PGParameter "interval" Time.DiffTime where
  pgEncode _ = BSC.pack . show
  pgLiteral _ = pgQuoteUnsafe . show
#ifdef USE_BINARY
  pgEncodeValue = binEncDatetime BinE.interval
#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 _ a = either (error . ("pgDecode interval: " ++) . show) id $ P.parse ps (BSC.unpack a) a where
    ps = do
      _ <- P.char 'P'
      d <- units [('Y', 12*month), ('M', month), ('W', 7*day), ('D', day)]
      (d +) <$> pt P.<|> d <$ P.eof
    pt = do
      _ <- P.char 'T'
      t <- units [('H', 3600), ('M', 60), ('S', 1)]
      _ <- P.eof
      return t
    units l = fmap sum $ P.many $ do
      s <- negate <$ P.char '-' P.<|> id <$ P.char '+' P.<|> return id
      x <- num
      u <- P.choice $ map (\(c, u) -> s u <$ P.char c) l
      return $ either (Time.secondsToDiffTime . (* u)) (realToFrac . (* fromInteger u)) x
    day = 86400
    month = 2629746
    num = naturalOrFloat $ makeTokenParser $ LanguageDef
      { commentStart   = ""
      , commentEnd     = ""
      , commentLine    = ""
      , nestedComments = False
      , identStart     = mzero
      , identLetter    = mzero
      , opStart        = mzero
      , opLetter       = mzero
      , reservedOpNames= []
      , reservedNames  = []
      , caseSensitive  = True
      }
#ifdef USE_BINARY
  pgDecodeBinary = binDecDatetime BinD.interval
#endif

instance PGType "numeric" where BIN_COL
instance PGParameter "numeric" Rational where
  pgEncode _ r
    | denominator r == 0 = BSC.pack "NaN" -- this can't happen
    | otherwise = BSC.pack $ take 30 (showRational (r / (10 ^^ e))) ++ 'e' : show e where
    e = floor $ logBase (10 :: Double) $ fromRational $ abs r :: Int -- not great, and arbitrarily truncate somewhere
  pgLiteral _ r
    | denominator r == 0 = "'NaN'" -- this can't happen
    | otherwise = '(' : show (numerator r) ++ '/' : show (denominator r) ++ "::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 _ bs
    | s == "NaN" = 0 % 0 -- this won't work
    | otherwise = ur $ readFloat s where
    ur [(x,"")] = x
    ur _ = error $ "pgDecode numeric: " ++ s
    s = BSC.unpack bs
  BIN_DEC((realToFrac .) . binDec BinD.numeric)

-- This will produce infinite(-precision) strings
showRational :: Rational -> String
showRational r = show (ri :: Integer) ++ '.' : frac (abs rf) where
  (ri, rf) = properFraction r
  frac 0 = ""
  frac f = intToDigit i : frac f' where (i, f') = properFraction (10 * f)

#ifdef USE_SCIENTIFIC
instance PGParameter "numeric" Scientific where
  pgEncode _ = BSC.pack . show
  pgLiteral _ = show
  BIN_ENC(BinE.numeric)
instance PGColumn "numeric" Scientific where
  pgDecode _ = read . BSC.unpack
  BIN_DEC(binDec BinD.numeric)
#endif

#ifdef USE_UUID
instance PGType "uuid" where BIN_COL
instance PGParameter "uuid" UUID.UUID where
  pgEncode _ = UUID.toASCIIBytes
  pgLiteral _ = pgQuoteUnsafe . UUID.toString
  BIN_ENC(BinE.uuid)
instance PGColumn "uuid" UUID.UUID where
  pgDecode _ u = fromMaybe (error $ "pgDecode uuid: " ++ BSC.unpack u) $ UUID.fromASCIIBytes u
  BIN_DEC(binDec 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 _ (PGRecord l) =
    buildPGValue $ BSB.char7 '(' <> mconcat (intersperse (BSB.char7 ',') $ map (maybe mempty (pgDQuote "(),")) l) <> BSB.char7 ')' where
  pgLiteral _ (PGRecord l) =
    "ROW(" ++ intercalate "," (map (maybe "NULL" (pgQuote . BSU.toString)) l) ++ ")" where
instance PGRecordType t => PGColumn t PGRecord where
  pgDecode _ a = either (error . ("pgDecode record: " ++) . show) PGRecord $ P.parse pa (BSC.unpack a) a where
    pa = do
      l <- P.between (P.char '(') (P.char ')') $
        P.sepBy el (P.char ',')
      _ <- P.eof
      return l
    el = fmap BSC.pack <$> parsePGDQuote "()," null

instance PGType "record"
-- |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"

{-
--, ( 114,  199, "json",        ?)
--, ( 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",      ?)
-}