diff options
Diffstat (limited to 'src/Hakyll/Web/Paginate.hs')
-rw-r--r-- | src/Hakyll/Web/Paginate.hs | 134 |
1 files changed, 134 insertions, 0 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) + ] |