site.hs

--------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
import           Hakyll
import           Hakyll.Web.Tags
import           Hakyll.Web.Template.Context 

import           Control.Applicative
import           Control.Monad
import           System.Locale                    (defaultTimeLocale)

import           Data.Ord
import           Data.List                        (intercalate, intersperse, sortBy)
import           Data.Map                         (lookup)  
import           Data.Monoid                      (mappend, mconcat)

import qualified Text.Blaze.Html5                 as H
import qualified Text.Blaze.Html5.Attributes      as A
import           Text.Blaze.Html                  (toHtml, toValue, (!))
import           Text.Blaze.Html.Renderer.String  (renderHtml)
--------------------------------------------------------------------------------
main :: IO ()
main = hakyll $ do

    tags <- buildTags "posts/*" (fromCapture "tags/*.html")

    tagsRules tags $ \tag pattern -> do
--           let title = "Tagged: " ++ tag
           route idRoute
           compile $ do
               posts <- constField "posts" <$> postLst pattern "templates/tag-item.html" (taggedPostCtx tags) recentFirst
    
               makeItem ""
                   >>= loadAndApplyTemplate "templates/tagpage.html" (posts `mappend` (taggedPostCtx tags))
                   -- >>= relativizeUrls
  
    match ("images/*"   .||. "favicon.ico"  .||. "assets/**"  .||. 
            "talks/**"  .||. "bootstrap/**" .||. "data/**"    .||. 
            "scripts/**")  $ do
        route   idRoute
        compile copyFileCompiler
        
    match "css/*" $ do
        route   idRoute
        compile compressCssCompiler

    match "posts/*" $ do
        route $ dateRoute
        compile $ pandocCompiler
            >>= saveSnapshot "teaser"
            >>= loadAndApplyTemplate "templates/post.html" (taggedPostCtx tags)
            >>= loadAndApplyTemplate "templates/blog.html" (taggedPostCtx tags)
            -- >>= relativizeUrls

    match ("facts.html" .||. "contact.html" )$ do
        route idRoute
        compile $ do
            getResourceBody
                >>= loadAndApplyTemplate "templates/main.html" (taggedPostCtx tags)
                -- >>= relativizeUrls
    
    match "talks.html" $ do 
        route idRoute
        compile $ do
            let indexCtx = field "posts" (\_ -> postList getTalks) `mappend` (taggedPostCtx tags)

            getResourceBody
                >>= applyAsTemplate indexCtx
                >>= loadAndApplyTemplate "templates/blog.html" (taggedPostCtx tags)
                -- >>= relativizeUrls
              
    match "index.html" $ do
        route idRoute
        compile $ do
            let indexCtx = (field "posts" $ \_ ->
                                postList $ fmap (take 3) . recentFirst) `mappend`
                            (taggedPostCtx tags)

            getResourceBody
                >>= applyAsTemplate indexCtx
                >>= loadAndApplyTemplate "templates/blog.html" (taggedPostCtx tags)
                -- >>= relativizeUrls

    match "templates/*" $ compile templateCompiler
    
--------------------------------------------------------------------------------
dateRoute :: Routes
dateRoute = gsubRoute "posts/" (const "") `composeRoutes` 
              gsubRoute "pages/" (const "") `composeRoutes`
                gsubRoute "[0-9]{4}-[0-9]{2}-[0-9]{2}-" (map replaceChars) `composeRoutes` 
                 setExtension "html" 
            where
              replaceChars c | c == '-' || c == '_' = '/'
                             | otherwise = c

--------------------------------------------------------------------------------

getTalks :: [Item String] -> Compiler [Item String]
getTalks items = do
  itemsWithTime <- forM items $ \item -> do
    talk <- isTalk $ itemIdentifier item
    utc <- getItemUTC defaultTimeLocale $ itemIdentifier item
    return (talk, (utc,item))
  -- we return a sorted item list
  return $ map snd $ reverse $ sortBy (comparing fst) $ map snd $ filter fst itemsWithTime
  
isTalk :: MonadMetadata m => Identifier -> m Bool 
isTalk id' = do
    metadata <- getMetadata id'
    let typ = Data.Map.lookup "type" metadata
    return (typ == Just "talk")

--------------------------------------------------------------------------------

tagCloudCtx :: Tags -> Context String
tagCloudCtx tags = field "tagcloud" $ \item -> rendered 
  where rendered = renderLogTagCloud 85.0 165.0 tags

taggedPostCtx :: Tags -> Context String
taggedPostCtx tags = mconcat [postCtx, (tagsField "tags" tags), (tagCloudCtx tags)]

postCtx :: Context String
postCtx = mconcat [dateField "date" "%Y %b %d" , defaultContext]

--------------------------------------------------------------------------------
postLst :: Pattern -> Identifier -> Context String -> ([Item String] -> Compiler [Item String]) -> Compiler String
postLst pattern template context sortFilter = do
    posts   <- sortFilter =<< loadAll pattern
    itemTpl <- loadBody template
    list    <- applyTemplateList itemTpl ((teaserContext "teaser") `mappend` context) posts
    return list

postList :: ([Item String] -> Compiler [Item String]) -> Compiler String
postList = postLst "posts/*" "templates/post-item.html" postCtx


--------------------------------------------------------------------------------
renderLogTagCloud :: Double
               -- ^ Smallest font size, in percent
               -> Double
               -- ^ Biggest font size, in percent
               -> Tags
               -- ^ Input tags
               -> Compiler String
               -- ^ Rendered cloud
renderLogTagCloud minSize maxSize = renderTags makeLink (intercalate " ")
  where
    makeLink tag url count min' max' = renderHtml $
        H.a ! A.style (toValue $ "font-size: " ++ size count min' max')
            ! A.href (toValue url)
            $ toHtml tag

    -- Show the relative size of one 'count' in percent
    size count min' max' =
        let diff = (log (fromIntegral max') - log (fromIntegral min'))
            relative = (log (fromIntegral count) - log (fromIntegral min')) / diff
            size' = floor $ minSize + relative * (maxSize - minSize)
        in show (size' :: Int) ++ "%"