Paginate simplification
This commit is contained in:
Jasper Van der Jeugt
parent
8a4045cb16
commit
738fd3d1ad
4 changed files with 137 additions and 209 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
134
src/Hakyll/Web/Paginate.hs
Normal file
134
src/Hakyll/Web/Paginate.hs
Normal file
|
|
@ -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)
|
||||
]
|
||||
|
|
@ -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
|
||||
|
||||
Loading…
Reference in a new issue