diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2010, Patrick Brisbin + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Patrick Brisbin nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Yesod/Paginator.hs b/Yesod/Paginator.hs new file mode 100644 --- /dev/null +++ b/Yesod/Paginator.hs @@ -0,0 +1,161 @@ +{-# 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, and one for paginating +-- directly out of the database, you provide the same filters as you +-- would to @selectList@. +-- +-- Both functions return a tuple: the first element being the list of +-- items to display on this page and the second being a widget showing +-- the pagination navagation links. +-- +------------------------------------------------------------------------------- +module Yesod.Paginator + ( paginate + , selectPaginated + , paginationWidget + ) where + +import Yesod +import Database.Persist.Store (Entity) +import Data.Text (Text) +import qualified Data.Text as T + +-- | Paginate an existing list of items. +-- +-- > getSomeRoute = do +-- > things' <- getAllThings +-- > +-- > (things, widget) <- paginate 10 things' +-- > +-- > defaultLayout $ do +-- > [whamlet| +-- > $forall thing <- things +-- > ^{showThing thing} +-- > +-- >
+-- > ^{widget} +-- > |] +-- +paginate :: Int -- ^ items per page + -> [a] -- ^ complete list of items + -> GHandler s m ([a], GWidget s m ()) +paginate per items = do + let tot = length items + + p <- getCurrentPage tot + + let xs = take per $ drop ((p - 1) * per) items + + return (xs, paginationWidget p per tot) + +-- | Paginate directly out of the database. +-- +-- > getSomeRoute something = do +-- > -- note: things is [Entity val] just like selectList returns +-- > (things, widget) <- selectPaginated 10 [SomeThing ==. something] [] +-- > +-- > defaultLayout $ do +-- > [whamlet| +-- > $forall thing <- things +-- > ^{showThing $ entityVal thing} +-- > +-- >
+-- > ^{widget} +-- > |] +-- +selectPaginated :: ( YesodPersistBackend m ~ PersistEntityBackend v + , YesodPersist m + , PersistEntity v + , PersistQuery (PersistEntityBackend v) (GHandler s m) + ) + => Int -> [Filter v] -> [SelectOpt v] + -> GHandler s m ([Entity v], GWidget s m ()) +selectPaginated per filters selectOpts = do + tot <- runDB $ count filters + p <- getCurrentPage tot + xs <- runDB $ selectList filters (selectOpts ++ [OffsetBy ((p-1)*per), LimitTo per]) + + return (xs, paginationWidget p per tot) + +-- | A widget showing pagination links. Follows bootstrap principles. +-- Utilizes a \"p\" GET param but leaves all other GET params intact. +paginationWidget :: Int -- ^ current page + -> Int -- ^ items per page + -> Int -- ^ total number of items + -> GWidget s m () +paginationWidget page per tot = do + let pages = (\(n, r) -> n + (min r 1)) $ tot `divMod` per + + if pages <= 1 + then return () + else do + let prev = [1 ..(page-1)] + let next = [(page+1)..pages ] + + let lim = 9 -- don't show more than nine links on either side + let prev' = if length prev > lim then drop ((length prev) - lim) prev else prev + let next' = if length next > lim then take lim next else next + + curParams <- lift $ fmap reqGetParams getRequest + + [whamlet| +