diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +## v0.4 (2024-02-29) + + - New support for figures ([#23](https://github.com/diagrams/diagrams-pandoc/pull/23); thanks to Berk Özkütük) + - New test suite ([#22](https://github.com/diagrams/diagrams-pandoc/pull/22); thanks to Berk Özkütük) + - Allow `base-4.19`, `text-2.1`, `tasty-1.5` + - Test on GHC 9.8 + ## v0.3.1.1 (2023-07-10) - Update upper bounds to allow: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -28,15 +28,19 @@ You can specify attributes to control how the diagram is generated. The following, for example, ``` markdown - ~~~ {.diagram width=800 height=400} + ~~~ {.diagram width=800 height=400 caption="A circle"} example = circle 1 ~~~ ``` -will override the default width and height of the generated diagram. -The following attributes are supported: +will override the default width and height of the generated diagram, and +provide a caption for it. The following attributes are supported: * `width`: The width of the generated diagram, in pixels. The default is 500. * `height`: The height of the generated diagram, in pixels. The default is 200. +* `caption`: The caption of the diagram. Providing a caption makes the diagram +appear as a figure, rather than an inline image. Diagrams have no caption by default. +* `alt`: The alt text of the diagram. The caption is used as the default value +if it is provided, otherwise it is empty. ## Details diff --git a/diagrams-pandoc.cabal b/diagrams-pandoc.cabal --- a/diagrams-pandoc.cabal +++ b/diagrams-pandoc.cabal @@ -1,5 +1,6 @@ +cabal-version: 3.0 name: diagrams-pandoc -version: 0.3.1.1 +version: 0.4 synopsis: A Pandoc filter to express diagrams inline using the Haskell EDSL _Diagrams_ description: 'diagrams-pandoc' replaces appropriately marked code blocks in pandoc input with images. The code blocks are compiled @@ -7,51 +8,67 @@ Diagram named 'example', to be output. This name and other defaults can be overridden by command-line arguments to the diagrams-pandoc program. -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Daniel Bergey maintainer: diagrams-discuss@googlegroups.com category: Text build-type: Simple Bug-reports: http://github.com/diagrams/diagrams-pandoc/issues -Extra-source-files: README.md, CHANGELOG.md -cabal-version: >=1.10 -Tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.7 || ==9.4.5 || ==9.6.1 +Extra-source-files: README.md, test/*.md, test/*.html +extra-doc-files: CHANGELOG.md +Tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.3 || ==9.8.1 Source-repository head type: git location: http://github.com/diagrams/diagrams-pandoc.git +common common-deps + build-depends: base >= 4.6 && < 4.20, + text >= 1.2 && < 2.2, + pandoc-types >= 1.23 && < 1.24, + directory >= 1.2 && < 1.4, + filepath >= 1.3 && < 1.5 + library - build-depends: base >= 4.6 && < 4.19, - text >= 1.2 && < 2.1, - pandoc-types >= 1.20 && < 1.24, - diagrams-lib >= 1.3 && < 1.5, + import: common-deps + build-depends: diagrams-lib >= 1.3 && < 1.5, linear >= 1.10 && < 1.23, diagrams-builder >= 0.7 && < 0.9, diagrams-cairo >= 1.3 && < 1.5, - directory >= 1.2 && < 1.4, - filepath >= 1.3 && < 1.5, diagrams-svg >= 1.4 && < 1.5, diagrams-core >= 1.4 && < 1.6, hashable >= 1.2 && < 1.5, - svg-builder >= 0.1 && < 0.2 + svg-builder >= 0.1 && < 0.2, + pandoc >= 3.0 && < 3.2 exposed-modules: Text.Pandoc.Diagrams default-language: Haskell2010 hs-source-dirs: src ghc-options: -Wall +test-suite test + import: common-deps + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: diagrams-pandoc, + bytestring >= 0.10.10 && < 0.13, + pandoc >= 3.0 && < 3.2, + tasty >= 1.4.3 && < 1.6, + tasty-golden >= 2.3.5 && < 2.4, + + -- sandbox dependencies + SVGFonts >= 1.8.0 && < 1.9 + + executable diagrams-pandoc + import: common-deps main-is: src/Main.hs other-extensions: CPP - build-depends: base >= 4.6 && < 4.19, - text >= 1.2 && < 2.1, - pandoc-types >= 1.20 && < 1.24, - diagrams-lib >= 1.3 && < 1.5, + build-depends: diagrams-lib >= 1.3 && < 1.5, linear >= 1.10 && < 1.23, diagrams-builder >= 0.7 && < 0.9, diagrams-cairo >= 1.3 && < 1.5, - directory >= 1.2 && < 1.4, - filepath >= 1.3 && < 1.5, diagrams-pandoc, optparse-applicative >= 0.11 && < 0.19 default-language: Haskell2010 diff --git a/src/Text/Pandoc/Diagrams.hs b/src/Text/Pandoc/Diagrams.hs --- a/src/Text/Pandoc/Diagrams.hs +++ b/src/Text/Pandoc/Diagrams.hs @@ -25,9 +25,14 @@ import Linear (V2 (..), zero) import System.Directory (createDirectoryIfMissing) import System.FilePath (pathSeparator, (<.>), ()) -import System.IO -import Text.Pandoc.Definition -import Data.Maybe (maybeToList) +import System.IO (hFlush, hPutStr, hPutStrLn, stderr) +import Text.Pandoc.Definition (Block(..), Caption, Attr) +import qualified Text.Pandoc.Builder as PB +import qualified Text.Pandoc as Pandoc +import qualified Text.Pandoc.Shared as Pandoc +import Text.Pandoc.Options (def, readerExtensions, pandocExtensions) +import Data.Maybe (fromMaybe) +import Data.Foldable (fold) backendExt :: Opts -> String backendExt Opts {_backend = SVG } = "svg" @@ -57,23 +62,56 @@ insertDiagrams :: Opts -> Block -> IO [Block] insertDiagrams opts@Opts{..} (CodeBlock (ident, classes, attrs) code) | "diagram-haskell" `elem` classes = do - i <- maybeToList <$> img + i <- PB.toList <$> img return $ case echo of Above -> bl' : i Below -> i <> [bl'] - | "diagram" `elem` classes = maybeToList <$> img + | "diagram" `elem` classes = PB.toList <$> img where img = do - d <- compileDiagram opts attrs code - return $ case d of - Left _err -> Nothing -- TODO log an error here - Right imgName -> Just $ Para - [Image ("",[],[]) [] - (if _absolutePath then T.cons pathSeparator imgName else imgName,"") - ] -- no alt text, no title + d <- compileDiagram opts attrs code + case d of + Left _err -> pure mempty -- TODO log an error here + Right imgName -> case captionRaw of + Just captionRaw' -> do + captionBlocks <- parseCaption captionRaw' + let caption = blocksToCaption captionBlocks + alt = fromMaybe (blocksToAlt captionBlocks) altAttr + pure $ figureWithCaption + -- transfer identifier from code block to figure, so that + -- it can be referenced by `pandoc-crossref` and the like. + (ident, [], []) + caption + (if _absolutePath then T.cons pathSeparator imgName else imgName) + "" + alt + Nothing -> + pure $ PB.plain $ PB.imageWith + (ident, [], []) + (if _absolutePath then T.cons pathSeparator imgName else imgName) + "" + (fold altAttr) bl' = CodeBlock (ident, "haskell":delete "diagram-haskell" classes, attrs) code echo = readEcho attrs + captionRaw = lookup "caption" attrs + altAttr = PB.str <$> lookup "alt" attrs insertDiagrams _ block = return [block] + +figureWithCaption :: Attr -> Caption -> Text -> Text -> PB.Inlines -> PB.Blocks +figureWithCaption attr caption url title alt = + PB.figure caption . PB.plain $ PB.imageWith attr url title alt + +blocksToCaption :: [Block] -> Caption +blocksToCaption = PB.simpleCaption . PB.fromList + +blocksToAlt :: [Block] -> PB.Inlines +blocksToAlt = Pandoc.blocksToInlines' + +parseCaption :: Text -> IO [Block] +parseCaption s = Pandoc.runIOorExplode $ do + (Pandoc.Pandoc _ blks) <- + Pandoc.readMarkdown (def { readerExtensions = pandocExtensions }) s + pure blks -- Copied from https://github.com/diagrams/diagrams-doc/blob/master/doc/Xml2Html.hs -- With the CPP removed, thereby requiring Cairo diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Test.Tasty (TestTree) +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.Golden as Tasty + +import qualified Text.Pandoc as Pandoc +import Text.Pandoc.Options (def, readerExtensions, pandocExtensions, writerExtensions) +import qualified Text.Pandoc.Walk as Pandoc + +import Control.Monad.IO.Class (liftIO) +import qualified Data.ByteString.Lazy as LBS +import Data.Text (Text) +import qualified Data.Text.IO as T +import qualified Data.Text.Encoding as T +import System.Directory (removeDirectoryRecursive) +import System.FilePath (replaceExtension, takeBaseName) + +import Text.Pandoc.Diagrams (Opts (..), Backend (..), insertDiagrams) + + +main :: IO () +main = Tasty.defaultMain . withCleanup =<< goldenTests + +-- Cleanup the generated "images" directory after the test runs complete +withCleanup :: TestTree -> TestTree +withCleanup tt = Tasty.withResource (pure ()) (const cleanup) (const tt) + where + cleanup :: IO () + cleanup = removeDirectoryRecursive (_outDir defaultOpts) + +-- Extracted from the CLI parser +defaultOpts :: Opts +defaultOpts = Opts + { _outFormat = "html" + , _outDir = "images" + , _expression = "example" + , _absolutePath = False + , _backend = Cairo + } + +diagramsFilter :: Pandoc.Pandoc -> IO Pandoc.Pandoc +diagramsFilter = Pandoc.walkM (fmap concat . mapM (insertDiagrams defaultOpts)) + +-- We are renaming the image files so that the file names would be deterministic +-- across environments, GHC versions, etc. We are interested in the actual +-- generated image anyway. +renameImageHash :: Pandoc.Inline -> Pandoc.Inline +renameImageHash (Pandoc.Image attr alt (_, title)) = Pandoc.Image attr alt ("image.png", title) +renameImageHash x = x + +mdToHtml :: String -> IO Text +mdToHtml f = do + mdContents <- T.readFile f + Pandoc.runIOorExplode $ do + -- Pandoc extensions that are enabled by default in Pandoc CLI are also + -- enabled here, because the input files make use of some fancy syntax + -- (backtick_code_blocks, fenced_code_attributes, etc.) + ast <- Pandoc.readMarkdown (def { readerExtensions = pandocExtensions }) mdContents + filteredAst <- liftIO $ diagramsFilter ast + let renamedAst = Pandoc.walk renameImageHash filteredAst + Pandoc.writeHtml5String (def { writerExtensions = pandocExtensions }) renamedAst + +goldenTests :: IO TestTree +goldenTests = do + mdFiles <- Tasty.findByExtension [".md"] "test" + pure $ Tasty.testGroup "golden tests" + [ Tasty.goldenVsString + (takeBaseName mdFile) + htmlFile + (LBS.fromStrict . T.encodeUtf8 <$> mdToHtml mdFile) + | mdFile <- mdFiles + , let htmlFile = replaceExtension mdFile ".html" + ] diff --git a/test/alt-no-caption.html b/test/alt-no-caption.html new file mode 100644 --- /dev/null +++ b/test/alt-no-caption.html @@ -0,0 +1,2 @@ +

