{-# 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

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"
        >>> applyTemplateCompiler "templates/default.html"
        >>> relativizeUrlsCompiler

  -- Index
  match "index.html" $ route idRoute
  create "index.html" $ constA mempty
    >>> arr (setField "title" "Home")
    >>> addTagCloud
    >>> addArchiveLinks
    >>> requireAllA allPosts (id *** arr recentFirst >>> addPosts)
    >>> applyTemplateCompiler "templates/index.html"
    >>> applyTemplateCompiler "templates/default.html"
    >>> relativizeUrlsCompiler

  match "posts/*" $ compile $ readPageCompiler
    >>> (id &&& getIdentifier)
    >>> setFieldA "path" (arr $ fromMaybe "" . runRoutes (setExtension ".html"))
    >>> (id &&& arr (getField "path"))
    >>> setFieldA "url" (arr ('/':))
    
  -- Tags
  create "tags" $
    requireAll allPosts (\_ ps -> readTags ps :: Tags String)

  -- Add a tag list compiler for every tag
  match "tags/*" $ route $ setExtension ".html"
  metaCompile $ require_ "tags"
    >>> arr tagsMap
    >>> arr (map (\(t, p) -> (tagIdentifier t, makeTagList t p)))

  -- Archive
  create "archive" $
    requireAll allPosts (\_ -> 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 (\(m, p) -> (archiveIdentifier m, makeArchive m p)))

  -- 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/*"


patternIntersection :: [Pattern a] -> Pattern a
patternIntersection patterns = predicate $ flip all patterns . flip matches


getUTCMaybe :: TimeLocale     -- ^ Output time locale
            -> Page a         -- ^ Input page
            -> Maybe UTCTime  -- ^ Parsed UTCTime
getUTCMaybe locale 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"
    , fromPublished "%B %e, %Y"
    , getFieldMaybe "path" page >>= parseTime' "%Y-%m-%d" .
        intercalate "-" . take 3 . splitAll "-" . takeFileName
    ]
  where
    fromPublished f  = getFieldMaybe "published" page >>= parseTime' f
    parseTime' f str = parseTime locale f str

getDate :: Page a -> Maybe String
getDate = liftM ((\(y, m, _) -> printf "%04d/%02d" y m) . toGregorian . utctDay) . getUTCMaybe defaultTimeLocale

groupTuples :: Eq a => [(a, b)] -> [(a, [b])]
groupTuples = map (fst . head &&& map snd) . groupBy ((==) `on` fst)


addPosts :: Compiler (Page String, [Page String]) (Page String)
addPosts = setFieldA "posts" $
              mapCompiler (addDate
                           >>> addTagCloud
                           >>> renderTagsField "prettytags" (fromCapture "tags/*")
                           >>> applyTemplateCompiler "templates/post_short.html")
              >>> arr mconcat
              >>> arr pageBody

addDate = arr $ renderDateField "date" "<span class=\"data\"><span class=\"j\">%e</span>%b/%y</span>" ""

addTagCloud = requireA "tags" (setFieldA "tagcloud" renderTagCloud')
  where
    renderTagCloud' :: Compiler (Tags String) String
    renderTagCloud' = renderTagCloud tagIdentifier 100 300

addArchiveLinks = requireA "archive" (setFieldA "archive" renderArchive)
  where
    renderArchive :: Compiler (Tags String) String
    renderArchive = arr tagsMap
                    >>> arr (map (\(s, p) -> "<li><a href=\"/archive/" ++ s ++ ".html\" title=\"" ++ prettyMonth s ++ "\">" ++ prettyMonth s ++ "</a>&nbsp;(" ++ show (length p) ++ ")</li>"))
                    >>> arr mconcat

prettyMonth :: String -> String
prettyMonth s = month ++ " " ++ year
  where
    year = take 4 s
    month = case (drop 5 s) of
      "01" -> "January"
      "02" -> "February"
      "03" -> "March"
      "04" -> "April"
      "05" -> "May"
      "06" -> "June"
      "07" -> "July"
      "08" -> "August"
      "09" -> "September"
      "10" -> "October"
      "11" -> "November"
      "12" -> "December"
      _ -> "Unknown"


tagIdentifier :: String -> Identifier (Page String)
tagIdentifier = fromCapture "tags/*"

archiveIdentifier :: String -> Identifier (Page String)
archiveIdentifier = fromCapture "archive/*"

makeTagList :: String -> [Page String] -> Compiler () (Page String)
makeTagList tag posts = constA (mempty, posts)
                        >>> addPosts
                        >>> addTagCloud
                        >>> addArchiveLinks
                        >>> arr (setField "title" ("Posts tagged &#8216;" ++ tag ++ "&#8217;"))
                        >>> applyTemplateCompiler "templates/posts.html"
                        >>> applyTemplateCompiler "templates/default.html"
                        >>> relativizeUrlsCompiler

makeArchive :: String -> [Page String] -> Compiler () (Page String)
makeArchive month posts = constA (mempty, posts)
                        >>> addPosts
                        >>> addTagCloud
                        >>> addArchiveLinks
                        >>> arr (setField "title" ("Archive for " ++ prettyMonth month))
                        >>> applyTemplateCompiler "templates/posts.html"
                        >>> applyTemplateCompiler "templates/default.html"
                        >>> relativizeUrlsCompiler

feedConfiguration :: FeedConfiguration
feedConfiguration = FeedConfiguration
    { feedTitle       = "Universe Factory"
    , feedDescription = "Because one universe is not enough"
    , feedAuthorName  = "NeoRaider"
    , feedRoot        = "http://blog.universe-factory.net/"
    }