Paginate simplification

2 files changed, 134 insertions, 206 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)
+    ]
diff --git a/src/Hakyll/Web/Paginator.hs b/src/Hakyll/Web/Paginator.hs
deleted file mode 100644
index ec15256..0000000
--- a/src/Hakyll/Web/Paginator.hs
+++ /dev/null
@@ -1,206 +0,0 @@
-{-# LANGUAGE OverloadedStrings          #-}
-
-module Hakyll.Web.Paginator
-   ( Paginator(..)
-   , PagState(..)
-   , NavigationLinkType(..)
-   , buildPaginator
-   , buildPaginatorWith
-   , paginatorRules
-   , renderPaginator
-   , renderPaginatorWith
-
-   , paginatorFields
-  ) where
-
---------------------------------------------------------------------------------
-import           Control.Monad                   (forM, forM_)
-import           Data.List                       (intercalate, unfoldr)
-import           Data.Monoid                     ((<>))
-import           Data.Maybe                      (fromMaybe)
-import qualified Data.Map                        as M
-import           Text.Blaze.Html                 (toHtml, toValue, (!))
-import           Text.Printf                     (printf)
-import           Text.Blaze.Html.Renderer.String (renderHtml)
-import qualified Text.Blaze.Html5                as H
-import qualified Text.Blaze.Html5.Attributes     as A
-
-
---------------------------------------------------------------------------------
-import           Hakyll.Core.Compiler
-import           Hakyll.Core.Identifier
-import           Hakyll.Core.Identifier.Pattern
-import           Hakyll.Core.Metadata
-import           Hakyll.Core.Rules
-import           Hakyll.Web.Template.Context
-import           Hakyll.Core.Item
-import           Hakyll.Web.Html
-
--- | Data about paginators
-data Paginator = Paginator
-    { pagPages  :: M.Map Int [Identifier]
-    , pagPlaces :: M.Map Identifier Int
-    , pagMakeId :: PagState -> Identifier
-    , pagDependency :: Dependency
-    } deriving (Show)
-
-data PagState = PagState { pagPos :: Int
-                         , pagLen :: Int }
-
-buildPaginatorWith :: MonadMetadata m
-                   => Int
-                   -> (PagState -> Identifier)
-                   -> Pattern
-                   -> m Paginator
-buildPaginatorWith 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 = unfoldr f idents
-        where
-          f [] = Nothing
-          f x  = Just $ splitAt n x
-      nPages     = length pages
-      pagPages'  = zip [1..] pages
-      pagPlaces' = [(ident, idx) | (idx,ids) <- pagPages', ident <- ids] ++
-                   [(makeId (PagState i nPages), i) | i <- [1 .. nPages]]
-  return $ Paginator (M.fromList pagPages') (M.fromList pagPlaces') makeId
-                     (PatternDependency pattern idents)
-
---------------------------------------------------------------------------------
-
-buildPaginator :: MonadMetadata m => Pattern -> m Paginator
-buildPaginator = buildPaginatorWith 5 makeId
-  where
-    makeId (PagState pos n) = fromFilePath $ "index" ++ makeIndex pos n ++ ".html"
-    makeIndex i n = let nils = replicate (length (show n) - length (show i)) '0'
-                    in  nils ++ show i
-
---------------------------------------------------------------------------------
-
-paginatorRules :: Paginator -> (PagState -> Pattern -> Rules ()) -> Rules ()
-paginatorRules paginator rules =
-    forM_ (M.toList $ pagPages paginator) $ \(idx, identifiers) ->
-        let pagState = PagState idx (M.size $ pagPages paginator)
-        in  create [pagMakeId paginator pagState] $
-                rulesExtraDependencies [pagDependency paginator] $
-                    rules pagState $ fromList identifiers
-
---------------------------------------------------------------------------------
-
-data NavigationLinkType = NFirst | NPrev | NNext | NLast
-
-instance Show NavigationLinkType where
-  show NFirst = "first"
-  show NPrev  = "prev"
-  show NNext  = "next"
-  show NLast  = "last"
-
-renderPaginatorWith :: (String -> Int -> Int -> Int -> String)
-                    -- ^ Produce a paginator menu item: url, index of menu element,
-                    --   index of current page, amount of pages
-                    -> (String -> NavigationLinkType -> Int -> String)
-                    -- ^ Produce fast navigation links: url, type of navigation
-                    --   element (e.g. last, prev...), index of corresponding page
-                    -> ([String] -> String)
-                    -- ^ Join items
-                    -> Paginator
-                    -> PagState
-                    -> Compiler String
-renderPaginatorWith makeHtml navigationHtml concatHtml paginator (PagState i n) = do
-    pags' <- forM (M.toList $ pagPages paginator) $ \(idx,_) -> do
-        let pagState = PagState idx (M.size $ pagPages paginator)
-            
-        url <- getRoute $ pagMakeId paginator pagState
-        return (url, idx)
-
-    let -- Create a link for one item
-        makeHtml' (url, idx) =
-            makeHtml (toUrl $ fromMaybe "/" url) idx i n
-
-        -- Fast-travel links logic: first, prev, next, last (<< < > >>)
-        navIdxs = [1, max 1 (i-1), min (i+1) n, n]
-        navIds  = [NFirst, NPrev, NNext, NLast]
-        navUrls = map (\idx -> toFilePath $ pagMakeId paginator (PagState idx n))
-                     navIdxs
-        navHtmlCode = zipWith3 navigationHtml navUrls navIds navIdxs
-        navLefts = if i==1
-                   then []
-                   else take 2 navHtmlCode
-        navRights= if i==n
-                   then []
-                   else drop 2 navHtmlCode
-
-    return $ concatHtml $ navLefts ++ map makeHtml' pags' ++ navRights
-
-renderPaginator :: Paginator -> PagState -> Compiler String
-renderPaginator =
-  renderPaginatorWith makeHtml navigationHtml concatHtml
-  where
-    navigationHtml url navType _idx =
-      let (caption, alt) = arrow navType
-      in  renderHtml $ H.a ! (A.href  (toValue url) <>
-                              A.title (toValue alt))
-                           $ toHtml caption
-      where
-        arrow :: NavigationLinkType -> (String, String)
-        arrow NPrev  = ("<" , "prev")
-        arrow NNext  = (">" , "next")
-        arrow NFirst = ("<<", "first")
-        arrow NLast  = (">>", "last")
-    concatHtml = intercalate " " . filter (not . null)
-    makeHtml url menuItemIdx pageIdx nPages
-      | menuItemIdx == pageIdx = show menuItemIdx
-      | not shouldBeDisplayed = ""
-      | otherwise =
-        let caption = show menuItemIdx
-        in  renderHtml $ H.a ! (A.href  (toValue url) <>
-                                A.title (toValue caption))
-                             $ toHtml caption
-      where
-        shouldBeDisplayed =
-          let leg = 2
-              width = 1 + 2*leg
-          in    abs (menuItemIdx - pageIdx) <= leg
-             || pageIdx - leg <= 0      && menuItemIdx - width <= 0
-             || pageIdx + leg >= nPages && menuItemIdx + width >= nPages
-
-
-paginatorField :: Paginator -> String -> NavigationLinkType -> Context a
-paginatorField pag fieldName arrowType = field fieldName $ \item -> do
-    let identifier = itemIdentifier item
-        nPages     = M.size (pagPages pag)
-        
-        neededPage NNext pos | pos+1 > nPages = Nothing
-        neededPage NNext pos = Just (pos + 1)
-        
-        neededPage NPrev pos | pos-1 < 1 = Nothing
-        neededPage NPrev pos = Just (pos - 1)
-
-        neededPage NFirst pos | pos == 1 = Nothing
-        neededPage NFirst  _  = Just 1
-
-        neededPage NLast pos | pos == nPages = Nothing
-        neededPage NLast  _  = Just nPages
-    
-    case M.lookup identifier (pagPlaces pag) of
-      Nothing -> error $ printf "Hakyll.Web.Paginator: there is no page %s in paginator map."
-                         (show identifier)
-      Just pos -> case neededPage arrowType pos of
-        Nothing   -> fail $ printf "There is no %s page for page %s in position %s."
-                            (show arrowType) (show identifier) (show pos)
-        Just pos' -> do
-          let nextId = pagMakeId pag (PagState pos' nPages)
-          mroute <- getRoute nextId
-          case mroute of
-            Nothing -> error $ printf "Hakyll.Web.Paginator: unable to get route of identifier %s."
-                               (show nextId)
-            Just rt -> return $ toUrl rt
-
-paginatorFields :: Paginator -> Context a
-paginatorFields pag =    paginatorField pag "firstPage" NFirst
-                      <> paginatorField pag "prevPage"  NPrev
-                      <> paginatorField pag "nextPage"  NNext
-                      <> paginatorField pag "lastPage"  NLast
-                      
\ No newline at end of file