7de2bc811a
- Output files now go to output/<document-name>/ relative to input - Images named after nearest heading (e.g., file_flow.svg) - Multiple images under same heading get suffixes: _1, _2, etc. - Images before any heading use document name as prefix - Add StateT-based AST traversal for heading tracking - Add HSpec test suite with 21 tests 🤖 Generated with [Claude Code](https://claude.com/claude-code) Co-Authored-By: Claude Opus 4.5 <noreply@anthropic.com>
111 lines
4.5 KiB
Haskell
111 lines
4.5 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
-- | Mermaid diagram processing functionality
|
|
module Docster.Mermaid
|
|
( -- * Diagram Processing
|
|
processMermaidBlock
|
|
, renderMermaidDiagram
|
|
, generateDiagramId
|
|
, createImageBlock
|
|
) where
|
|
|
|
import Docster.Types (DiagramConfig(..), DiagramId(..), OutputDir(..), OutputFormat(..), DocsterError(..))
|
|
import Text.Pandoc.Definition (Block(..), Inline(..), nullAttr)
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.IO as TIO
|
|
import Data.Hashable (hash)
|
|
import System.FilePath (takeFileName, (</>))
|
|
import System.Directory (removeFile, getTemporaryDirectory)
|
|
import System.Process (callProcess)
|
|
import System.IO (hClose)
|
|
import System.IO.Temp (openTempFile)
|
|
import Control.Exception (bracket, catch, SomeException)
|
|
|
|
-- | Application constants
|
|
mermaidCommand :: Text
|
|
mermaidCommand = "mmdc"
|
|
|
|
diagramPrefix :: Text
|
|
diagramPrefix = "diagram-"
|
|
|
|
successEmoji :: Text
|
|
successEmoji = "✅"
|
|
|
|
-- | Generate a diagram ID from content hash or explicit ID
|
|
generateDiagramId :: Text -> Text -> DiagramId
|
|
generateDiagramId explicitId contents
|
|
| T.null explicitId = DiagramId $ diagramPrefix <> T.take 6 (T.pack . show . abs . hash $ T.unpack contents)
|
|
| otherwise = DiagramId explicitId
|
|
|
|
-- | Transform Mermaid code blocks into image embeds
|
|
processMermaidBlock :: DiagramConfig -> Block -> IO (Either DocsterError Block)
|
|
processMermaidBlock config (CodeBlock (id', classes, _) contents)
|
|
| "mermaid" `elem` classes = do
|
|
let diagId = generateDiagramId id' contents
|
|
result <- renderMermaidDiagram config diagId contents
|
|
case result of
|
|
Left err -> return $ Left err
|
|
Right imagePath -> return $ Right $ createImageBlock imagePath
|
|
processMermaidBlock _ block = return $ Right block
|
|
|
|
-- | Render Mermaid diagram to appropriate format with resource cleanup
|
|
renderMermaidDiagram :: DiagramConfig -> DiagramId -> Text -> IO (Either DocsterError Text)
|
|
renderMermaidDiagram config@(DiagramConfig _ (OutputDir outDir) format) diagId contents = do
|
|
let diagIdStr = T.unpack $ (\(DiagramId d) -> d) diagId
|
|
mmdFile = outDir </> diagIdStr <> ".mmd"
|
|
(outputFile, imagePath) = generateDiagramPaths config diagId
|
|
|
|
-- Use bracket to ensure cleanup of temporary mermaid file
|
|
result <- bracket
|
|
(TIO.writeFile mmdFile contents >> return mmdFile)
|
|
(\file -> removeFile file `catch` \(_ :: SomeException) -> return ())
|
|
(\_ -> do
|
|
processResult <- callMermaidProcess format mmdFile outputFile
|
|
case processResult of
|
|
Left err -> return $ Left err
|
|
Right _ -> do
|
|
putStrLn $ T.unpack $ successEmoji <> " Generated " <> T.pack outputFile
|
|
return $ Right imagePath)
|
|
return result
|
|
|
|
-- | Generate file paths for diagram based on format
|
|
generateDiagramPaths :: DiagramConfig -> DiagramId -> (FilePath, Text)
|
|
generateDiagramPaths (DiagramConfig _ (OutputDir outDir) format) (DiagramId diagId) =
|
|
let diagIdStr = T.unpack diagId
|
|
in case format of
|
|
HTML -> let svgFile = outDir </> diagIdStr <> ".svg"
|
|
in (svgFile, T.pack $ takeFileName svgFile)
|
|
PDF -> let pngFile = outDir </> diagIdStr <> ".png"
|
|
in (pngFile, T.pack pngFile)
|
|
|
|
-- | Puppeteer configuration content for disabling sandbox
|
|
puppeteerConfigContent :: Text
|
|
puppeteerConfigContent = "{\n \"args\": [\"--no-sandbox\", \"--disable-setuid-sandbox\"]\n}"
|
|
|
|
-- | Call mermaid CLI process with appropriate arguments
|
|
callMermaidProcess :: OutputFormat -> FilePath -> FilePath -> IO (Either DocsterError ())
|
|
callMermaidProcess format mmdFile outputFile = do
|
|
let baseArgs = case format of
|
|
HTML -> ["-i", mmdFile, "-o", outputFile]
|
|
PDF -> ["-i", mmdFile, "-o", outputFile, "--scale", "3"]
|
|
|
|
-- Create temporary puppeteer config file
|
|
result <- bracket
|
|
(do tempDir <- getTemporaryDirectory
|
|
(configPath, configHandle) <- openTempFile tempDir "puppeteer-config.json"
|
|
hClose configHandle
|
|
TIO.writeFile configPath puppeteerConfigContent
|
|
return configPath)
|
|
(\configPath -> removeFile configPath `catch` \(_ :: SomeException) -> return ())
|
|
(\configPath -> do
|
|
let args = baseArgs ++ ["--puppeteerConfigFile", configPath]
|
|
catch
|
|
(callProcess (T.unpack mermaidCommand) args >> return (Right ()))
|
|
(\(e :: SomeException) -> return $ Left $ ProcessError $ "Mermaid process failed: " <> T.pack (show e)))
|
|
return result
|
|
|
|
-- | Create Pandoc image block from image path
|
|
createImageBlock :: Text -> Block
|
|
createImageBlock imagePath = Para [Image nullAttr [] (imagePath, "Mermaid diagram")] |