summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--hakyll.cabal2
-rw-r--r--src/Hakyll.hs4
-rw-r--r--src/Hakyll/Web/Paginate.hs134
-rw-r--r--src/Hakyll/Web/Paginator.hs206
4 files changed, 137 insertions, 209 deletions
diff --git a/hakyll.cabal b/hakyll.cabal
index bc9fc7a..5cefdaf 100644
--- a/hakyll.cabal
+++ b/hakyll.cabal
@@ -111,7 +111,7 @@ Library
Hakyll.Web.Pandoc.Biblio
Hakyll.Web.Pandoc.FileType
Hakyll.Web.Tags
- Hakyll.Web.Paginator
+ Hakyll.Web.Paginate
Hakyll.Web.Template
Hakyll.Web.Template.Context
Hakyll.Web.Template.List
diff --git a/src/Hakyll.hs b/src/Hakyll.hs
index 564a52d..f7113cd 100644
--- a/src/Hakyll.hs
+++ b/src/Hakyll.hs
@@ -24,7 +24,7 @@ module Hakyll
, module Hakyll.Web.Pandoc.Biblio
, module Hakyll.Web.Pandoc.FileType
, module Hakyll.Web.Tags
- , module Hakyll.Web.Paginator
+ , module Hakyll.Web.Paginate
, module Hakyll.Web.Template
, module Hakyll.Web.Template.Context
, module Hakyll.Web.Template.List
@@ -51,11 +51,11 @@ import Hakyll.Web.CompressCss
import Hakyll.Web.Feed
import Hakyll.Web.Html
import Hakyll.Web.Html.RelativizeUrls
+import Hakyll.Web.Paginate
import Hakyll.Web.Pandoc
import Hakyll.Web.Pandoc.Biblio
import Hakyll.Web.Pandoc.FileType
import Hakyll.Web.Tags
-import Hakyll.Web.Paginator
import Hakyll.Web.Template
import Hakyll.Web.Template.Context
import Hakyll.Web.Template.List
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
generated by cgit v1.2.3 (git 2.39.1) at 2025-04-04 05:30:20 +0000