amelia
/
blag


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