Paginate simplification

1 files changed, 134 insertions, 0 deletions

diff --git a/src/Hakyll/Web/Paginate.hs b/src/Hakyll/Web/Paginate.hs
new file mode 100644
index 0000000..eafd3a9
--- /dev/null
+++ b/src/Hakyll/Web/Paginate.hs
@@ -0,0 +1,134 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE OverloadedStrings #-}
+module Hakyll.Web.Paginate
+    ( PageNumber
+    , Paginate (..)
+    , buildPaginate
+    , buildPaginateWith
+    , paginateRules
+    , paginateContext
+    ) where
+
+
+--------------------------------------------------------------------------------
+import           Control.Monad                  (forM_)
+import           Data.List                      (unfoldr)
+import qualified Data.Map                       as M
+import           Data.Monoid                    (mconcat)
+import           Text.Printf                    (printf)
+
+
+--------------------------------------------------------------------------------
+import           Hakyll.Core.Compiler
+import           Hakyll.Core.Identifier
+import           Hakyll.Core.Identifier.Pattern
+import           Hakyll.Core.Item
+import           Hakyll.Core.Metadata
+import           Hakyll.Core.Rules
+import           Hakyll.Web.Html
+import           Hakyll.Web.Template.Context
+
+
+--------------------------------------------------------------------------------
+type PageNumber = Int
+
+
+--------------------------------------------------------------------------------
+-- | Data about paginators
+data Paginate = Paginate
+    { paginatePages      :: M.Map PageNumber [Identifier]
+    , paginatePlaces     :: M.Map Identifier PageNumber
+    , paginateMakeId     :: PageNumber -> Identifier
+    , paginateDependency :: Dependency
+    } deriving (Show)
+
+
+--------------------------------------------------------------------------------
+buildPaginate :: MonadMetadata m
+              => Pattern
+              -> m Paginate
+buildPaginate pattern = do
+    idents <- getMatches pattern
+    let pagPages  = M.fromList $ zip [1 ..] (map return idents)
+        pagPlaces = M.fromList $ zip idents [1 ..]
+        makeId pn = case M.lookup pn pagPages of
+            Just [id'] -> id'
+            _          -> error $
+                "Hakyll.Web.Paginate.buildPaginate: " ++
+                "invalid page number: " ++ show pn
+
+    return $ Paginate pagPages pagPlaces makeId
+        (PatternDependency pattern idents)
+
+
+--------------------------------------------------------------------------------
+buildPaginateWith :: MonadMetadata m
+                  => Int
+                  -> (PageNumber -> Identifier)
+                  -> Pattern
+                  -> m Paginate
+buildPaginateWith n makeId pattern = do
+    -- TODO: there is no sensible order for `ids` here, for now it's random;
+    -- but it should be `resectFirst` order because most recent posts should
+    -- correspond to 1st paginator page and oldest one to last page
+    idents <- getMatches pattern
+    let pages          = flip unfoldr idents $ \xs ->
+            if null xs then Nothing else Just (splitAt n xs)
+        nPages         = length pages
+        paginatePages' = zip [1..] pages
+        pagPlaces'     =
+            [(ident, idx) | (idx,ids) <- paginatePages', ident <- ids] ++
+            [(makeId i, i) | i <- [1 .. nPages]]
+
+    return $ Paginate (M.fromList paginatePages') (M.fromList pagPlaces') makeId
+        (PatternDependency pattern idents)
+
+
+--------------------------------------------------------------------------------
+paginateRules :: Paginate -> (PageNumber -> Pattern -> Rules ()) -> Rules ()
+paginateRules paginator rules =
+    forM_ (M.toList $ paginatePages paginator) $ \(idx, identifiers) ->
+        create [paginateMakeId paginator idx] $
+            rulesExtraDependencies [paginateDependency paginator] $
+                rules idx $ fromList identifiers
+
+
+--------------------------------------------------------------------------------
+-- | Takes first, current, last page and produces index of next page
+type RelPage = PageNumber -> PageNumber -> PageNumber -> Maybe PageNumber
+
+
+--------------------------------------------------------------------------------
+paginateField :: Paginate -> String -> RelPage -> Context a
+paginateField pag fieldName relPage = field fieldName $ \item ->
+    let identifier = itemIdentifier item
+    in case M.lookup identifier (paginatePlaces pag) of
+        Nothing -> fail $ printf
+            "Hakyll.Web.Paginate: there is no page %s in paginator map."
+            (show identifier)
+        Just pos -> case relPage 1 pos nPages of
+            Nothing   -> fail "Hakyll.Web.Paginate: No page here."
+            Just pos' -> do
+                let nextId = paginateMakeId pag pos'
+                mroute <- getRoute nextId
+                case mroute of
+                    Nothing -> fail $ printf
+                        "Hakyll.Web.Paginate: unable to get route for %s."
+                        (show nextId)
+                    Just rt -> return $ toUrl rt
+  where
+    nPages = M.size (paginatePages pag)
+
+
+--------------------------------------------------------------------------------
+paginateContext :: Paginate -> Context a
+paginateContext pag = mconcat
+    [ paginateField pag "firstPage"
+        (\f c _ -> if c <= f then Nothing else Just f)
+    , paginateField pag "previousPage"
+        (\f c _ -> if c <= f then Nothing else Just (c - 1))
+    , paginateField pag "nextPage"
+        (\_ c l -> if c >= l then Nothing else Just (c + 1))
+    , paginateField pag "lastPage"
+        (\_ c l -> if c >= l then Nothing else Just l)
+    ]