190 lines
8.1 KiB
Haskell
190 lines
8.1 KiB
Haskell
{-# LANGUAGE GHC2021 #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
-- | Inline data visualizations into the Pandoc AST.
|
|
--
|
|
-- Two fenced-div classes are recognized in Markdown:
|
|
--
|
|
-- __Static figure__ (Matplotlib → SVG, no client-side JS required):
|
|
--
|
|
-- > ::: {.figure script="figures/myplot.py" caption="Caption text"}
|
|
-- > :::
|
|
--
|
|
-- Runs the Python script; stdout must be an SVG document with a
|
|
-- transparent background. Black fills and strokes are replaced with
|
|
-- @currentColor@ so figures adapt to dark mode automatically.
|
|
-- See @tools/viz_theme.py@ for the recommended matplotlib setup.
|
|
--
|
|
-- __Interactive figure__ (Altair/Vega-Lite → JSON spec):
|
|
--
|
|
-- > ::: {.visualization script="figures/myplot.py" caption="Caption text"}
|
|
-- > :::
|
|
--
|
|
-- Runs the Python script; stdout must be a Vega-Lite JSON spec. The spec
|
|
-- is embedded verbatim inside a @\<script type=\"application\/json\"\>@ tag;
|
|
-- @viz.js@ picks it up and renders it via Vega-Embed, applying a
|
|
-- monochrome theme that responds to the site\'s light/dark toggle.
|
|
--
|
|
-- __Authoring conventions:__
|
|
--
|
|
-- * Scripts are run from the project root; paths are relative to it.
|
|
-- * @script=@ paths are resolved relative to the source file\'s directory.
|
|
-- * For @.figure@ scripts: use pure black (@#000000@) for all drawn
|
|
-- elements and transparent backgrounds so @processColors@ and CSS
|
|
-- @currentColor@ handle dark mode.
|
|
-- * For @.visualization@ scripts: set encoding colours to @\"black\"@;
|
|
-- @viz.js@ applies the site palette via Vega-Lite @config@.
|
|
-- * Set @viz: true@ in the page\'s YAML frontmatter to load Vega JS.
|
|
module Filters.Viz (inlineViz) where
|
|
|
|
import Control.Exception (IOException, catch)
|
|
import Data.Maybe (fromMaybe)
|
|
import qualified Data.Text as T
|
|
import System.Directory (doesFileExist)
|
|
import System.Exit (ExitCode (..))
|
|
import System.FilePath ((</>))
|
|
import System.IO (hPutStrLn, stderr)
|
|
import System.Process (readProcessWithExitCode)
|
|
import Text.Pandoc.Definition
|
|
import Text.Pandoc.Walk (walkM)
|
|
import qualified Utils as U
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- Public entry point
|
|
-- ---------------------------------------------------------------------------
|
|
|
|
-- | Walk the Pandoc AST and inline all @.figure@ and @.visualization@ divs.
|
|
-- @baseDir@ is the directory of the source file; @script=@ paths are
|
|
-- resolved relative to it.
|
|
inlineViz :: FilePath -> Pandoc -> IO Pandoc
|
|
inlineViz baseDir = walkM (transformBlock baseDir)
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- Block transformation
|
|
-- ---------------------------------------------------------------------------
|
|
|
|
transformBlock :: FilePath -> Block -> IO Block
|
|
transformBlock baseDir blk@(Div (_, cls, attrs) _)
|
|
| "figure" `elem` cls = do
|
|
result <- runScript baseDir attrs
|
|
case result of
|
|
Left err ->
|
|
warn "figure" err >> return (errorBlock err)
|
|
Right out ->
|
|
let caption = attr "caption" attrs
|
|
in return $ RawBlock (Format "html")
|
|
(staticFigureHtml (processColors out) caption)
|
|
| "visualization" `elem` cls = do
|
|
result <- runScript baseDir attrs
|
|
case result of
|
|
Left err ->
|
|
warn "visualization" err >> return (errorBlock err)
|
|
Right out ->
|
|
let caption = attr "caption" attrs
|
|
in return $ RawBlock (Format "html")
|
|
(interactiveFigureHtml (escScriptTag out) caption)
|
|
| otherwise = return blk
|
|
transformBlock _ b = return b
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- Script execution
|
|
-- ---------------------------------------------------------------------------
|
|
|
|
-- | Run @python3 <script>@. Returns the script\'s stdout on success, or an
|
|
-- error message on failure (non-zero exit, missing @script=@ attribute, or
|
|
-- missing script file).
|
|
runScript :: FilePath -> [(T.Text, T.Text)] -> IO (Either String T.Text)
|
|
runScript baseDir attrs =
|
|
case lookup "script" attrs of
|
|
Nothing -> return (Left "missing script= attribute")
|
|
Just p -> do
|
|
let fullPath = baseDir </> T.unpack p
|
|
exists <- doesFileExist fullPath
|
|
if not exists
|
|
then return (Left ("script not found: " ++ fullPath))
|
|
else do
|
|
(ec, out, err) <-
|
|
readProcessWithExitCode "python3" [fullPath] ""
|
|
`catch` (\e -> return (ExitFailure 1, "", show (e :: IOException)))
|
|
return $ case ec of
|
|
ExitSuccess -> Right (T.pack out)
|
|
ExitFailure _ -> Left $
|
|
"in " ++ fullPath ++ ": "
|
|
++ (if null err then "non-zero exit" else err)
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- SVG colour post-processing (mirrors Filters.Score.processColors)
|
|
-- ---------------------------------------------------------------------------
|
|
|
|
-- | Replace hardcoded black fill/stroke values with @currentColor@ so the
|
|
-- embedded SVG inherits the CSS text colour in both light and dark modes.
|
|
processColors :: T.Text -> T.Text
|
|
processColors
|
|
= T.replace "fill=\"#000\"" "fill=\"currentColor\""
|
|
. T.replace "fill=\"black\"" "fill=\"currentColor\""
|
|
. T.replace "stroke=\"#000\"" "stroke=\"currentColor\""
|
|
. T.replace "stroke=\"black\"" "stroke=\"currentColor\""
|
|
. T.replace "fill:#000" "fill:currentColor"
|
|
. T.replace "fill:black" "fill:currentColor"
|
|
. T.replace "stroke:#000" "stroke:currentColor"
|
|
. T.replace "stroke:black" "stroke:currentColor"
|
|
. T.replace "fill=\"#000000\"" "fill=\"currentColor\""
|
|
. T.replace "stroke=\"#000000\"" "stroke=\"currentColor\""
|
|
. T.replace "fill:#000000" "fill:currentColor"
|
|
. T.replace "stroke:#000000" "stroke:currentColor"
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- JSON safety for <script> embedding
|
|
-- ---------------------------------------------------------------------------
|
|
|
|
-- | Replace @<\/@ with the JSON Unicode escape @\u003c\/@ so that Vega-Lite
|
|
-- JSON embedded inside a @\<script\>@ tag cannot accidentally close it.
|
|
-- JSON.parse decodes the escape back to @<\/@ transparently.
|
|
escScriptTag :: T.Text -> T.Text
|
|
escScriptTag = T.replace "</" "\\u003c/"
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- HTML output
|
|
-- ---------------------------------------------------------------------------
|
|
|
|
staticFigureHtml :: T.Text -> T.Text -> T.Text
|
|
staticFigureHtml svgContent caption = T.concat
|
|
[ "<figure class=\"viz-figure\">"
|
|
, svgContent
|
|
, if T.null caption then ""
|
|
else "<figcaption class=\"viz-caption\">" <> escHtml caption <> "</figcaption>"
|
|
, "</figure>"
|
|
]
|
|
|
|
interactiveFigureHtml :: T.Text -> T.Text -> T.Text
|
|
interactiveFigureHtml jsonSpec caption = T.concat
|
|
[ "<figure class=\"viz-interactive\">"
|
|
, "<div class=\"vega-container\">"
|
|
, "<script type=\"application/json\" class=\"vega-spec\">"
|
|
, jsonSpec
|
|
, "</script>"
|
|
, "</div>"
|
|
, if T.null caption then ""
|
|
else "<figcaption class=\"viz-caption\">" <> escHtml caption <> "</figcaption>"
|
|
, "</figure>"
|
|
]
|
|
|
|
errorBlock :: String -> Block
|
|
errorBlock msg = RawBlock (Format "html") $ T.concat
|
|
[ "<div class=\"viz-error\"><strong>Visualization error:</strong> "
|
|
, escHtml (T.pack msg)
|
|
, "</div>"
|
|
]
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- Helpers
|
|
-- ---------------------------------------------------------------------------
|
|
|
|
attr :: T.Text -> [(T.Text, T.Text)] -> T.Text
|
|
attr key kvs = fromMaybe "" (lookup key kvs)
|
|
|
|
warn :: String -> String -> IO ()
|
|
warn kind msg = hPutStrLn stderr $ "[Viz] " ++ kind ++ " error: " ++ msg
|
|
|
|
escHtml :: T.Text -> T.Text
|
|
escHtml = U.escapeHtmlText
|