{-# OPTIONS_HADDOCK not-home #-}

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Opaleye.Internal.MaybeFields where

import           Control.Arrow (returnA, (<<<), (>>>))

import qualified Opaleye.Internal.Binary as B
import qualified Opaleye.Internal.Column as IC
import qualified Opaleye.ToFields as Constant
import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ
import           Opaleye.Internal.Inferrable (Inferrable(Inferrable),
                                              runInferrable)
import qualified Opaleye.Internal.QueryArr as IQ
import qualified Opaleye.Internal.Rebind as Rebind
import qualified Opaleye.Internal.RunQuery as RQ
import qualified Opaleye.Internal.Unpackspec as U
import qualified Opaleye.Internal.Values as V
import           Opaleye.Select (Select, SelectArr)
import qualified Opaleye.Column
import qualified Opaleye.Field
import           Opaleye.Field (Field)
import           Opaleye.Internal.Operators ((.&&), (.||), (.==), restrict, not,
                                             ifExplict, IfPP, EqPP(EqPP))
import qualified Opaleye.Internal.Lateral
import qualified Opaleye.SqlTypes
import           Opaleye.SqlTypes (SqlBool, IsSqlType)

import           Control.Monad (replicateM_)

import qualified Data.Profunctor as P
import qualified Data.Profunctor.Product as PP
import qualified Data.Profunctor.Product.Default as PP

import qualified Database.PostgreSQL.Simple.FromRow as PGSR

-- | The Opaleye analogue of 'Data.Maybe.Maybe'.  A value of type
-- @MaybeFields a@ either contains a value of type @a@, or it contains
-- nothing.
data MaybeFields fields =
  MaybeFields {
    forall fields. MaybeFields fields -> Column SqlBool
mfPresent :: Opaleye.Column.Column Opaleye.SqlTypes.SqlBool
  , forall fields. MaybeFields fields -> fields
mfFields  :: fields
  }
  deriving forall a b. a -> MaybeFields b -> MaybeFields a
forall a b. (a -> b) -> MaybeFields a -> MaybeFields b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> MaybeFields b -> MaybeFields a
$c<$ :: forall a b. a -> MaybeFields b -> MaybeFields a
fmap :: forall a b. (a -> b) -> MaybeFields a -> MaybeFields b
$cfmap :: forall a b. (a -> b) -> MaybeFields a -> MaybeFields b
Functor

instance Applicative MaybeFields where
  pure :: forall a. a -> MaybeFields a
pure a
fields = MaybeFields { mfPresent :: Column SqlBool
mfPresent = Bool -> Field SqlBool
Opaleye.SqlTypes.sqlBool Bool
True
                            , mfFields :: a
mfFields  = a
fields
                            }
  MaybeFields Column SqlBool
t a -> b
f <*> :: forall a b. MaybeFields (a -> b) -> MaybeFields a -> MaybeFields b
<*> MaybeFields Column SqlBool
t' a
a =
    MaybeFields {
      mfPresent :: Column SqlBool
mfPresent = Column SqlBool
t Field SqlBool -> Field SqlBool -> Field SqlBool
.&& Column SqlBool
t'
    , mfFields :: b
mfFields  = a -> b
f a
a
    }

instance Monad MaybeFields where
  return :: forall a. a -> MaybeFields a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  MaybeFields Column SqlBool
t a
a >>= :: forall a b. MaybeFields a -> (a -> MaybeFields b) -> MaybeFields b
>>= a -> MaybeFields b
f = case a -> MaybeFields b
f a
a of
    MaybeFields Column SqlBool
t' b
b -> forall fields. Column SqlBool -> fields -> MaybeFields fields
MaybeFields (Column SqlBool
t Field SqlBool -> Field SqlBool -> Field SqlBool
.&& Column SqlBool
t') b
b

-- | The Opaleye analogue of 'Data.Maybe.Nothing'.
nothingFields :: PP.Default V.Nullspec a a => MaybeFields a
nothingFields :: forall a. Default Nullspec a a => MaybeFields a
nothingFields = forall a b. Nullspec a b -> MaybeFields b
nothingFieldsExplicit forall a. Default Nullspec a a => Nullspec a a
def
  where def :: PP.Default V.Nullspec a a => V.Nullspec a a
        def :: forall a. Default Nullspec a a => Nullspec a a
def = forall (p :: * -> * -> *) a b. Default p a b => p a b
PP.def

-- | The Opaleye analogue of @'Prelude.const' 'Data.Maybe.Nothing'@.
-- Can be useful to avoid type inference problems, because it doesn't
-- pick up a type class constraint.
nothingFieldsOfTypeOf :: a -> MaybeFields a
nothingFieldsOfTypeOf :: forall a. a -> MaybeFields a
nothingFieldsOfTypeOf a
a = MaybeFields {
    mfPresent :: Column SqlBool
mfPresent = Bool -> Field SqlBool
Opaleye.SqlTypes.sqlBool Bool
False
  , mfFields :: a
mfFields  = a
a
  }

-- | The Opaleye analogue of 'Data.Maybe.Just'.  Equivalent to
-- 'Control.Applicative.pure'.
justFields :: a -> MaybeFields a
justFields :: forall a. a -> MaybeFields a
justFields = forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | The Opaleye analogue of 'Data.Maybe.maybe'
maybeFields :: PP.Default IfPP b b => b -> (a -> b) -> MaybeFields a -> b
maybeFields :: forall b a. Default IfPP b b => b -> (a -> b) -> MaybeFields a -> b
maybeFields = forall b b' a. IfPP b b' -> b -> (a -> b) -> MaybeFields a -> b'
maybeFieldsExplicit forall (p :: * -> * -> *) a b. Default p a b => p a b
PP.def

-- | Use a Haskell @\\case@ expression to pattern match on a
-- 'MaybeFields'.
--
-- @
-- example :: MaybeFields (Field SqlInt4) -> Field SqlInt4
-- example mf = matchMaybe mf $ \\case
--   Nothing -> 0
--   Just x  -> x * 100
-- @
matchMaybe :: PP.Default IfPP b b => MaybeFields a -> (Maybe a -> b) -> b
matchMaybe :: forall b a.
Default IfPP b b =>
MaybeFields a -> (Maybe a -> b) -> b
matchMaybe MaybeFields a
mf Maybe a -> b
f = forall b a. Default IfPP b b => b -> (a -> b) -> MaybeFields a -> b
maybeFields (Maybe a -> b
f forall a. Maybe a
Nothing) (Maybe a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just) MaybeFields a
mf

-- | The Opaleye analogue of 'Data.Maybe.fromMaybe'
fromMaybeFields :: PP.Default IfPP b b => b -> MaybeFields b -> b
fromMaybeFields :: forall b. Default IfPP b b => b -> MaybeFields b -> b
fromMaybeFields = forall b. IfPP b b -> b -> MaybeFields b -> b
fromMaybeFieldsExplicit forall (p :: * -> * -> *) a b. Default p a b => p a b
PP.def

-- | The Opaleye analogue of 'Data.Maybe.maybeToList'. Unless you are
-- using arrow notation you'll probably find 'catMaybeFields' easier
-- to use.
maybeFieldsToSelect :: SelectArr (MaybeFields a) a
maybeFieldsToSelect :: forall a. SelectArr (MaybeFields a) a
maybeFieldsToSelect = proc MaybeFields a
mf -> do
  SelectArr (Field SqlBool) ()
restrict -< forall fields. MaybeFields fields -> Column SqlBool
mfPresent MaybeFields a
mf
  forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< forall fields. MaybeFields fields -> fields
mfFields MaybeFields a
mf

-- | The Opaleye analogue of 'Data.Maybe.catMaybes'.  Most commonly
-- you will want to use this at type
--
-- @
-- catMaybeFields :: Select (MaybeFields a) -> Select a
-- @
catMaybeFields :: SelectArr i (MaybeFields a) -> SelectArr i a
catMaybeFields :: forall i a. SelectArr i (MaybeFields a) -> SelectArr i a
catMaybeFields = (forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a. SelectArr (MaybeFields a) a
maybeFieldsToSelect)

maybeFieldsExplicit :: IfPP b b' -> b -> (a -> b) -> MaybeFields a -> b'
maybeFieldsExplicit :: forall b b' a. IfPP b b' -> b -> (a -> b) -> MaybeFields a -> b'
maybeFieldsExplicit IfPP b b'
ifpp b
b a -> b
f MaybeFields a
mf =
  forall columns columns'.
IfPP columns columns'
-> Field SqlBool -> columns -> columns -> columns'
ifExplict IfPP b b'
ifpp (forall fields. MaybeFields fields -> Column SqlBool
mfPresent MaybeFields a
mf) (a -> b
f (forall fields. MaybeFields fields -> fields
mfFields MaybeFields a
mf)) b
b

fromMaybeFieldsExplicit :: IfPP b b -> b -> MaybeFields b -> b
fromMaybeFieldsExplicit :: forall b. IfPP b b -> b -> MaybeFields b -> b
fromMaybeFieldsExplicit IfPP b b
ifpp = forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall b b' a. IfPP b b' -> b -> (a -> b) -> MaybeFields a -> b'
maybeFieldsExplicit IfPP b b
ifpp) forall a. a -> a
id

nothingFieldsExplicit :: V.Nullspec a b -> MaybeFields b
nothingFieldsExplicit :: forall a b. Nullspec a b -> MaybeFields b
nothingFieldsExplicit = forall a. a -> MaybeFields a
nothingFieldsOfTypeOf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a fields. Nullspec a fields -> fields
V.nullFields

traverseMaybeFields :: SelectArr a b -> SelectArr (MaybeFields a) (MaybeFields b)
traverseMaybeFields :: forall a b.
SelectArr a b -> SelectArr (MaybeFields a) (MaybeFields b)
traverseMaybeFields SelectArr a b
query = proc MaybeFields a
mfInput -> do
  MaybeFields b
mfOutput <- forall i a. SelectArr i a -> SelectArr i (MaybeFields a)
optional (SelectArr a b
query forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< forall a. SelectArr (MaybeFields a) a
maybeFieldsToSelect) -< MaybeFields a
mfInput
  SelectArr (Field SqlBool) ()
restrict -< forall fields. MaybeFields fields -> Column SqlBool
mfPresent MaybeFields a
mfInput Field SqlBool -> Field SqlBool -> Field SqlBool
`implies` forall fields. MaybeFields fields -> Column SqlBool
mfPresent MaybeFields b
mfOutput
  forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< forall fields. Column SqlBool -> fields -> MaybeFields fields
MaybeFields (forall fields. MaybeFields fields -> Column SqlBool
mfPresent MaybeFields a
mfInput) (forall fields. MaybeFields fields -> fields
mfFields MaybeFields b
mfOutput)

  where Field SqlBool
a implies :: Field SqlBool -> Field SqlBool -> Field SqlBool
`implies` Field SqlBool
b = Field SqlBool -> Field SqlBool
Opaleye.Internal.Operators.not Field SqlBool
a Field SqlBool -> Field SqlBool -> Field SqlBool
.|| Field SqlBool
b

optional :: SelectArr i a -> SelectArr i (MaybeFields a)
optional :: forall i a. SelectArr i a -> SelectArr i (MaybeFields a)
optional = forall a b i.
(Select a -> Select b) -> SelectArr i a -> SelectArr i b
Opaleye.Internal.Lateral.laterally (forall a r.
(FieldNullable SqlBool -> a -> r) -> Select a -> Select r
optionalInternal (forall fields. Column SqlBool -> fields -> MaybeFields fields
MaybeFields forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. FieldNullable a -> Field SqlBool
isNotNull))
  where isNotNull :: FieldNullable a -> Field SqlBool
isNotNull = Field SqlBool -> Field SqlBool
Opaleye.Internal.Operators.not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. FieldNullable a -> Field SqlBool
Opaleye.Field.isNull

optionalInternal :: (Opaleye.Field.FieldNullable SqlBool -> a -> r) -> Select a -> Select r
optionalInternal :: forall a r.
(FieldNullable SqlBool -> a -> r) -> Select a -> Select r
optionalInternal FieldNullable SqlBool -> a -> r
f Select a
query = forall a b.
State Tag (a -> (b, PrimExpr, PrimQuery)) -> QueryArr a b
IQ.leftJoinQueryArr' forall a b. (a -> b) -> a -> b
$ do
    -- This is basically a left join on TRUE, but Shane (@duairc)
    -- wrote it to ensure that we don't need an Unpackspec a a.
    let true :: PrimExpr
true = Literal -> PrimExpr
HPQ.ConstExpr (Bool -> Literal
HPQ.BoolLit Bool
True)
    (r
r, PrimQuery
right) <- forall a. Select a -> State Tag (a, PrimQuery)
IQ.runSimpleSelect forall a b. (a -> b) -> a -> b
$ proc () -> do
          a
a <- Select a
query -< ()
          FieldNullable SqlBool
true_ <- forall a. Default Unpackspec a a => SelectArr a a
Rebind.rebind -< forall a. Field a -> FieldNullable a
Opaleye.Field.toNullable (forall (n :: Nullability) sqlType. PrimExpr -> Field_ n sqlType
IC.Column PrimExpr
true)
          forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< FieldNullable SqlBool -> a -> r
f FieldNullable SqlBool
true_ a
a
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ \() -> (r
r, PrimExpr
true, PrimQuery
right)


-- | An example to demonstrate how the functionality of (lateral)
-- @LEFT JOIN@ can be recovered using 'optional'.
lateralLeftJoinOptional :: SelectArr i a
                        -> SelectArr i b
                        -> ((a, b) -> Opaleye.Field.Field Opaleye.SqlTypes.SqlBool)
                        -> SelectArr i (a, MaybeFields b)
lateralLeftJoinOptional :: forall i a b.
SelectArr i a
-> SelectArr i b
-> ((a, b) -> Field SqlBool)
-> SelectArr i (a, MaybeFields b)
lateralLeftJoinOptional SelectArr i a
fieldsL SelectArr i b
fieldsR (a, b) -> Field SqlBool
cond = proc i
i -> do
  a
fieldsL' <- SelectArr i a
fieldsL -< i
i
  MaybeFields b
maybeFieldsR' <- forall i a. SelectArr i a -> SelectArr i (MaybeFields a)
optional (proc (a
fieldsL', i
i) -> do
                                b
fieldsR' <- SelectArr i b
fieldsR -< i
i
                                SelectArr (Field SqlBool) ()
restrict -< (a, b) -> Field SqlBool
cond (a
fieldsL', b
fieldsR')
                                forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< b
fieldsR'
                                ) -< (a
fieldsL', i
i)
  forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< (a
fieldsL', MaybeFields b
maybeFieldsR')

-- | An example to demonstrate how the functionality of
-- 'Opaleye.Join.optionalRestrict' can be recovered using 'optional'.
optionalRestrictOptional :: Select a
                         -> SelectArr (a -> Field SqlBool) (MaybeFields a)
optionalRestrictOptional :: forall a.
Select a -> SelectArr (a -> Field SqlBool) (MaybeFields a)
optionalRestrictOptional Select a
q = forall i a. SelectArr i a -> SelectArr i (MaybeFields a)
optional forall a b. (a -> b) -> a -> b
$ proc a -> Field SqlBool
cond -> do
  a
a <- Select a
q -< ()
  SelectArr (Field SqlBool) ()
restrict -< a -> Field SqlBool
cond a
a
  forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< a
a

-- | Convert @NULL@ to 'nothingFields' and non-@NULL@ to a 'justFields'
nullableToMaybeFields :: Opaleye.Field.FieldNullable a -> MaybeFields (Field a)
nullableToMaybeFields :: forall a. FieldNullable a -> MaybeFields (Field a)
nullableToMaybeFields FieldNullable a
x = MaybeFields
  { mfPresent :: Column SqlBool
mfPresent = Field SqlBool -> Field SqlBool
Opaleye.Internal.Operators.not (forall {a}. FieldNullable a -> Field SqlBool
Opaleye.Field.isNull FieldNullable a
x)
  , mfFields :: Field a
mfFields = forall a. FieldNullable a -> Field a
unsafeFromNonNull FieldNullable a
x
  }
  where unsafeFromNonNull :: Opaleye.Field.FieldNullable a -> Field a
        unsafeFromNonNull :: forall a. FieldNullable a -> Field a
unsafeFromNonNull = forall (n :: Nullability) a (n' :: Nullability) b.
Field_ n a -> Field_ n' b
Opaleye.Field.unsafeCoerceField

-- | Convert 'nothingFields' to @NULL@ to a 'justFields' to non-@NULL@
maybeFieldsToNullable :: MaybeFields (Field a) -> Opaleye.Field.FieldNullable a
maybeFieldsToNullable :: forall a. MaybeFields (Field a) -> FieldNullable a
maybeFieldsToNullable MaybeFields (Field a)
x =
  forall (n' :: Nullability) pgBool (n :: Nullability) a.
Field_ n' pgBool -> Field_ n a -> Field_ n a -> Field_ n a
IC.unsafeIfThenElse (forall fields. MaybeFields fields -> Column SqlBool
mfPresent MaybeFields (Field a)
x)
                      (forall a. Field a -> FieldNullable a
Opaleye.Field.toNullable (forall fields. MaybeFields fields -> fields
mfFields MaybeFields (Field a)
x))
                      forall a. FieldNullable a
Opaleye.Field.null

fromFieldsMaybeFields :: RQ.FromFields fields haskells
                      -> RQ.FromFields (MaybeFields fields) (Maybe haskells)
fromFieldsMaybeFields :: forall fields haskells.
FromFields fields haskells
-> FromFields (MaybeFields fields) (Maybe haskells)
fromFieldsMaybeFields (RQ.FromFields Unpackspec fields ()
u fields -> RowParser haskells
p fields -> Int
c) = forall fields haskells.
Unpackspec fields ()
-> (fields -> RowParser haskells)
-> (fields -> Int)
-> FromFields fields haskells
RQ.FromFields Unpackspec (MaybeFields fields) ()
u' MaybeFields fields -> RowParser (Maybe haskells)
p' MaybeFields fields -> Int
c'
  where u' :: Unpackspec (MaybeFields fields) ()
u' = () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (p :: * -> * -> *) a b.
ProductProfunctor p =>
p (Field SqlBool) (Field SqlBool)
-> p a b -> p (MaybeFields a) (MaybeFields b)
productProfunctorMaybeFields forall (n :: Nullability) a. Unpackspec (Field_ n a) (Field_ n a)
U.unpackspecField Unpackspec fields ()
u

        p' :: MaybeFields fields -> RowParser (Maybe haskells)
p' = \MaybeFields fields
mf -> do
          Bool
hIsPresent <- forall a. FromField a => RowParser a
PGSR.field

          case Bool
hIsPresent of
            Bool
True  -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> fields -> RowParser haskells
p (forall fields. MaybeFields fields -> fields
mfFields MaybeFields fields
mf)
            Bool
False -> forall a. Maybe a
Nothing forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ (fields -> Int
c (forall fields. MaybeFields fields -> fields
mfFields MaybeFields fields
mf))
                                            (forall a. FieldParser a -> RowParser a
PGSR.fieldWith (\Field
_ Maybe ByteString
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()))

        c' :: MaybeFields fields -> Int
c' = \MaybeFields fields
mf -> fields -> Int
c (forall fields. MaybeFields fields -> fields
mfFields MaybeFields fields
mf) forall a. Num a => a -> a -> a
+ Int
1

-- | This is not safe in general because it relies on p not doing
-- anything observable with the @a@s if @mfPresent@ is false.  In
-- particular, it won't work for
-- 'Opaleye.Internal.Distinct.Distinctspec' because it does indeed
-- look at the @mfFields@ to check distinctness.
productProfunctorMaybeFields :: PP.ProductProfunctor p
                             => p (Field SqlBool) (Field SqlBool)
                             -> p a b
                             -> p (MaybeFields a) (MaybeFields b)
productProfunctorMaybeFields :: forall (p :: * -> * -> *) a b.
ProductProfunctor p =>
p (Field SqlBool) (Field SqlBool)
-> p a b -> p (MaybeFields a) (MaybeFields b)
productProfunctorMaybeFields p (Field SqlBool) (Field SqlBool)
b p a b
p = forall fields. Column SqlBool -> fields -> MaybeFields fields
MaybeFields forall (p :: * -> * -> *) b c a.
ProductProfunctor p =>
(b -> c) -> p a b -> p a c
PP.***$ forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
P.lmap forall fields. MaybeFields fields -> Column SqlBool
mfPresent p (Field SqlBool) (Field SqlBool)
b
                                               forall (p :: * -> * -> *) a b c.
ProductProfunctor p =>
p a (b -> c) -> p a b -> p a c
PP.**** forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
P.lmap forall fields. MaybeFields fields -> fields
mfFields p a b
p

nullspecMaybeFields :: V.Nullspec a b
                    -> V.Nullspec (MaybeFields a) (MaybeFields b)
nullspecMaybeFields :: forall a b.
Nullspec a b -> Nullspec (MaybeFields a) (MaybeFields b)
nullspecMaybeFields = forall (p :: * -> * -> *) a b.
ProductProfunctor p =>
p (Field SqlBool) (Field SqlBool)
-> p a b -> p (MaybeFields a) (MaybeFields b)
productProfunctorMaybeFields forall a (n :: Nullability) sqlType.
IsSqlType sqlType =>
Nullspec a (Field_ n sqlType)
V.nullspecField

unpackspecMaybeFields :: U.Unpackspec a b
                      -> U.Unpackspec (MaybeFields a) (MaybeFields b)
unpackspecMaybeFields :: forall a b.
Unpackspec a b -> Unpackspec (MaybeFields a) (MaybeFields b)
unpackspecMaybeFields = forall (p :: * -> * -> *) a b.
ProductProfunctor p =>
p (Field SqlBool) (Field SqlBool)
-> p a b -> p (MaybeFields a) (MaybeFields b)
productProfunctorMaybeFields forall (n :: Nullability) a. Unpackspec (Field_ n a) (Field_ n a)
U.unpackspecField

valuesspecMaybeFields :: V.Valuesspec a b
                      -> V.Valuesspec (MaybeFields a) (MaybeFields b)
valuesspecMaybeFields :: forall a b.
Valuesspec a b -> Valuesspec (MaybeFields a) (MaybeFields b)
valuesspecMaybeFields = forall (p :: * -> * -> *) a b.
ProductProfunctor p =>
p (Field SqlBool) (Field SqlBool)
-> p a b -> p (MaybeFields a) (MaybeFields b)
productProfunctorMaybeFields forall a (n :: Nullability).
IsSqlType a =>
Valuesspec (Field_ n a) (Field_ n a)
V.valuesspecField

toFieldsMaybeFields :: V.Nullspec a b
                    -> Constant.ToFields a b
                    -> Constant.ToFields (Maybe a) (MaybeFields b)
toFieldsMaybeFields :: forall a b.
Nullspec a b -> ToFields a b -> ToFields (Maybe a) (MaybeFields b)
toFieldsMaybeFields Nullspec a b
n ToFields a b
p = forall haskells fields.
(haskells -> fields) -> ToFields haskells fields
Constant.toToFields forall a b. (a -> b) -> a -> b
$ \case
  Maybe a
Nothing -> forall a b. Nullspec a b -> MaybeFields b
nothingFieldsExplicit Nullspec a b
n
  Just a
a  -> forall a. a -> MaybeFields a
justFields (forall haskells fields.
ToFields haskells fields -> haskells -> fields
Constant.toFieldsExplicit ToFields a b
p a
a)

ifPPMaybeFields :: IfPP a b -> IfPP (MaybeFields a) (MaybeFields b)
ifPPMaybeFields :: forall a b. IfPP a b -> IfPP (MaybeFields a) (MaybeFields b)
ifPPMaybeFields = forall (p :: * -> * -> *) a b.
ProductProfunctor p =>
p (Field SqlBool) (Field SqlBool)
-> p a b -> p (MaybeFields a) (MaybeFields b)
productProfunctorMaybeFields forall (p :: * -> * -> *) a b. Default p a b => p a b
PP.def

-- I'd rather not crack open EqPP to implement this but the
-- alternative is adding an operation eqPPOr :: EqPP a b -> EqPP a' b
-- -> EqPP (a, a') b, and possibly even more than that, so I can't be
-- bothered right now.
eqPPMaybeFields :: EqPP a b -> EqPP (MaybeFields a) (MaybeFields b)
eqPPMaybeFields :: forall a b. EqPP a b -> EqPP (MaybeFields a) (MaybeFields b)
eqPPMaybeFields (EqPP a -> a -> Field SqlBool
eqFields) = forall a b. (a -> a -> Field SqlBool) -> EqPP a b
EqPP (\MaybeFields a
m1 MaybeFields a
m2 ->
    (forall fields. MaybeFields fields -> Column SqlBool
mfPresent MaybeFields a
m1 forall columns.
Default EqPP columns columns =>
columns -> columns -> Field SqlBool
.== forall fields. MaybeFields fields -> Column SqlBool
mfPresent MaybeFields a
m2)
    Field SqlBool -> Field SqlBool -> Field SqlBool
.&& (forall fields. MaybeFields fields -> Column SqlBool
mfPresent MaybeFields a
m1 Field SqlBool -> Field SqlBool -> Field SqlBool
`implies` a -> a -> Field SqlBool
eqFields (forall fields. MaybeFields fields -> fields
mfFields MaybeFields a
m1) (forall fields. MaybeFields fields -> fields
mfFields MaybeFields a
m2)))
  where Field SqlBool
a implies :: Field SqlBool -> Field SqlBool -> Field SqlBool
`implies` Field SqlBool
b = Field SqlBool -> Field SqlBool
Opaleye.Internal.Operators.not Field SqlBool
a Field SqlBool -> Field SqlBool -> Field SqlBool
.|| Field SqlBool
b

-- | This is only safe if d is OK with having nulls passed through it
-- when they claim to be non-null.
unWithNulls :: PP.ProductProfunctor p
            => p (Field SqlBool) (Field SqlBool)
            -> WithNulls p a b
            -> p (MaybeFields a) (MaybeFields b)
unWithNulls :: forall (p :: * -> * -> *) a b.
ProductProfunctor p =>
p (Field SqlBool) (Field SqlBool)
-> WithNulls p a b -> p (MaybeFields a) (MaybeFields b)
unWithNulls p (Field SqlBool) (Field SqlBool)
b (WithNulls p (MaybeFields a) b
d) =
    forall fields. Column SqlBool -> fields -> MaybeFields fields
MaybeFields forall (p :: * -> * -> *) b c a.
ProductProfunctor p =>
(b -> c) -> p a b -> p a c
PP.***$ forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
P.lmap forall fields. MaybeFields fields -> Column SqlBool
mfPresent p (Field SqlBool) (Field SqlBool)
b
                forall (p :: * -> * -> *) a b c.
ProductProfunctor p =>
p a (b -> c) -> p a b -> p a c
PP.**** p (MaybeFields a) b
d

newtype WithNulls p a b =
  WithNulls (p (MaybeFields a) b)

-- | This is only safe if @b@ is OK with having nulls passed through it
-- when they claim to be non-null.
mapMaybeFieldsWithNulls :: PP.ProductProfunctor p
                        => p (Field SqlBool) (Field SqlBool)
                        -> WithNulls p a b
                        -> WithNulls p (MaybeFields a) (MaybeFields b)
mapMaybeFieldsWithNulls :: forall (p :: * -> * -> *) a b.
ProductProfunctor p =>
p (Field SqlBool) (Field SqlBool)
-> WithNulls p a b -> WithNulls p (MaybeFields a) (MaybeFields b)
mapMaybeFieldsWithNulls p (Field SqlBool) (Field SqlBool)
b WithNulls p a b
d =
  forall fields. Column SqlBool -> fields -> MaybeFields fields
MaybeFields forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
P.lmap forall fields. MaybeFields fields -> Column SqlBool
mfPresent (forall a (p :: * -> * -> *) (n :: Nullability).
(IsSqlType a, Profunctor p) =>
p (Field_ n a) (Field_ n a)
-> WithNulls p (Field_ n a) (Field_ n a)
withNullsField p (Field SqlBool) (Field SqlBool)
b)
              forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
P.lmap forall fields. MaybeFields fields -> fields
mfFields WithNulls p a b
d

-- | This is only safe if @col@ is OK with having nulls passed through it
-- when they claim to be non-null.
withNullsField :: (IsSqlType a, P.Profunctor p)
               => p (IC.Field_ n a) (IC.Field_ n a)
               -> WithNulls p (IC.Field_ n a) (IC.Field_ n a)
withNullsField :: forall a (p :: * -> * -> *) (n :: Nullability).
(IsSqlType a, Profunctor p) =>
p (Field_ n a) (Field_ n a)
-> WithNulls p (Field_ n a) (Field_ n a)
withNullsField p (Field_ n a) (Field_ n a)
col = WithNulls p (Field_ n a) (Field_ n a)
result
  where result :: WithNulls p (Field_ n a) (Field_ n a)
result = forall (p :: * -> * -> *) a b.
p (MaybeFields a) b -> WithNulls p a b
WithNulls (forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
P.lmap (\(MaybeFields Column SqlBool
b Field_ n a
c) ->
                                      forall columns columns'.
IfPP columns columns'
-> Field SqlBool -> columns -> columns -> columns'
ifExplict forall (p :: * -> * -> *) a b. Default p a b => p a b
PP.def Column SqlBool
b Field_ n a
c forall {n :: Nullability}. Field_ n a
nullC) p (Field_ n a) (Field_ n a)
col)
        nullC :: Field_ n a
nullC = forall a fields. Nullspec a fields -> fields
V.nullFields forall a (n :: Nullability) sqlType.
IsSqlType sqlType =>
Nullspec a (Field_ n sqlType)
V.nullspecField

binaryspecMaybeFields
  :: WithNulls B.Binaryspec a b
  -> B.Binaryspec (MaybeFields a) (MaybeFields b)
binaryspecMaybeFields :: forall a b.
WithNulls Binaryspec a b
-> Binaryspec (MaybeFields a) (MaybeFields b)
binaryspecMaybeFields = forall (p :: * -> * -> *) a b.
ProductProfunctor p =>
p (Field SqlBool) (Field SqlBool)
-> WithNulls p a b -> p (MaybeFields a) (MaybeFields b)
unWithNulls forall (p :: * -> * -> *) a b. Default p a b => p a b
PP.def

instance P.Profunctor p => P.Profunctor (WithNulls p) where
  dimap :: forall a b c d.
(a -> b) -> (c -> d) -> WithNulls p b c -> WithNulls p a d
dimap a -> b
f c -> d
g (WithNulls p (MaybeFields b) c
d) = forall (p :: * -> * -> *) a b.
p (MaybeFields a) b -> WithNulls p a b
WithNulls (forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
P.dimap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) c -> d
g p (MaybeFields b) c
d)

instance P.Profunctor p => Functor (WithNulls p a) where
  fmap :: forall a b. (a -> b) -> WithNulls p a a -> WithNulls p a b
fmap = forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
P.rmap

instance PP.ProductProfunctor p => Applicative (WithNulls p a) where
  pure :: forall a. a -> WithNulls p a a
pure = forall (p :: * -> * -> *) a b.
p (MaybeFields a) b -> WithNulls p a b
WithNulls forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) b a. ProductProfunctor p => b -> p a b
PP.purePP
  WithNulls p (MaybeFields a) (a -> b)
fd <*> :: forall a b.
WithNulls p a (a -> b) -> WithNulls p a a -> WithNulls p a b
<*> WithNulls p (MaybeFields a) a
xd = forall (p :: * -> * -> *) a b.
p (MaybeFields a) b -> WithNulls p a b
WithNulls (p (MaybeFields a) (a -> b)
fd forall (p :: * -> * -> *) a b c.
ProductProfunctor p =>
p a (b -> c) -> p a b -> p a c
PP.**** p (MaybeFields a) a
xd)

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

instance PP.SumProfunctor p => PP.SumProfunctor (WithNulls p) where
  WithNulls p (MaybeFields a) b
ff +++! :: forall a b a' b'.
WithNulls p a b
-> WithNulls p a' b' -> WithNulls p (Either a a') (Either b b')
+++! WithNulls p (MaybeFields a') b'
xf =
    forall (p :: * -> * -> *) a b.
p (MaybeFields a) b -> WithNulls p a b
WithNulls (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
P.lmap (p (MaybeFields a) b
ff forall (p :: * -> * -> *) a b a' b'.
SumProfunctor p =>
p a b -> p a' b' -> p (Either a a') (Either b b')
PP.+++! p (MaybeFields a') b'
xf) forall a b. (a -> b) -> a -> b
$ \case
                  MaybeFields Column SqlBool
b (Left a
l)  -> forall a b. a -> Either a b
Left  (forall fields. Column SqlBool -> fields -> MaybeFields fields
MaybeFields Column SqlBool
b a
l)
                  MaybeFields Column SqlBool
b (Right a'
r) -> forall a b. b -> Either a b
Right (forall fields. Column SqlBool -> fields -> MaybeFields fields
MaybeFields Column SqlBool
b a'
r))

instance PP.Default RQ.FromFields fields haskells
  => PP.Default RQ.FromFields (MaybeFields fields) (Maybe haskells) where
  def :: FromFields (MaybeFields fields) (Maybe haskells)
def = forall fields haskells.
FromFields fields haskells
-> FromFields (MaybeFields fields) (Maybe haskells)
fromFieldsMaybeFields forall (p :: * -> * -> *) a b. Default p a b => p a b
PP.def

instance PP.Default U.Unpackspec a b
  => PP.Default U.Unpackspec (MaybeFields a) (MaybeFields b) where
  def :: Unpackspec (MaybeFields a) (MaybeFields b)
def = forall a b.
Unpackspec a b -> Unpackspec (MaybeFields a) (MaybeFields b)
unpackspecMaybeFields forall (p :: * -> * -> *) a b. Default p a b => p a b
PP.def

instance PP.Default V.Valuesspec a b
  => PP.Default V.Valuesspec (MaybeFields a) (MaybeFields b) where
  def :: Valuesspec (MaybeFields a) (MaybeFields b)
def = forall a b.
Valuesspec a b -> Valuesspec (MaybeFields a) (MaybeFields b)
valuesspecMaybeFields forall (p :: * -> * -> *) a b. Default p a b => p a b
PP.def

instance (PP.Default Constant.ToFields a b, PP.Default V.Nullspec a b)
  => PP.Default Constant.ToFields (Maybe a) (MaybeFields b) where
  def :: ToFields (Maybe a) (MaybeFields b)
def = forall a b.
Nullspec a b -> ToFields a b -> ToFields (Maybe a) (MaybeFields b)
toFieldsMaybeFields forall (p :: * -> * -> *) a b. Default p a b => p a b
PP.def forall (p :: * -> * -> *) a b. Default p a b => p a b
PP.def

instance PP.Default IfPP a b
  => PP.Default IfPP (MaybeFields a) (MaybeFields b) where
  def :: IfPP (MaybeFields a) (MaybeFields b)
def = forall a b. IfPP a b -> IfPP (MaybeFields a) (MaybeFields b)
ifPPMaybeFields forall (p :: * -> * -> *) a b. Default p a b => p a b
PP.def

instance PP.Default EqPP a b
  => PP.Default EqPP (MaybeFields a) (MaybeFields b) where
  def :: EqPP (MaybeFields a) (MaybeFields b)
def = forall a b. EqPP a b -> EqPP (MaybeFields a) (MaybeFields b)
eqPPMaybeFields forall (p :: * -> * -> *) a b. Default p a b => p a b
PP.def

instance (P.Profunctor p, IsSqlType a, PP.Default p (IC.Field_ n a) (IC.Field_ n a))
  => PP.Default (WithNulls p) (IC.Field_ n a) (IC.Field_ n a) where
  def :: WithNulls p (Field_ n a) (Field_ n a)
def = forall a (p :: * -> * -> *) (n :: Nullability).
(IsSqlType a, Profunctor p) =>
p (Field_ n a) (Field_ n a)
-> WithNulls p (Field_ n a) (Field_ n a)
withNullsField forall (p :: * -> * -> *) a b. Default p a b => p a b
PP.def

instance PP.Default (WithNulls B.Binaryspec) a b
  => PP.Default B.Binaryspec (MaybeFields a) (MaybeFields b) where
  def :: Binaryspec (MaybeFields a) (MaybeFields b)
def = forall a b.
WithNulls Binaryspec a b
-> Binaryspec (MaybeFields a) (MaybeFields b)
binaryspecMaybeFields forall (p :: * -> * -> *) a b. Default p a b => p a b
PP.def

instance (PP.Default (Inferrable RQ.FromFields) fields haskells,
          Maybe haskells ~ maybe_haskells)
  => PP.Default (Inferrable RQ.FromFields) (MaybeFields fields) maybe_haskells where
  def :: Inferrable FromFields (MaybeFields fields) maybe_haskells
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable (forall fields haskells.
FromFields fields haskells
-> FromFields (MaybeFields fields) (Maybe haskells)
fromFieldsMaybeFields (forall (p :: * -> * -> *) a b. Inferrable p a b -> p a b
runInferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
PP.def))

instance (PP.Default (Inferrable Constant.ToFields) a b, PP.Default V.Nullspec a b,
          MaybeFields b ~ maybeFields_b)
  => PP.Default (Inferrable Constant.ToFields) (Maybe a) maybeFields_b where
  def :: Inferrable ToFields (Maybe a) maybeFields_b
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable (forall a b.
Nullspec a b -> ToFields a b -> ToFields (Maybe a) (MaybeFields b)
toFieldsMaybeFields forall (p :: * -> * -> *) a b. Default p a b => p a b
PP.def (forall (p :: * -> * -> *) a b. Inferrable p a b -> p a b
runInferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
PP.def))