amelia
/
blag


{-# LANGUAGE BangPatterns #-}

{-# LANGUAGE MultiWayIf #-}

{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE BlockArguments #-}


import Control.DeepSeq (rnf)

import Control.Concurrent

import Control.Exception

import Control.Monad


import qualified Data.ByteString.Lazy.Char8 as BS

import Data.ByteString.Lazy.Char8 (pack, unpack)

import qualified Data.HashMap.Strict as HMap

import qualified Data.Text.Encoding as T

import qualified Data.Map.Strict as Map

import qualified Data.Text as T

import Data.Functor

import Data.Monoid

import Data.Binary

import Data.Maybe

import Data.Aeson

import Data.List

import Data.Char


import Hakyll.Core.Compiler.Internal

import Hakyll.Core.Compiler

import Hakyll.Web.Sass

import Hakyll


import qualified Network.URI.Encode as URI (encode)


import qualified Skylighting as Sky


import System.Directory

import System.Environment

import System.Process

import System.Exit

import System.IO


import Text.Pandoc.Walk (query, walkM, walk)

import Text.Pandoc.Highlighting

import Text.Pandoc.Definition

import Text.Pandoc.Options

import Text.Sass.Functions


import Data.Text (Text)

import Data.IORef

import Data.Hashable (Hashable (hashWithSalt))

import GHC.Stack

import Text.Read (readMaybe)


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" }


katexFilter :: IORef KatexCache -> Pandoc -> Compiler Pandoc

katexFilter cacheVar (Pandoc meta doc) =

 do

 initCache <- unsafeCompiler (readIORef cacheVar)

 id <- compilerUnderlying <$> compilerAsk

 t <- getMetadata id


 invalidateCache id (abbrevs t) cacheVar


 doc <- Pandoc meta <$> walkM (go (show id) (abbrevs t)) doc

 unsafeCompiler $ flushCache cacheVar

 pure doc

 where

 abbrevs :: HMap.HashMap Text Value -> [String]

 abbrevs x =

 case HMap.lookup "abbreviations" x of

 Just (Object map) -> concat $ mapMaybe oneAbbrev (HMap.toList map)

 _ -> []


 oneAbbrev (x, String t) = Just ["-m", '\\':T.unpack x ++ ':':T.unpack t]

 oneAbbrev _ = Nothing


 go :: String -> [String] -> Inline -> Compiler Inline

 go id abbrevs (Math kind math) = unsafeCompiler $ do

 cache <- readIORef cacheVar

 case HMap.lookup (id, kind, math) (spanMap cache) of

 Just x -> pure (RawInline "html" x)

 Nothing -> do

 let args = flip (:) abbrevs $ case kind of { DisplayMath -> "-td"; InlineMath -> "-t" }


 (contents, _) <- readProcessBS "node_modules/.bin/katex" args . BS.fromStrict . T.encodeUtf8 $ math

 let text = T.init . T.init . T.decodeUtf8 . BS.toStrict $ contents


 atomicModifyIORef' cacheVar (\m -> (bumpCacheEntry cache id abbrevs kind text math, ()))

 pure $ RawInline "html" text


 go id _ x = pure x


 bumpCacheEntry (KatexCache spans depends abbrevVars) id abbrevs kind text math =

 let

 str = T.unpack text

 usedAbbrevs = map (\x -> (T.pack (takeWhile (/= ':') (tail x)), T.pack (tail (dropWhile (/= ':') (tail x)))))

 $ filter (\x -> (takeWhile (/= ':') (tail x)) `isInfixOf` str)

 $ filter (not . isPrefixOf "-") abbrevs

 addDeps [] x = x

 addDeps ((k, _):xs) vl = HMap.alter (\v -> Just (maybe [(id, kind, math)] ((id, kind, math):) v)) (id, k) $ addDeps xs vl


 recordVars [] x = x

 recordVars ((k, v):xs) x = HMap.insert (id, k) v (recordVars xs x)

 in

 case usedAbbrevs of

 [] -> KatexCache (HMap.insert (id, kind, math) text spans) depends abbrevVars

 xs -> KatexCache (HMap.insert (id, kind, math) text spans) (addDeps xs depends) (recordVars xs abbrevVars)


abbreviationFilter :: Pandoc -> Compiler Pandoc

abbreviationFilter (Pandoc meta doc) =

 do

 id <- compilerUnderlying <$> compilerAsk

 t <- getMetadata id

 case HMap.lookup "abbreviations" t of

 Just (Object map) -> do

 pure (Pandoc meta (walk (replace map) doc))

 _ -> pure (Pandoc meta doc)

 where

 replace map x =

 case x of

 Str t | Just (e, r) <- entity t -> fromMaybe (Str t) (toInline r =<< HMap.lookup e map)

 x -> x


 toInline r (String t) = Just (Str (t <> r))

 toInline _ _ = Nothing


 entity x

 | T.isPrefixOf "&" x && T.length x >= 3 =

 let

 (name, rest') = T.span (/= ';') (T.tail x)

 rest = T.tail rest'

 in pure (name, rest)

 | otherwise = Nothing


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 :: Pandoc -> Pandoc

addLanguageTag (Pandoc meta blocks) = Pandoc meta (map go blocks) where

 go :: Block -> Block

 go block@(CodeBlock (identifier, classes@(language:classes'), kv) text) =

 Div

 ( mempty

 , "code-container":if haskv then "custom-tag":classes' else classes'

 , []

 )

 [block, Div (mempty, ["code-tag"], []) [Plain [Span (mempty, [], []) [Str tag]]]]

 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)


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

 go x = x


saveSynopsys :: Pandoc -> Compiler Pandoc

saveSynopsys (Pandoc meta doc) =

 do

 id <- getUnderlying

 n <- fromMaybe (1 :: Int) . readMaybe . fromMaybe "" . lookupString "synopsys" <$> getMetadata id


 case dropWhile (not . isParagraph) doc of

 p:ps -> do

 saveSnapshot "synopsys" =<< makeItem (take n (p:ps))

 pure ()

 [] -> pure ()

 pure $ Pandoc meta doc

 where

 isParagraph Para{} = True

 isParagraph _ = False


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 []


setup :: IO (IORef KatexCache)

setup = do

 setEnv "AMC_LIBRARY_PATH" "/usr/lib/amuletml/lib/"

 loadCache


compiler :: IORef KatexCache -> Compiler (Item String)

compiler katexCache = do

 wops <- writerOptions

 pandocCompilerWithTransformM readerOpts wops $

 katexFilter katexCache

 >=> abbreviationFilter

 >=> saveSynopsys

 >=> pure . estimateReadingTime

 >=> pure . addLanguageTag


main :: IO ()

main = setup >>= \katexCache -> hakyllWith conf $ do

 match "static/*" do

 route idRoute

 compile copyFileCompiler


 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 $ do

 wops <- writerOptions

 id <- getUnderlying

 r <- compiler katexCache

 >>= loadAndApplyTemplate "templates/post.html" postCtx

 >>= saveSnapshot "content"

 >>= loadAndApplyTemplate "templates/default.html" postCtx

 >>= relativizeUrls


 loadSnapshot id "synopsys" >>= saveSnapshot "synopsys" . writePandocWith wops . fmap (Pandoc mempty)

 pure r


 match "pages/posts/*.lhs" $ version "raw" $ do

 route idRoute

 compile copyFileCompiler


 create ["archive.html"] $ do

 route idRoute

 compile $ do

 posts <- recentFirst =<< onlyPublic =<< loadAll ("pages/posts/*" .&&. hasNoVersion)

 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 =<< onlyPublic =<< loadAll ("pages/posts/*" .&&. hasNoVersion)

 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 $ setExtension "html" <> gsubRoute "pages/" (const "")

 compile $ compiler katexCache

 >>= 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 <- fmap (take 10) . recentFirst =<< onlyPublic =<< loadAllSnapshots ("pages/posts/*" .&&. hasNoVersion) "synopsys"

 renderRss rssfeed feedCtx posts


onlyPublic :: [Item String] -> Compiler [Item String]

onlyPublic = filterM isPublic where

 isPublic item = do

 t <- getMetadata (itemIdentifier item)

 case HMap.lookup "public" t of

 Just (Bool False) -> pure False

 _ -> pure True


postCtx :: Context String

postCtx =

 dateField "date" "%B %e, %Y"

 <> synopsysField

 <> defaultContext

 where

 synopsysField = field "synopsys" $ \x -> do

 let id = itemIdentifier x

 itemBody <$> loadSnapshot id "synopsys"


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)


loadCache :: HasCallStack => IO (IORef KatexCache)

loadCache = do

 t <- doesFileExist ".katex_cache"

 let fixup (a, b, c) = KatexCache (HMap.fromList a) (HMap.fromList b) (HMap.fromList c)

 map <- if t

 then (fixup <$> decodeFile ".katex_cache") `catch` \e ->

 const (print e *> pure (KatexCache mempty mempty mempty)) (e :: SomeException)

 else pure (KatexCache mempty mempty mempty)

 var <- newIORef map

 pure var


flushCache :: IORef KatexCache -> IO ()

flushCache var = do

 KatexCache x y z <- readIORef var

 Data.Binary.encodeFile ".katex_cache" (HMap.toList x, HMap.toList y, HMap.toList z)


invalidateCache :: Identifier -> [String] -> IORef KatexCache -> Compiler KatexCache

invalidateCache id abbrevs cacheVar = unsafeCompiler $ atomicModifyIORef' cacheVar (\x -> (go x, go x)) where

 currentValues = map (\x -> (T.pack (takeWhile (/= ':') (tail x)), T.pack (tail (dropWhile (/= ':') (tail x)))))

 $ filter (not . isPrefixOf "-") abbrevs

 ident = show id


 go (KatexCache spanMap abbrKeys abbrText) =

 let

 go (abbr, val) (spanMap, abbrKeys, abbrText) =

 case HMap.lookup (ident, abbr) abbrText of

 Just vl | vl /= val ->

 let l = HMap.lookupDefault [] (ident, abbr) abbrKeys

 in (foldr HMap.delete spanMap l, abbrKeys, abbrText)

 _ -> (spanMap, abbrKeys, abbrText)


 (a, b, c) = foldr go (spanMap, abbrKeys, abbrText) currentValues

 in KatexCache a b c


data KatexCache

 = KatexCache { spanMap :: HMap.HashMap (String, MathType, Text) Text

 , abbreviationKeys :: HMap.HashMap (String, Text) [(String, MathType, Text)]

 , abbreviationText :: HMap.HashMap (String, Text) Text

 }


instance Hashable MathType where

 hashWithSalt s DisplayMath = hashWithSalt s (0 :: Int)

 hashWithSalt s InlineMath = hashWithSalt s (1 :: Int)