{-# LANGUAGE OverloadedStrings #-} module Main where import Prelude hiding (id) import Control.Arrow import Control.Category (id) import Control.Monad import Data.Function (on) import Data.List hiding (group) import Data.Maybe import Data.Monoid (mempty, mconcat) import System.FilePath (takeFileName) import System.Locale (defaultTimeLocale, TimeLocale) import Data.Time.Calendar import Data.Time.Clock (UTCTime (..)) import Data.Time.Format (parseTime, formatTime) import Text.Printf import Hakyll hiding (chronological, recentFirst) main :: IO () main = hakyll $ do -- Compress CSS match "css/*" $ do route idRoute compile compressCssCompiler -- Images match "images/**" $ do route idRoute compile copyFileCompiler -- Render posts group "posts" $ do match (inPostGroup "posts/*") $ do route $ setExtension ".html" compile $ pageCompiler >>> addDate >>> addTagCloud >>> 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 ("Home", "index*") &&& id) >>> paginatePosts match "posts/*" $ compile $ pageCompiler >>> (id &&& getIdentifier) >>> setFieldA "path" (arr $ fromMaybe "" . runRoutes (setExtension ".html")) >>> (id &&& arr (getField "path")) >>> setFieldA "url" (arr toUrl) -- Tags create "tags" $ requireAll_ allPosts >>> arr readTags match "tags/*" $ route $ setExtension ".html" metaCompile $ require_ "tags" >>> arr tagsMap >>> arr (map $ second recentFirst) >>> mapCompiler (((arr (\tag -> "Posts tagged ‘" ++ tag ++ "’") &&& arr (parseGlob . (++ "*") . identifierPath . tagIdentifier)) *** id) >>> paginatePosts ) >>> arr concat -- Archive create "archive" $ 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 $ second recentFirst) >>> mapCompiler (((arr (\month -> "Archive for " ++ prettyMonth month) &&& arr (parseGlob . (++ "*") . identifierPath . archiveIdentifier)) *** id) >>> paginatePosts ) >>> arr concat -- Render RSS feed match "rss.xml" $ route idRoute create "rss.xml" $ requireAll_ allPosts >>> mapCompiler (arr $ copyBodyToField "description") >>> renderRss feedConfiguration -- Read templates match "templates/*" $ compile templateCompiler where postGroup = Just "posts" inPostGroup :: Pattern a -> Pattern a inPostGroup p = patternIntersection [inGroup postGroup, p] notInPostGroup :: Pattern a -> Pattern a notInPostGroup p = patternIntersection [complement $ inGroup postGroup, p] allPosts :: Pattern (Page String) allPosts = notInPostGroup "posts/*" addTopnav :: Compiler (Page a) (Page a) addTopnav = arr (id &&& const ()) >>> setFieldA "topnav" topnav 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))) -> "