diff --git a/src/Yesod/Paginator.hs b/src/Yesod/Paginator.hs --- a/src/Yesod/Paginator.hs +++ b/src/Yesod/Paginator.hs @@ -51,11 +51,19 @@ -- * Paginators , paginate + , paginateWith , selectPaginated + , selectPaginatedWith -- * Widgets , simple + , simpleWith , ellipsed + , ellipsedWith + + -- * Pagination configuration + , PaginationConfig(..) + , PageParamName(..) ) where diff --git a/src/Yesod/Paginator/Paginate.hs b/src/Yesod/Paginator/Paginate.hs --- a/src/Yesod/Paginator/Paginate.hs +++ b/src/Yesod/Paginator/Paginate.hs @@ -1,13 +1,17 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} module Yesod.Paginator.Paginate ( paginate , paginate' + , paginateWith , selectPaginated , selectPaginated' + , selectPaginatedWith , getCurrentPage + , PaginationConfig(..) + , PageParamName(..) + , defaultPaginationConfig ) where @@ -17,11 +21,18 @@ import Database.Persist import Yesod.Core import Yesod.Paginator.Pages +import Yesod.Paginator.PaginationConfig -- | Paginate a list of items paginate :: MonadHandler m => PerPage -> [a] -> m (Pages a) -paginate per items = paginate' per items <$> getCurrentPage +paginate per = + paginateWith defaultPaginationConfig { paginationConfigPerPage = per } +-- | Paginate a list of items given a pagination config +paginateWith :: MonadHandler m => PaginationConfig -> [a] -> m (Pages a) +paginateWith config items = paginate' (paginationConfigPerPage config) items + <$> (getCurrentPageWith . paginationConfigPageParamName) config + -- | A version where the current page is given -- -- This can be used to avoid the monadic context altogether. @@ -58,9 +69,25 @@ -> [Filter record] -> [SelectOpt record] -> ReaderT backend m (Pages (Entity record)) -selectPaginated per filters options = - selectPaginated' per filters options =<< lift getCurrentPage +selectPaginated per = selectPaginatedWith defaultPaginationConfig + { paginationConfigPerPage = per + } +-- | Paginate out of a persistent database given a pagination config +selectPaginatedWith + :: ( MonadHandler m + , PersistEntity record + , PersistEntityBackend record ~ BaseBackend backend + , PersistQueryRead backend + ) + => PaginationConfig + -> [Filter record] + -> [SelectOpt record] + -> ReaderT backend m (Pages (Entity record)) +selectPaginatedWith config filters options = + selectPaginated' (paginationConfigPerPage config) filters options + =<< lift ((getCurrentPageWith . paginationConfigPageParamName) config) + -- | A version where the current page is given -- -- This can be used to avoid the @'MonadHandler'@ context. @@ -86,7 +113,12 @@ ) getCurrentPage :: MonadHandler m => m PageNumber -getCurrentPage = fromMaybe 1 . go <$> lookupGetParam "p" +getCurrentPage = + getCurrentPageWith (paginationConfigPageParamName defaultPaginationConfig) + +getCurrentPageWith :: MonadHandler m => PageParamName -> m PageNumber +getCurrentPageWith pageParamName = fromMaybe 1 . go <$> lookupGetParam + (unPageParamName pageParamName) where go :: Maybe Text -> Maybe PageNumber go mp = readIntegral . unpack =<< mp diff --git a/src/Yesod/Paginator/PaginationConfig.hs b/src/Yesod/Paginator/PaginationConfig.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/Paginator/PaginationConfig.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +module Yesod.Paginator.PaginationConfig + ( PaginationConfig(..) + , PageParamName(..) + , defaultPaginationConfig + ) +where + +import Yesod.Paginator.Prelude + +import Yesod.Core +import Yesod.Paginator.Pages + +newtype PageParamName = PageParamName { unPageParamName :: Text } + deriving (Eq) + deriving newtype (Read, Show, PathPiece) + +data PaginationConfig = PaginationConfig + { paginationConfigPageParamName :: PageParamName + , paginationConfigPerPage :: PerPage + } + +defaultPaginationConfig :: PaginationConfig +defaultPaginationConfig = PaginationConfig + { paginationConfigPageParamName = PageParamName "p" + , paginationConfigPerPage = 3 + } diff --git a/src/Yesod/Paginator/Prelude.hs b/src/Yesod/Paginator/Prelude.hs --- a/src/Yesod/Paginator/Prelude.hs +++ b/src/Yesod/Paginator/Prelude.hs @@ -12,7 +12,6 @@ import Control.Monad as X import Data.List as X import Data.Maybe as X -import Data.Semigroup as X ((<>)) import Data.Text as X (Text, pack, unpack) import Numeric.Natural as X import Safe as X diff --git a/src/Yesod/Paginator/Widgets.hs b/src/Yesod/Paginator/Widgets.hs --- a/src/Yesod/Paginator/Widgets.hs +++ b/src/Yesod/Paginator/Widgets.hs @@ -4,7 +4,9 @@ module Yesod.Paginator.Widgets ( PaginationWidget , simple + , simpleWith , ellipsed + , ellipsedWith ) where @@ -14,6 +16,7 @@ import Network.URI.Encode (encodeText) import Yesod.Core import Yesod.Paginator.Pages +import Yesod.Paginator.Paginate type PaginationWidget site a = Pages a -> WidgetFor site () @@ -46,9 +49,12 @@ -- @ -- simple :: Natural -> PaginationWidget m a -simple elements pages = do - updateGetParams <- getUpdateGetParams +simple = simpleWith defaultPaginationConfig +simpleWith :: PaginationConfig -> Natural -> PaginationWidget m a +simpleWith config elements pages = do + updateGetParams <- getUpdateGetParams (paginationConfigPageParamName config) + let (prevPages, nextPages) = getBalancedPages elements pages mPrevPage = getPreviousPage pages mNextPage = getNextPage pages @@ -80,9 +86,12 @@ -- | Show pages before and after, ellipsis, and first/last ellipsed :: Natural -> PaginationWidget m a -ellipsed elements pages = do - updateGetParams <- getUpdateGetParams +ellipsed = ellipsedWith defaultPaginationConfig +ellipsedWith :: PaginationConfig -> Natural -> PaginationWidget m a +ellipsedWith config elements pages = do + updateGetParams <- getUpdateGetParams (paginationConfigPageParamName config) + let (prevPages, nextPages) = getBalancedPages elements pages mPrevPage = getPreviousPage pages @@ -159,10 +168,10 @@ prevPagesNaive = takePreviousPages (elements `div` 2) pages prevPagesCalcd = takePreviousPages (elements - genericLength nextPages - 1) pages -getUpdateGetParams :: WidgetFor site (PageNumber -> [(Text, Text)]) -getUpdateGetParams = do +getUpdateGetParams :: PageParamName -> WidgetFor site (PageNumber -> [(Text, Text)]) +getUpdateGetParams pageParamName = do params <- handlerToWidget $ reqGetParams <$> getRequest - pure $ \number -> nubOn fst $ [("p", tshow number)] <> params + pure $ \number -> nubOn fst $ [(unPageParamName pageParamName, tshow number)] <> params renderGetParams :: [(Text, Text)] -> Text renderGetParams [] = "" diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -21,6 +21,8 @@ mkYesod "App" [parseRoutes| /simple/#ItemsCount/#PerPage/#Natural SimpleR GET /ellipsed/#ItemsCount/#PerPage/#Natural EllipsedR GET + /simple-param-name/#ItemsCount/#PerPage/#Natural/#PageParamName SimpleParamNameR GET + /ellipsed-param-name/#ItemsCount/#PerPage/#Natural/#PageParamName EllipsedParamNameR GET |] instance Yesod App @@ -34,6 +36,28 @@ getEllipsedR total per elements = do pages <- paginate per $ genericReplicate total () defaultLayout [whamlet|^{ellipsed elements pages}|] + +getSimpleParamNameR + :: ItemsCount -> PerPage -> Natural -> PageParamName -> Handler Html +getSimpleParamNameR total per elements pageParamName = do + let + config = PaginationConfig + { paginationConfigPerPage = per + , paginationConfigPageParamName = pageParamName + } + pages <- paginateWith config $ genericReplicate total () + defaultLayout [whamlet|^{simpleWith config elements pages}|] + +getEllipsedParamNameR + :: ItemsCount -> PerPage -> Natural -> PageParamName -> Handler Html +getEllipsedParamNameR total per elements pageParamName = do + let + config = PaginationConfig + { paginationConfigPerPage = per + , paginationConfigPageParamName = pageParamName + } + pages <- paginateWith config $ genericReplicate total () + defaultLayout [whamlet|^{ellipsedWith config elements pages}|] withApp :: SpecWith (TestApp App) -> Spec withApp = before $ pure (App, id) diff --git a/test/Yesod/Paginator/WidgetsSpec.hs b/test/Yesod/Paginator/WidgetsSpec.hs --- a/test/Yesod/Paginator/WidgetsSpec.hs +++ b/test/Yesod/Paginator/WidgetsSpec.hs @@ -98,3 +98,94 @@ , "
  • »
    • " , "" ] + + describe "simple with page param" $ it "works" $ do + get $ SimpleParamNameR 10 3 3 (PageParamName "page") + + statusIs 200 + bodyContains $ concat + [ "" + ] + + request $ do + addGetParam "page" "3" + setUrl $ SimpleParamNameR 10 3 3 (PageParamName "page") + + statusIs 200 + bodyContains $ concat + [ "" + ] + + request $ do + addGetParam "page" "4" + setUrl $ SimpleParamNameR 10 3 3 (PageParamName "page") + + statusIs 200 + bodyContains $ concat + [ "" + ] + + describe "ellipsed with page param" $ it "works" $ do + get $ EllipsedParamNameR 10 3 3 (PageParamName "page") + + statusIs 200 + bodyContains $ concat + [ "" + ] + + get $ EllipsedParamNameR 15 3 3 (PageParamName "page") + + statusIs 200 + bodyContains $ concat + [ "" + ] + + request $ do + addGetParam "page" "5" + setUrl $ EllipsedParamNameR 15 3 3 (PageParamName "page") + + statusIs 200 + bodyContains $ concat + [ "" + ] diff --git a/yesod-paginator.cabal b/yesod-paginator.cabal --- a/yesod-paginator.cabal +++ b/yesod-paginator.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.1. +-- This file has been generated from package.yaml by hpack version 0.31.2. -- -- see: https://github.com/sol/hpack -- --- hash: c412aee17c1ede253c8e371db6af5b8e8618b2b0a835c5410cf4b90cd566aaeb +-- hash: 997fa6b9ee2b93c5590ad92497cf2b628931167ff2ccdd566227408106b0e1df name: yesod-paginator -version: 1.1.0.2 +version: 1.1.1.0 synopsis: A pagination approach for yesod description: Paginate a list showing a per-item widget and links to other pages category: Web, Yesod @@ -32,6 +32,7 @@ Yesod.Paginator Yesod.Paginator.Pages Yesod.Paginator.Paginate + Yesod.Paginator.PaginationConfig Yesod.Paginator.Prelude Yesod.Paginator.Widgets other-modules: