{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveFunctor #-}
module Opaleye.Internal.MaybeFields where
import Control.Applicative hiding (optional)
import Control.Arrow (returnA, (<<<), (>>>))
import qualified Opaleye.Internal.Binary as B
import qualified Opaleye.Internal.Column as IC
import qualified Opaleye.Constant as Constant
import qualified Opaleye.Internal.PackMap as PM
import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ
import qualified Opaleye.Internal.PrimQuery as PQ
import qualified Opaleye.Internal.QueryArr as IQ
import qualified Opaleye.Internal.RunQuery as RQ
import qualified Opaleye.Internal.Tag as Tag
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
data MaybeFields fields =
MaybeFields {
mfPresent :: Opaleye.Column.Column Opaleye.SqlTypes.SqlBool
, mfFields :: fields
}
deriving Functor
instance Applicative MaybeFields where
pure fields = MaybeFields { mfPresent = Opaleye.SqlTypes.sqlBool True
, mfFields = fields
}
MaybeFields t f <*> MaybeFields t' a =
MaybeFields {
mfPresent = t .&& t'
, mfFields = f a
}
instance Monad MaybeFields where
return = pure
MaybeFields t a >>= f = case f a of
MaybeFields t' b -> MaybeFields (t .&& t') b
nothingFields :: PP.Default V.Nullspec a a => MaybeFields a
nothingFields = nothingFieldsExplicit def
where def :: PP.Default V.Nullspec a a => V.Nullspec a a
def = PP.def
nothingFieldsOfTypeOf :: a -> MaybeFields a
nothingFieldsOfTypeOf a = MaybeFields {
mfPresent = Opaleye.SqlTypes.sqlBool False
, mfFields = a
}
justFields :: a -> MaybeFields a
justFields = pure
maybeFields :: PP.Default IfPP b b => b -> (a -> b) -> MaybeFields a -> b
maybeFields = maybeFieldsExplicit PP.def
fromMaybeFields :: PP.Default IfPP b b => b -> MaybeFields b -> b
fromMaybeFields = fromMaybeFieldsExplicit PP.def
maybeFieldsToSelect :: SelectArr (MaybeFields a) a
maybeFieldsToSelect = proc mf -> do
restrict -< mfPresent mf
returnA -< mfFields mf
catMaybeFields :: SelectArr i (MaybeFields a) -> SelectArr i a
catMaybeFields = (>>> maybeFieldsToSelect)
maybeFieldsExplicit :: IfPP b b' -> b -> (a -> b) -> MaybeFields a -> b'
maybeFieldsExplicit ifpp b f mf =
ifExplict ifpp (mfPresent mf) (f (mfFields mf)) b
fromMaybeFieldsExplicit :: IfPP b b -> b -> MaybeFields b -> b
fromMaybeFieldsExplicit ifpp = flip (maybeFieldsExplicit ifpp) id
nothingFieldsExplicit :: V.Nullspec a b -> MaybeFields b
nothingFieldsExplicit = nothingFieldsOfTypeOf . V.nullFields
traverseMaybeFields :: SelectArr a b -> SelectArr (MaybeFields a) (MaybeFields b)
traverseMaybeFields query = proc mfInput -> do
mfOutput <- optional (query <<< maybeFieldsToSelect) -< mfInput
restrict -< mfPresent mfInput `implies` mfPresent mfOutput
returnA -< MaybeFields (mfPresent mfInput) (mfFields mfOutput)
where a `implies` b = Opaleye.Internal.Operators.not a .|| b
optional :: SelectArr i a -> SelectArr i (MaybeFields a)
optional = Opaleye.Internal.Lateral.laterally optionalSelect
where
optionalSelect :: Select a -> Select (MaybeFields a)
optionalSelect = IQ.QueryArr . go
go query ((), left, tag) = (MaybeFields present a, join, Tag.next tag')
where
(MaybeFields t a, right, tag') =
IQ.runSimpleQueryArr (justFields <$> query) ((), tag)
present = isNotNull (IC.unsafeCoerceColumn t')
(t', bindings) =
PM.run (U.runUnpackspec U.unpackspecColumn (PM.extractAttr "maybe" tag') t)
join = PQ.Join PQ.LeftJoin true [] bindings left right
true = HPQ.ConstExpr (HPQ.BoolLit True)
isNotNull = Opaleye.Internal.Operators.not . Opaleye.Field.isNull
lateralLeftJoinOptional :: SelectArr i a
-> SelectArr i b
-> ((a, b) -> Opaleye.Field.Field Opaleye.SqlTypes.SqlBool)
-> SelectArr i (a, MaybeFields b)
lateralLeftJoinOptional fieldsL fieldsR cond = proc i -> do
fieldsL' <- fieldsL -< i
maybeFieldsR' <- optional (proc (fieldsL', i) -> do
fieldsR' <- fieldsR -< i
restrict -< cond (fieldsL', fieldsR')
returnA -< fieldsR'
) -< (fieldsL', i)
returnA -< (fieldsL', maybeFieldsR')
optionalRestrictOptional :: Select a
-> SelectArr (a -> Field SqlBool) (MaybeFields a)
optionalRestrictOptional q = optional $ proc cond -> do
a <- q -< ()
restrict -< cond a
returnA -< a
fromFieldsMaybeFields :: RQ.FromFields fields haskells
-> RQ.FromFields (MaybeFields fields) (Maybe haskells)
fromFieldsMaybeFields (RQ.QueryRunner u p c) = RQ.QueryRunner u' p' c'
where u' = () <$ productProfunctorMaybeFields U.unpackspecColumn u
p' = \mf -> do
hIsPresent <- PGSR.field
case hIsPresent of
True -> Just <$> p (mfFields mf)
False -> Nothing <$ replicateM_ (c (mfFields mf))
(PGSR.fieldWith (\_ _ -> pure ()))
c' = \mf -> c (mfFields mf) + 1
productProfunctorMaybeFields :: PP.ProductProfunctor p
=> p (Field SqlBool) (Field SqlBool)
-> p a b
-> p (MaybeFields a) (MaybeFields b)
productProfunctorMaybeFields b p = MaybeFields PP.***$ P.lmap mfPresent b
PP.**** P.lmap mfFields p
nullspecMaybeFields :: V.Nullspec a b
-> V.Nullspec (MaybeFields a) (MaybeFields b)
nullspecMaybeFields = productProfunctorMaybeFields V.nullspecField
unpackspecMaybeFields :: U.Unpackspec a b
-> U.Unpackspec (MaybeFields a) (MaybeFields b)
unpackspecMaybeFields = productProfunctorMaybeFields U.unpackspecField
valuesspecMaybeFields :: V.ValuesspecSafe a b
-> V.ValuesspecSafe (MaybeFields a) (MaybeFields b)
valuesspecMaybeFields = productProfunctorMaybeFields V.valuesspecField
toFieldsMaybeFields :: V.Nullspec a b
-> Constant.ToFields a b
-> Constant.ToFields (Maybe a) (MaybeFields b)
toFieldsMaybeFields n p = Constant.Constant $ \case
Nothing -> nothingFieldsExplicit n
Just a -> justFields (Constant.constantExplicit p a)
ifPPMaybeFields :: IfPP a b -> IfPP (MaybeFields a) (MaybeFields b)
ifPPMaybeFields = productProfunctorMaybeFields PP.def
eqPPMaybeFields :: EqPP a b -> EqPP (MaybeFields a) (MaybeFields b)
eqPPMaybeFields (EqPP eqFields) = EqPP (\m1 m2 ->
(mfPresent m1 .== mfPresent m2)
.&& (mfPresent m1 `implies` eqFields (mfFields m1) (mfFields m2)))
where a `implies` b = Opaleye.Internal.Operators.not a .|| b
unWithNulls :: PP.ProductProfunctor p
=> p (Field SqlBool) (Field SqlBool)
-> WithNulls p a b
-> p (MaybeFields a) (MaybeFields b)
unWithNulls b (WithNulls d) =
MaybeFields PP.***$ P.lmap mfPresent b
PP.**** d
newtype WithNulls p a b =
WithNulls (p (MaybeFields a) b)
mapMaybeFieldsWithNulls :: PP.ProductProfunctor p
=> p (Field SqlBool) (Field SqlBool)
-> WithNulls p a b
-> WithNulls p (MaybeFields a) (MaybeFields b)
mapMaybeFieldsWithNulls b d =
MaybeFields <$> P.lmap mfPresent (withNullsField b)
<*> P.lmap mfFields d
withNullsField :: (IsSqlType a, P.Profunctor p)
=> p (IC.Column a) (IC.Column a)
-> WithNulls p (IC.Column a) (IC.Column a)
withNullsField col = result
where result = WithNulls (P.lmap (\(MaybeFields b c) ->
ifExplict PP.def b c nullC) col)
nullC = IC.Column (V.nullPE (columnProxy result))
columnProxy :: f (IC.Column sqlType) -> Maybe sqlType
columnProxy _ = Nothing
binaryspecMaybeFields
:: WithNulls B.Binaryspec a b
-> B.Binaryspec (MaybeFields a) (MaybeFields b)
binaryspecMaybeFields = unWithNulls PP.def
instance P.Profunctor p => P.Profunctor (WithNulls p) where
dimap f g (WithNulls d) = WithNulls (P.dimap (fmap f) g d)
instance P.Profunctor p => Functor (WithNulls p a) where
fmap = P.rmap
instance PP.ProductProfunctor p => Applicative (WithNulls p a) where
pure = WithNulls . PP.purePP
WithNulls fd <*> WithNulls xd = WithNulls (fd PP.**** xd)
instance PP.ProductProfunctor p => PP.ProductProfunctor (WithNulls p) where
purePP = pure
(****) = (<*>)
instance PP.SumProfunctor p => PP.SumProfunctor (WithNulls p) where
WithNulls ff +++! WithNulls xf =
WithNulls (flip P.lmap (ff PP.+++! xf) $ \case
MaybeFields b (Left l) -> Left (MaybeFields b l)
MaybeFields b (Right r) -> Right (MaybeFields b r))
instance PP.Default RQ.QueryRunner fields haskells
=> PP.Default RQ.QueryRunner (MaybeFields fields) (Maybe haskells) where
def = fromFieldsMaybeFields PP.def
instance PP.Default U.Unpackspec a b
=> PP.Default U.Unpackspec (MaybeFields a) (MaybeFields b) where
def = unpackspecMaybeFields PP.def
instance PP.Default V.ValuesspecSafe a b
=> PP.Default V.ValuesspecSafe (MaybeFields a) (MaybeFields b) where
def = valuesspecMaybeFields PP.def
instance (PP.Default Constant.Constant a b, PP.Default V.Nullspec a b)
=> PP.Default Constant.Constant (Maybe a) (MaybeFields b) where
def = toFieldsMaybeFields PP.def PP.def
instance PP.Default IfPP a b
=> PP.Default IfPP (MaybeFields a) (MaybeFields b) where
def = ifPPMaybeFields PP.def
instance PP.Default EqPP a b
=> PP.Default EqPP (MaybeFields a) (MaybeFields b) where
def = eqPPMaybeFields PP.def
instance (P.Profunctor p, IsSqlType a, PP.Default p (IC.Column a) (IC.Column a))
=> PP.Default (WithNulls p) (IC.Column a) (IC.Column a) where
def = withNullsField PP.def
instance PP.Default (WithNulls B.Binaryspec) a b
=> PP.Default B.Binaryspec (MaybeFields a) (MaybeFields b) where
def = binaryspecMaybeFields PP.def