Here is a square:

+a square diff --git a/test/alt-no-caption.md b/test/alt-no-caption.md new file mode 100644 --- /dev/null +++ b/test/alt-no-caption.md @@ -0,0 +1,6 @@ +Here is a square: + +``` {.diagram alt="a square"} +example = square 1 +``` + diff --git a/test/alt-with-caption.html b/test/alt-with-caption.html new file mode 100644 --- /dev/null +++ b/test/alt-with-caption.html @@ -0,0 +1,6 @@ +

Here is a square:

+
+a square +

This is a square with area 12

+
diff --git a/test/alt-with-caption.md b/test/alt-with-caption.md new file mode 100644 --- /dev/null +++ b/test/alt-with-caption.md @@ -0,0 +1,6 @@ +Here is a square: + +``` {.diagram alt="a square" caption="This _is_ a square with area $1^2$"} +example = square 1 +``` + diff --git a/test/codeblock.html b/test/codeblock.html new file mode 100644 --- /dev/null +++ b/test/codeblock.html @@ -0,0 +1,4 @@ +

Here is a square:

+
example = square 1
+ diff --git a/test/codeblock.md b/test/codeblock.md new file mode 100644 --- /dev/null +++ b/test/codeblock.md @@ -0,0 +1,6 @@ +Here is a square: + +``` {.diagram-haskell echo=Above} +example = square 1 +``` + diff --git a/test/figure-md-caption.html b/test/figure-md-caption.html new file mode 100644 --- /dev/null +++ b/test/figure-md-caption.html @@ -0,0 +1,6 @@ +

