{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Database.Relational.Monad.Trans.Join
(
QueryJoin, join',
extractProduct,
unsafeSubQueryWithAttr,
) where
import Prelude hiding (product)
import Control.Monad.Trans.Class (MonadTrans (lift))
import Control.Monad.Trans.Writer (WriterT, runWriterT, tell)
import Control.Monad.Trans.State (modify, StateT, runStateT)
import Control.Applicative (Applicative, (<$>))
import Control.Arrow (second, (***))
import Data.Maybe (fromMaybe)
import Data.Monoid (Last (Last, getLast))
import Database.Relational.Internal.ContextType (Flat)
import Database.Relational.Internal.Config (addQueryTableAliasAS)
import Database.Relational.SqlSyntax
(Duplication (All), NodeAttr (Just', Maybe), Predicate, Record,
SubQuery, Qualified, JoinProduct, restrictProduct, growProduct, )
import Database.Relational.Monad.Class (liftQualify)
import Database.Relational.Monad.Trans.JoinState
(JoinContext, primeJoinContext, updateProduct, joinProduct)
import qualified Database.Relational.Record as Record
import Database.Relational.Projectable (PlaceHolders, unsafeAddPlaceHolders)
import Database.Relational.Monad.BaseType (ConfigureQuery, askConfig, qualifyQuery, Relation, untypeRelation)
import Database.Relational.Monad.Class (MonadQualify (..), MonadQuery (..))
newtype QueryJoin m a =
QueryJoin (StateT JoinContext (WriterT (Last Duplication) m) a)
deriving (forall a. a -> QueryJoin m a
forall a b. QueryJoin m a -> QueryJoin m b -> QueryJoin m b
forall a b. QueryJoin m a -> (a -> QueryJoin m b) -> QueryJoin m b
forall {m :: * -> *}. Monad m => Applicative (QueryJoin m)
forall (m :: * -> *) a. Monad m => a -> QueryJoin m a
forall (m :: * -> *) a b.
Monad m =>
QueryJoin m a -> QueryJoin m b -> QueryJoin m b
forall (m :: * -> *) a b.
Monad m =>
QueryJoin m a -> (a -> QueryJoin m b) -> QueryJoin m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> QueryJoin m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> QueryJoin m a
>> :: forall a b. QueryJoin m a -> QueryJoin m b -> QueryJoin m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
QueryJoin m a -> QueryJoin m b -> QueryJoin m b
>>= :: forall a b. QueryJoin m a -> (a -> QueryJoin m b) -> QueryJoin m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
QueryJoin m a -> (a -> QueryJoin m b) -> QueryJoin m b
Monad, forall a b. a -> QueryJoin m b -> QueryJoin m a
forall a b. (a -> b) -> QueryJoin m a -> QueryJoin m b
forall (m :: * -> *) a b.
Functor m =>
a -> QueryJoin m b -> QueryJoin m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> QueryJoin m a -> QueryJoin m 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 -> QueryJoin m b -> QueryJoin m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> QueryJoin m b -> QueryJoin m a
fmap :: forall a b. (a -> b) -> QueryJoin m a -> QueryJoin m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> QueryJoin m a -> QueryJoin m b
Functor, forall a. a -> QueryJoin m a
forall a b. QueryJoin m a -> QueryJoin m b -> QueryJoin m a
forall a b. QueryJoin m a -> QueryJoin m b -> QueryJoin m b
forall a b. QueryJoin m (a -> b) -> QueryJoin m a -> QueryJoin m b
forall a b c.
(a -> b -> c) -> QueryJoin m a -> QueryJoin m b -> QueryJoin m c
forall {m :: * -> *}. Monad m => Functor (QueryJoin m)
forall (m :: * -> *) a. Monad m => a -> QueryJoin m a
forall (m :: * -> *) a b.
Monad m =>
QueryJoin m a -> QueryJoin m b -> QueryJoin m a
forall (m :: * -> *) a b.
Monad m =>
QueryJoin m a -> QueryJoin m b -> QueryJoin m b
forall (m :: * -> *) a b.
Monad m =>
QueryJoin m (a -> b) -> QueryJoin m a -> QueryJoin m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> QueryJoin m a -> QueryJoin m b -> QueryJoin m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. QueryJoin m a -> QueryJoin m b -> QueryJoin m a
$c<* :: forall (m :: * -> *) a b.
Monad m =>
QueryJoin m a -> QueryJoin m b -> QueryJoin m a
*> :: forall a b. QueryJoin m a -> QueryJoin m b -> QueryJoin m b
$c*> :: forall (m :: * -> *) a b.
Monad m =>
QueryJoin m a -> QueryJoin m b -> QueryJoin m b
liftA2 :: forall a b c.
(a -> b -> c) -> QueryJoin m a -> QueryJoin m b -> QueryJoin m c
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> QueryJoin m a -> QueryJoin m b -> QueryJoin m c
<*> :: forall a b. QueryJoin m (a -> b) -> QueryJoin m a -> QueryJoin m b
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
QueryJoin m (a -> b) -> QueryJoin m a -> QueryJoin m b
pure :: forall a. a -> QueryJoin m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> QueryJoin m a
Applicative)
instance MonadTrans QueryJoin where
lift :: forall (m :: * -> *) a. Monad m => m a -> QueryJoin m a
lift = forall (m :: * -> *) a.
StateT JoinContext (WriterT (Last Duplication) m) a
-> QueryJoin m a
QueryJoin forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
join' :: Monad m => m a -> QueryJoin m a
join' :: forall (m :: * -> *) a. Monad m => m a -> QueryJoin m a
join' = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
updateContext :: Monad m => (JoinContext -> JoinContext) -> QueryJoin m ()
updateContext :: forall (m :: * -> *).
Monad m =>
(JoinContext -> JoinContext) -> QueryJoin m ()
updateContext = forall (m :: * -> *) a.
StateT JoinContext (WriterT (Last Duplication) m) a
-> QueryJoin m a
QueryJoin forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify
updateJoinRestriction :: Monad m => Predicate Flat -> QueryJoin m ()
updateJoinRestriction :: forall (m :: * -> *). Monad m => Predicate Flat -> QueryJoin m ()
updateJoinRestriction Predicate Flat
e = forall (m :: * -> *).
Monad m =>
(JoinContext -> JoinContext) -> QueryJoin m ()
updateContext ((Maybe (Node (DList (Predicate Flat)))
-> Node (DList (Predicate Flat)))
-> JoinContext -> JoinContext
updateProduct Maybe (Node (DList (Predicate Flat)))
-> Node (DList (Predicate Flat))
d) where
d :: Maybe (Node (DList (Predicate Flat)))
-> Node (DList (Predicate Flat))
d Maybe (Node (DList (Predicate Flat)))
Nothing = forall a. HasCallStack => [Char] -> a
error [Char]
"on: Product is empty! Restrict target product is not found!"
d (Just Node (DList (Predicate Flat))
pt) = Node (DList (Predicate Flat))
-> Predicate Flat -> Node (DList (Predicate Flat))
restrictProduct Node (DList (Predicate Flat))
pt Predicate Flat
e
instance MonadQualify q m => MonadQualify q (QueryJoin m) where
liftQualify :: forall a. q a -> QueryJoin m a
liftQualify = forall (m :: * -> *) a. Monad m => m a -> QueryJoin m a
join' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (q :: * -> *) (m :: * -> *) a.
MonadQualify q m =>
q a -> m a
liftQualify
instance MonadQuery (QueryJoin ConfigureQuery) where
setDuplication :: Duplication -> QueryJoin ConfigureQuery ()
setDuplication = forall (m :: * -> *) a.
StateT JoinContext (WriterT (Last Duplication) m) a
-> QueryJoin m a
QueryJoin forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Maybe a -> Last a
Last forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just
restrictJoin :: Predicate Flat -> QueryJoin ConfigureQuery ()
restrictJoin = forall (m :: * -> *). Monad m => Predicate Flat -> QueryJoin m ()
updateJoinRestriction
query' :: forall p r.
Relation p r
-> QueryJoin ConfigureQuery (PlaceHolders p, Record Flat r)
query' = forall p r c.
NodeAttr
-> Relation p r
-> QueryJoin ConfigureQuery (PlaceHolders p, Record c r)
queryWithAttr NodeAttr
Just'
queryMaybe' :: forall p r.
Relation p r
-> QueryJoin ConfigureQuery (PlaceHolders p, Record Flat (Maybe r))
queryMaybe' Relation p r
pr = do
(PlaceHolders p
ph, Record Flat r
pj) <- forall p r c.
NodeAttr
-> Relation p r
-> QueryJoin ConfigureQuery (PlaceHolders p, Record c r)
queryWithAttr NodeAttr
Maybe Relation p r
pr
forall (m :: * -> *) a. Monad m => a -> m a
return (PlaceHolders p
ph, forall c r. Record c r -> Record c (Maybe r)
Record.just Record Flat r
pj)
unsafeSubQueryWithAttr :: MonadQualify ConfigureQuery q
=> NodeAttr
-> Qualified SubQuery
-> QueryJoin q (Record c r)
unsafeSubQueryWithAttr :: forall (q :: * -> *) c r.
MonadQualify ConfigureQuery q =>
NodeAttr -> Qualified SubQuery -> QueryJoin q (Record c r)
unsafeSubQueryWithAttr NodeAttr
attr Qualified SubQuery
qsub = do
Bool
addAS <- Config -> Bool
addQueryTableAliasAS forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *) (m :: * -> *) a.
MonadQualify q m =>
q a -> m a
liftQualify ConfigureQuery Config
askConfig
forall (m :: * -> *).
Monad m =>
(JoinContext -> JoinContext) -> QueryJoin m ()
updateContext ((Maybe (Node (DList (Predicate Flat)))
-> Node (DList (Predicate Flat)))
-> JoinContext -> JoinContext
updateProduct (Maybe (Node (DList (Predicate Flat)))
-> (NodeAttr, (Bool, Qualified SubQuery))
-> Node (DList (Predicate Flat))
`growProduct` (NodeAttr
attr, (Bool
addAS, Qualified SubQuery
qsub))))
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall c t. Qualified SubQuery -> Record c t
Record.unsafeFromQualifiedSubQuery Qualified SubQuery
qsub
queryWithAttr :: NodeAttr
-> Relation p r
-> QueryJoin ConfigureQuery (PlaceHolders p, Record c r)
queryWithAttr :: forall p r c.
NodeAttr
-> Relation p r
-> QueryJoin ConfigureQuery (PlaceHolders p, Record c r)
queryWithAttr NodeAttr
attr = forall (f :: * -> *) a p. Functor f => f a -> f (PlaceHolders p, a)
unsafeAddPlaceHolders forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {q :: * -> *} {p} {r} {c} {r}.
MonadQualify ConfigureQuery q =>
Relation p r -> QueryJoin q (Record c r)
run where
run :: Relation p r -> QueryJoin q (Record c r)
run Relation p r
rel = do
Qualified SubQuery
q <- forall (q :: * -> *) (m :: * -> *) a.
MonadQualify q m =>
q a -> m a
liftQualify forall a b. (a -> b) -> a -> b
$ do
SubQuery
sq <- forall p r. Relation p r -> ConfigureQuery SubQuery
untypeRelation Relation p r
rel
forall a. a -> ConfigureQuery (Qualified a)
qualifyQuery SubQuery
sq
forall (q :: * -> *) c r.
MonadQualify ConfigureQuery q =>
NodeAttr -> Qualified SubQuery -> QueryJoin q (Record c r)
unsafeSubQueryWithAttr NodeAttr
attr Qualified SubQuery
q
extractProduct :: Functor m => QueryJoin m a -> m ((a, JoinProduct), Duplication)
(QueryJoin StateT JoinContext (WriterT (Last Duplication) m) a
s) = (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second JoinContext -> JoinProduct
joinProduct forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (forall a. a -> Maybe a -> a
fromMaybe Duplication
All forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Last a -> Maybe a
getLast))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT JoinContext (WriterT (Last Duplication) m) a
s JoinContext
primeJoinContext)