{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}

import qualified Data.ByteString.Lazy.Char8 as BS
import Data.Functor

import Control.Concurrent
import Control.Exception
import Control.DeepSeq (rnf)
import Control.Monad

import Text.Pandoc.Highlighting
import Text.Pandoc.Options
import Text.Pandoc.Definition
import Text.Sass.Functions
import Text.Pandoc.Walk (query, walkM)

import Hakyll.Core.Compiler
import Hakyll.Web.Sass
import Hakyll

import qualified Skylighting as Sky

import Data.ByteString.Lazy.Char8 (pack, unpack)
import qualified Network.URI.Encode as URI (encode)

import System.Environment
import System.Process
import System.Exit
import System.IO

import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Hakyll.Core.Compiler.Internal
import Data.List
import Data.Char
import qualified Data.Map.Strict as Map
import Data.Monoid

import Debug.Trace
import Data.Maybe

readerOpts :: ReaderOptions
readerOpts = def { readerExtensions = pandocExtensions
                 , readerIndentedCodeClasses = ["amulet"] }

writerOptions :: Compiler WriterOptions
writerOptions = do
  syntaxMap <- loadAllSnapshots "syntax/*.xml" "syntax"
           <&> foldr (Sky.addSyntaxDefinition . itemBody) Sky.defaultSyntaxMap

  pure $ defaultHakyllWriterOptions
    { writerExtensions = extensionsFromList
                         [ Ext_tex_math_dollars
                         , Ext_tex_math_double_backslash
                         , Ext_latex_macros
                         ] <> writerExtensions defaultHakyllWriterOptions
    , writerSyntaxMap = syntaxMap
    , writerHighlightStyle = Just kate
    }

rssfeed :: FeedConfiguration
rssfeed
  = FeedConfiguration { feedTitle = "Abigail's Blag: Latest articles"
                      , feedDescription = ""
                      , feedAuthorName = "Abigail Magalhães"
                      , feedAuthorEmail = "[email protected]"
                      , feedRoot = "https://abby.how"
                      }

conf :: Configuration
conf = def { destinationDirectory = ".site"
           , storeDirectory       = ".store"
           , tmpDirectory         = ".store/tmp"
           , deployCommand        = "./sync" }

tikzFilter :: Block -> Compiler Block
tikzFilter (CodeBlock (id, "tikzpicture":extraClasses, namevals) contents) =
  (imageBlock . T.pack . ("data:image/svg+xml;utf8," <>) . URI.encode . filter (/= '\n') . T.unpack . itemBody <$>) $
    makeItem contents
      >>= loadAndApplyTemplate (fromFilePath "templates/tikz.tex") (bodyField "body") . fmap T.unpack
      >>= withItemBody (pure . BS.fromStrict . T.encodeUtf8
                       >=> unixFilterLBS "rubber-pipe" ["--pdf"] 
                       >=> unixFilterLBS "pdftocairo" ["-svg", "-", "-"] 
                       >=> pure . T.decodeUtf8 . BS.toStrict)
          . fmap T.pack
  where imageBlock fname = Para [Image (id, "tikzpicture":extraClasses, namevals) [] (fname, "")]
tikzFilter x = return x

katexFilter :: Pandoc -> Compiler Pandoc
katexFilter (Pandoc meta doc) = do
  id <- compilerUnderlying <$> compilerAsk
  t <- getMetadata id
  case lookupString "fastbuild" t of
    Just _ -> pure (Pandoc meta doc)
    Nothing -> Pandoc meta <$> walkM go doc
  where
    go :: Inline -> Compiler Inline
    go (Math kind math) = unsafeCompiler $ do
      let args =
            case kind of
              DisplayMath -> ["-Std"]
              InlineMath  -> ["-St"]
      (contents, _) <- readProcessBS "node_modules/.bin/katex" args . BS.fromStrict . T.encodeUtf8 $ math
      pure . RawInline "html" . T.init . T.init . T.decodeUtf8 . BS.toStrict $ contents
    go x = pure x

