{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}
{-# LANGUAGE ConstraintKinds #-}

module Opaleye.Internal.RunQuery where

import           Control.Applicative
  (Applicative, pure, (<$>), (*>), (<*>), liftA2)

import qualified Database.PostgreSQL.Simple as PGS
import qualified Database.PostgreSQL.Simple.Cursor  as PGSC (Cursor)
import           Database.PostgreSQL.Simple.Internal (RowParser)
import qualified Database.PostgreSQL.Simple.FromField as PGS
import           Database.PostgreSQL.Simple.FromField
  (FieldParser, fromField, pgArrayFieldParser)
import           Database.PostgreSQL.Simple.FromRow (fromRow, fieldWith)
import           Database.PostgreSQL.Simple.Types (fromPGArray, Only(..))

import           Opaleye.Column (Column)
import           Opaleye.Internal.Column (Nullable)
import qualified Opaleye.Internal.PackMap as PackMap
import qualified Opaleye.Internal.QueryArr as Q
import qualified Opaleye.Column as C
import qualified Opaleye.Internal.Unpackspec as U
import qualified Opaleye.Internal.PGTypesExternal as T
import qualified Opaleye.Internal.PGTypes as IPT (strictDecodeUtf8)
import qualified Opaleye.Select as S
import qualified Opaleye.Sql as S

import qualified Data.Profunctor as P
import           Data.Profunctor (dimap)
import qualified Data.Profunctor.Product as PP
import qualified Data.Profunctor.Product.Default as D

import qualified Data.Aeson as Ae
import qualified Data.CaseInsensitive as CI
import qualified Data.Text as ST
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as SBS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Time as Time
import qualified Data.Scientific as Sci
import qualified Data.String as String
import           Data.UUID (UUID)
import           GHC.Int (Int32, Int64)

-- { Only needed for postgresql-simple FieldParsers

import           Database.PostgreSQL.Simple.FromField
  (ResultError(UnexpectedNull, Incompatible), typeInfo, returnError)
import qualified Database.PostgreSQL.Simple.TypeInfo as TI
import qualified Database.PostgreSQL.Simple.Range as PGSR
import           Data.Typeable (Typeable)

-- }

-- | A 'FromField' @sqlType@ @haskellType@
-- encodes how to turn
-- a value of Postgres type @sqlType@ into a value of Haskell type
-- @haskellType@.  For example a value of type 'FromField'
-- 'T.SqlText' 'String' encodes how to turn a 'T.SqlText' result from the
-- database into a Haskell 'String'.
--
-- \"'FromField' @sqlType@ @haskellType@\" corresponds to
-- postgresql-simple's \"'FieldParser' @haskellType@\".

-- This is *not* a Product Profunctor because it is the only way I
-- know of to get the instance generation to work for non-Nullable and
-- Nullable types at once.

-- I can no longer remember what the above comment means, but it might
-- be that we can't add nullability to a RowParser, only to a
-- FieldParser, so we have to have some type that we know contains
-- just a FieldParser.
data FromField pgType haskellType =
  QueryRunnerColumn (U.Unpackspec (Column pgType) ()) (FieldParser haskellType)

instance Functor (FromField u) where
  fmap :: (a -> b) -> FromField u a -> FromField u b
fmap a -> b
f ~(QueryRunnerColumn Unpackspec (Column u) ()
u FieldParser a
fp) = Unpackspec (Column u) () -> FieldParser b -> FromField u b
forall pgType haskellType.
Unpackspec (Column pgType) ()
-> FieldParser haskellType -> FromField pgType haskellType
QueryRunnerColumn Unpackspec (Column u) ()
u ((((Maybe ByteString -> Conversion a)
 -> Maybe ByteString -> Conversion b)
-> FieldParser a -> FieldParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Maybe ByteString -> Conversion a)
  -> Maybe ByteString -> Conversion b)
 -> FieldParser a -> FieldParser b)
-> ((a -> b)
    -> (Maybe ByteString -> Conversion a)
    -> Maybe ByteString
    -> Conversion b)
-> (a -> b)
-> FieldParser a
-> FieldParser b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Conversion a -> Conversion b)
-> (Maybe ByteString -> Conversion a)
-> Maybe ByteString
-> Conversion b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Conversion a -> Conversion b)
 -> (Maybe ByteString -> Conversion a)
 -> Maybe ByteString
 -> Conversion b)
-> ((a -> b) -> Conversion a -> Conversion b)
-> (a -> b)
-> (Maybe ByteString -> Conversion a)
-> Maybe ByteString
-> Conversion b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> Conversion a -> Conversion b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) a -> b
f FieldParser a
fp)

type QueryRunnerColumn = FromField

