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
(MonadQualify (..), 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 MonadQualify q m => MonadQualify q (Orderings c m) where
liftQualify = orderings . liftQualify
instance MonadQuery m => MonadQuery (Orderings c m) where
setDuplication = orderings . setDuplication
restrictJoin = orderings . restrictJoin
query' = orderings . query'
queryMaybe' = orderings . queryMaybe'
instance MonadAggregate m => MonadAggregate (Orderings c m) where
groupBy = orderings . groupBy
groupBy' = orderings . groupBy'
instance MonadPartition c m => MonadPartition c (Orderings c m) where
partitionBy = orderings . partitionBy
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