Basic pagination for Vervis

src/Data/Functor/Local.hs

@@ -0,0 +1,32 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ 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
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+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 <&>

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"
+        { psSelect  = error "You didn't implement psSelect"
-        , psCurrent = return 1
+        , psCurrent = error "You didn't implement psCurrent"
         , psPer     = 30
         }
 

src/Vervis/Paginate.hs

@@ -0,0 +1,74 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ 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
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+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)

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 =
+pageNavWidget nm nws mklink =
-    [whamlet|
+    let link n label =
+            let (route, suffix) = mklink n
+            in  [whamlet|
+                    <a href=@{route}#{suffix}>#{label}
+                |]
+    in  [whamlet|
             <ul>
               $if nmFirst nm
                 <li>
-              <a href=@{route 1}>#{nwsFirst nws}
+                  ^{link 1 $ nwsFirst nws}
               <li>#{nwsCurrent nws (nmCurrent nm) (nmTotal nm)}
               $if nmLast nm
                 <li>
-              <a href=@{route $ nmTotal nm}>#{nwsLast nws $ nmTotal nm}
+                  ^{link (nmTotal nm) (nwsLast nws $ nmTotal nm)}
         |]

vervis.cabal

@@ -43,6 +43,7 @@ library
                        Data.ByteString.Local
                        Data.Char.Local
                        Data.EventTime.Local
+                       Data.Functor.Local
                        Data.Git.Local
                        Data.Hourglass.Local
                        Data.List.Local
@@ -86,6 +87,7 @@ library
                        Vervis.MediaType
                        Vervis.Model
                        Vervis.Model.Repo
+                       Vervis.Paginate
                        Vervis.Path
                        Vervis.Readme
                        Vervis.Render