#! /usr/bin/env nix-shell
#! nix-shell -p "haskellPackages.ghcWithPackages (p: [p.mustache p.pandoc p.shake  p.deriving-aeson])"
#! nix-shell -i runhaskell
{-# 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 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.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

main :: IO ()
main = do
  templateCache <- newTemplateCache
  postCache <- newPostCache

  Shake.shakeArgs Shake.shakeOptions $ do
    Shake.withTargetDocs "Build the site" $
      "build" ~> buildTargets postCache
    Shake.withTargetDocs "Clean the built site" $
      "clean" ~> Shake.removeFilesAfter outputDir ["//*"]

    Shake.withoutTargets $ buildRules templateCache postCache

outputDir :: String
outputDir = "_site"

buildTargets :: PostCache -> Action ()
buildTargets postCache = 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 postCache
  Shake.need
    [ outputDir </> "tags" </> T.unpack tag </> "index.html"
      | post <- posts, tag <- postTags post ]

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"

buildRules :: TemplateCache -> PostCache -> Rules ()
buildRules templateCache postCache = do
  assets
  pages templateCache
  posts templateCache postCache
  archive templateCache postCache
  tags templateCache postCache
  home templateCache postCache

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

data Page = Page {pageTitle :: Text, pageContent :: Text}
  deriving (Show, Generic)
  deriving (ToJSON) via PrefixedSnake "page" Page

pages :: TemplateCache -> Rules ()
pages templateCache =
  map indexHtmlOutputPath pagePaths |%> \out -> do
    let src = indexHtmlSourcePath out
    (meta, html) <- markdownToHtml src

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

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

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

posts :: TemplateCache -> PostCache -> Rules ()
posts templateCache postCache =
  map indexHtmlOutputPath postGlobs |%> \out -> do
    let src = indexHtmlSourcePath out
    post <- postCache src
    postHtml <- applyTemplate templateCache "post.html" post

    let page = Page (postTitle post) postHtml
    applyTemplateAndWrite templateCache "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 <> "/"
    }

type PostCache = FilePath -> Action Post

newPostCache :: IO PostCache
newPostCache = Shake.newCacheIO readPost

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

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

tags :: TemplateCache -> PostCache -> Rules ()
tags templateCache postCache =
  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 postCache
    writeArchive templateCache (T.pack "Posts tagged " <> tag) posts out

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

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

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

applyTemplate :: ToJSON a => TemplateCache -> FilePath -> a -> Action Text
applyTemplate templateCache template context = do
  tmpl <- templateCache $ "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 => TemplateCache -> FilePath -> a -> FilePath -> Action ()
applyTemplateAndWrite templateCache template context out =
  applyTemplate templateCache 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

type TemplateCache = FilePath -> Action Mus.Template

newTemplateCache :: IO TemplateCache
newTemplateCache = Shake.newCacheIO readTemplate