module Database.Relational.Query.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.Query.Expr (Expr, fromJust)
import Database.Relational.Query.Component (QueryRestriction)
import Database.Relational.Query.Monad.Class (MonadRestrict(..), MonadQuery (..), MonadAggregate(..))
newtype Restrictings c m a =
Restrictings (WriterT (DList (Expr c Bool)) m a)
deriving (MonadTrans, Monad, Functor, Applicative)
restrictings :: Monad m => m a -> Restrictings c m a
restrictings = lift
updateRestriction :: Monad m => Expr c (Maybe Bool) -> Restrictings c m ()
updateRestriction = Restrictings . tell . pure . fromJust
instance (Monad q, Functor q) => MonadRestrict c (Restrictings c q) where
restrictContext = updateRestriction
instance MonadQuery q => MonadQuery (Restrictings c q) where
setDuplication = restrictings . setDuplication
restrictJoin = restrictings . restrictJoin
unsafeSubQuery a = restrictings . unsafeSubQuery a
instance MonadAggregate m => MonadAggregate (Restrictings c m) where
unsafeAddAggregateElement = restrictings . unsafeAddAggregateElement
extractRestrict :: (Monad m, Functor m) => Restrictings c m a -> m (a, QueryRestriction c)
extractRestrict (Restrictings rc) = second toList <$> runWriterT rc