-- | A 'FromFields'
--   specifies how to convert Postgres values (@fields@)
--   into Haskell values (@haskells@).  Most likely you will never need
--   to create on of these or handle one directly.  It will be provided
--   for you by the 'D.Default' 'FromFields' instance.
--
-- \"'FromFields' @fields@ @haskells@\" corresponds to
-- postgresql-simple's \"'RowParser' @haskells@\".  \"'Default'
-- 'FromFields' @columns@ @haskells@\" corresponds to
-- postgresql-simple's \"@FromRow@ @haskells@\".
data FromFields columns haskells =
  QueryRunner (U.Unpackspec columns ())
              (columns -> RowParser haskells)
              -- We never actually look at the columns except to see
              -- its "type" in the case of a sum profunctor
              (columns -> Int)
              -- How many columns have we requested?  If we
              -- asked for zero columns then the SQL generator will
              -- have to put a dummy 0 into the SELECT statement,
              -- since we can't select zero columns.  In that case we
              -- have to make sure we read a single Int.
              --
              -- NB this does have to be a function of 'columns'
              -- because we have a `SumProfunctor` instance.  For some
              -- values of 'columns' there may be zero columns and for
              -- other values one or more, for example, 'Maybe (Column
              -- SqlInt4)' has no columns when it is Nothing and one
              -- column when it is Just.

type QueryRunner = FromFields

fieldQueryRunnerColumn :: PGS.FromField haskell => FromField pgType haskell
fieldQueryRunnerColumn :: FromField pgType haskell
fieldQueryRunnerColumn = FromField pgType haskell
forall haskell pgType.
FromField haskell =>
FromField pgType haskell
fromPGSFromField

fromPGSFromField :: PGS.FromField haskell => FromField pgType haskell
fromPGSFromField :: FromField pgType haskell
fromPGSFromField = FieldParser haskell -> FromField pgType haskell
forall haskell pgType.
FieldParser haskell -> FromField pgType haskell
fieldParserQueryRunnerColumn FieldParser haskell
forall a. FromField a => FieldParser a
fromField

fieldParserQueryRunnerColumn :: FieldParser haskell -> FromField pgType haskell
fieldParserQueryRunnerColumn :: FieldParser haskell -> FromField pgType haskell
fieldParserQueryRunnerColumn = FieldParser haskell -> FromField pgType haskell
forall haskell pgType.
FieldParser haskell -> FromField pgType haskell
fromPGSFieldParser

fromPGSFieldParser :: FieldParser haskell -> FromField pgType haskell
fromPGSFieldParser :: FieldParser haskell -> FromField pgType haskell
fromPGSFieldParser = Unpackspec (Column pgType) ()
-> FieldParser haskell -> FromField pgType haskell
forall pgType haskellType.
Unpackspec (Column pgType) ()
-> FieldParser haskellType -> FromField pgType haskellType
QueryRunnerColumn ((Column pgType -> ())
-> Unpackspec (Column pgType) (Column pgType)
-> Unpackspec (Column pgType) ()
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
P.rmap (() -> Column pgType -> ()
forall a b. a -> b -> a
const ()) Unpackspec (Column pgType) (Column pgType)
forall a. Unpackspec (Column a) (Column a)
U.unpackspecField)

queryRunner :: FromField a b -> FromFields (Column a) b
queryRunner :: FromField a b -> FromFields (Column a) b
queryRunner FromField a b
qrc = Unpackspec (Column a) ()
-> (Column a -> RowParser b)
-> (Column a -> Int)
-> FromFields (Column a) b
forall columns haskells.
Unpackspec columns ()
-> (columns -> RowParser haskells)
-> (columns -> Int)
-> FromFields columns haskells
QueryRunner Unpackspec (Column a) ()
u (RowParser b -> Column a -> RowParser b
forall a b. a -> b -> a
const (FieldParser b -> RowParser b
forall a. FieldParser a -> RowParser a
fieldWith FieldParser b
fp)) (Int -> Column a -> Int
forall a b. a -> b -> a
const Int
1)
    where QueryRunnerColumn Unpackspec (Column a) ()
u FieldParser b
fp = FromField a b
qrc

queryRunnerColumnNullable :: FromField a b
                          -> FromField (Nullable a) (Maybe b)
queryRunnerColumnNullable :: FromField a b -> FromField (Nullable a) (Maybe b)
queryRunnerColumnNullable FromField a b
qr =
  Unpackspec (Column (Nullable a)) ()
