From 5a7c9b9c1f405d143c9fdc5aeb241c13f53320b7 Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Sat, 2 Jun 2012 08:05:21 +0200 Subject: Better publish time handling, dynamic topnav --- hakyll.hs | 85 ++++++++++++++++++++++++++++++++++++++++++--------------------- 1 file changed, 57 insertions(+), 28 deletions(-) (limited to 'hakyll.hs') diff --git a/hakyll.hs b/hakyll.hs index 9ec9225..2afd1b7 100644 --- a/hakyll.hs +++ b/hakyll.hs @@ -18,7 +18,7 @@ import Data.Time.Format (parseTime, formatTime) import Text.Printf -import Hakyll +import Hakyll hiding (chronological, recentFirst) main :: IO () main = hakyll $ do @@ -42,14 +42,15 @@ main = hakyll $ do >>> addArchiveLinks >>> renderTagsField "prettytags" (fromCapture "tags/*") >>> applyTemplateCompiler "templates/post.html" + >>> addTopnav >>> applyTemplateCompiler "templates/default.html" >>> relativizeUrlsCompiler -- Index match "index*" $ route $ setExtension ".html" metaCompile $ requireAllA allPosts $ arr (recentFirst . snd) - >>> ((constA () &&& constA "index*") &&& id) - >>> paginatePosts (const "Home") + >>> (constA ("Home", "index*") &&& id) + >>> paginatePosts match "posts/*" $ compile $ pageCompiler >>> (id &&& getIdentifier) @@ -64,8 +65,9 @@ main = hakyll $ do match "tags/*" $ route $ setExtension ".html" metaCompile $ require_ "tags" >>> arr tagsMap - >>> mapCompiler (((arr id &&& arr (parseGlob . (++ "*") . identifierPath . tagIdentifier)) *** id) - >>> paginatePosts (\tag -> "Posts tagged ‘" ++ tag ++ "’") + >>> arr (map $ second recentFirst) + >>> mapCompiler (((arr (\tag -> "Posts tagged ‘" ++ tag ++ "’") &&& arr (parseGlob . (++ "*") . identifierPath . tagIdentifier)) *** id) + >>> paginatePosts ) >>> arr concat @@ -76,8 +78,9 @@ main = hakyll $ do match "archive/**" $ route $ setExtension ".html" metaCompile $ require_ "archive" >>> arr tagsMap - >>> mapCompiler (((arr id &&& arr (parseGlob . (++ "*") . identifierPath . archiveIdentifier)) *** id) - >>> paginatePosts (\month -> "Archive for " ++ prettyMonth month) + >>> arr (map $ second recentFirst) + >>> mapCompiler (((arr (\month -> "Archive for " ++ prettyMonth month) &&& arr (parseGlob . (++ "*") . identifierPath . archiveIdentifier)) *** id) + >>> paginatePosts ) >>> arr concat @@ -101,41 +104,61 @@ main = hakyll $ do allPosts :: Pattern (Page String) allPosts = notInPostGroup "posts/*" - nav prev next = navPrev prev ++ navNext next + addTopnav :: Compiler (Page a) (Page a) + addTopnav = arr (id &&& const ()) >>> setFieldA "topnav" topnav - navPrev Nothing = " " - navPrev (Just url) = "« Newer Entries" + topnav :: Compiler () String + topnav = constA topLinks >>> mapCompiler topnavLink >>> arr (concat . catMaybes) + where + topnavLink = second (id &&& (getRouteFor >>> arr (fmap toUrl)) >>> arr pullSnd) + >>> arr pullSnd + >>> (getIdentifier &&& id) + >>> arr pullSnd + >>> arr (fmap (\(cur, (text, (link, url))) -> "
  • " ++ escapeHtml text ++ "
    • ")) + + cl cur link = if cur == link then " class=\"s\"" else "" + + pagenav prev next = pagenavPrev prev ++ pagenavNext next + + pagenavPrev Nothing = " " + pagenavPrev (Just url) = "« Newer Entries" - navNext Nothing = " " - navNext (Just url) = "Older Entries »" + pagenavNext Nothing = " " + pagenavNext (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 - ) + paginatePosts :: Compiler ((String, Pattern (Page String)), [Page String]) [(Identifier (Page String), Compiler () (Page String))] + paginatePosts = paginate 5 (setExtension ".html") + (arr (\(title, prev, next, i, pages) -> ((mempty, (title, prev, next, i)), pages)) + >>> first (first (addTagCloud >>> addArchiveLinks) + >>> arr (\(page, (title, prev, next, i)) -> setField "pagenav" (pagenav prev next) $ setField "title" (title ++ pageTitle i) page) + ) + >>> addPosts + >>> applyTemplateCompiler "templates/index.html" + >>> addTopnav + >>> applyTemplateCompiler "templates/default.html" + >>> relativizeUrlsCompiler + ) + +topLinks :: [(String, Identifier (Page String))] +topLinks = [("Home", "index") + ] +pullSnd :: Functor m => (a, m b) -> m (a, b) +pullSnd (a, b) = fmap (const a &&& id) b patternIntersection :: [Pattern a] -> Pattern a patternIntersection patterns = predicate $ flip all patterns . flip matches -getUTCMaybe :: TimeLocale -- ^ Output time locale - -> Page a -- ^ Input page +getUTCMaybe :: Page a -- ^ Input page -> Maybe UTCTime -- ^ Parsed UTCTime -getUTCMaybe locale page = msum +getUTCMaybe page = msum [ fromPublished "%a, %d %b %Y %H:%M:%S UT" , fromPublished "%Y-%m-%dT%H:%M:%SZ" , fromPublished "%B %e, %Y %l:%M %p" @@ -145,10 +168,16 @@ getUTCMaybe locale page = msum ] where fromPublished f = getFieldMaybe "published" page >>= parseTime' f - parseTime' f str = parseTime locale f str + parseTime' f str = parseTime defaultTimeLocale f str getDate :: Page a -> Maybe String -getDate = liftM ((\(y, m, _) -> printf "%04d/%02d" y m) . toGregorian . utctDay) . getUTCMaybe defaultTimeLocale +getDate = liftM ((\(y, m, _) -> printf "%04d/%02d" y m) . toGregorian . utctDay) . getUTCMaybe + +chronological :: [Page a] -> [Page a] +chronological = sortBy (compare `on` getUTCMaybe) + +recentFirst :: [Page a] -> [Page a] +recentFirst = reverse . chronological groupTuples :: Eq a => [(a, b)] -> [(a, [b])] groupTuples = map (fst . head &&& map snd) . groupBy ((==) `on` fst) -- cgit v1.2.3