{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}

{- | Hakyll extension for rendering Coq code blocks using Alectryon.

  See the README for instructions on how to use this module.

  Import this module qualified:

  > import qualified Hakyll.Alectryon as Alectryon

  The main two functions are:

  - 'tryTransform': transform Pandoc documents, ignoring those where
    the @alectryon@ field is not set.
  - 'hakyllWith': extend the Hakyll CLI with an option to enable
    processing code blocks with Alectryon. This is disabled by default,
    assuming that the output is already cached.

-}
module Hakyll.Alectryon
  ( -- * Transformations
    tryTransform
  , tryTransform_
  , transform

    -- ** Alectryon and pygments
  , transformAlectryon
  , transformPygments

    -- * Options
  , Options(..)
  , defaultOptions
  , enabledOptions
  , hakyll
  , hakyllWith
  , optionParser

    -- ** Extend Hakyll with custom parsers
  , execParser
  , parserInfo
  , hakyllWithArgsParser

    -- * Low-level interface
  , updateAlectryonBlocks
  , updateBlocks
  , onCoqBlocks
  , onAlectryonBlocks
  , onBlocks
  , doRunAlectryon
  , doRunPygments
  , name

    -- ** Call Alectryon
  , splitAlectryonHTML
  , callAlectryon

    -- ** Call Pygments
  , 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 -->\")"
  ]

-- | If the @alectryon@ flag is set, 'transform'.
--
-- Do nothing if @alectryon@ flag is not set.
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

-- | If the @alectryon@ flag is set, 'transform'.
--
-- Do nothing if @alectryon@ flag is not set.
--
-- This is 'tryTransform' with all options enabled.
tryTransform_ :: Item Pandoc -> Compiler (Item Pandoc)
tryTransform_ :: Item Pandoc -> Compiler (Item Pandoc)
tryTransform_ = Options -> Item Pandoc -> Compiler (Item Pandoc)
tryTransform Options
enabledOptions

-- | Convert @alectryon@ and @coq@ code blocks to HTML using Alectryon and
-- pygments respectively.
transform ::
  Options ->
  Maybe FilePath {- ^ Cache directory location -} ->
  [String] {- ^ Alectryon options (e.g., Coq @-Q@, @-R@) -} ->
  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)

-- | Convert @alectryon@ code blocks to HTML using Alectryon.
--
-- > transform opt cache args :: Pandoc -> Compiler Pandoc
transformAlectryon ::
  Options ->
  Maybe FilePath {- ^ Cache file location -} ->
  [String] {- ^ Alectryon options (e.g., Coq @-Q@, @-R@) -} ->
  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]
: [])

-- | Convert @coq@ code blocks to HTML using pygments.
transformPygments ::
  Options ->
  Maybe FilePath {- ^ Cache file location -} ->
  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]
: [])

-- | @\"alectryon\"@
name :: Text
name :: Text
name = Text
"alectryon"

-- | @\"coq\"@
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

-- | Transform a list of blocks using alectryon.
--
-- If the input list is empty, return the empty list immediately,
-- saving an external call.
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)

-- | Transform a list of blocks using pygments.
--
-- If the input list is empty, return the empty list immediately,
-- saving an external call.
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)

-- | Split Alectryon output.
splitAlectryonHTML :: Text -> [Text]
splitAlectryonHTML :: Text -> [Text]
splitAlectryonHTML = Text -> Text -> [Text]
Text.splitOn Text
"<!-- alectryon-block-end -->"

-- | Split pygments output.
splitPygmentsHTML :: Text -> [Text]
splitPygmentsHTML :: Text -> [Text]
splitPygmentsHTML = Text -> Text -> [Text]
Text.splitOn Text
"<!-- pygments-batch-end -->"

-- | Call the Alectryon executable.
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 ()

-- | Call the pygments script.
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)

-- | Configurations for hakyll-alectryon.
--
-- Avoid using the 'Options' constructor directly, prefer record updates on
-- 'defaultOptions'.
data Options = Options
  { -- | If @True@, actually process code blocks using Alectryon and Pygments.
    -- If @False@, use the cached output, and fail if the cache is not found
    -- (this is to ensure the site is buildable without Alectryon).
    Options -> Bool
runAlectryon :: Bool

    -- | If @True@, process all posts. If @False@, process only posts whose
    -- metadata contains an @alectryon@ field set to a list.
    --
    -- That list contains options to pass to the Alectryon executable.
    -- It defaults to the empty list if @enableAll = True@ and it is not
    -- present in the metadata of a post.
  , Options -> Bool
enableAll :: Bool
  }

defaultOptions :: Options
defaultOptions :: Options
defaultOptions = Options
  { runAlectryon :: Bool
runAlectryon = Bool
False
  , enableAll :: Bool
enableAll = Bool
False
  }

-- | Always run Alectryon on all posts.
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