{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
module Opaleye.Internal.Values where
import Opaleye.Internal.Column (Column(Column))
import qualified Opaleye.Internal.Unpackspec as U
import qualified Opaleye.Internal.Tag as T
import qualified Opaleye.Internal.PrimQuery as PQ
import qualified Opaleye.Internal.PackMap as PM
import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ
import qualified Opaleye.Internal.PGTypes
import qualified Opaleye.SqlTypes
import Data.Functor.Identity (runIdentity)
import qualified Data.List.NonEmpty as NEL
import Data.Profunctor (Profunctor, dimap, rmap, lmap)
import Data.Profunctor.Product (ProductProfunctor)
import qualified Data.Profunctor.Product as PP
import Data.Profunctor.Product.Default (Default, def)
import Control.Applicative (Applicative, pure, (<*>))
valuesU :: U.Unpackspec columns columns'
-> ValuesspecUnsafe columns columns'
-> [columns]
-> ((), T.Tag) -> (columns', PQ.PrimQuery, T.Tag)
valuesU unpack valuesspec rows ((), t) = (newColumns, primQ', T.next t)
where runRow row = valuesRow
where (_, valuesRow) =
PM.run (U.runUnpackspec unpack extractValuesEntry row)
(newColumns, valuesPEs_nulls) =
PM.run (runValuesspec valuesspec (extractValuesField t))
valuesPEs = map fst valuesPEs_nulls
values :: [[HPQ.PrimExpr]]
values = map runRow rows
primQ' = case NEL.nonEmpty values of
Nothing -> PQ.Empty ()
Just values' -> PQ.Values valuesPEs values'
extractValuesEntry :: HPQ.PrimExpr -> PM.PM [HPQ.PrimExpr] HPQ.PrimExpr
extractValuesEntry pe = do
PM.write pe
return pe
extractValuesField :: T.Tag -> primExpr
-> PM.PM [(HPQ.Symbol, primExpr)] HPQ.PrimExpr
extractValuesField = PM.extractAttr "values"
newtype ValuesspecUnsafe columns columns' =
Valuesspec (PM.PackMap () HPQ.PrimExpr () columns')
runValuesspec :: Applicative f => ValuesspecUnsafe columns columns'
-> (() -> f HPQ.PrimExpr) -> f columns'
runValuesspec (Valuesspec v) f = PM.traversePM v f ()
instance Default ValuesspecUnsafe (Column a) (Column a) where
def = Valuesspec (PM.iso id Column)
valuesUSafe :: Valuesspec columns columns'
-> [columns]
-> ((), T.Tag) -> (columns', PQ.PrimQuery, T.Tag)
valuesUSafe valuesspec@(ValuesspecSafe _ unpack) rows ((), t) =
(newColumns, primQ', T.next t)
where runRow row =
case PM.run (U.runUnpackspec unpack extractValuesEntry row) of
(_, []) -> [zero]
(_, xs) -> xs
(newColumns, valuesPEs_nulls) =
PM.run (runValuesspecSafe valuesspec (extractValuesField t))
valuesPEs = map fst valuesPEs_nulls
nulls = case map snd valuesPEs_nulls of
[] -> [nullInt]
nulls' -> nulls'
yieldNoRows :: PQ.PrimQuery -> PQ.PrimQuery
yieldNoRows = PQ.restrict (HPQ.ConstExpr (HPQ.BoolLit False))
zero = HPQ.ConstExpr (HPQ.IntegerLit 0)
nullInt = HPQ.CastExpr (Opaleye.Internal.PGTypes.showSqlType
(Nothing :: Maybe Opaleye.SqlTypes.SqlInt4))
(HPQ.ConstExpr HPQ.NullLit)
(values, wrap) = case NEL.nonEmpty rows of
Nothing -> (pure nulls, yieldNoRows)
Just rows' -> (fmap runRow rows', id)
primQ' = wrap (PQ.Values valuesPEs values)
data Valuesspec columns columns' =
ValuesspecSafe (PM.PackMap HPQ.PrimExpr HPQ.PrimExpr () columns')
(U.Unpackspec columns columns')
type ValuesspecSafe = Valuesspec
runValuesspecSafe :: Applicative f
=> Valuesspec columns columns'
-> (HPQ.PrimExpr -> f HPQ.PrimExpr)
-> f columns'
runValuesspecSafe (ValuesspecSafe v _) f = PM.traversePM v f ()
valuesspecField :: Opaleye.SqlTypes.IsSqlType a
=> Valuesspec (Column a) (Column a)
valuesspecField = def
instance Opaleye.Internal.PGTypes.IsSqlType a
=> Default Valuesspec (Column a) (Column a) where
def = def_
where def_ = ValuesspecSafe (PM.PackMap (\f () -> fmap Column (f null_)))
U.unpackspecField
null_ = nullPE sqlType
sqlType = columnProxy def_
columnProxy :: f (Column sqlType) -> Maybe sqlType
columnProxy _ = Nothing
nullPE :: Opaleye.SqlTypes.IsSqlType a => proxy a -> HPQ.PrimExpr
nullPE sqlType = HPQ.CastExpr (Opaleye.Internal.PGTypes.showSqlType sqlType)
(HPQ.ConstExpr HPQ.NullLit)
newtype Nullspec fields fields' = Nullspec (Valuesspec fields fields')
nullspecField :: Opaleye.SqlTypes.IsSqlType b
=> Nullspec a (Column b)
nullspecField = Nullspec (lmap e valuesspecField)
where e = error (concat [ "We looked at the argument of a Nullspec when we "
, "expected that we never would! This is a bug in "
, "Opaleye. Please report it, if you can reproduce "
, "it."
])
nullspecList :: Nullspec a [b]
nullspecList = pure []
nullspecEitherLeft :: Nullspec a b
-> Nullspec a (Either b b')
nullspecEitherLeft = fmap Left
nullspecEitherRight :: Nullspec a b'
-> Nullspec a (Either b b')
nullspecEitherRight = fmap Right
instance Opaleye.SqlTypes.IsSqlType b
=> Default Nullspec a (Column b) where
def = nullspecField
nullFields :: Nullspec a fields -> fields
nullFields (Nullspec v) = runIdentity (runValuesspecSafe v pure)
instance Functor (ValuesspecUnsafe a) where
fmap f (Valuesspec g) = Valuesspec (fmap f g)
instance Applicative (ValuesspecUnsafe a) where
pure = Valuesspec . pure
Valuesspec f <*> Valuesspec x = Valuesspec (f <*> x)
instance Profunctor ValuesspecUnsafe where
dimap _ g (Valuesspec q) = Valuesspec (rmap g q)
instance ProductProfunctor ValuesspecUnsafe where
purePP = pure
(****) = (<*>)
instance Functor (Valuesspec a) where
fmap f (ValuesspecSafe g h) = ValuesspecSafe (fmap f g) (fmap f h)
instance Applicative (Valuesspec a) where
pure a = ValuesspecSafe (pure a) (pure a)
ValuesspecSafe f f' <*> ValuesspecSafe x x' =
ValuesspecSafe (f <*> x) (f' <*> x')
instance Profunctor Valuesspec where
dimap f g (ValuesspecSafe q q') = ValuesspecSafe (rmap g q) (dimap f g q')
instance ProductProfunctor Valuesspec where
purePP = pure
(****) = (<*>)
instance Functor (Nullspec a) where
fmap f (Nullspec g) = Nullspec (fmap f g)
instance Applicative (Nullspec a) where
pure = Nullspec . pure
Nullspec f <*> Nullspec x = Nullspec (f <*> x)
instance Profunctor Nullspec where
dimap f g (Nullspec q) = Nullspec (dimap f g q)
instance ProductProfunctor Nullspec where
purePP = pure
(****) = (<*>)