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