@@ -0,0 +1,206 @@
1+{-# LANGUAGE OverloadedStrings #-}
3+module Hakyll.Web.Paginator
6+ , NavigationLinkType(..)
11+ , renderPaginatorWith
16+--------------------------------------------------------------------------------
17+import Control.Monad (forM, forM_)
18+import Data.List (intercalate, unfoldr)
19+import Data.Monoid ((<>))
20+import Data.Maybe (fromMaybe)
21+import qualified Data.Map as M
22+import Text.Blaze.Html (toHtml, toValue, (!))
23+import Text.Printf (printf)
24+import Text.Blaze.Html.Renderer.String (renderHtml)
25+import qualified Text.Blaze.Html5 as H
26+import qualified Text.Blaze.Html5.Attributes as A
29+--------------------------------------------------------------------------------
30+import Hakyll.Core.Compiler
31+import Hakyll.Core.Identifier
32+import Hakyll.Core.Identifier.Pattern
33+import Hakyll.Core.Metadata
34+import Hakyll.Core.Rules
35+import Hakyll.Web.Template.Context
36+import Hakyll.Core.Item
37+import Hakyll.Web.Html
39+-- | Data about paginators
40+data Paginator = Paginator
41+ { pagPages :: M.Map Int [Identifier]
42+ , pagPlaces :: M.Map Identifier Int
43+ , pagMakeId :: PagState -> Identifier
44+ , pagDependency :: Dependency
47+data PagState = PagState { pagPos :: Int
50+buildPaginatorWith :: MonadMetadata m
52+ -> (PagState -> Identifier)
55+buildPaginatorWith n makeId pattern = do
56+ -- TODO: there is no sensible order for `ids` here, for now it's random;
57+ -- but it should be `resectFirst` order because most recent posts should
58+ -- correspond to 1st paginator page and oldest one to last page
59+ idents <- getMatches pattern
60+ let pages = unfoldr f idents
63+ f x = Just $ splitAt n x
64+ nPages = length pages
65+ pagPages' = zip [1..] pages
66+ pagPlaces' = [(ident, idx) | (idx,ids) <- pagPages', ident <- ids] ++
67+ [(makeId (PagState i nPages), i) | i <- [1 .. nPages]]
68+ return $ Paginator (M.fromList pagPages') (M.fromList pagPlaces') makeId
69+ (PatternDependency pattern idents)
71+--------------------------------------------------------------------------------
73+buildPaginator :: MonadMetadata m => Pattern -> m Paginator
74+buildPaginator = buildPaginatorWith 5 makeId
76+ makeId (PagState pos n) = fromFilePath $ "index" ++ makeIndex pos n ++ ".html"
77+ makeIndex i n = let nils = replicate (length (show n) - length (show i)) '0'
80+--------------------------------------------------------------------------------
82+paginatorRules :: Paginator -> (PagState -> Pattern -> Rules ()) -> Rules ()
83+paginatorRules paginator rules =
84+ forM_ (M.toList $ pagPages paginator) $ \(idx, identifiers) ->
85+ let pagState = PagState idx (M.size $ pagPages paginator)
86+ in create [pagMakeId paginator pagState] $
87+ rulesExtraDependencies [pagDependency paginator] $
88+ rules pagState $ fromList identifiers
90+--------------------------------------------------------------------------------
92+data NavigationLinkType = NFirst | NPrev | NNext | NLast
94+instance Show NavigationLinkType where
95+ show NFirst = "first"
100+renderPaginatorWith :: (String -> Int -> Int -> Int -> String)
101+ -- ^ Produce a paginator menu item: url, index of menu element,
102+ -- index of current page, amount of pages
103+ -> (String -> NavigationLinkType -> Int -> String)
104+ -- ^ Produce fast navigation links: url, type of navigation
105+ -- element (e.g. last, prev...), index of corresponding page
106+ -> ([String] -> String)
111+renderPaginatorWith makeHtml navigationHtml concatHtml paginator (PagState i n) = do
112+ pags' <- forM (M.toList $ pagPages paginator) $ \(idx,_) -> do
113+ let pagState = PagState idx (M.size $ pagPages paginator)
115+ url <- getRoute $ pagMakeId paginator pagState
118+ let -- Create a link for one item
119+ makeHtml' (url, idx) =
120+ makeHtml (toUrl $ fromMaybe "/" url) idx i n
122+ -- Fast-travel links logic: first, prev, next, last (<< < > >>)
123+ navIdxs = [1, max 1 (i-1), min (i+1) n, n]
124+ navIds = [NFirst, NPrev, NNext, NLast]
125+ navUrls = map (\idx -> toFilePath $ pagMakeId paginator (PagState idx n))
127+ navHtmlCode = zipWith3 navigationHtml navUrls navIds navIdxs
130+ else take 2 navHtmlCode
133+ else drop 2 navHtmlCode
135+ return $ concatHtml $ navLefts ++ map makeHtml' pags' ++ navRights
137+renderPaginator :: Paginator -> PagState -> Compiler String
139+ renderPaginatorWith makeHtml navigationHtml concatHtml
141+ navigationHtml url navType _idx =
142+ let (caption, alt) = arrow navType
143+ in renderHtml $ H.a ! (A.href (toValue url) <>
144+ A.title (toValue alt))
147+ arrow :: NavigationLinkType -> (String, String)
148+ arrow NPrev = ("<" , "prev")
149+ arrow NNext = (">" , "next")
150+ arrow NFirst = ("<<", "first")
151+ arrow NLast = (">>", "last")
152+ concatHtml = intercalate " " . filter (not . null)
153+ makeHtml url menuItemIdx pageIdx nPages
154+ | menuItemIdx == pageIdx = show menuItemIdx
155+ | not shouldBeDisplayed = ""
157+ let caption = show menuItemIdx
158+ in renderHtml $ H.a ! (A.href (toValue url) <>
159+ A.title (toValue caption))
165+ in abs (menuItemIdx - pageIdx) <= leg
166+ || pageIdx - leg <= 0 && menuItemIdx - width <= 0
167+ || pageIdx + leg >= nPages && menuItemIdx + width >= nPages
170+paginatorField :: Paginator -> String -> NavigationLinkType -> Context a
171+paginatorField pag fieldName arrowType = field fieldName $ \item -> do
172+ let identifier = itemIdentifier item
173+ nPages = M.size (pagPages pag)
175+ neededPage NNext pos | pos+1 > nPages = Nothing
176+ neededPage NNext pos = Just (pos + 1)
178+ neededPage NPrev pos | pos-1 < 1 = Nothing
179+ neededPage NPrev pos = Just (pos - 1)
181+ neededPage NFirst pos | pos == 1 = Nothing
182+ neededPage NFirst _ = Just 1
184+ neededPage NLast pos | pos == nPages = Nothing
185+ neededPage NLast _ = Just nPages
187+ case M.lookup identifier (pagPlaces pag) of
188+ Nothing -> error $ printf "Hakyll.Web.Paginator: there is no page %s in paginator map."
190+ Just pos -> case neededPage arrowType pos of
191+ Nothing -> fail $ printf "There is no %s page for page %s in position %s."
192+ (show arrowType) (show identifier) (show pos)
194+ let nextId = pagMakeId pag (PagState pos' nPages)
195+ mroute <- getRoute nextId
197+ Nothing -> error $ printf "Hakyll.Web.Paginator: unable to get route of identifier %s."
199+ Just rt -> return $ toUrl rt
201+paginatorFields :: Paginator -> Context a
202+paginatorFields pag = paginatorField pag "firstPage" NFirst
203+ <> paginatorField pag "prevPage" NPrev
204+ <> paginatorField pag "nextPage" NNext
205+ <> paginatorField pag "lastPage" NLast