-- start snippet imports
{-# LANGUAGE DeriveGeneric, ScopedTypeVariables, LambdaCase, Strict, ApplicativeDo #-}
module Main where

import Control.Monad (void)
import Data.Aeson.Types (FromJSON (..), Result (..), ToJSON (..))
import Data.List (nub, sortOn)
import Data.Time (UTCTime, defaultTimeLocale, formatTime, parseTimeM)
import Development.Shake ((%>), Action, Rules, (|%>), (~>))
import Development.Shake.FilePath ((<.>), (</>))
import GHC.Generics (Generic)
import Text.Pandoc (Block (Plain), Meta (..), MetaValue (..), Pandoc (..))
import qualified Data.Aeson.Types as A
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import qualified Development.Shake as Shake
import qualified Development.Shake.FilePath as Shake
import qualified Text.Mustache as Mus
import qualified Text.Mustache.Compile as Mus
import qualified Text.Pandoc as Pandoc
import qualified Data.Ord as Ord
-- end snippet imports

-- start snippet main
main :: IO ()
main = do
  Shake.shakeArgs Shake.shakeOptions $ do
    Shake.withTargetDocs "Build the site" $
      "build" ~> buildTargets
    Shake.withTargetDocs "Clean the built site" $
      "clean" ~> Shake.removeFilesAfter outputDir ["//*"]

    Shake.withoutTargets buildRules
-- end snippet main

-- start snippet build-rules
outputDir :: String
outputDir = "_site"

buildTargets :: Action ()
buildTargets = void $ do
  needOutput [ "about/index.html"
             , "contact/index.html"
             , "archive/index.html"
             , "index.html"
             ]
  
  postPaths  <- Shake.getDirectoryFiles "" ["posts/*.md"]
  assetPaths <- Shake.getDirectoryFiles "" ["css/*.css", "images/*.png"]
  Shake.need . map indexHtmlOutputPath $ postPaths
  needOutput assetPaths
  
  posts <- Shake.forP postPaths readPost
  needOutput 
    . map (\tag -> "tags" </> tag </> "index.html") 
    . nub 
    . concatMap postTags 
    $ posts
  where
    needOutput = Shake.need . map (outputDir </>)

buildRules :: Rules ()
buildRules = do
  assets
  pages
  posts      
  archive    
  tagArchives
  index      
-- end snippet build-rules

-- start snippet assets
assets :: Rules ()
assets =
  map (outputDir </>) ["css/*.css", "images/*.png"] |%> \out -> do
    let src = Shake.dropDirectory1 out
    Shake.copyFile' src out
    Shake.putInfo $ "Copied " <> out <> " from " <> src
-- end snippet assets

-- start snippet pages
data Page = Page { pageTitle :: T.Text, pageContent :: T.Text }
            deriving (Show, Generic)

instance ToJSON Page where
  toJSON = A.genericToJSON $
    A.defaultOptions { A.fieldLabelModifier = A.camelTo2 '_' . drop 4 }

instance FromJSON Page where
  parseJSON = A.genericParseJSON $
    A.defaultOptions { A.fieldLabelModifier = A.camelTo2 '_' . drop 4 }

pages :: Rules ()
pages =
  map indexHtmlOutputPath ["about.md", "contact.md"] |%> \out -> do
    let src      = indexHtmlSourcePath out
    (meta, html) <- markdownToHtml src

    let page = Page (meta HM.! "title") html
    applyTemplateAndWrite "default.html" page out
    Shake.putInfo $ "Built " <> out <> " from " <> src
-- end snippet pages

-- start snippet posts-1
data Post = Posts {
    postTitle   :: T.Text
  , postAuthor  :: Maybe String
  , postTags    :: [String]
  , postDate    :: Maybe String
  , postContent :: Maybe T.Text
  , postUrl     :: Maybe String
  } deriving (Show, Generic)

instance ToJSON Post where
  toJSON = A.genericToJSON $
    A.defaultOptions { A.fieldLabelModifier = A.camelTo2 '_' . drop 4 }

instance FromJSON Post where
  parseJSON = A.genericParseJSON $
    A.defaultOptions { A.fieldLabelModifier = A.camelTo2 '_' . drop 4 }
-- end snippet posts-1

-- start snippet posts-2
posts :: Rules ()
posts =
  outputDir </> "posts/*/index.html" %> \out -> do
    let src  = indexHtmlSourcePath out
    post     <- readPost src
    postHtml <- applyTemplate "post.html" post

    let page = Page (postTitle post) postHtml
    applyTemplateAndWrite "default.html" page out
    Shake.putInfo $ "Built " <> out <> " from " <> src

readPost :: FilePath -> Action Post
readPost postPath = do
  date :: UTCTime <- parseTimeM False defaultTimeLocale "%Y-%-m-%-d"
      . take 10
      . Shake.takeBaseName
      $ postPath
  let dateFmtd = formatTime defaultTimeLocale "%b %e, %Y" date

  (post, html) <- markdownToHtml postPath
  Shake.putInfo $ "Read " <> postPath
  return $ post { postDate    = Just dateFmtd
                , postContent = Just html
                , postUrl     = Just $ "/" <> Shake.dropExtension postPath <> "/" }
-- end snippet posts-2

-- start snippet archive
archive :: Rules ()
archive =
  outputDir </> "archive/index.html" %> \out -> do
    postPaths <- Shake.getDirectoryFiles "" ["posts/*.md"]
    posts     <- sortOn (Ord.Down . postDate) <$> Shake.forP postPaths readPost
    writeArchive "Archive" posts out

writeArchive :: String -> [Post] -> FilePath -> Action ()
writeArchive title posts out = do
  archiveHtml <- applyTemplate "archive.html"
      $ HM.singleton "posts" posts

  let page = Page (T.pack title) archiveHtml
  applyTemplateAndWrite "default.html" page out
  Shake.putInfo $ "Built " <> out
-- end snippet archive

-- start snippet tag-archive
tagArchives :: Rules ()
tagArchives =
  outputDir </> "tags/*/index.html" %> \out -> do
    let tag   = Shake.splitDirectories out !! 2
    postPaths <- Shake.getDirectoryFiles "" ["posts/*.md"]
    posts     <- sortOn (Ord.Down . postDate)
      . filter ((tag `elem`) . postTags)
      <$> Shake.forP postPaths readPost
    writeArchive ("Posts tagged " <> tag) posts out
-- end snippet tag-archive

-- start snippet index
index :: Rules ()
index =
  outputDir </> "index.html" %> \out -> do
    postPaths <- Shake.getDirectoryFiles "" ["posts/*.md"]
    posts     <- take 3
      . sortOn (Ord.Down . postDate)
      <$> Shake.forP postPaths readPost
    indexHtml <- applyTemplate "index.html"
      $ HM.singleton "posts" posts

    let page = Page (T.pack "Home") indexHtml
    applyTemplateAndWrite "default.html" page out
    Shake.putInfo $ "Built " <> out
-- end snippet index

-- start snippet shake
indexHtmlOutputPath :: FilePath -> FilePath
indexHtmlOutputPath srcPath =
  outputDir </> Shake.dropExtension srcPath </> "index.html"

indexHtmlSourcePath :: FilePath -> FilePath
indexHtmlSourcePath =
  Shake.dropDirectory1
  . (<.> "md")
  . Shake.dropTrailingPathSeparator
  . Shake.dropFileName
-- end snippet shake

-- start snippet pandoc
markdownToHtml :: FromJSON a => FilePath -> Action (a, T.Text)
markdownToHtml fp = do
  content <- Shake.readFile' fp
  Shake.quietly . Shake.traced "Markdown to HTML" $ do
    pandoc@(Pandoc meta _) <- runPandoc . Pandoc.readMarkdown readerOptions . T.pack $ content
    meta' <- metaToValue meta >>= convert
    html <- runPandoc . Pandoc.writeHtml5String writerOptions $ pandoc
    return (meta', html)
  where
    readerOptions = Pandoc.def { Pandoc.readerExtensions = Pandoc.pandocExtensions }
    writerOptions = Pandoc.def { Pandoc.writerExtensions = Pandoc.pandocExtensions }

    metaToValue (Meta meta) = toJSON <$> traverse go meta

    go (MetaMap     m) = toJSON <$> traverse go m
    go (MetaList    m) = toJSONList <$> traverse go m
    go (MetaBool    m) = pure $ toJSON m
    go (MetaString  m) = pure $ toJSON $ T.strip m
    go (MetaInlines m) =
      toJSON . T.strip <$> (runPandoc . Pandoc.writePlain Pandoc.def . Pandoc mempty . (:[]) . Plain $ m)
    go (MetaBlocks  m) =
      toJSON . T.strip <$> (runPandoc . Pandoc.writePlain Pandoc.def . Pandoc mempty $ m)

    convert a = case A.fromJSON (toJSON a) of
      Success res -> pure res
      Error err   -> fail $ "json conversion error:" ++ err

    runPandoc p = Pandoc.runIO p >>= either (fail . show) return
-- end snippet pandoc

-- start snippet mustache
applyTemplate :: ToJSON a => FilePath -> a -> Action T.Text
applyTemplate template context = do
  tmpl <- readTemplate $ "templates" </> template
  case Mus.checkedSubstitute tmpl (toJSON context) of
    ([], text) -> return text
    (errs, _)  -> fail $ 
      "Error while substituting template " <> template <> ": " <> unlines (map show errs)

applyTemplateAndWrite :: (ToJSON a) => FilePath -> a -> FilePath -> Action ()
applyTemplateAndWrite template context out =
    applyTemplate template context >>= Shake.writeFile' out . T.unpack

readTemplate :: FilePath -> Action Mus.Template
readTemplate tmplPath = do
  Shake.need [tmplPath]
  Shake.liftIO (Mus.localAutomaticCompile tmplPath) >>= \case
    Right template -> do
      Shake.need (Mus.getPartials . Mus.ast $ template)
      return template
    Left err -> fail $ show err
-- end snippet mustache