estimateReadingTime :: Pandoc -> Pandoc
estimateReadingTime (Pandoc meta doc) = Pandoc meta doc' where
  wordCount = T.pack (show (getSum (query inlineLen doc)))

  inlineLen (Str s) = Sum (length (T.words s))
  inlineLen _ = mempty

  doc' = RawBlock "html" ("<span id=reading-length>" <> wordCount <> "</span>")
       : doc

addLanguageTag :: Block -> Block
addLanguageTag block@(CodeBlock (identifier, classes@(language:classes'), kv) text) = 
  Div
    ( mempty
    , "code-container":if haskv then "custom-tag":classes' else classes'
    , []
    )
    [Plain [Span (mempty, [], []) [Str tag]], block]
  where
    language' = case T.uncons language of
      Nothing -> mempty
      Just (c, cs) -> T.cons (toUpper c) cs
    tag   = fromMaybe language' (lookup "tag" kv)
    haskv = fromMaybe False (True <$ lookup "tag" kv)

addLanguageTag block@(CodeBlock (identifier, [], kv) text) = Div (mempty, ["code-container"], []) [block]

addLanguageTag x = x

sassImporter :: SassImporter
sassImporter = SassImporter 0 go where
  go "normalize" _ = do
    c <- readFile "node_modules/normalize.css/normalize.css"
    pure [ SassImport { importPath = Nothing
                      , importAbsolutePath = Nothing
                      , importSource = Just c
                      , importSourceMap = Nothing
                      } ]
  go _ _ = pure []

main :: IO ()
main = (*>) (setEnv "AMC_LIBRARY_PATH" "/usr/lib/amuletml/lib/") $ hakyllWith conf $ do
  let compiler = do
        wops <- writerOptions
        pandocCompilerWithTransformM readerOpts wops $
          walkM tikzFilter
          >=> katexFilter
          >=> pure . estimateReadingTime
          >=> walkM (pure . addLanguageTag)

  match "static/**/*" $ do
    route idRoute
    compile copyFileCompiler

  match "css/**/*" $ do
    route idRoute
    compile copyFileCompiler

  match "css/*.css" $ do
    route idRoute
    compile copyFileCompiler

  match "css/*.scss" $ do
    route $ setExtension "css"
    compile $ sassCompilerWith def { sassOutputStyle = SassStyleCompressed
                                   , sassImporters = Just [ sassImporter ]
                                   }

  match "diagrams/**/*.tex" $ do
    route $ setExtension "svg"
    compile $ getResourceBody
          >>= loadAndApplyTemplate "templates/tikz.tex" (bodyField "body")
          >>= withItemBody (return . pack 
                        >=> unixFilterLBS "rubber-pipe" ["--pdf"]
                        >=> unixFilterLBS "pdftocairo" ["-svg", "-", "-"]
                        >=> return . unpack)


  match "pages/posts/*" $ do
    route $ metadataRoute pathFromTitle

    compile $ compiler
      >>= loadAndApplyTemplate "templates/post.html"    postCtx
      >>= saveSnapshot "content"
      >>= loadAndApplyTemplate "templates/default.html" postCtx
      >>= relativizeUrls

  create ["archive.html"] $ do
    route idRoute
    compile $ do
      posts <- recentFirst =<< loadAll "pages/posts/*"
      let archiveCtx =
            listField "posts" postCtx (return posts) <>
            constField "title" "Archives"            <>
            defaultContext
      makeItem ""
        >>= loadAndApplyTemplate "templates/archive.html" archiveCtx
        >>= loadAndApplyTemplate "templates/default.html" archiveCtx
        >>= relativizeUrls

  match "pages/*.html" $ do
    route $ gsubRoute "pages/" (const "")
    compile $ do
      posts <- fmap (take 5) . recentFirst =<< loadAll "pages/posts/*"
      let indexCtx =
            listField "posts" postCtx (return posts) <>
            constField "title" "Home"                <>
            defaultContext
      getResourceBody
        >>= applyAsTemplate indexCtx
        >>= loadAndApplyTemplate "templates/default.html" indexCtx
        >>= relativizeUrls

  match "pages/*.md" $ do
    route $ gsubRoute "pages/" (const "") <> setExtension "html"
    compile $ compiler
      >>= loadAndApplyTemplate "templates/default.html" defaultContext
      >>= relativizeUrls

  match "syntax/*.xml" $ compile $ do
    path <- toFilePath <$> getUnderlying
    contents <- itemBody <$> getResourceBody
    debugCompiler ("Loaded syntax definition from " ++ show path)
    res <- unsafeCompiler (Sky.parseSyntaxDefinitionFromString path contents)
    _ <- saveSnapshot "syntax" =<< case res of
      Left e -> fail e
      Right x -> makeItem x
    makeItem contents

  match "templates/*" $ compile templateBodyCompiler

  create ["feed.xml"] $ do
    route idRoute
    compile $ do
      let feedCtx = postCtx <> bodyField "description"
      posts <- (take 10 <$>) . recentFirst =<< loadAllSnapshots "pages/posts/*" "content"
      renderRss rssfeed feedCtx posts

postCtx :: Context String
postCtx =
       dateField "date" "%B %e, %Y"
    <> defaultContext

readProcessBS :: FilePath -> [String] -> BS.ByteString -> IO (BS.ByteString, String)
readProcessBS path args input =
  let process = (proc path args)
        { std_in = CreatePipe
        , std_out = CreatePipe
        , std_err = CreatePipe
        }
  in withCreateProcess process $ \stdin stdout stderr ph ->
    case (stdin, stdout, stderr) of
      (Nothing, _, _) -> fail "Failed to get a stdin handle."
      (_, Nothing, _) -> fail "Failed to get a stdout handle."
      (_, _, Nothing) -> fail "Failed to get a stderr handle."
      (Just stdin, Just stdout, Just stderr) -> do
        out <- BS.hGetContents stdout
        err <- hGetContents stderr

        withForkWait (evaluate $ rnf out) $ \waitOut ->
          withForkWait (evaluate $ rnf err) $ \waitErr -> do
            -- Write input and close.
            BS.hPutStr stdin input
            hClose stdin

            -- wait on the output
            waitOut
            waitErr

            hClose stdout
            hClose stderr

            -- wait on the process
            ex <- waitForProcess ph
            case ex of
              ExitSuccess -> pure (out, err)
              ExitFailure ex -> fail (err ++ "Exited with " ++ show ex)

  where
    withForkWait :: IO () -> (IO () ->  IO a) -> IO a
    withForkWait async body = do
      waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))
      mask $ \restore -> do
        tid <- forkIO $ try (restore async) >>= putMVar waitVar
        let wait = takeMVar waitVar >>= either throwIO return
        restore (body wait) `onException` killThread tid

pathFromTitle :: Metadata -> Routes
pathFromTitle meta =
  let
    declaredCategory =
      case lookupString "category" meta of
        Just s -> ((s ++ "/") ++)
        Nothing -> ("posts/" <>)

    !titleString =
      case lookupString "title" meta of
        Just s -> s
        Nothing -> error "post has no title?"
    
    title = filter (/= "") . map (filter isAlphaNum . map toLower) . words $ titleString

    (category, title') =
      if | "or" `elem` title                   -> (declaredCategory, takeWhile (/= "or") title)
         | ["a", "quickie"] `isPrefixOf` title -> (("quick/" ++), drop 2 title)
         | otherwise                           -> (declaredCategory, title)
  in
    case lookupString "path" meta of
      Just p -> constRoute (category (p <> ".html"))
      Nothing -> constRoute (category (intercalate "-" title' <> ".html"))

foldMapM :: (Monad w, Monoid m, Foldable f) => (a -> w m) -> f a -> w m
foldMapM k = foldr (\x y -> do { m <- k x; (m <>) <$> y }) (pure mempty)