{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
module Opaleye.SQLite.Internal.Values where
import qualified Opaleye.SQLite.PGTypes as T
import Opaleye.SQLite.Internal.Column (Column(Column))
import qualified Opaleye.SQLite.Internal.Unpackspec as U
import qualified Opaleye.SQLite.Internal.Tag as T
import qualified Opaleye.SQLite.Internal.PrimQuery as PQ
import qualified Opaleye.SQLite.Internal.PackMap as PM
import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as HPQ
import Data.Profunctor (Profunctor, dimap, rmap)
import Data.Profunctor.Product (ProductProfunctor, empty, (***!))
import qualified Data.Profunctor.Product as PP
import Data.Profunctor.Product.Default (Default, def)
import Control.Applicative (Applicative, pure, (<*>))
valuesU :: U.Unpackspec columns columns'
-> Valuesspec columns columns'
-> [columns]
-> ((), T.Tag) -> (columns', PQ.PrimQuery, T.Tag)
valuesU :: Unpackspec columns columns'
-> Valuesspec columns columns'
-> [columns]
-> ((), Tag)
-> (columns', PrimQuery, Tag)
valuesU Unpackspec columns columns'
unpack Valuesspec columns columns'
valuesspec [columns]
rows ((), Tag
t) = (columns'
newColumns, PrimQuery
primQ', Tag -> Tag
T.next Tag
t)
where runRow :: columns -> [PrimExpr]
runRow columns
row = [PrimExpr]
valuesRow
where (columns'
_, [PrimExpr]
valuesRow) =
PM [PrimExpr] columns' -> (columns', [PrimExpr])
forall a r. PM [a] r -> (r, [a])
PM.run (Unpackspec columns columns'
-> (PrimExpr -> StateT ([PrimExpr], Int) Identity PrimExpr)
-> columns
-> PM [PrimExpr] columns'
forall (f :: * -> *) columns b.
Applicative f =>
Unpackspec columns b -> (PrimExpr -> f PrimExpr) -> columns -> f b
U.runUnpackspec Unpackspec columns columns'
unpack PrimExpr -> StateT ([PrimExpr], Int) Identity PrimExpr
extractValuesEntry columns
row)
(columns'
newColumns, [(Symbol, PrimExpr)]
valuesPEs_nulls) =
PM [(Symbol, PrimExpr)] columns'
-> (columns', [(Symbol, PrimExpr)])
forall a r. PM [a] r -> (r, [a])
PM.run (Valuesspec columns columns'
-> (PrimExpr
-> StateT ([(Symbol, PrimExpr)], Int) Identity PrimExpr)
-> PM [(Symbol, PrimExpr)] columns'
forall (f :: * -> *) columns columns'.
Applicative f =>
Valuesspec columns columns'
-> (PrimExpr -> f PrimExpr) -> f columns'
runValuesspec Valuesspec columns columns'
valuesspec (Tag
-> PrimExpr -> StateT ([(Symbol, PrimExpr)], Int) Identity PrimExpr
extractValuesField Tag
t))
valuesPEs :: [Symbol]
valuesPEs = ((Symbol, PrimExpr) -> Symbol) -> [(Symbol, PrimExpr)] -> [Symbol]
forall a b. (a -> b) -> [a] -> [b]
map (Symbol, PrimExpr) -> Symbol
forall a b. (a, b) -> a
fst [(Symbol, PrimExpr)]
valuesPEs_nulls
nulls :: [PrimExpr]
nulls = ((Symbol, PrimExpr) -> PrimExpr)
-> [(Symbol, PrimExpr)] -> [PrimExpr]
forall a b. (a -> b) -> [a] -> [b]
map (Symbol, PrimExpr) -> PrimExpr
forall a b. (a, b) -> b
snd [(Symbol, PrimExpr)]
valuesPEs_nulls
yieldNoRows :: PQ.PrimQuery -> PQ.PrimQuery
yieldNoRows :: PrimQuery -> PrimQuery
yieldNoRows = PrimExpr -> PrimQuery -> PrimQuery
PQ.restrict (Literal -> PrimExpr
HPQ.ConstExpr (Bool -> Literal
HPQ.BoolLit Bool
False))
values' :: [[HPQ.PrimExpr]]
([[PrimExpr]]
values', PrimQuery -> PrimQuery
wrap) = if [columns] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [columns]
rows
then ([[PrimExpr]
nulls], PrimQuery -> PrimQuery
yieldNoRows)
else ((columns -> [PrimExpr]) -> [columns] -> [[PrimExpr]]
forall a b. (a -> b) -> [a] -> [b]
map columns -> [PrimExpr]
runRow [columns]
rows, PrimQuery -> PrimQuery
forall a. a -> a
id)
primQ' :: PrimQuery
primQ' = PrimQuery -> PrimQuery
wrap ([Symbol] -> [[PrimExpr]] -> PrimQuery
PQ.Values [Symbol]
valuesPEs [[PrimExpr]]
values')
extractValuesEntry :: HPQ.PrimExpr -> PM.PM [HPQ.PrimExpr] HPQ.PrimExpr
PrimExpr
pe = do
PrimExpr -> PM [PrimExpr] ()
forall a. a -> PM [a] ()
PM.write PrimExpr
pe
PrimExpr -> StateT ([PrimExpr], Int) Identity PrimExpr
forall (m :: * -> *) a. Monad m => a -> m a
return PrimExpr
pe
extractValuesField :: T.Tag -> HPQ.PrimExpr
-> PM.PM [(HPQ.Symbol, HPQ.PrimExpr)] HPQ.PrimExpr
= String
-> Tag
-> PrimExpr
-> StateT ([(Symbol, PrimExpr)], Int) Identity PrimExpr
forall primExpr.
String -> Tag -> primExpr -> PM [(Symbol, primExpr)] PrimExpr
PM.extractAttr String
"values"
newtype Valuesspec columns columns' =
Valuesspec (PM.PackMap HPQ.PrimExpr HPQ.PrimExpr () columns')
runValuesspec :: Applicative f => Valuesspec columns columns'
-> (HPQ.PrimExpr -> f HPQ.PrimExpr) -> f columns'
runValuesspec :: Valuesspec columns columns'
-> (PrimExpr -> f PrimExpr) -> f columns'
runValuesspec (Valuesspec PackMap PrimExpr PrimExpr () columns'
v) PrimExpr -> f PrimExpr
f = PackMap PrimExpr PrimExpr () columns'
-> (PrimExpr -> f PrimExpr) -> () -> f columns'
forall (f :: * -> *) a b s t.
Applicative f =>
PackMap a b s t -> (a -> f b) -> s -> f t
PM.traversePM PackMap PrimExpr PrimExpr () columns'
v PrimExpr -> f PrimExpr
f ()
instance Default Valuesspec (Column T.PGInt4) (Column T.PGInt4) where
def :: Valuesspec (Column PGInt4) (Column PGInt4)
def = PackMap PrimExpr PrimExpr () (Column PGInt4)
-> Valuesspec (Column PGInt4) (Column PGInt4)
forall columns columns'.
PackMap PrimExpr PrimExpr () columns'
-> Valuesspec columns columns'
Valuesspec ((forall (f :: * -> *).
Applicative f =>
(PrimExpr -> f PrimExpr) -> () -> f (Column PGInt4))
-> PackMap PrimExpr PrimExpr () (Column PGInt4)
forall a b s t.
(forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> PackMap a b s t
PM.PackMap (\PrimExpr -> f PrimExpr
f () -> (PrimExpr -> Column PGInt4) -> f PrimExpr -> f (Column PGInt4)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PrimExpr -> Column PGInt4
forall a. PrimExpr -> Column a
Column (PrimExpr -> f PrimExpr
f (Literal -> PrimExpr
HPQ.ConstExpr Literal
HPQ.NullLit))))
instance Functor (Valuesspec a) where
fmap :: (a -> b) -> Valuesspec a a -> Valuesspec a b
fmap a -> b
f (Valuesspec PackMap PrimExpr PrimExpr () a
g) = PackMap PrimExpr PrimExpr () b -> Valuesspec a b
forall columns columns'.
PackMap PrimExpr PrimExpr () columns'
-> Valuesspec columns columns'
Valuesspec ((a -> b)
-> PackMap PrimExpr PrimExpr () a -> PackMap PrimExpr PrimExpr () b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f PackMap PrimExpr PrimExpr () a
g)
instance Applicative (Valuesspec a) where
pure :: a -> Valuesspec a a
pure = PackMap PrimExpr PrimExpr () a -> Valuesspec a a
forall columns columns'.
PackMap PrimExpr PrimExpr () columns'
-> Valuesspec columns columns'
Valuesspec (PackMap PrimExpr PrimExpr () a -> Valuesspec a a)
-> (a -> PackMap PrimExpr PrimExpr () a) -> a -> Valuesspec a a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> PackMap PrimExpr PrimExpr () a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
Valuesspec PackMap PrimExpr PrimExpr () (a -> b)
f <*> :: Valuesspec a (a -> b) -> Valuesspec a a -> Valuesspec a b
<*> Valuesspec PackMap PrimExpr PrimExpr () a
x = PackMap PrimExpr PrimExpr () b -> Valuesspec a b
forall columns columns'.
PackMap PrimExpr PrimExpr () columns'
-> Valuesspec columns columns'
Valuesspec (PackMap PrimExpr PrimExpr () (a -> b)
f PackMap PrimExpr PrimExpr () (a -> b)
-> PackMap PrimExpr PrimExpr () a -> PackMap PrimExpr PrimExpr () b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PackMap PrimExpr PrimExpr () a
x)
instance Profunctor Valuesspec where
dimap :: (a -> b) -> (c -> d) -> Valuesspec b c -> Valuesspec a d
dimap a -> b
_ c -> d
g (Valuesspec PackMap PrimExpr PrimExpr () c
q) = PackMap PrimExpr PrimExpr () d -> Valuesspec a d
forall columns columns'.
PackMap PrimExpr PrimExpr () columns'
-> Valuesspec columns columns'
Valuesspec ((c -> d)
-> PackMap PrimExpr PrimExpr () c -> PackMap PrimExpr PrimExpr () d
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap c -> d
g PackMap PrimExpr PrimExpr () c
q)
instance ProductProfunctor Valuesspec where
empty :: Valuesspec () ()
empty = Valuesspec () ()
forall (p :: * -> * -> *). Applicative (p ()) => p () ()
PP.defaultEmpty
***! :: Valuesspec a b -> Valuesspec a' b' -> Valuesspec (a, a') (b, b')
(***!) = Valuesspec a b -> Valuesspec a' b' -> Valuesspec (a, a') (b, b')
forall (p :: * -> * -> *) a a' b b'.
(Applicative (p (a, a')), Profunctor p) =>
p a b -> p a' b' -> p (a, a') (b, b')
PP.defaultProfunctorProduct