simple hakyll site that escapes urls

simple.hs

{-# LANGUAGE OverloadedStrings, Arrows #-}
module Main where
import Prelude hiding (id)
import Data.Monoid(mempty)
import qualified Data.Map as M
import Control.Category (id)
import Control.Arrow((&&&),arr,(>>>),(>>^))

import Hakyll

main :: IO ()
main = hakyll $ do

    ["posts/*"] --> post 
    ["index.html"] --> index

    create "tags" $
      requireAll "posts/*" (\_ ps -> readTags ps :: Tags String)

    -- tag list compiler for every tag
    match "tags/*" $ route $ setExtension "html"
    metaCompile $ require_ "tags"
      >>> arr tagsMap
      >>> arr (map (\(t, p) -> (tagIdentifier t, makeTagListCompiler t p)))
        
    -- templates
    match "templates/*" $ compile templateCompiler

  where
      renderTagCloud' :: Compiler (Tags String) String
      renderTagCloud' = renderTagList tagIdentifierEscaped

      tagIdentifier = fromCapture "tags/*"
      tagIdentifierEscaped = fromCapture "tags/*" . escapeStr
    
      escapeStr = concatMap escape
        where escape x 
                | x == '+' = "%2B"
                | otherwise = x:[]

      xs --> f = mapM_ (`match` f) xs

      post = do
        route   $ setExtension ".html"
        compile $ pageCompiler
            >>> arr (renderDateField "date" "%Y-%m-%d" "Date unknown")
            >>> arr (setField "tagcloud" "")
            >>> renderTagsField "prettytags" tagIdentifierEscaped
            >>> arr (changeField "url" escapeStr)
            >>> applyTemplateCompiler "templates/post.html"
            >>> applyTemplateCompiler "templates/default.html"
            >>> relativizeUrlsCompiler

      index = do
        route idRoute
        create "index.html" $ constA mempty
            >>> arr (setField "tagcloud" "")
            >>> setFieldPageList recentFirst
                    "templates/postitem.html" "posts" "posts/*"
            >>> applyTemplateCompiler "templates/index.html"
            >>> applyTemplateCompiler "templates/default.html"
            >>> relativizeUrlsCompiler

      makeTagListCompiler :: String -> [Page String] -> Compiler () (Page String)
      makeTagListCompiler tag posts =
        constA posts
            >>> pageListCompiler recentFirst "templates/postitem.html"
            >>> arr (copyBodyToField "posts" . fromBody)
            >>> arr (setField "title" $ "Posts tagged " ++ tag)
            >>> arr (setField "description" $ "View all posts tagged with " ++ tag)
            >>> arr (setField "keywords" $ "tags, " ++ tag)
            >>> requireA "tags" (setFieldA "tagcloud" renderTagCloud')
            >>> applyTemplateCompiler "templates/posts.html"
            >>> applyTemplateCompiler "templates/default.html"