{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
module Hakyll.Alectryon
(
tryTransform
, tryTransform_
, transform
, transformAlectryon
, transformPygments
, Options(..)
, defaultOptions
, enabledOptions
, hakyll
, hakyllWith
, optionParser
, execParser
, parserInfo
, hakyllWithArgsParser
, updateAlectryonBlocks
, updateBlocks
, onCoqBlocks
, onAlectryonBlocks
, onBlocks
, doRunAlectryon
, doRunPygments
, name
, splitAlectryonHTML
, callAlectryon
, splitPygmentsHTML
, callPygments
) where
import Control.Applicative (liftA2, (<|>))
import Control.Monad ((>=>))
import Control.Monad.State (State, runState, get, put)
import Data.Foldable (for_)
import qualified Data.Aeson as Aeson
import qualified Data.ByteString.Lazy as LBS (toStrict)
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text (readFile, writeFile)
import qualified Data.Text.Encoding as Text (decodeUtf8)
import qualified Options.Applicative as OA
import System.FilePath ((</>))
import System.Process (readProcess)
import Text.Pandoc (Block(CodeBlock, RawBlock), Pandoc(..))
import Text.Pandoc.Walk (query, walkM)
import Hakyll.Core.File (TmpFile(..), newTmpFile)
import Hakyll
( Rules, Item, Compiler, getMetadata, itemIdentifier
, withItemBody, unsafeCompiler, lookupString, lookupStringList)
import qualified Hakyll
pygmentsBatch :: String
pygmentsBatch = unlines
[ "import sys, json"
, "from pygments import highlight"
, "from pygments.lexers import CoqLexer"
, "from pygments.formatters import HtmlFormatter"
, "code = json.load(sys.stdin)"
, "for line in code:"
, " print(highlight(line, CoqLexer(), HtmlFormatter()))"
, " print(\"<!-- pygments-batch-end -->\")"
]
tryTransform :: Options -> Item Pandoc -> Compiler (Item Pandoc)
tryTransform opt idoc = do
m <- getMetadata (itemIdentifier idoc)
case lookupStringList "alectryon" m <|> enable of
Just args -> withItemBody (transform opt (lookupString "alectryon-cache" m) args) idoc
Nothing -> pure idoc
where
enable = if enableAll opt then Just [] else Nothing
tryTransform_ :: Item Pandoc -> Compiler (Item Pandoc)
tryTransform_ = tryTransform enabledOptions
transform ::
Options ->
Maybe FilePath ->
[String] ->
Pandoc -> Compiler Pandoc
transform opt cache args =
transformAlectryon opt ((</> "alectryon.html") <$> cache) args
>=> transformPygments opt ((</> "pygments.html") <$> cache)
transformAlectryon ::
Options ->
Maybe FilePath ->
[String] ->
Pandoc -> Compiler Pandoc
transformAlectryon opt cache args doc = do
snips <- doRunAlectryon opt cache args blocks
pure (updateAlectryonBlocks snips doc)
where
blocks = query getBlock doc
getBlock = onAlectryonBlocks [] (: [])
transformPygments ::
Options ->
Maybe FilePath ->
Pandoc -> Compiler Pandoc
transformPygments opt cache doc = do
snips <- doRunPygments opt cache blocks
pure (updateBlocks coqName snips doc)
where
blocks = query getBlock doc
getBlock = onCoqBlocks [] (: [])
name :: Text
name = "alectryon"
coqName :: Text
coqName = "coq"
nextBlock :: State [Text] Block
nextBlock = do
xs <- get
case xs of
[] -> error "No blocks left"
x : xs -> do
put xs
pure (RawBlock "html" x)
updateAlectryonBlocks :: [Text] -> Pandoc -> Pandoc
updateAlectryonBlocks = updateBlocks name
updateBlocks :: Text -> [Text] -> Pandoc -> Pandoc
updateBlocks name bs = fst . flip runState bs . walkM setBlock
where
setBlock b = onBlocks name (pure b) (\_ -> nextBlock) b
onCoqBlocks :: b -> (Text -> b) -> Block -> b
onCoqBlocks = onBlocks coqName
onAlectryonBlocks :: b -> (Text -> b) -> Block -> b
onAlectryonBlocks = onBlocks name
onBlocks :: Text -> b -> (Text -> b) -> Block -> b
onBlocks name _ f (CodeBlock (_, cs, _) b) | name `elem` cs = f b
onBlocks _ x _ _ = x
doRunAlectryon :: Options -> Maybe FilePath -> [String] -> [Text] -> Compiler [Text]
doRunAlectryon _ _ _ [] = pure []
doRunAlectryon opt cache args blocks | runAlectryon opt = do
TmpFile snippets <- case cache of
Just snippets -> pure (TmpFile snippets)
Nothing -> newTmpFile "snippets.html"
Hakyll.unsafeCompiler $ do
callAlectryon args snippets (Text.decodeUtf8 (LBS.toStrict (Aeson.encode blocks)))
splitAlectryonHTML <$> Text.readFile snippets
doRunAlectryon _opt cache _args _blocks | otherwise =
case cache of
Nothing -> error "hakyll-alectryon: cache not set, enable --run-alectryon"
Just snippets -> Hakyll.unsafeCompiler (splitAlectryonHTML <$> Text.readFile snippets)
doRunPygments :: Options -> Maybe FilePath -> [Text] -> Compiler [Text]
doRunPygments _ _ [] = pure []
doRunPygments opt cache blocks | runAlectryon opt = do
Hakyll.unsafeCompiler $ do
out <- callPygments (Text.decodeUtf8 (LBS.toStrict (Aeson.encode blocks)))
for_ cache (\snippets -> Text.writeFile snippets out)
pure (splitPygmentsHTML out)
doRunPygments _opt cache _blocks | otherwise =
case cache of
Nothing -> error "hakyll-alectryon: cache not set, enable --run-alectryon"
Just snippets -> Hakyll.unsafeCompiler (splitPygmentsHTML <$> Text.readFile snippets)
splitAlectryonHTML :: Text -> [Text]
splitAlectryonHTML = Text.splitOn "<!-- alectryon-block-end -->"
splitPygmentsHTML :: Text -> [Text]
splitPygmentsHTML = Text.splitOn "<!-- pygments-batch-end -->"
callAlectryon :: [String] -> FilePath -> Text -> IO ()
callAlectryon args snippets x = do
_ <- readProcess
"alectryon"
(["--frontend", "json", "--backend", "snippets-html", "--stdin-filename", "stdin", "-o", snippets, "-"] ++ args)
(Text.unpack x)
pure ()
callPygments :: Text -> IO Text
callPygments x = do
Text.pack <$> readProcess "python3" ["-c", pygmentsBatch] (Text.unpack x)
data Options = Options
{
runAlectryon :: Bool
, enableAll :: Bool
}
defaultOptions :: Options
defaultOptions = Options
{ runAlectryon = False
, enableAll = False
}
enabledOptions :: Options
enabledOptions = Options
{ runAlectryon = True
, enableAll = True
}
optionParser :: OA.Parser Options
optionParser = Options
<$> OA.switch (OA.long "run-alectryon" <> OA.help "Process Alectryon-enabled posts")
<*> OA.switch (OA.long "enable-all" <> OA.help "Enable Alectryon on all posts")
execParser :: OA.Parser a -> Hakyll.Configuration -> IO (Hakyll.Options, a)
execParser p config = OA.customExecParser (OA.prefs OA.showHelpOnError) (parserInfo p config)
parserInfo :: OA.Parser a -> Hakyll.Configuration -> OA.ParserInfo (Hakyll.Options, a)
parserInfo p config = info { OA.infoParser = liftA2 (,) (OA.infoParser info) p }
where
info = Hakyll.defaultParserInfo config
hakyllWithArgsParser :: OA.Parser a -> Hakyll.Configuration -> (a -> Rules ()) -> IO ()
hakyllWithArgsParser oparser config rules = do
(hopts, opts) <- execParser oparser config
Hakyll.hakyllWithArgs config hopts (rules opts)
hakyllWith :: Hakyll.Configuration -> (Options -> Rules ()) -> IO ()
hakyllWith = hakyllWithArgsParser optionParser
hakyll :: (Options -> Rules ()) -> IO ()
hakyll = hakyllWith Hakyll.defaultConfiguration