-> FieldParser (Maybe b) -> FromField (Nullable a) (Maybe b)
forall pgType haskellType.
Unpackspec (Column pgType) ()
-> FieldParser haskellType -> FromField pgType haskellType
QueryRunnerColumn ((Column (Nullable a) -> Column a)
-> Unpackspec (Column a) () -> Unpackspec (Column (Nullable a)) ()
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
P.lmap Column (Nullable a) -> Column a
forall a b. Column a -> Column b
C.unsafeCoerceColumn Unpackspec (Column a) ()
u) (FieldParser b -> FieldParser (Maybe b)
forall a. FieldParser a -> FieldParser (Maybe a)
fromField' FieldParser b
fp)
  where QueryRunnerColumn Unpackspec (Column a) ()
u FieldParser b
fp = FromField a b
qr
        fromField' :: FieldParser a -> FieldParser (Maybe a)
        fromField' :: FieldParser a -> FieldParser (Maybe a)
fromField' FieldParser a
_ Field
_ Maybe ByteString
Nothing = Maybe a -> Conversion (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
        fromField' FieldParser a
fp' Field
f Maybe ByteString
bs = (a -> Maybe a) -> Conversion a -> Conversion (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (FieldParser a
fp' Field
f Maybe ByteString
bs)

unsafeFromFieldRaw :: FromField a (PGS.Field, Maybe SBS.ByteString)
unsafeFromFieldRaw :: FromField a (Field, Maybe ByteString)
unsafeFromFieldRaw = FieldParser (Field, Maybe ByteString)
-> FromField a (Field, Maybe ByteString)
forall haskell pgType.
FieldParser haskell -> FromField pgType haskell
fieldParserQueryRunnerColumn (\Field
f Maybe ByteString
mdata -> (Field, Maybe ByteString) -> Conversion (Field, Maybe ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Field
f, Maybe ByteString
mdata))

-- { Instances for automatic derivation

instance DefaultFromField a b =>
         DefaultFromField (Nullable a) (Maybe b) where
  defaultFromField :: FromField (Nullable a) (Maybe b)
defaultFromField = FromField a b -> FromField (Nullable a) (Maybe b)
forall a b. FromField a b -> FromField (Nullable a) (Maybe b)
queryRunnerColumnNullable FromField a b
forall sqlType haskellType.
DefaultFromField sqlType haskellType =>
FromField sqlType haskellType
defaultFromField

instance DefaultFromField a b =>
         D.Default FromFields (Column a) b where
  def :: FromFields (Column a) b
def = FromField a b -> FromFields (Column a) b
forall a b. FromField a b -> FromFields (Column a) b
queryRunner FromField a b
forall sqlType haskellType.
DefaultFromField sqlType haskellType =>
FromField sqlType haskellType
defaultFromField

-- }

-- { Instances that must be provided once for each type.  Instances
--   for Nullable are derived automatically from these.

-- | A 'DefaultFromField' @sqlType@ @haskellType@ represents
-- the default way to turn a @sqlType@ result from the database into a
-- Haskell value of type @haskellType@.
--
-- \"'DefaultFromField' @sqlType@ @haskellType@\" corresponds
-- to postgresql-simple's \"'FromField' @haskellType@\".
--
-- Creating an instance of 'DefaultFromField' for your own types is
-- necessary for retrieving those types from the database.
--
-- You should use one of the three methods below for writing a
-- 'DefaultFromField' instance.
--
-- 1. If you already have a postgresql-simple 'PGS.FromField' instance for
-- your @haskellType@, use
-- 'fromPGSFromField'.  (This is how most of the built-in instances are
-- defined.)
--
-- 2. If you don't have a postgresql-simple 'PGS.FromField' instance, but
-- you do have an Opaleye 'FromField' value for the type it wraps use
-- 'Opaleye.RunSelect.unsafeFromField' if possible.  See the documentation for
-- 'Opaleye.RunSelect.unsafeFromField' for an example.
--
-- 3. If you have a more complicated case, but not a 'PGS.FromField' instance,
-- write a 'FieldParser' for your type and use 'fromPGSFieldParser'.
-- You can also add a 'FromField' instance using this.
{-# DEPRECATED queryRunnerColumnDefault "Use defaultFromField instead.  It will be removed in 0.8" #-}
class DefaultFromField sqlType haskellType where
  queryRunnerColumnDefault :: FromField sqlType haskellType
  queryRunnerColumnDefault = FromField sqlType haskellType
forall sqlType haskellType.
DefaultFromField sqlType haskellType =>
FromField sqlType haskellType
defaultFromField
  defaultFromField         :: FromField sqlType haskellType
  defaultFromField = FromField sqlType haskellType
forall sqlType haskellType.
DefaultFromField sqlType haskellType =>
FromField sqlType haskellType
queryRunnerColumnDefault

  {-# MINIMAL queryRunnerColumnDefault | defaultFromField #-}

type QueryRunnerColumnDefault = DefaultFromField

instance DefaultFromField sqlType haskellType
    => D.Default FromField sqlType haskellType where
  def :: FromField sqlType haskellType
def = FromField sqlType haskellType
forall sqlType haskellType.
DefaultFromField sqlType haskellType =>
FromField sqlType haskellType
defaultFromField

instance DefaultFromField T.SqlNumeric Sci.Scientific where
  defaultFromField :: FromField SqlNumeric Scientific
defaultFromField = FromField SqlNumeric Scientific
forall haskell pgType.
FromField haskell =>
FromField pgType haskell
fromPGSFromField

instance DefaultFromField T.SqlInt4 Int where
  defaultFromField :: FromField SqlInt4 Int
defaultFromField = FromField SqlInt4 Int
forall haskell pgType.
FromField haskell =>
FromField pgType haskell
fromPGSFromField

instance DefaultFromField T.SqlInt4 Int32 where
  defaultFromField :: FromField SqlInt4 Int32
defaultFromField = FromField SqlInt4 Int32
forall haskell pgType.
FromField haskell =>
FromField pgType haskell
fromPGSFromField

instance DefaultFromField T.SqlInt8 Int64 where
  defaultFromField :: FromField SqlInt8 Int64
defaultFromField = FromField SqlInt8 Int64
forall haskell pgType.
FromField haskell =>
FromField pgType haskell
fromPGSFromField

instance DefaultFromField T.SqlText String where
  defaultFromField :: FromField SqlText String
defaultFromField = FromField SqlText String
forall haskell pgType.
FromField haskell =>
FromField pgType haskell
fromPGSFromField

instance DefaultFromField T.SqlFloat8 Double where
  defaultFromField :: FromField SqlFloat8 Double
defaultFromField = FromField SqlFloat8 Double
forall haskell pgType.
FromField haskell =>
FromField pgType haskell
fromPGSFromField

instance DefaultFromField T.SqlBool Bool where
  defaultFromField :: FromField SqlBool Bool
defaultFromField = FromField SqlBool Bool
forall haskell pgType.
FromField haskell =>
FromField pgType haskell
fromPGSFromField

instance DefaultFromField T.SqlUuid UUID where
  defaultFromField :: FromField SqlUuid UUID
defaultFromField = FromField SqlUuid UUID
forall haskell pgType.
FromField haskell =>
FromField pgType haskell
fromPGSFromField

instance DefaultFromField T.SqlBytea SBS.ByteString where
  defaultFromField :: FromField SqlBytea ByteString
defaultFromField = FromField SqlBytea ByteString
forall haskell pgType.
FromField haskell =>
FromField pgType haskell
fromPGSFromField

instance DefaultFromField T.SqlBytea LBS.ByteString where
  defaultFromField :: FromField SqlBytea ByteString
defaultFromField = FromField SqlBytea ByteString
forall haskell pgType.
FromField haskell =>
FromField pgType haskell
fromPGSFromField

instance DefaultFromField T.SqlText ST.Text where
  defaultFromField :: FromField SqlText Text
defaultFromField = FromField SqlText Text
forall haskell pgType.
FromField haskell =>
FromField pgType haskell
fromPGSFromField

instance DefaultFromField T.SqlText LT.Text where
  defaultFromField :: FromField SqlText Text
defaultFromField = FromField SqlText Text
forall haskell pgType.
FromField haskell =>
FromField pgType haskell
fromPGSFromField

instance DefaultFromField T.SqlDate Time.Day where
  defaultFromField :: FromField SqlDate Day
defaultFromField = FromField SqlDate Day
forall haskell pgType.
FromField haskell =>
FromField pgType haskell
fromPGSFromField

instance DefaultFromField T.SqlTimestamptz Time.UTCTime where
  defaultFromField :: FromField SqlTimestamptz UTCTime
defaultFromField = FromField SqlTimestamptz UTCTime
forall haskell pgType.
FromField haskell =>
FromField pgType haskell
fromPGSFromField

instance DefaultFromField T.SqlTimestamp Time.LocalTime where
  defaultFromField :: FromField SqlTimestamp LocalTime
defaultFromField = FromField SqlTimestamp LocalTime
forall haskell pgType.
FromField haskell =>
FromField pgType haskell
fromPGSFromField

instance DefaultFromField T.SqlTimestamptz Time.ZonedTime where
  defaultFromField :: FromField SqlTimestamptz ZonedTime
defaultFromField = FromField SqlTimestamptz ZonedTime
forall haskell pgType.
FromField haskell =>
FromField pgType haskell
fromPGSFromField

instance DefaultFromField T.SqlTime Time.TimeOfDay where
  defaultFromField :: FromField SqlTime TimeOfDay
defaultFromField = FromField SqlTime TimeOfDay
forall haskell pgType.
FromField haskell =>
FromField pgType haskell
fromPGSFromField

instance DefaultFromField T.SqlCitext (CI.CI ST.Text) where
  defaultFromField :: FromField SqlCitext (CI Text)
defaultFromField = FromField SqlCitext (CI Text)
forall haskell pgType.
FromField haskell =>
FromField pgType haskell
fromPGSFromField

instance DefaultFromField T.SqlCitext (CI.CI LT.Text) where
  defaultFromField :: FromField SqlCitext (CI Text)
defaultFromField = FromField SqlCitext (CI Text)
forall haskell pgType.
FromField haskell =>
FromField pgType haskell
fromPGSFromField

instance DefaultFromField T.SqlJson String where
  defaultFromField :: FromField SqlJson String
defaultFromField = FieldParser String -> FromField SqlJson String
forall haskell pgType.
FieldParser haskell -> FromField pgType haskell
fieldParserQueryRunnerColumn FieldParser String
jsonFieldParser

instance DefaultFromField T.SqlJson Ae.Value where
  defaultFromField :: FromField SqlJson Value
defaultFromField = FromField SqlJson Value
forall haskell pgType.
FromField haskell =>
FromField pgType haskell
fromPGSFromField

instance DefaultFromField T.SqlJsonb String where
  defaultFromField :: FromField SqlJsonb String
defaultFromField = FieldParser String -> FromField SqlJsonb String
forall haskell pgType.
FieldParser haskell -> FromField pgType haskell
fieldParserQueryRunnerColumn FieldParser String
jsonbFieldParser

instance DefaultFromField T.SqlJsonb Ae.Value where
  defaultFromField :: FromField SqlJsonb Value
defaultFromField = FromField SqlJsonb Value
forall haskell pgType.
FromField haskell =>
FromField pgType haskell
fromPGSFromField

-- No CI String instance since postgresql-simple doesn't define FromField (CI String)

arrayColumn :: Column (T.SqlArray a) -> Column a
arrayColumn :: Column (SqlArray a) -> Column a
arrayColumn = Column (SqlArray a) -> Column a
forall a b. Column a -> Column b
C.unsafeCoerceColumn

instance (Typeable b, DefaultFromField a b) =>
         DefaultFromField (T.SqlArray a) [b] where
  defaultFromField :: FromField (SqlArray a) [b]
defaultFromField = FromField a b -> FromField (SqlArray a) [b]
forall h f.
Typeable h =>
FromField f h -> FromField (SqlArray f) [h]
fromFieldArray FromField a b
forall sqlType haskellType.
DefaultFromField sqlType haskellType =>
FromField sqlType haskellType
defaultFromField

fromFieldArray :: Typeable h => FromField f h -> FromField (T.SqlArray f) [h]
fromFieldArray :: FromField f h -> FromField (SqlArray f) [h]
fromFieldArray FromField f h
q =
  Unpackspec (Column (SqlArray f)) ()
-> FieldParser [h] -> FromField (SqlArray f) [h]
forall pgType haskellType.
Unpackspec (Column pgType) ()
-> FieldParser haskellType -> FromField pgType haskellType
QueryRunnerColumn ((Column (SqlArray f) -> Column f)
-> Unpackspec (Column f) () -> Unpackspec (Column (SqlArray f)) ()
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
P.lmap Column (SqlArray f) -> Column f
forall a. Column (SqlArray a) -> Column a
arrayColumn Unpackspec (Column f) ()
c)
                    ((((Maybe ByteString -> Conversion (PGArray h))
 -> Maybe ByteString -> Conversion [h])
-> (Field -> Maybe ByteString -> Conversion (PGArray h))
-> FieldParser [h]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Maybe ByteString -> Conversion (PGArray h))
  -> Maybe ByteString -> Conversion [h])
 -> (Field -> Maybe ByteString -> Conversion (PGArray h))
 -> FieldParser [h])
-> ((PGArray h -> [h])
    -> (Maybe ByteString -> Conversion (PGArray h))
    -> Maybe ByteString
    -> Conversion [h])
-> (PGArray h -> [h])
-> (Field -> Maybe ByteString -> Conversion (PGArray h))
-> FieldParser [h]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Conversion (PGArray h) -> Conversion [h])
-> (Maybe ByteString -> Conversion (PGArray h))
-> Maybe ByteString
-> Conversion [h]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Conversion (PGArray h) -> Conversion [h])
 -> (Maybe ByteString -> Conversion (PGArray h))
 -> Maybe ByteString
 -> Conversion [h])
-> ((PGArray h -> [h]) -> Conversion (PGArray h) -> Conversion [h])
-> (PGArray h -> [h])
-> (Maybe ByteString -> Conversion (PGArray h))
-> Maybe ByteString
-> Conversion [h]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PGArray h -> [h]) -> Conversion (PGArray h) -> Conversion [h]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) PGArray h -> [h]
forall a. PGArray a -> [a]
fromPGArray (FieldParser h
-> Field -> Maybe ByteString -> Conversion (PGArray h)
forall a. Typeable a => FieldParser a -> FieldParser (PGArray a)
pgArrayFieldParser FieldParser h
f))
  where QueryRunnerColumn Unpackspec (Column f) ()
