From e99ba18f7d9936c51ab3f1aaba1f37f3efbd52d5 Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Fri, 1 Jun 2012 21:59:40 +0200 Subject: Add pagination --- hakyll.hs | 102 ++++++++++++++++++++++++++++++++++++++------------------------ 1 file changed, 63 insertions(+), 39 deletions(-) (limited to 'hakyll.hs') diff --git a/hakyll.hs b/hakyll.hs index daac1a5..f5e1045 100644 --- a/hakyll.hs +++ b/hakyll.hs @@ -46,40 +46,40 @@ main = hakyll $ do >>> relativizeUrlsCompiler -- Index - match "index.html" $ route idRoute - create "index.html" $ constA mempty - >>> arr (setField "title" "Home") - >>> addTagCloud - >>> addArchiveLinks - >>> requireAllA allPosts (id *** arr recentFirst >>> addPosts) - >>> applyTemplateCompiler "templates/index.html" - >>> applyTemplateCompiler "templates/default.html" - >>> relativizeUrlsCompiler + match "index*" $ route $ setExtension ".html" + metaCompile $ requireAllA allPosts $ arr (recentFirst . snd) + >>> ((constA () &&& constA "index*") &&& id) + >>> paginatePosts (const "Home") match "posts/*" $ compile $ readPageCompiler >>> (id &&& getIdentifier) >>> setFieldA "path" (arr $ fromMaybe "" . runRoutes (setExtension ".html")) >>> (id &&& arr (getField "path")) - >>> setFieldA "url" (arr ('/':)) + >>> setFieldA "url" (arr toUrl) -- Tags create "tags" $ - requireAll allPosts (\_ ps -> readTags ps :: Tags String) + requireAll_ allPosts >>> arr readTags - -- Add a tag list compiler for every tag match "tags/*" $ route $ setExtension ".html" metaCompile $ require_ "tags" >>> arr tagsMap - >>> arr (map (\(t, p) -> (tagIdentifier t, makeTagList t p))) + >>> mapCompiler (((arr id &&& arr (parseGlob . (++ "*") . identifierPath . tagIdentifier)) *** id) + >>> paginatePosts (\tag -> "Posts tagged ‘" ++ tag ++ "’") + ) + >>> arr concat -- Archive create "archive" $ - requireAll allPosts (\_ -> Tags . groupTuples . reverse . sortBy (compare `on` fst) . catMaybes . map (\page -> getDate page >>= (\date -> return (date, page)))) + requireAll_ allPosts >>> arr (Tags . groupTuples . reverse . sortBy (compare `on` fst) . catMaybes . map (\page -> getDate page >>= (\date -> return (date, page)))) match "archive/**" $ route $ setExtension ".html" metaCompile $ require_ "archive" >>> arr tagsMap - >>> arr (map (\(m, p) -> (archiveIdentifier m, makeArchive m p))) + >>> mapCompiler (((arr id &&& arr (parseGlob . (++ "*") . identifierPath . archiveIdentifier)) *** id) + >>> paginatePosts (\month -> "Archive for " ++ prettyMonth month) + ) + >>> arr concat -- Render RSS feed match "rss.xml" $ route idRoute @@ -97,10 +97,36 @@ main = hakyll $ do notInPostGroup :: Pattern a -> Pattern a notInPostGroup p = patternIntersection [complement $ inGroup postGroup, p] - + allPosts :: Pattern (Page String) allPosts = notInPostGroup "posts/*" + nav prev next = navPrev prev ++ navNext next + + navPrev Nothing = " " + navPrev (Just url) = "« Newer Entries" + + navNext Nothing = " " + navNext (Just url) = "Older Entries »" + + pageTitle 0 = "" + pageTitle i = " - Page " ++ show (i+1) + + paginatePosts :: (a -> String) -> Compiler ((a, Pattern (Page String)), [Page String]) [(Identifier (Page String), Compiler () (Page String))] + paginatePosts title = paginate 5 (setExtension ".html") + (arr (\(a, prev, next, i, pages) -> ((mempty, (a, prev, next, i)), pages)) + >>> first (first (addTagCloud >>> addArchiveLinks) + >>> arr (\(page, (a, prev, next, i)) -> setField "nav" (nav prev next) $ setField "title" (title a ++ pageTitle i) page) + ) + >>> addPosts + >>> applyTemplateCompiler "templates/index.html" + >>> applyTemplateCompiler "templates/default.html" + >>> relativizeUrlsCompiler + ) + + + + patternIntersection :: [Pattern a] -> Pattern a patternIntersection patterns = predicate $ flip all patterns . flip matches @@ -127,13 +153,31 @@ getDate = liftM ((\(y, m, _) -> printf "%04d/%02d" y m) . toGregorian . utctDay) groupTuples :: Eq a => [(a, b)] -> [(a, [b])] groupTuples = map (fst . head &&& map snd) . groupBy ((==) `on` fst) +paginate :: Int -> Routes -> Compiler (a, Maybe String, Maybe String, Int, [Page String]) (Page String) -> Compiler ((a, Pattern (Page String)), [Page String]) [(Identifier (Page String), Compiler () (Page String))] +paginate perPage routes c = arr $ \((a, pattern), posts) -> renderPages a pattern 0 (n posts) posts + where + renderPages _ _ _ _ [] = [] + renderPages a pattern i n posts = (name i, constA (a, prev i, next i n, i, cur) >>> c):(renderPages a pattern (i+1) n rest) + where + (cur, rest) = splitAt perPage posts + + prev 0 = Nothing + prev i = fmap toUrl . runRoutes routes . name $ i-1 + + next i n = if i == (n-1) then Nothing else fmap toUrl . runRoutes routes . name $ i+1 + + name 0 = fromCapture pattern "" + name i = fromCapture pattern $ show i + + n posts = (length posts + perPage - 1) `div` perPage + addPosts :: Compiler (Page String, [Page String]) (Page String) addPosts = setFieldA "posts" $ mapCompiler (addDate >>> addTagCloud >>> renderTagsField "prettytags" (fromCapture "tags/*") - >>> applyTemplateCompiler "templates/post_short.html") + >>> applyTemplateCompiler "templates/post.html") >>> arr mconcat >>> arr pageBody @@ -148,7 +192,7 @@ addArchiveLinks = requireA "archive" (setFieldA "archive" renderArchive) where renderArchive :: Compiler (Tags String) String renderArchive = arr tagsMap - >>> arr (map (\(s, p) -> "
  • " ++ prettyMonth s ++ " (" ++ show (length p) ++ ")
    • ")) + >>> arr (map (\(s, p) -> "
  • " ++ prettyMonth s ++ " (" ++ show (length p) ++ ")
    • ")) >>> arr mconcat prettyMonth :: String -> String @@ -177,30 +221,10 @@ tagIdentifier = fromCapture "tags/*" archiveIdentifier :: String -> Identifier (Page String) archiveIdentifier = fromCapture "archive/*" -makeTagList :: String -> [Page String] -> Compiler () (Page String) -makeTagList tag posts = constA (mempty, posts) - >>> addPosts - >>> addTagCloud - >>> addArchiveLinks - >>> arr (setField "title" ("Posts tagged ‘" ++ tag ++ "’")) - >>> applyTemplateCompiler "templates/posts.html" - >>> applyTemplateCompiler "templates/default.html" - >>> relativizeUrlsCompiler - -makeArchive :: String -> [Page String] -> Compiler () (Page String) -makeArchive month posts = constA (mempty, posts) - >>> addPosts - >>> addTagCloud - >>> addArchiveLinks - >>> arr (setField "title" ("Archive for " ++ prettyMonth month)) - >>> applyTemplateCompiler "templates/posts.html" - >>> applyTemplateCompiler "templates/default.html" - >>> relativizeUrlsCompiler - feedConfiguration :: FeedConfiguration feedConfiguration = FeedConfiguration { feedTitle = "Universe Factory" , feedDescription = "Because one universe is not enough" , feedAuthorName = "NeoRaider" - , feedRoot = "http://blog.universe-factory.net/" + , feedRoot = "http://blog.universe-factory.net" } -- cgit v1.2.3