Here is a square:

+
+This is a square with area 1^2 + +
diff --git a/test/figure-md-caption.md b/test/figure-md-caption.md new file mode 100644 --- /dev/null +++ b/test/figure-md-caption.md @@ -0,0 +1,6 @@ +Here is a square: + +``` {.diagram caption="This _is_ a square with area $1^2$"} +example = square 1 +``` + diff --git a/test/figure-simple.html b/test/figure-simple.html new file mode 100644 --- /dev/null +++ b/test/figure-simple.html @@ -0,0 +1,5 @@ +

Here is a square:

+
+This is a square + +
diff --git a/test/figure-simple.md b/test/figure-simple.md new file mode 100644 --- /dev/null +++ b/test/figure-simple.md @@ -0,0 +1,6 @@ +Here is a square: + +``` {.diagram caption="This is a square"} +example = square 1 +``` + diff --git a/test/simple.html b/test/simple.html new file mode 100644 --- /dev/null +++ b/test/simple.html @@ -0,0 +1,2 @@ +

Here is a square:

+ diff --git a/test/simple.md b/test/simple.md new file mode 100644 --- /dev/null +++ b/test/simple.md @@ -0,0 +1,6 @@ +Here is a square: + +``` {.diagram} +example = square 1 +``` + diff --git a/test/size.html b/test/size.html new file mode 100644 --- /dev/null +++ b/test/size.html @@ -0,0 +1,2 @@ +

Here is a square:

+ diff --git a/test/size.md b/test/size.md new file mode 100644 --- /dev/null +++ b/test/size.md @@ -0,0 +1,6 @@ +Here is a square: + +``` {.diagram width=100 height=100} +example = square 1 +``` +