c FieldParser h
f = FromField f h
q

-- }

instance (Typeable b, DefaultFromField a b) =>
         DefaultFromField (T.PGRange a) (PGSR.PGRange b) where
  defaultFromField :: FromField (PGRange a) (PGRange b)
defaultFromField = FromField a b -> FromField (PGRange a) (PGRange b)
forall b a.
Typeable b =>
FromField a b -> FromField (PGRange a) (PGRange b)
fromFieldRange FromField a b
forall sqlType haskellType.
DefaultFromField sqlType haskellType =>
FromField sqlType haskellType
defaultFromField

fromFieldRange :: Typeable b
               => FromField a b
               -> FromField (T.PGRange a) (PGSR.PGRange b)
fromFieldRange :: FromField a b -> FromField (PGRange a) (PGRange b)
fromFieldRange FromField a b
off =
  Unpackspec (Column (PGRange a)) ()
-> FieldParser (PGRange b) -> FromField (PGRange a) (PGRange b)
forall pgType haskellType.
Unpackspec (Column pgType) ()
-> FieldParser haskellType -> FromField pgType haskellType
QueryRunnerColumn ((Column (PGRange a) -> Column a)
-> Unpackspec (Column a) () -> Unpackspec (Column (PGRange a)) ()
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
P.lmap Column (PGRange a) -> Column a
forall a b. Column a -> Column b
C.unsafeCoerceColumn Unpackspec (Column a) ()
c) (FieldParser b -> FieldParser (PGRange b)
forall a. Typeable a => FieldParser a -> FieldParser (PGRange a)
PGSR.fromFieldRange FieldParser b
pff)
  where QueryRunnerColumn Unpackspec (Column a) ()
