Last active
April 16, 2019 09:34
-
-
Save srhoulam/e3d219759e87ae5ca2b9e6d19f9fb5c9 to your computer and use it in GitHub Desktop.
A Hakyll site file that provides for blog posts to link to chronologically-adjacent posts.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
-------------------------------------------------------------------------------- | |
{-# LANGUAGE OverloadedStrings #-} | |
import Control.Monad.Trans.Maybe | |
import Data.Binary (Binary (..)) | |
import Data.List (find) | |
import Data.Monoid ((<>)) | |
import Data.Time.Locale.Compat (defaultTimeLocale) | |
import Data.Typeable (Typeable (..)) | |
import Hakyll | |
-------------------------------------------------------------------------------- | |
main :: IO () | |
main = hakyll $ do | |
match "images/*" $ do | |
route idRoute | |
compile copyFileCompiler | |
match "css/*" $ do | |
route idRoute | |
compile compressCssCompiler | |
match (fromList ["about.rst", "contact.markdown"]) $ do | |
route $ setExtension "html" | |
compile $ pandocCompiler | |
>>= loadAndApplyTemplate "templates/default.html" defaultContext | |
>>= relativizeUrls | |
match "posts/*" $ do | |
route $ setExtension "html" | |
compile $ pandocCompiler | |
>>= saveSnapshot "content" | |
>>= loadAndApplyTemplate "templates/post.html" postCtx | |
>>= saveSnapshot "content" | |
>>= (\itm -> withAdjacentPosts postCtx $ \ctx -> | |
return itm | |
>>= loadAndApplyTemplate "templates/default.html" ctx | |
>>= relativizeUrls) | |
create ["archive.html"] $ do | |
route idRoute | |
compile $ do | |
posts <- recentFirst =<< loadAll "posts/*" | |
let archiveCtx = | |
listField "posts" postCtx (return posts) `mappend` | |
constField "title" "Archives" `mappend` | |
defaultContext | |
makeItem "" | |
>>= loadAndApplyTemplate "templates/archive.html" archiveCtx | |
>>= loadAndApplyTemplate "templates/default.html" archiveCtx | |
>>= relativizeUrls | |
match "index.html" $ do | |
route idRoute | |
compile $ do | |
posts <- recentFirst =<< loadAll "posts/*" | |
let indexCtx = | |
listField "posts" postCtx (return posts) `mappend` | |
constField "title" "Home" `mappend` | |
defaultContext | |
getResourceBody | |
>>= applyAsTemplate indexCtx | |
>>= loadAndApplyTemplate "templates/default.html" indexCtx | |
>>= relativizeUrls | |
match "templates/*" $ compile templateCompiler | |
-------------------------------------------------------------------------------- | |
postCtx :: Context String | |
postCtx = | |
dateField "date" "%B %e, %Y" `mappend` | |
defaultContext | |
withAdjacentPosts :: (Binary a, Typeable a, Writable a) | |
=> Context String | |
-> (Context String -> Compiler (Item a)) | |
-> Compiler (Item a) | |
withAdjacentPosts ctx next = do | |
let getItemDate = getItemUTC defaultTimeLocale | |
ui <- getUnderlying | |
posts <- chronological =<< loadAllSnapshots ("posts/*" .&&. (complement . fromGlob . show $ ui)) "content" :: Compiler [Item String] | |
let adjacentPosts fn (Item itm _) = do | |
itemDate <- getItemDate itm | |
datedPosts <- traverse (\(Item i _) -> do | |
date <- getItemDate i | |
return (date, i) | |
) posts | |
prevRoute <- runMaybeT $ do | |
(_, item) <- MaybeT . return . find (\x -> fst x <= itemDate) $ reverse datedPosts | |
MaybeT $ fn item | |
nextRoute <- runMaybeT $ do | |
(_, item) <- MaybeT . return . find (\x -> fst x >= itemDate) $ datedPosts | |
MaybeT $ fn item | |
return (prevRoute, nextRoute) | |
previousPost fn1 fn2 _ itm = do | |
(previous, _) <- adjacentPosts fn1 itm | |
return $ fn2 previous | |
nextPost fn1 fn2 _ itm = do | |
(_, next) <- adjacentPosts fn1 itm | |
return $ fn2 next | |
getTitle = flip getMetadataField $ "title" | |
defaultPath = maybe "/default" ("/"<>) | |
defaultTitle = maybe "Default" id | |
-- re: using `functionField`s in templates: | |
-- http://beerendlauwers.be/posts/2015-09-21-hakylls-functionfield.html | |
withAdjCtx = | |
functionField "nextPost" (nextPost getRoute defaultPath) | |
<> functionField "prevPost" (previousPost getRoute defaultPath) | |
<> functionField "nextTitle" (nextPost getTitle defaultTitle) | |
<> functionField "prevTitle" (previousPost getTitle defaultTitle) | |
<> ctx | |
next withAdjCtx |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment