--- > ^{widget}
--- > |]
+-- $# display at most 5 page elements, with current page middle-ish
+-- ^{'simple' 5 pages}
+-- |]
+-- @
--
--- And another for paginating directly out of the database, you provide
--- the same filters as you would to @selectList@.
+-- And another for paginating directly out of the database, you provide the same
+-- arguments as you would for @'selectList'@:
--
--- > getSomeRoute something = do
--- > -- note: things is [Entity val] just like selectList returns
--- > (things, widget) <- runDB $ selectPaginated 10 [SomeThing ==. something] []
--- >
--- > defaultLayout $ do
--- > [whamlet|
--- > $forall thing <- things
--- > ^{showThing $ entityVal thing}
--- >
--- >
--- > ^{widget}
--- > |]
+-- @
+-- getSomeRoute something = do
+-- pages <- runDB $ 'selectPaginated' 10 [SomeThing ==. something] []
--
--- Both functions return a tuple: the first element being the list of
--- items (or Entities) to display on this page and the second being a
--- widget showing the pagination navagation links.
+-- defaultLayout $ do
+-- [whamlet|
+-- $forall thing <- 'pageItems' $ 'pagesCurrent' pages
+-- ^{showThing $ entityVal thing}
--
--------------------------------------------------------------------------------
+-- ^{'simple' 5 pages}
+-- |]
+-- @
+--
module Yesod.Paginator
- ( paginate
- , paginateWith
- , selectPaginated
- , selectPaginatedWith
- , module Yesod.Paginator.Widget
- ) where
-
-import Yesod
-import Yesod.Paginator.Widget
-
-paginate :: Yesod m => Int -> [a] -> HandlerT m IO ([a], WidgetT m IO ())
-paginate = paginateWith defaultWidget
-
-paginateWith :: Yesod m
- => PageWidget m
- -> Int
- -> [a]
- -> HandlerT m IO ([a], WidgetT m IO ())
-paginateWith widget per items = do
- p <- getCurrentPage
+ (
+ -- * Type-safe numerics
+ PageNumber
+ , PerPage
+ , ItemsCount
- let tot = length items
- let xs = take per $ drop ((p - 1) * per) items
+ -- * Paginated data
+ , Pages
+ , pagesCurrent
- return (xs, widget p per tot)
+ -- * The current page
+ , Page
+ , pageItems
-selectPaginated :: ( PersistEntity val
-#if MIN_VERSION_persistent(2, 5, 0)
- , PersistEntityBackend val ~ BaseBackend (YesodPersistBackend m)
-#else
- , PersistEntityBackend val ~ YesodPersistBackend m
-#endif
- , PersistQuery (YesodPersistBackend m)
- , Yesod m
- )
- => Int
- -> [Filter val]
- -> [SelectOpt val]
- -> YesodDB m ([Entity val], WidgetT m IO ())
-selectPaginated = selectPaginatedWith defaultWidget
+ -- * Paginators
+ , paginate
+ , selectPaginated
-selectPaginatedWith :: ( PersistEntity val
-#if MIN_VERSION_persistent(2, 5, 0)
- , PersistEntityBackend val ~ BaseBackend (YesodPersistBackend m)
-#else
- , PersistEntityBackend val ~ YesodPersistBackend m
-#endif
- , PersistQuery (YesodPersistBackend m)
- , Yesod m
- )
- => PageWidget m
- -> Int
- -> [Filter val]
- -> [SelectOpt val]
- -> YesodDB m ([Entity val], WidgetT m IO ())
-selectPaginatedWith widget per filters selectOpts = do
- p <- lift getCurrentPage
- tot <- count filters
- xs <- selectList filters (selectOpts ++ [OffsetBy ((p-1)*per), LimitTo per])
+ -- * Widgets
+ , simple
+ , ellipsed
+ )
+where
- return (xs, widget p per tot)
+import Yesod.Paginator.Pages
+import Yesod.Paginator.Paginate
+import Yesod.Paginator.Widgets
diff --git a/src/Yesod/Paginator/Pages.hs b/src/Yesod/Paginator/Pages.hs
new file mode 100644
--- /dev/null
+++ b/src/Yesod/Paginator/Pages.hs
@@ -0,0 +1,150 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Yesod.Paginator.Pages
+ (
+ -- * Type safe @'Natural'@s
+ -- |
+ --
+ -- N.B. @'PageNumber'@ and @'PerPage'@ will currently allow @0@, but it's
+ -- unclear if that's correct and may not be the case in the future.
+ --
+ PageNumber
+ , PerPage
+ , ItemsCount
+ , pageOffset
+
+ -- * Page
+ , Page
+ , pageItems
+ , pageNumber
+ , toPage
+
+ -- * Pages
+ , Pages
+ , pagesCurrent
+ , pagesLast
+ , toPages
+
+ -- * Safely accessing Pages data
+ , takePreviousPages
+ , takeNextPages
+ , getPreviousPage
+ , getNextPage
+ )
+where
+
+import Yesod.Paginator.Prelude
+
+import Text.Blaze (ToMarkup)
+import Web.PathPieces
+
+newtype PageNumber = PageNumber Natural
+ deriving (Enum, Eq, Integral, Num, Ord, Real)
+ deriving newtype (Show, ToMarkup)
+
+newtype PerPage = PerPage Natural
+ deriving (Enum, Eq, Integral, Num, Ord, Real)
+ deriving newtype (Read, Show, PathPiece)
+
+newtype ItemsCount = ItemsCount Natural
+ deriving (Enum, Eq, Integral, Num, Ord, Real)
+ deriving newtype (Read, Show, PathPiece)
+
+data Page a = Page
+ { pageItems :: [a]
+ , pageNumber :: PageNumber
+ }
+ deriving (Eq, Show)
+
+-- | @'Page'@ constructor
+toPage :: [a] -> PageNumber -> Page a
+toPage = Page
+
+data Pages a = Pages
+ { pagesCurrent :: Page a
+ , pagesPrevious :: [PageNumber]
+ , pagesNext :: [PageNumber]
+ , pagesLast :: PageNumber
+ }
+ deriving (Eq, Show)
+
+-- | Take previous pages, going back from current
+--
+-- >>> takePreviousPages 3 $ Pages (Page [] 5) [1,2,3,4] [6] 6
+-- [2,3,4]
+--
+takePreviousPages :: Natural -> Pages a -> [PageNumber]
+takePreviousPages n = reverse . genericTake n . reverse . pagesPrevious
+
+-- | Take next pages, going forward from current
+--
+-- >>> takeNextPages 3 $ Pages (Page [] 2) [1] [3,4,5,6] 6
+-- [3,4,5]
+--
+takeNextPages :: Natural -> Pages a -> [PageNumber]
+takeNextPages n = genericTake n . pagesNext
+
+-- | The previous page number, if it exists
+--
+-- >>> getPreviousPage $ Pages (Page [] 1) [] [2,3,4] 4
+-- Nothing
+--
+-- >>> getPreviousPage $ Pages (Page [] 2) [1] [3,4] 4
+-- Just 1
+--
+getPreviousPage :: Pages a -> Maybe PageNumber
+getPreviousPage pages = do
+ let prevPage = pageNumber (pagesCurrent pages) - 1
+ firstPage <- headMay $ pagesPrevious pages
+ prevPage <$ guard (prevPage >= firstPage)
+
+-- | The next page number, if it exists
+--
+-- >>> getNextPage $ Pages (Page [] 4) [1,2,3] [] 4
+-- Nothing
+--
+-- >>> getNextPage $ Pages (Page [] 3) [1,2] [4] 4
+-- Just 4
+--
+getNextPage :: Pages a -> Maybe PageNumber
+getNextPage pages = do
+ let nextPage = pageNumber (pagesCurrent pages) + 1
+ lastPage <- lastMay $ pagesNext pages
+ nextPage <$ guard (nextPage <= lastPage)
+
+-- | Construct a @'Pages' a@ from paginated data
+--
+-- >>> toPages 4 3 10 []
+-- Pages {pagesCurrent = Page {pageItems = [], pageNumber = 4}, pagesPrevious = [1,2,3], pagesNext = [], pagesLast = 4}
+--
+toPages :: PageNumber -> PerPage -> ItemsCount -> [a] -> Pages a
+toPages number per total items = Pages
+ { pagesCurrent = toPage items number
+ , pagesPrevious = [1 .. (number - 1)]
+ , pagesNext = [(number + 1) .. lastPage]
+ , pagesLast = lastPage
+ }
+ where lastPage = getLastPage total per
+
+-- | Calculate the last page of some paginated data
+--
+-- >>> getLastPage 10 3
+-- 4
+--
+-- >>> getLastPage 10 5
+-- 2
+--
+getLastPage :: ItemsCount -> PerPage -> PageNumber
+getLastPage total = fromIntegral . carry . (total `divMod`) . fromIntegral
+ where
+ carry (q, 0) = q
+ carry (q, _) = q + 1
+
+-- | Calculate a page's zero-based offset in the overall items
+--
+-- >>> pageOffset 4 3
+-- 9
+--
+pageOffset :: PageNumber -> PerPage -> ItemsCount
+pageOffset p per = fromIntegral $ (fromIntegral p - 1) * per
diff --git a/src/Yesod/Paginator/Paginate.hs b/src/Yesod/Paginator/Paginate.hs
new file mode 100644
--- /dev/null
+++ b/src/Yesod/Paginator/Paginate.hs
@@ -0,0 +1,92 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Yesod.Paginator.Paginate
+ ( paginate
+ , paginate'
+ , selectPaginated
+ , selectPaginated'
+ )
+where
+
+import Yesod.Paginator.Prelude
+
+import Control.Monad.Trans.Reader (ReaderT)
+import Database.Persist
+import Yesod.Core
+import Yesod.Paginator.Pages
+import Yesod.Persist.Core
+
+-- | Paginate a list of items
+paginate :: Yesod site => PerPage -> [a] -> HandlerFor site (Pages a)
+paginate per items = paginate' per items <$> getCurrentPage
+
+-- | A version where the current page is given
+--
+-- This can be used to avoid the monadic context altogether.
+--
+-- >>> paginate' 3 ([1..10] :: [Int]) 1
+-- Pages {pagesCurrent = Page {pageItems = [1,2,3], pageNumber = 1}, pagesPrevious = [], pagesNext = [2,3,4], pagesLast = 4}
+--
+-- >>> paginate' 3 ([1..10] :: [Int]) 2
+-- Pages {pagesCurrent = Page {pageItems = [4,5,6], pageNumber = 2}, pagesPrevious = [1], pagesNext = [3,4], pagesLast = 4}
+--
+-- >>> paginate' 3 ([1..10] :: [Int]) 3
+-- Pages {pagesCurrent = Page {pageItems = [7,8,9], pageNumber = 3}, pagesPrevious = [1,2], pagesNext = [4], pagesLast = 4}
+--
+-- >>> paginate' 3 ([1..10] :: [Int]) 4
+-- Pages {pagesCurrent = Page {pageItems = [10], pageNumber = 4}, pagesPrevious = [1,2,3], pagesNext = [], pagesLast = 4}
+--
+-- >>> paginate' 3 ([1..10] :: [Int]) 5
+-- Pages {pagesCurrent = Page {pageItems = [], pageNumber = 5}, pagesPrevious = [1,2,3,4], pagesNext = [], pagesLast = 4}
+--
+paginate' :: PerPage -> [a] -> PageNumber -> Pages a
+paginate' per items p =
+ toPages p per (genericLength items) $ genericTake per $ genericDrop
+ (pageOffset p per)
+ items
+
+-- | Paginate out of a persistent database
+selectPaginated
+ :: ( PersistEntity val
+ , PersistEntityBackend val ~ BaseBackend (YesodPersistBackend site)
+ , PersistQuery (YesodPersistBackend site)
+ , Yesod site
+ )
+ => PerPage
+ -> [Filter val]
+ -> [SelectOpt val]
+ -> YesodDB site (Pages (Entity val))
+selectPaginated per filters options =
+ selectPaginated' per filters options =<< lift getCurrentPage
+
+-- | A version where the current page is given
+--
+-- This can be used to avoid the Yesod context
+--
+selectPaginated'
+ :: ( MonadIO m
+ , PersistEntity record
+ , PersistEntityBackend record ~ BaseBackend backend
+ , PersistQueryRead backend
+ )
+ => PerPage
+ -> [Filter record]
+ -> [SelectOpt record]
+ -> PageNumber
+ -> ReaderT backend m (Pages (Entity record))
+selectPaginated' per filters options p =
+ toPages p per <$> (fromIntegral <$> count filters) <*> selectList
+ filters
+ (options
+ <> [ OffsetBy $ fromIntegral $ pageOffset p per
+ , LimitTo $ fromIntegral per
+ ]
+ )
+
+getCurrentPage :: MonadHandler m => m PageNumber
+getCurrentPage = fromMaybe 1 . go <$> lookupGetParam "p"
+ where
+ go :: Maybe Text -> Maybe PageNumber
+ go mp = readIntegral . unpack =<< mp
diff --git a/src/Yesod/Paginator/Prelude.hs b/src/Yesod/Paginator/Prelude.hs
new file mode 100644
--- /dev/null
+++ b/src/Yesod/Paginator/Prelude.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Yesod.Paginator.Prelude
+ ( module X
+ , module Yesod.Paginator.Prelude
+ )
+where
+
+import Prelude as X
+
+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
+
+import Data.Function (on)
+import Web.PathPieces
+
+instance PathPiece Natural where
+ toPathPiece = toPathPiece @Int . fromIntegral
+ fromPathPiece p = do
+ n <- fromPathPiece @Int p
+ guard $ n >= 0
+ pure $ fromIntegral n
+
+tshow :: Show a => a -> Text
+tshow = pack . show
+
+nubOn :: Eq b => (a -> b) -> [a] -> [a]
+nubOn f = nubBy ((==) `on` f)
diff --git a/src/Yesod/Paginator/Widget.hs b/src/Yesod/Paginator/Widget.hs
deleted file mode 100644
--- a/src/Yesod/Paginator/Widget.hs
+++ /dev/null
@@ -1,173 +0,0 @@
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleContexts #-}
-module Yesod.Paginator.Widget
- ( getCurrentPage
- , paginationWidget
- , defaultWidget
- , defaultPageWidgetConfig
- , simplePaginationWidget
- , PageWidget
- , PageWidgetConfig(..)
- , PageLink(..)
- , showLink
- ) where
-
-import Yesod
-import Control.Monad (when, liftM)
-import Data.Maybe (fromMaybe)
-import Data.Text (Text)
-
-import qualified Data.Text as T
-
--- | currentPage, itemsPerPage, totalItems -> widget
-type PageWidget m = Int -> Int -> Int -> WidgetT m IO ()
-
-data PageWidgetConfig = PageWidgetConfig
- { prevText :: Text -- ^ The text for the 'previous page' link.
- , nextText :: Text -- ^ The text for the 'next page' link.
- , pageCount :: Int -- ^ The number of page links to show
- , ascending :: Bool -- ^ Whether to list pages in ascending order.
- , showEllipsis :: Bool -- ^ Whether to show an ellipsis if there are
- -- more pages than pageCount
- , listClasses :: [Text] -- ^ Additional classes for top level list
- }
-
--- | Individual links to pages need to follow strict (but sane) markup
--- to be styled correctly by bootstrap. This type allows construction
--- of such links in both enabled and disabled states.
-data PageLink = Enabled Int Text Text -- ^ page, content, class
- | Disabled Text Text -- ^ content, class
-
--- | Correctly show one of the constructed links
-showLink :: [(Text, Text)] -> PageLink -> WidgetT m IO ()
-showLink params (Enabled pg cnt cls) = do
- let param = ("p", showT pg)
-
- [whamlet|$newline never
-
- #{cnt}
- |]
-
- where
- updateGetParam :: [(Text,Text)] -> (Text,Text) -> Text
- updateGetParam getParams (p, n) = T.cons '?' . T.intercalate "&"
- . map (\(k,v) -> k `T.append` "=" `T.append` v)
- . (++ [(p, n)]) . filter ((/= p) . fst) $ getParams
-
-showLink _ (Disabled cnt cls) =
- [whamlet|$newline never
-
- #{cnt}
- |]
-
--- | Default widget config provided for easy overriding of only some fields.
-defaultPageWidgetConfig :: PageWidgetConfig
-defaultPageWidgetConfig = PageWidgetConfig { prevText = "«"
- , nextText = "»"
- , pageCount = 9
- , ascending = True
- , showEllipsis = True
- , listClasses = ["pagination"]
- }
-
-defaultWidget :: Yesod m => PageWidget m
-defaultWidget = paginationWidget defaultPageWidgetConfig
-
--- | A widget showing pagination links. Follows bootstrap principles.
--- Utilizes a \"p\" GET param but leaves all other GET params intact.
-paginationWidget :: Yesod m => PageWidgetConfig -> PageWidget m
-paginationWidget PageWidgetConfig {..} page per tot = do
- -- total / per + 1 for any remainder
- let pages = (\(n, r) -> n + min r 1) $ tot `divMod` per
-
- when (pages > 1) $ do
- curParams <- handlerToWidget $ liftM reqGetParams getRequest
-
- [whamlet|$newline never
-
- $forall link <- buildLinks page pages
- ^{showLink curParams link}
- |]
-
- where
- -- | Concatenate all additional classes.
- cls = T.intercalate " " listClasses
-
- -- | Build up each component of the overall list of links. We'll
- -- use empty lists to denote ommissions along the way then
- -- concatenate.
- buildLinks :: Int -> Int -> [PageLink]
- buildLinks pg pgs =
- let prev = [1 .. pg - 1]
- next = [pg + 1 .. pgs ]
-
- -- these always appear
- prevLink = [(if null prev then Disabled else Enabled (pg - 1)) prevText "prev"]
- nextLink = [(if null next then Disabled else Enabled (pg + 1)) nextText "next"]
-
- -- show first/last unless we're on it
- firstLink = [ Enabled 1 "1" "prev" | pg > 1 ]
- lastLink = [ Enabled pgs (showT pgs) "next" | pg < pgs ]
-
- -- we'll show ellipsis if there are enough links that some will
- -- be ommitted from the list
- prevEllipsis = [ Disabled "..." "prev" | showEllipsis && length prev > pageCount + 1 ]
- nextEllipsis = [ Disabled "..." "next" | showEllipsis && length next > pageCount + 1 ]
-
- -- the middle lists, strip the first/last pages and
- -- correctly take up to limit away from current
- prevLinks = reverse . take pageCount . reverse . drop 1 $ map (\p -> Enabled p (showT p) "prev") prev
- nextLinks = take pageCount . reverse . drop 1 . reverse $ map (\p -> Enabled p (showT p) "next") next
-
- -- finally, this page itself
- curLink = [Disabled (showT pg) "active"]
-
- in concat $ (if ascending then id else reverse) [ prevLink
- , firstLink
- , prevEllipsis
- , prevLinks
- , curLink
- , nextLinks
- , nextEllipsis
- , lastLink
- , nextLink
- ]
-
--- | A simple widget that only shows next and previous links. Follows bootstrap
--- principles. Utilizes a \"p\" GET param but leaves all other GET params
--- intact. Uses the same config data type as the main pagination widget, but
--- ignores all of the values with the exception of the text for the next and
--- previous links.
-simplePaginationWidget :: Yesod m => PageWidgetConfig -> PageWidget m
-simplePaginationWidget PageWidgetConfig {..} page per tot = do
- -- total number of pages
- let pages = (\(n, r) -> n + min r 1) $ tot `divMod` per
-
- when (pages > 1) $ do
- curParams <- handlerToWidget $ liftM reqGetParams getRequest
-
- [whamlet|$newline never
-