c FieldParser b
pff = FromField a b
off

-- Boilerplate instances

instance Functor (FromFields c) where
  fmap :: (a -> b) -> FromFields c a -> FromFields c b
fmap a -> b
f (QueryRunner Unpackspec c ()
u c -> RowParser a
r c -> Int
b) = Unpackspec c ()
-> (c -> RowParser b) -> (c -> Int) -> FromFields c b
forall columns haskells.
Unpackspec columns ()
-> (columns -> RowParser haskells)
-> (columns -> Int)
-> FromFields columns haskells
QueryRunner Unpackspec c ()
u (((RowParser a -> RowParser b)
-> (c -> RowParser a) -> c -> RowParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((RowParser a -> RowParser b)
 -> (c -> RowParser a) -> c -> RowParser b)
-> ((a -> b) -> RowParser a -> RowParser b)
-> (a -> b)
-> (c -> RowParser a)
-> c
-> RowParser b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> RowParser a -> RowParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) a -> b
f c -> RowParser a
r) c -> Int
b

-- TODO: Seems like this one should be simpler!
instance Applicative (FromFields c) where
  pure :: a -> FromFields c a
pure = ((c -> RowParser a) -> (c -> Int) -> FromFields c a)
-> (c -> Int) -> (c -> RowParser a) -> FromFields c a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Unpackspec c ()
-> (c -> RowParser a) -> (c -> Int) -> FromFields c a
forall columns haskells.
Unpackspec columns ()
-> (columns -> RowParser haskells)
-> (columns -> Int)
-> FromFields columns haskells
QueryRunner ((c -> ()) -> Unpackspec () () -> Unpackspec c ()
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
P.lmap (() -> c -> ()
forall a b. a -> b -> a
const ()) Unpackspec () ()
forall (p :: * -> * -> *). ProductProfunctor p => p () ()
PP.empty)) (Int -> c -> Int
forall a b. a -> b -> a
const Int
0)
         ((c -> RowParser a) -> FromFields c a)
-> (a -> c -> RowParser a) -> a -> FromFields c a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RowParser a -> c -> RowParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
         (RowParser a -> c -> RowParser a)
-> (a -> RowParser a) -> a -> c -> RowParser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> RowParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  QueryRunner Unpackspec c ()
uf c -> RowParser (a -> b)
rf c -> Int
bf <*> :: FromFields c (a -> b) -> FromFields c a -> FromFields c b
<*> QueryRunner Unpackspec c ()
ux c -> RowParser a
rx c -> Int
bx =
    Unpackspec c ()
-> (c -> RowParser b) -> (c -> Int) -> FromFields c b
forall columns haskells.
Unpackspec columns ()
-> (columns -> RowParser haskells)
-> (columns -> Int)
-> FromFields columns haskells
QueryRunner ((c -> (c, c))
-> (((), ()) -> ())
-> Unpackspec (c, c) ((), ())
-> Unpackspec c ()
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
P.dimap (\c
x -> (c
x,c
x)) (() -> ((), ()) -> ()
forall a b. a -> b -> a
const ()) (Unpackspec c ()
uf Unpackspec c () -> Unpackspec c () -> Unpackspec (c, c) ((), ())
forall (p :: * -> * -> *) a b a' b'.
ProductProfunctor p =>
p a b -> p a' b' -> p (a, a') (b, b')
PP.***! Unpackspec c ()
ux)) (RowParser (a -> b) -> RowParser a -> RowParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) (RowParser (a -> b) -> RowParser a -> RowParser b)
-> (c -> RowParser (a -> b)) -> c -> RowParser a -> RowParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> c -> RowParser (a -> b)
rf (c -> RowParser a -> RowParser b)
-> (c -> RowParser a) -> c -> RowParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> c -> RowParser a
rx) ((Int -> Int -> Int) -> (c -> Int) -> (c -> Int) -> c -> Int
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) c -> Int
bf c -> Int
bx)

