#! /usr/bin/env nix-shell
#! nix-shell -p "haskellPackages.ghcWithPackages (p: [p.mustache p.pandoc p.shake p.deriving-aeson])"
#! nix-shell -i runhaskell
-- start snippet imports
{-# LANGUAGE ApplicativeDo, DataKinds, DeriveGeneric #-}
{-# LANGUAGE DerivingVia, LambdaCase, TypeApplications #-}

module Main where

import Control.Monad (void)
import Data.Aeson.Types (Result (..))
import Data.List (nub, sortOn)
import Data.Text (Text)
import Data.Time (UTCTime, defaultTimeLocale, formatTime, parseTimeM)
import Deriving.Aeson
import Deriving.Aeson.Stock (PrefixedSnake)
import Development.Shake (Action, Rules, (%>), (|%>), (~>))
import Development.Shake.FilePath ((<.>), (</>))
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.Ord as Ord
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
-- end snippet imports

-- start snippet main
main :: IO ()
main = 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

outputDir :: String
outputDir = "_site"
-- end snippet main

-- start snippet build-targets
buildTargets :: Action ()
buildTargets = do
  assetPaths <- Shake.getDirectoryFiles "" assetGlobs
  Shake.need $ map (outputDir </>) assetPaths

  Shake.need $ map indexHtmlOutputPath pagePaths

  postPaths <- Shake.getDirectoryFiles "" postGlobs
  Shake.need $ map indexHtmlOutputPath postPaths

  Shake.need $ map (outputDir </>) ["archive/index.html", "index.html"]

  posts <- Shake.forP postPaths readPost
  Shake.need
    [ outputDir </> "tags" </> T.unpack tag </> "index.html"
      | post <- posts, tag <- postTags post ]
-- end snippet build-targets

-- start snippet paths
assetGlobs :: [String]
assetGlobs = ["css/*.css", "images/*.png"]

pagePaths :: [String]
pagePaths = ["about.md", "contact.md"]

postGlobs :: [String]
postGlobs = ["posts/*.md"]

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

-- start snippet build-targets-parallel
buildTargetsParallel :: Action ()
buildTargetsParallel = do
  (assetPaths, postPaths) <-
    Shake.getDirectoryFiles "" assetGlobs
      `Shake.par` Shake.getDirectoryFiles "" postGlobs
  posts <- Shake.forP postPaths readPost

  Shake.need $
    map (outputDir </>)
      (assetPaths
        <> ["archive/index.html", "index.html"]
        <> ["tags" </> T.unpack tag </> "index.html"
            | post <- posts, tag <- postTags post ])
    <> map indexHtmlOutputPath (pagePaths <> postPaths)

-- end snippet build-targets-parallel

-- start snippet build-rules
buildRules :: Rules ()
buildRules = do
  assets
  pages
  posts
  archive
  tags
  home
-- end snippet build-rules

-- start snippet assets
assets :: Rules ()
assets = map (outputDir </>) assetGlobs |%> \out -> do
  let src = Shake.dropDirectory1 out
  Shake.copyFileChanged src out
  Shake.putInfo $ "Copied " <> out <> " from " <> src
-- end snippet assets

-- start snippet pages-1
data Page = Page {pageTitle :: Text, pageContent :: Text}
  deriving (Show, Generic)
  deriving (ToJSON) via PrefixedSnake "page" Page
-- end snippet pages-1

-- start snippet pages-2
pages :: Rules ()
pages = map indexHtmlOutputPath pagePaths |%> \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

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

-- start snippet posts-1
data Post = Post
  { postTitle :: Text,
    postAuthor :: Maybe Text,
    postTags :: [Text],
    postDate :: Maybe Text,
    postContent :: Maybe Text,
    postUrl :: Maybe Text
  } deriving (Show, Generic)
    deriving (FromJSON, ToJSON) via PrefixedSnake "post" Post
-- end snippet posts-1

-- start snippet posts-2
posts :: Rules ()
posts = map indexHtmlOutputPath postGlobs |%> \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 <- parseTimeM False defaultTimeLocale "%Y-%-m-%-d"
    . take 10
    . Shake.takeBaseName
    $ postPath
  let formattedDate =
        T.pack $ formatTime @UTCTime defaultTimeLocale "%b %e, %Y" date

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

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

writeArchive :: Text -> [Post] -> FilePath -> Action ()
writeArchive title posts out = do
  html <- applyTemplate "archive.html" $ HM.singleton "posts" posts
  applyTemplateAndWrite "default.html" (Page title html) out
  Shake.putInfo $ "Built " <> out
-- end snippet archive

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

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

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

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

    fromMeta (Meta meta) =
      A.fromJSON . A.toJSON <$> traverse metaValueToJSON meta >>= \case
        Success res -> pure res
        Error err -> fail $ "json conversion error:" <> err

    metaValueToJSON = \case
      MetaMap m -> A.toJSON <$> traverse metaValueToJSON m
      MetaList m -> A.toJSONList <$> traverse metaValueToJSON m
      MetaBool m -> pure $ A.toJSON m
      MetaString m -> pure $ A.toJSON $ T.strip m
      MetaInlines m -> metaValueToJSON $ MetaBlocks [Plain m]
      MetaBlocks m ->
        fmap (A.toJSON . T.strip)
          . runPandoc
          . Pandoc.writePlain Pandoc.def
          $ Pandoc mempty m

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

-- start snippet mustache
applyTemplate :: ToJSON a => FilePath -> a -> Action Text
applyTemplate template context = do
  tmpl <- readTemplate $ "templates" </> template
  case Mus.checkedSubstitute tmpl (A.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]
  eTemplate <- Shake.quietly
    . Shake.traced "Compile template"
    $ Mus.localAutomaticCompile tmplPath
  case eTemplate of
    Right template -> do
      Shake.need . Mus.getPartials . Mus.ast $ template
      Shake.putInfo $ "Read " <> tmplPath
      return template
    Left err -> fail $ show err
-- end snippet mustache