{-# 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 (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 :: MonadQualify ConfigureQuery q
=> NodeAttr
-> Qualified SubQuery
-> QueryJoin q (Record c r)
unsafeSubQueryWithAttr attr qsub = do
addAS <- addQueryTableAliasAS <$> liftQualify askConfig
updateContext (updateProduct (`growProduct` (attr, (addAS, 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)