instance P.Profunctor FromFields where
  dimap :: (a -> b) -> (c -> d) -> FromFields b c -> FromFields a d
dimap a -> b
f c -> d
g (QueryRunner Unpackspec b ()
u b -> RowParser c
r b -> Int
b) =
    Unpackspec a ()
-> (a -> RowParser d) -> (a -> Int) -> FromFields a d
forall columns haskells.
Unpackspec columns ()
-> (columns -> RowParser haskells)
-> (columns -> Int)
-> FromFields columns haskells
QueryRunner ((a -> b) -> Unpackspec b () -> Unpackspec a ()
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
P.lmap a -> b
f Unpackspec b ()
u) ((a -> b)
-> (RowParser c -> RowParser d)
-> (b -> RowParser c)
-> a
-> RowParser d
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
P.dimap a -> b
f ((c -> d) -> RowParser c -> RowParser d
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
g) b -> RowParser c
r) ((a -> b) -> (b -> Int) -> a -> Int
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
P.lmap a -> b
f b -> Int
b)

instance PP.ProductProfunctor FromFields where
  purePP :: b -> FromFields a b
purePP = b -> FromFields a b
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  **** :: FromFields a (b -> c) -> FromFields a b -> FromFields a c
(****) = FromFields a (b -> c) -> FromFields a b -> FromFields a c
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)

instance PP.SumProfunctor FromFields where
  FromFields a b
f +++! :: FromFields a b
-> FromFields a' b' -> FromFields (Either a a') (Either b b')
+++! FromFields a' b'
g = Unpackspec (Either a a') ()
-> (Either a a' -> RowParser (Either b b'))
-> (Either a a' -> Int)
-> FromFields (Either a a') (Either b b')
forall columns haskells.
Unpackspec columns ()
-> (columns -> RowParser haskells)
-> (columns -> Int)
-> FromFields columns haskells
QueryRunner ((Either () () -> ())
-> Unpackspec (Either a a') (Either () ())
-> Unpackspec (Either a a') ()
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
P.rmap (() -> Either () () -> ()
forall a b. a -> b -> a
const ()) (Unpackspec a ()
fu Unpackspec a ()
-> Unpackspec a' () -> Unpackspec (Either a a') (Either () ())
forall (p :: * -> * -> *) a b a' b'.
SumProfunctor p =>
p a b -> p a' b' -> p (Either a a') (Either b b')
PP.+++! Unpackspec a' ()
gu))
                         ((a -> RowParser b)
-> (a' -> RowParser b') -> Either a a' -> RowParser (Either b b')
forall (p :: * -> * -> *) (f :: * -> *) a b a' b'.
(SumProfunctor p, Functor f) =>
p a (f b) -> p a' (f b') -> p (Either a a') (f (Either b b'))
PackMap.eitherFunction a -> RowParser b
fr a' -> RowParser b'
gr)
                         ((a -> Int) -> (a' -> Int) -> Either a a' -> Int
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> Int
fb a' -> Int
gb)
    where QueryRunner Unpackspec a ()
fu a -> RowParser b
fr a -> Int
fb = FromFields a b
f
          QueryRunner Unpackspec a' ()
gu a' -> RowParser b'
gr a' -> Int
gb = FromFields a' b'
g

-- }

