module Database.Relational.Query.Monad.Trans.Ordering (
Orderings, orderings, OrderingTerms,
orderBy, asc, desc,
extractOrderingTerms
) 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.Component
(Order(Asc, Desc), OrderColumn, OrderingTerm, OrderingTerms)
import Database.Relational.Query.Projection (Projection)
import qualified Database.Relational.Query.Projection as Projection
import Database.Relational.Query.Monad.Class
(MonadRestrict(..), MonadQuery(..), MonadAggregate(..), MonadPartition(..))
newtype Orderings c m a =
Orderings (WriterT (DList OrderingTerm) m a)
deriving (MonadTrans, Monad, Functor, Applicative)
orderings :: Monad m => m a -> Orderings c m a
orderings = lift
instance MonadRestrict rc m => MonadRestrict rc (Orderings c m) where
restrict = orderings . restrict
instance MonadQuery m => MonadQuery (Orderings c m) where
setDuplication = orderings . setDuplication
restrictJoin = orderings . restrictJoin
unsafeSubQuery na = orderings . unsafeSubQuery na
instance MonadAggregate m => MonadAggregate (Orderings c m) where
unsafeAddAggregateElement = orderings . unsafeAddAggregateElement
instance MonadPartition m => MonadPartition (Orderings c m) where
unsafeAddPartitionKey = orderings . unsafeAddPartitionKey
class ProjectableOrdering p where
orderTerms :: p t -> [OrderColumn]
instance ProjectableOrdering (Projection c) where
orderTerms = Projection.columns
updateOrderBys :: (Monad m, ProjectableOrdering (Projection c))
=> Order
-> Projection c t
-> Orderings c m ()
updateOrderBys order p = Orderings . mapM_ tell $ terms where
terms = curry pure order `map` orderTerms p
orderBy :: (Monad m, ProjectableOrdering (Projection c))
=> Projection c t
-> Order
-> Orderings c m ()
orderBy = flip updateOrderBys
asc :: (Monad m, ProjectableOrdering (Projection c))
=> Projection c t
-> Orderings c m ()
asc = updateOrderBys Asc
desc :: (Monad m, ProjectableOrdering (Projection c))
=> Projection c t
-> Orderings c m ()
desc = updateOrderBys Desc
extractOrderingTerms :: (Monad m, Functor m) => Orderings c m a -> m (a, OrderingTerms)
extractOrderingTerms (Orderings oc) = second toList <$> runWriterT oc