@@ -0,0 +1,206 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module Hakyll.Web.Paginator
4+ ( Paginator(..)
5+ , PagState(..)
6+ , NavigationLinkType(..)
7+ , buildPaginator
8+ , buildPaginatorWith
9+ , paginatorRules
10+ , renderPaginator
11+ , renderPaginatorWith
12+
13+ , paginatorFields
14+ ) where
15+
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
27+
28+
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
38+
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
45+ } deriving (Show)
46+
47+data PagState = PagState { pagPos :: Int
48+ , pagLen :: Int }
49+
50+buildPaginatorWith :: MonadMetadata m
51+ => Int
52+ -> (PagState -> Identifier)
53+ -> Pattern
54+ -> m Paginator
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
61+ where
62+ f [] = Nothing
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)
70+
71+--------------------------------------------------------------------------------
72+
73+buildPaginator :: MonadMetadata m => Pattern -> m Paginator
74+buildPaginator = buildPaginatorWith 5 makeId
75+ where
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'
78+ in nils ++ show i
79+
80+--------------------------------------------------------------------------------
81+
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
89+
90+--------------------------------------------------------------------------------
91+
92+data NavigationLinkType = NFirst | NPrev | NNext | NLast
93+
94+instance Show NavigationLinkType where
95+ show NFirst = "first"
96+ show NPrev = "prev"
97+ show NNext = "next"
98+ show NLast = "last"
99+
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)
107+ -- ^ Join items
108+ -> Paginator
109+ -> PagState
110+ -> Compiler 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)
114+
115+ url <- getRoute $ pagMakeId paginator pagState
116+ return (url, idx)
117+
118+ let -- Create a link for one item
119+ makeHtml' (url, idx) =
120+ makeHtml (toUrl $ fromMaybe "/" url) idx i n
121+
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))
126+ navIdxs
127+ navHtmlCode = zipWith3 navigationHtml navUrls navIds navIdxs
128+ navLefts = if i==1
129+ then []
130+ else take 2 navHtmlCode
131+ navRights= if i==n
132+ then []
133+ else drop 2 navHtmlCode
134+
135+ return $ concatHtml $ navLefts ++ map makeHtml' pags' ++ navRights
136+
137+renderPaginator :: Paginator -> PagState -> Compiler String
138+renderPaginator =
139+ renderPaginatorWith makeHtml navigationHtml concatHtml
140+ where
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))
145+ $ toHtml caption
146+ where
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 = ""
156+ | otherwise =
157+ let caption = show menuItemIdx
158+ in renderHtml $ H.a ! (A.href (toValue url) <>
159+ A.title (toValue caption))
160+ $ toHtml caption
161+ where
162+ shouldBeDisplayed =
163+ let leg = 2
164+ width = 1 + 2*leg
165+ in abs (menuItemIdx - pageIdx) <= leg
166+ || pageIdx - leg <= 0 && menuItemIdx - width <= 0
167+ || pageIdx + leg >= nPages && menuItemIdx + width >= nPages
168+
169+
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)
174+
175+ neededPage NNext pos | pos+1 > nPages = Nothing
176+ neededPage NNext pos = Just (pos + 1)
177+
178+ neededPage NPrev pos | pos-1 < 1 = Nothing
179+ neededPage NPrev pos = Just (pos - 1)
180+
181+ neededPage NFirst pos | pos == 1 = Nothing
182+ neededPage NFirst _ = Just 1
183+
184+ neededPage NLast pos | pos == nPages = Nothing
185+ neededPage NLast _ = Just nPages
186+
187+ case M.lookup identifier (pagPlaces pag) of
188+ Nothing -> error $ printf "Hakyll.Web.Paginator: there is no page %s in paginator map."
189+ (show identifier)
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)
193+ Just pos' -> do
194+ let nextId = pagMakeId pag (PagState pos' nPages)
195+ mroute <- getRoute nextId
196+ case mroute of
197+ Nothing -> error $ printf "Hakyll.Web.Paginator: unable to get route of identifier %s."
198+ (show nextId)
199+ Just rt -> return $ toUrl rt
200+
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
206+