-- { Allow @postgresql-simple@ conversions from JSON types to 'String'

jsonFieldParser, jsonbFieldParser :: FieldParser String
jsonFieldParser :: FieldParser String
jsonFieldParser  = ByteString -> FieldParser String
jsonFieldTypeParser (String -> ByteString
forall a. IsString a => String -> a
String.fromString String
"json")
jsonbFieldParser :: FieldParser String
jsonbFieldParser = ByteString -> FieldParser String
jsonFieldTypeParser (String -> ByteString
forall a. IsString a => String -> a
String.fromString String
"jsonb")

-- typenames, not type Oids are used in order to avoid creating
-- a dependency on 'Database.PostgreSQL.LibPQ'
--
-- Eventually we want to move this to postgresql-simple
--
--     https://github.com/tomjaguarpaw/haskell-opaleye/issues/329
jsonFieldTypeParser :: SBS.ByteString -> FieldParser String
jsonFieldTypeParser :: ByteString -> FieldParser String
jsonFieldTypeParser ByteString
jsonTypeName Field
field Maybe ByteString
mData = do
    TypeInfo
ti <- Field -> Conversion TypeInfo
typeInfo Field
field
    if TypeInfo -> ByteString
TI.typname TypeInfo
ti ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
jsonTypeName
       then Conversion String
convert
       else (String -> Maybe Oid -> String -> String -> String -> ResultError)
-> Field -> String -> Conversion String
forall a err.
(Typeable a, Exception err) =>
(String -> Maybe Oid -> String -> String -> String -> err)
-> Field -> String -> Conversion a
returnError String -> Maybe Oid -> String -> String -> String -> ResultError
Incompatible Field
field String
"types incompatible"
  where
    convert :: Conversion String
convert = case Maybe ByteString
mData of
        Just ByteString
bs -> String -> Conversion String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Conversion String) -> String -> Conversion String
forall a b. (a -> b) -> a -> b
$ ByteString -> String
IPT.strictDecodeUtf8 ByteString
bs
        Maybe ByteString
_       -> (String -> Maybe Oid -> String -> String -> String -> ResultError)
-> Field -> String -> Conversion String
forall a err.
(Typeable a, Exception err) =>
(String -> Maybe Oid -> String -> String -> String -> err)
-> Field -> String -> Conversion a
returnError String -> Maybe Oid -> String -> String -> String -> ResultError
UnexpectedNull Field
field String
""

-- }

prepareRowParser :: FromFields columns haskells -> columns -> RowParser haskells
prepareRowParser :: FromFields columns haskells -> columns -> RowParser haskells
prepareRowParser (QueryRunner Unpackspec columns ()
_ columns -> RowParser haskells
rowParser columns -> Int
numColumns) columns
cols =
  if columns -> Int
numColumns columns
cols Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
  then columns -> RowParser haskells
rowParser columns
cols
  else (RowParser (Only Int)
forall a. FromRow a => RowParser a
fromRow :: RowParser (Only Int)) RowParser (Only Int) -> RowParser haskells -> RowParser haskells
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> columns -> RowParser haskells
rowParser columns
cols
     -- If we are selecting zero columns then the SQL
     -- generator will have to put a dummy 0 into the
     -- SELECT statement, since we can't select zero
     -- columns.  In that case we have to make sure we
     -- read a single Int.

-- | Cursor within a transaction.
data Cursor haskells = EmptyCursor | Cursor (RowParser haskells) PGSC.Cursor

prepareQuery :: FromFields fields haskells -> S.Select fields -> (Maybe PGS.Query, RowParser haskells)
prepareQuery :: FromFields fields haskells
-> Select fields -> (Maybe Query, RowParser haskells)
prepareQuery qr :: FromFields fields haskells
qr@(QueryRunner Unpackspec fields ()
u fields -> RowParser haskells
_ fields -> Int
_) Select fields
q = (Maybe Query
sql, RowParser haskells
parser)
  where sql :: Maybe PGS.Query
        sql :: Maybe Query
sql = (String -> Query) -> Maybe String -> Maybe Query
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Query
forall a. IsString a => String -> a
String.fromString (Unpackspec fields () -> Select fields -> Maybe String
forall fields b.
Unpackspec fields b -> Select fields -> Maybe String
S.showSqlExplicit Unpackspec fields ()
u Select fields
q)
        -- FIXME: We're doing work twice here
        (fields
b, PrimQuery
_, Tag
_) = Select fields -> () -> (fields, PrimQuery, Tag)
forall a b. QueryArr a b -> a -> (b, PrimQuery, Tag)
Q.runSimpleQueryArrStart Select fields
q ()
        parser :: RowParser haskells
parser = FromFields fields haskells -> fields -> RowParser haskells
forall columns haskells.
FromFields columns haskells -> columns -> RowParser haskells
prepareRowParser FromFields fields haskells
qr fields
b