diff --git a/src/Data/Functor/Local.hs b/src/Data/Functor/Local.hs new file mode 100644 index 0000000..e3e70ce --- /dev/null +++ b/src/Data/Functor/Local.hs @@ -0,0 +1,32 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Data.Functor.Local + ( fwith + , (<&>) + ) +where + +import Prelude + +-- | Flipped 'fmap'. +fwith :: Functor f => f a -> (a -> b) -> f b +fwith = flip fmap + +-- | Flipped '<$>'. +(<&>) :: Functor f => f a -> (a -> b) -> f b +(<&>) = flip (<$>) + +infixr 4 <&> diff --git a/src/Data/Paginate/Local.hs b/src/Data/Paginate/Local.hs index aa75ba3..d541d28 100644 --- a/src/Data/Paginate/Local.hs +++ b/src/Data/Paginate/Local.hs @@ -98,10 +98,10 @@ data PaginateSettings m f i = PaginateSettings , psPer :: Int } -instance Monad m => Default (PaginateSettings m f i) where +instance Default (PaginateSettings m f i) where def = PaginateSettings - { psSelect = \ _ _ -> error "You didn't implement psSelect" - , psCurrent = return 1 + { psSelect = error "You didn't implement psSelect" + , psCurrent = error "You didn't implement psCurrent" , psPer = 30 } diff --git a/src/Vervis/Paginate.hs b/src/Vervis/Paginate.hs new file mode 100644 index 0000000..4d8bfd7 --- /dev/null +++ b/src/Vervis/Paginate.hs @@ -0,0 +1,74 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Vervis.Paginate + ( getPaginated + ) +where + +import Prelude + +import Control.Arrow (second) +import Data.Default.Class (def) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import Yesod.Core (MonadHandler (HandlerSite)) +import Yesod.Core.Handler (getCurrentRoute, lookupGetParam) +import Yesod.Core.Widget (WidgetT) + +import qualified Data.Text as T (null, pack) +import qualified Data.Text.Read as TR (decimal) + +import Data.Functor.Local +import Data.Paginate.Local +import Yesod.Paginate.Local + +navSettings :: NavSettings +navSettings = def + +getCurrentPage :: MonadHandler m => m Int +getCurrentPage = lookupGetParam "page" <&> \ mpage -> + case mpage of + Nothing -> 1 + Just page -> + case second T.null <$> TR.decimal page of + Right (p, True) -> p + _ -> 1 + +paginateSettings + :: MonadHandler m + => (Int -> Int -> m (Int, f i)) + -> PaginateSettings m f i +paginateSettings select = def + { psSelect = select + , psCurrent = getCurrentPage + } + +navWidgetSettings :: NavWidgetSettings +navWidgetSettings = def + +getPaginated + :: MonadHandler m + => (Int -> Int -> m (Int, f i)) + -- ^ Given offset and limit, get total number of items and chosen subset + -> m (f i, WidgetT (HandlerSite m) IO ()) +getPaginated select = do + (items, nm) <- paginate (paginateSettings select) navSettings + route <- + fromMaybe (error "Pagination in invalid response content") <$> + getCurrentRoute + let url n = (route, "?page=" <> T.pack (show n)) + widget = pageNavWidget nm navWidgetSettings url + return (items, widget) diff --git a/src/Yesod/Paginate/Local.hs b/src/Yesod/Paginate/Local.hs index 7f5d082..f219d50 100644 --- a/src/Yesod/Paginate/Local.hs +++ b/src/Yesod/Paginate/Local.hs @@ -30,6 +30,7 @@ import Prelude import Data.Default.Class import Data.Text (Text) +import Text.Blaze (ToMarkup) import Yesod.Core (RenderRoute (..)) import Yesod.Core.Widget (WidgetT, whamlet) @@ -65,18 +66,24 @@ instance Default NavWidgetSettings where } pageNavWidget - :: NavModel + :: ToMarkup t + => NavModel -> NavWidgetSettings - -> (Int -> Route site) + -> (Int -> (Route site, t)) -> WidgetT site IO () -pageNavWidget nm nws route = - [whamlet| -