module Database.Relational.Monad.Trans.Restricting (
Restrictings, restrictings,
extractRestrict
) where
import Control.Monad.Trans.Class (MonadTrans (lift))
import Control.Monad.Trans.Writer (WriterT, runWriterT, tell)
import Control.Applicative (Applicative, pure, (<$>))
import Control.Arrow (second)
import Data.DList (DList, toList)
import Database.Relational.SqlSyntax (Predicate)
import Database.Relational.Monad.Class
(MonadQualify (..), MonadRestrict(..), MonadQuery (..), MonadAggregate(..))
newtype Restrictings c m a =
Restrictings (WriterT (DList (Predicate c)) m a)
deriving (MonadTrans, Monad, Functor, Applicative)
restrictings :: Monad m => m a -> Restrictings c m a
restrictings = lift
updateRestriction :: Monad m => Predicate c -> Restrictings c m ()
updateRestriction = Restrictings . tell . pure
instance (Monad q, Functor q) => MonadRestrict c (Restrictings c q) where
restrict = updateRestriction
instance MonadQualify q m => MonadQualify q (Restrictings c m) where
liftQualify = restrictings . liftQualify
instance MonadQuery q => MonadQuery (Restrictings c q) where
setDuplication = restrictings . setDuplication
restrictJoin = restrictings . restrictJoin
query' = restrictings . query'
queryMaybe' = restrictings . queryMaybe'
instance MonadAggregate m => MonadAggregate (Restrictings c m) where
groupBy = restrictings . groupBy
groupBy' = restrictings . groupBy'
extractRestrict :: (Monad m, Functor m) => Restrictings c m a -> m (a, [Predicate c])
extractRestrict (Restrictings rc) = second toList <$> runWriterT rc