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.SqlSyntax
(Duplication (All), NodeAttr (Just', Maybe), Predicate, Record,
SubQuery, Qualified, JoinProduct, restrictProduct, growProduct, )
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, qualifyQuery, Relation, untypeRelation)
import Database.Relational.Monad.Class (MonadQualify (..), MonadQuery (..))
newtype QueryJoin m a =
QueryJoin (StateT JoinContext (WriterT (Last Duplication) m) a)
deriving (Monad, Functor, Applicative)
instance MonadTrans QueryJoin where
lift = QueryJoin . lift . lift
join' :: Monad m => m a -> QueryJoin m a
join' = lift
updateContext :: Monad m => (JoinContext -> JoinContext) -> QueryJoin m ()
updateContext = QueryJoin . modify
updateJoinRestriction :: Monad m => Predicate Flat -> QueryJoin m ()
updateJoinRestriction e = updateContext (updateProduct d) where
d Nothing = error "on: Product is empty! Restrict target product is not found!"
d (Just pt) = restrictProduct pt e
instance MonadQualify q m => MonadQualify q (QueryJoin m) where
liftQualify = join' . liftQualify
instance MonadQuery (QueryJoin ConfigureQuery) where
setDuplication = QueryJoin . lift . tell . Last . Just
restrictJoin = updateJoinRestriction
query' = queryWithAttr Just'
queryMaybe' pr = do
(ph, pj) <- queryWithAttr Maybe pr
return (ph, Record.just pj)
unsafeSubQueryWithAttr :: Monad q
=> NodeAttr
-> Qualified SubQuery
-> QueryJoin q (Record c r)
unsafeSubQueryWithAttr attr qsub = do
updateContext (updateProduct (`growProduct` (attr, qsub)))
return $ Record.unsafeFromQualifiedSubQuery qsub
queryWithAttr :: NodeAttr
-> Relation p r
-> QueryJoin ConfigureQuery (PlaceHolders p, Record c r)
queryWithAttr attr = unsafeAddPlaceHolders . run where
run rel = do
q <- liftQualify $ do
sq <- untypeRelation rel
qualifyQuery sq
unsafeSubQueryWithAttr attr q
extractProduct :: Functor m => QueryJoin m a -> m ((a, JoinProduct), Duplication)
extractProduct (QueryJoin s) = (second joinProduct *** (fromMaybe All . getLast))
<$> runWriterT (runStateT s primeJoinContext)