{-# 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 (Applicative (QueryJoin m)
a -> QueryJoin m a
Applicative (QueryJoin m)
-> (forall a b.
QueryJoin m a -> (a -> QueryJoin m b) -> QueryJoin m b)
-> (forall a b. QueryJoin m a -> QueryJoin m b -> QueryJoin m b)
-> (forall a. a -> QueryJoin m a)
-> Monad (QueryJoin m)
QueryJoin m a -> (a -> QueryJoin m b) -> QueryJoin m b
QueryJoin m a -> QueryJoin m b -> QueryJoin m b
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 :: a -> QueryJoin m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> QueryJoin m a
>> :: 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
>>= :: 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
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (QueryJoin m)
Monad, a -> QueryJoin m b -> QueryJoin m a
(a -> b) -> QueryJoin m a -> QueryJoin m b
(forall a b. (a -> b) -> QueryJoin m a -> QueryJoin m b)
-> (forall a b. a -> QueryJoin m b -> QueryJoin m a)
-> Functor (QueryJoin m)
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
<$ :: a -> QueryJoin m b -> QueryJoin m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> QueryJoin m b -> QueryJoin m a
fmap :: (a -> b) -> QueryJoin m a -> QueryJoin m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> QueryJoin m a -> QueryJoin m b
Functor, Functor (QueryJoin m)
a -> QueryJoin m a
Functor (QueryJoin m)
-> (forall a. a -> QueryJoin m a)
-> (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 a b. QueryJoin m a -> QueryJoin m b -> QueryJoin m b)
-> (forall a b. QueryJoin m a -> QueryJoin m b -> QueryJoin m a)
-> Applicative (QueryJoin m)
QueryJoin m a -> QueryJoin m b -> QueryJoin m b
QueryJoin m a -> QueryJoin m b -> QueryJoin m a
QueryJoin m (a -> b) -> QueryJoin m a -> QueryJoin m b
(a -> b -> c) -> QueryJoin m a -> QueryJoin m b -> QueryJoin m c
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
<* :: 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
*> :: 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 :: (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
<*> :: 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 :: a -> QueryJoin m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> QueryJoin m a
$cp1Applicative :: forall (m :: * -> *). Monad m => Functor (QueryJoin m)
Applicative)
instance MonadTrans QueryJoin where
lift :: m a -> QueryJoin m a
lift = StateT JoinContext (WriterT (Last Duplication) m) a
-> QueryJoin m a
forall (m :: * -> *) a.
StateT JoinContext (WriterT (Last Duplication) m) a
-> QueryJoin m a
QueryJoin (StateT JoinContext (WriterT (Last Duplication) m) a
-> QueryJoin m a)
-> (m a -> StateT JoinContext (WriterT (Last Duplication) m) a)
-> m a
-> QueryJoin m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT (Last Duplication) m a
-> StateT JoinContext (WriterT (Last Duplication) m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT (Last Duplication) m a
-> StateT JoinContext (WriterT (Last Duplication) m) a)
-> (m a -> WriterT (Last Duplication) m a)
-> m a
-> StateT JoinContext (WriterT (Last Duplication) m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> WriterT (Last Duplication) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
join' :: Monad m => m a -> QueryJoin m a
join' :: m a -> QueryJoin m a
join' = m a -> QueryJoin m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
updateContext :: Monad m => (JoinContext -> JoinContext) -> QueryJoin m ()
updateContext :: (JoinContext -> JoinContext) -> QueryJoin m ()
updateContext = StateT JoinContext (WriterT (Last Duplication) m) ()
-> QueryJoin m ()
forall (m :: * -> *) a.
StateT JoinContext (WriterT (Last Duplication) m) a
-> QueryJoin m a
QueryJoin (StateT JoinContext (WriterT (Last Duplication) m) ()
-> QueryJoin m ())
-> ((JoinContext -> JoinContext)
-> StateT JoinContext (WriterT (Last Duplication) m) ())
-> (JoinContext -> JoinContext)
-> QueryJoin m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (JoinContext -> JoinContext)
-> StateT JoinContext (WriterT (Last Duplication) m) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify
updateJoinRestriction :: Monad m => Predicate Flat -> QueryJoin m ()
updateJoinRestriction :: Predicate Flat -> QueryJoin m ()
updateJoinRestriction Predicate Flat
e = (JoinContext -> JoinContext) -> QueryJoin m ()
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 = [Char] -> Node (DList (Predicate Flat))
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 :: q a -> QueryJoin m a
liftQualify = m a -> QueryJoin m a
forall (m :: * -> *) a. Monad m => m a -> QueryJoin m a
join' (m a -> QueryJoin m a) -> (q a -> m a) -> q a -> QueryJoin m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. q a -> m a
forall (q :: * -> *) (m :: * -> *) a.
MonadQualify q m =>
q a -> m a
liftQualify
instance MonadQuery (QueryJoin ConfigureQuery) where
setDuplication :: Duplication -> QueryJoin ConfigureQuery ()
setDuplication = StateT JoinContext (WriterT (Last Duplication) ConfigureQuery) ()
-> QueryJoin ConfigureQuery ()
forall (m :: * -> *) a.
StateT JoinContext (WriterT (Last Duplication) m) a
-> QueryJoin m a
QueryJoin (StateT JoinContext (WriterT (Last Duplication) ConfigureQuery) ()
-> QueryJoin ConfigureQuery ())
-> (Duplication
-> StateT
JoinContext (WriterT (Last Duplication) ConfigureQuery) ())
-> Duplication
-> QueryJoin ConfigureQuery ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT (Last Duplication) ConfigureQuery ()
-> StateT
JoinContext (WriterT (Last Duplication) ConfigureQuery) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT (Last Duplication) ConfigureQuery ()
-> StateT
JoinContext (WriterT (Last Duplication) ConfigureQuery) ())
-> (Duplication -> WriterT (Last Duplication) ConfigureQuery ())
-> Duplication
-> StateT
JoinContext (WriterT (Last Duplication) ConfigureQuery) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Last Duplication -> WriterT (Last Duplication) ConfigureQuery ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell (Last Duplication -> WriterT (Last Duplication) ConfigureQuery ())
-> (Duplication -> Last Duplication)
-> Duplication
-> WriterT (Last Duplication) ConfigureQuery ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Duplication -> Last Duplication
forall a. Maybe a -> Last a
Last (Maybe Duplication -> Last Duplication)
-> (Duplication -> Maybe Duplication)
-> Duplication
-> Last Duplication
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Duplication -> Maybe Duplication
forall a. a -> Maybe a
Just
restrictJoin :: Predicate Flat -> QueryJoin ConfigureQuery ()
restrictJoin = Predicate Flat -> QueryJoin ConfigureQuery ()
forall (m :: * -> *). Monad m => Predicate Flat -> QueryJoin m ()
updateJoinRestriction
query' :: Relation p r
-> QueryJoin ConfigureQuery (PlaceHolders p, Record Flat r)
query' = NodeAttr
-> Relation p r
-> QueryJoin ConfigureQuery (PlaceHolders p, Record Flat r)
forall p r c.
NodeAttr
-> Relation p r
-> QueryJoin ConfigureQuery (PlaceHolders p, Record c r)
queryWithAttr NodeAttr
Just'
queryMaybe' :: Relation p r
-> QueryJoin ConfigureQuery (PlaceHolders p, Record Flat (Maybe r))
queryMaybe' Relation p r
pr = do
(PlaceHolders p
ph, Record Flat r
pj) <- NodeAttr
-> Relation p r
-> QueryJoin ConfigureQuery (PlaceHolders p, Record Flat r)
forall p r c.
NodeAttr
-> Relation p r
-> QueryJoin ConfigureQuery (PlaceHolders p, Record c r)
queryWithAttr NodeAttr
Maybe Relation p r
pr
(PlaceHolders p, Record Flat (Maybe r))
-> QueryJoin ConfigureQuery (PlaceHolders p, Record Flat (Maybe r))
forall (m :: * -> *) a. Monad m => a -> m a
return (PlaceHolders p
ph, Record Flat r -> Record Flat (Maybe r)
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 :: NodeAttr -> Qualified SubQuery -> QueryJoin q (Record c r)
unsafeSubQueryWithAttr NodeAttr
attr Qualified SubQuery
qsub = do
Bool
addAS <- Config -> Bool
addQueryTableAliasAS (Config -> Bool) -> QueryJoin q Config -> QueryJoin q Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Qualify (QueryConfig Identity) Config -> QueryJoin q Config
forall (q :: * -> *) (m :: * -> *) a.
MonadQualify q m =>
q a -> m a
liftQualify Qualify (QueryConfig Identity) Config
askConfig
(JoinContext -> JoinContext) -> QueryJoin q ()
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))))
Record c r -> QueryJoin q (Record c r)
forall (m :: * -> *) a. Monad m => a -> m a
return (Record c r -> QueryJoin q (Record c r))
-> Record c r -> QueryJoin q (Record c r)
forall a b. (a -> b) -> a -> b
$ Qualified SubQuery -> Record c r
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 :: NodeAttr
-> Relation p r
-> QueryJoin ConfigureQuery (PlaceHolders p, Record c r)
queryWithAttr NodeAttr
attr = QueryJoin ConfigureQuery (Record c r)
-> QueryJoin ConfigureQuery (PlaceHolders p, Record c r)
forall (f :: * -> *) a p. Functor f => f a -> f (PlaceHolders p, a)
unsafeAddPlaceHolders (QueryJoin ConfigureQuery (Record c r)
-> QueryJoin ConfigureQuery (PlaceHolders p, Record c r))
-> (Relation p r -> QueryJoin ConfigureQuery (Record c r))
-> Relation p r
-> QueryJoin ConfigureQuery (PlaceHolders p, Record c r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Relation p r -> QueryJoin ConfigureQuery (Record c r)
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 <- Qualify (QueryConfig Identity) (Qualified SubQuery)
-> QueryJoin q (Qualified SubQuery)
forall (q :: * -> *) (m :: * -> *) a.
MonadQualify q m =>
q a -> m a
liftQualify (Qualify (QueryConfig Identity) (Qualified SubQuery)
-> QueryJoin q (Qualified SubQuery))
-> Qualify (QueryConfig Identity) (Qualified SubQuery)
-> QueryJoin q (Qualified SubQuery)
forall a b. (a -> b) -> a -> b
$ do
SubQuery
sq <- Relation p r -> ConfigureQuery SubQuery
forall p r. Relation p r -> ConfigureQuery SubQuery
untypeRelation Relation p r
rel
SubQuery -> Qualify (QueryConfig Identity) (Qualified SubQuery)
forall a. a -> ConfigureQuery (Qualified a)
qualifyQuery SubQuery
sq
NodeAttr -> Qualified SubQuery -> QueryJoin q (Record c r)
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) = ((JoinContext -> JoinProduct)
-> (a, JoinContext) -> (a, JoinProduct)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second JoinContext -> JoinProduct
joinProduct ((a, JoinContext) -> (a, JoinProduct))
-> (Last Duplication -> Duplication)
-> ((a, JoinContext), Last Duplication)
-> ((a, JoinProduct), Duplication)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (Duplication -> Maybe Duplication -> Duplication
forall a. a -> Maybe a -> a
fromMaybe Duplication
All (Maybe Duplication -> Duplication)
-> (Last Duplication -> Maybe Duplication)
-> Last Duplication
-> Duplication
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Last Duplication -> Maybe Duplication
forall a. Last a -> Maybe a
getLast))
(((a, JoinContext), Last Duplication)
-> ((a, JoinProduct), Duplication))
-> m ((a, JoinContext), Last Duplication)
-> m ((a, JoinProduct), Duplication)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterT (Last Duplication) m (a, JoinContext)
-> m ((a, JoinContext), Last Duplication)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (StateT JoinContext (WriterT (Last Duplication) m) a
-> JoinContext -> WriterT (Last Duplication) m (a, JoinContext)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT JoinContext (WriterT (Last Duplication) m) a
s JoinContext
primeJoinContext)