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