diff --git a/Yesod/Paginator.hs b/Yesod/Paginator.hs deleted file mode 100644 --- a/Yesod/Paginator.hs +++ /dev/null @@ -1,104 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -------------------------------------------------------------------------------- --- | --- --- Inspiration from a concept by ajdunlap: --- --- --- But uses an entirely different approach. --- --- There are two pagination functions. One for arbitrary items where you --- provide the list of things to be paginated: --- --- > getSomeRoute = do --- > things' <- getAllThings --- > --- > (things, widget) <- paginate 10 things' --- > --- > defaultLayout $ do --- > [whamlet| --- > $forall thing <- things --- > ^{showThing thing} --- > --- >
--- > ^{widget} --- > |] --- --- And another for paginating directly out of the database, you provide --- the same filters as you would to @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} --- > |] --- --- 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. --- -------------------------------------------------------------------------------- -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 - - let tot = length items - let xs = take per $ drop ((p - 1) * per) items - - return (xs, widget p per tot) - -selectPaginated :: ( PersistEntity val - , PersistEntityBackend val ~ YesodPersistBackend m - , PersistQuery (YesodPersistBackend m) - , Yesod m - ) - => Int - -> [Filter val] - -> [SelectOpt val] - -> YesodDB m ([Entity val], WidgetT m IO ()) -selectPaginated = selectPaginatedWith defaultWidget - -selectPaginatedWith :: ( PersistEntity val - , PersistEntityBackend val ~ YesodPersistBackend m - , 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]) - - return (xs, widget p per tot) diff --git a/Yesod/Paginator/Widget.hs b/Yesod/Paginator/Widget.hs deleted file mode 100644 --- a/Yesod/Paginator/Widget.hs +++ /dev/null @@ -1,145 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -module Yesod.Paginator.Widget - ( getCurrentPage - , paginationWidget - , defaultWidget - , defaultPageWidgetConfig - , PageWidget - , PageWidgetConfig(..) - ) 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 - ] - --- | looks up the \"p\" GET param and converts it to an Int. returns a --- default of 1 when conversion fails. -getCurrentPage :: Yesod m => HandlerT m IO Int -getCurrentPage = liftM (fromMaybe 1 . go) $ lookupGetParam "p" - - where - go :: Maybe Text -> Maybe Int - go mp = readIntegral . T.unpack =<< mp - -showT :: (Show a) => a -> Text -showT = T.pack . show diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Main where + +import Yesod +import Yesod.Paginator +import Network.Wai.Handler.Warp (run) + +data App = App + +mkYesod "App" [parseRoutes| + / RootR GET +|] + +instance Yesod App where + approot = ApprootRelative + defaultLayout widget = do + pc <- widgetToPageContent widget + withUrlRenderer [hamlet|$newline never + $doctype 5 + + + + #{pageTitle pc} + <!-- Get Boostrap from CDN --> + <link href="https://maxcdn.bootstrapcdn.com/bootstrap/3.3.6/css/bootstrap.min.css" rel="stylesheet" integrity="sha256-7s5uDGW3AHqw6xtJmNNtr+OBRJUlgkNJEo78P4b0yRw= sha512-nNo+yCHEyn0smMxSswnf/OnX6/KwJuZTlNZBjauKhTK0c+zT+q5JOCx0UFhXQ6rJR9jg6Es8gPuD2uZcYDLqSw==" crossorigin="anonymous"> + ^{pageHead pc} + <body> + ^{pageBody pc} + |] + +getRootR :: Handler Html +getRootR = do + -- unneeded return here to match README + things' <- return [1..1142] :: Handler [Int] + + (things, widget) <- paginate 3 things' + + defaultLayout $ do + setTitle "My title" + [whamlet|$newline never + <h1>Pagination + <p>The things: + <ul> + $forall thing <- things + <li>Thing #{show thing} + + <div .pagination> + ^{widget} + |] + +main :: IO () +main = run 3000 =<< toWaiApp App diff --git a/src/Yesod/Paginator.hs b/src/Yesod/Paginator.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/Paginator.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +------------------------------------------------------------------------------- +-- | +-- +-- Inspiration from a concept by ajdunlap: +-- <http://hackage.haskell.org/package/yesod-paginate> +-- +-- But uses an entirely different approach. +-- +-- There are two pagination functions. One for arbitrary items where you +-- provide the list of things to be paginated: +-- +-- > getSomeRoute = do +-- > things' <- getAllThings +-- > +-- > (things, widget) <- paginate 10 things' +-- > +-- > defaultLayout $ do +-- > [whamlet| +-- > $forall thing <- things +-- > ^{showThing thing} +-- > +-- > <div .pagination> +-- > ^{widget} +-- > |] +-- +-- And another for paginating directly out of the database, you provide +-- the same filters as you would to @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} +-- > +-- > <div .pagination> +-- > ^{widget} +-- > |] +-- +-- 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. +-- +------------------------------------------------------------------------------- +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 + + let tot = length items + let xs = take per $ drop ((p - 1) * per) items + + return (xs, widget p per tot) + +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 + +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]) + + return (xs, widget p per tot) diff --git a/src/Yesod/Paginator/Widget.hs b/src/Yesod/Paginator/Widget.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/Paginator/Widget.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +module Yesod.Paginator.Widget + ( getCurrentPage + , paginationWidget + , defaultWidget + , defaultPageWidgetConfig + , PageWidget + , PageWidgetConfig(..) + ) 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 + <li .#{cls}> + <a href="#{updateGetParam params param}">#{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 + <li .#{cls} .disabled> + <a>#{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 + <ul class="#{cls}"> + $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 + ] + +-- | looks up the \"p\" GET param and converts it to an Int. returns a +-- default of 1 when conversion fails. +getCurrentPage :: Yesod m => HandlerT m IO Int +getCurrentPage = liftM (fromMaybe 1 . go) $ lookupGetParam "p" + + where + go :: Maybe Text -> Maybe Int + go mp = readIntegral . T.unpack =<< mp + +showT :: (Show a) => a -> Text +showT = T.pack . show diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/yesod-paginator.cabal b/yesod-paginator.cabal --- a/yesod-paginator.cabal +++ b/yesod-paginator.cabal @@ -1,29 +1,61 @@ -name: yesod-paginator -version: 0.10.0 -synopsis: A pagination approach for yesod -description: Paginate a list showing a per-item widget and links to other pages -homepage: http://github.com/pbrisbin/yesod-paginator -license: BSD3 -license-file: LICENSE -author: Patrick Brisbin -maintainer: pbrisbin@gmail.com -category: Web, Yesod -build-type: Simple -cabal-version: >=1.6 +name: yesod-paginator +version: 0.10.1 +synopsis: A pagination approach for yesod +description: Paginate a list showing a per-item widget and links to other pages +homepage: http://github.com/pbrisbin/yesod-paginator +license: BSD3 +license-file: LICENSE +author: Patrick Brisbin +maintainer: pbrisbin@gmail.com +category: Web, Yesod +build-type: Simple +cabal-version: >=1.8 +flag example + description: Build the example application + default: False + library - exposed-modules: Yesod.Paginator - Yesod.Paginator.Widget + hs-source-dirs: src + exposed-modules: Yesod.Paginator + Yesod.Paginator.Widget - build-depends: base >= 4 && < 5 - , text >= 0.11 && < 2.0 - , yesod >= 1.4 - , persistent >= 2.0 - , resourcet >= 0.4.4 - , transformers + build-depends: base >= 4 && < 5 + , text >= 0.11 && < 2.0 + , yesod >= 1.4 + , persistent >= 2.0 + , resourcet >= 0.4.4 + , transformers ghc-options: -Wall -source-repository head - type: git - location: git://github.com/pbrisbin/yesod-paginator.git +test-suite test + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + ghc-options: -Wall + build-depends: base + , hspec + , yesod-paginator + , data-default + , wai-extra + , yesod-core + , yesod-test + +executable yesod-paginator-example + if flag(example) + buildable: True + else + buildable: False + + main-is: Main.hs + hs-source-dirs: example + ghc-options: -Wall + build-depends: base + , yesod + , yesod-paginator + , warp + +source-repository head + type: git + location: git://github.com/pbrisbin/yesod-paginator.git