diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2025, Renato Garcia + + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,343 @@ +# hakyll-diagrams + +**Contents** +* [Overview](#overview) +* [Usage](#usage) + * [Input format](#input-format) + * [Code](#code) + * [Options](#options) + * [Metadata options](#metadata-options) + * [Haskell API](#haskell-api) + * [Package databases](#package-databases) +* [Similar projects](#similar-projects) + + +## Overview + +Compiles any [diagrams](https://diagrams.github.io/) code found within markdown source files +and inserts the resulting figures into the generated HTML output. The figures can be embedded +as inline SVG code or referenced via external image files using `` tags. + +For example, when a block like this is found in a markdown file: + +```` Haskell +``` diagram { svg:width=300 } +let + target = mconcat + [ circle 1 # lw 0 # fc red + , circle 2 # lw 0 # fc white + , circle 3 # lw 0 # fc red + ] + + background = roundedRect 8 8 0.1 + # lw 0 + # fc (sRGB24read "#808080") + # opacity 0.15 + +in target <> background +``` +```` + +That code will be compiled, and replaced by the rendered SVG figure: + +![](./docs-data/target.svg) + +If we add a few attributes to the rendered SVG figure: + +```` Haskell +``` diagram { + figcaption="An interactive figure. It reacts to mouse hover and each part is a link." + svg:width=400 +} +let + hydrogen = + mconcat + [ proton + , electron # moveTo p0 + , orbit + ] + where + orbit = + circle 2 + # svgAttr "pointer-events" "stroke" + # href "https://en.wikipedia.org/wiki/Atomic_orbital" + # svgClass "svg_orbit" + electron = + circle 0.1 + # fc blue + # lw 0 + # href "https://en.wikipedia.org/wiki/Electron" + # svgClass "svg_electron" + proton = + circle 0.3 + # fc red + # lw 0 + # href "https://en.wikipedia.org/wiki/Proton" + # svgClass "svg_proton" + p0 = fromJust $ maxTraceP origin (angleV $ 3/8 @@ turn) orbit + + background = + roundedRect 5 5 0.1 + # lw 0 + # fc (sRGB24read "#808080") + # opacity 0.15 + +in hydrogen <> background +``` +```` + +We will generate this figure: + +![](./docs-data/hydrogen.svg) + +And with the help of some additional CSS or JavaScript code, we can make it an interactive +figure. That will not be possible to be shown here, because GitHub has restrictions on +adding inline SVG and JavaScript code to the Markdown files, however that same figure with +interactive features is available +[here](http://renatogarcia.blog.br/posts/hakyll-diagram-example.html). + +## Usage + +### Input format + +In a source file, any Haskell code within a *code block* having `diagram` as one of its +classes will be rendered to a diagram figure. In a markdown file, it means any code block +like this: + +````{.markdown} +``` diagram { + + } + +``` +```` + +Where `` is a list of library and HTML tag attributes, fully described in the +[Options](#options) section, and `` must consist of a single Haskell expression +whose resulting value has type [`Diagram SVG`](https://hackage.haskell.org/package/diagrams-core-1.5.1.1/docs/Diagrams-Core.html#t:Diagram). + +#### Code + +The code block must contain a single Haskell expression of type +[`Diagram SVG`](https://hackage.haskell.org/package/diagrams-core/docs/Diagrams-Core.html#t:Diagram). + +The interpreter environment is configurable via the [`Options`] record, which serves as an +argument to the [`drawDiagramsWith`] function. All exports from modules listed in +[`globalModules`] and [`localModules`] will be available in the context. + +#### Options + +The options configure what the diagram rendering will produce as results, and specify any +additional attributes for the resulting HTML and SVG elements. + +A valid options list must be in the format: + +``` +options := {option} +option := id | class | figcaption | attribute +id := "#" name +class := "." name +figcaption := "figcaption=" value +attritube := tag ":" name "=" value +tag := "figure" | "img" | "svg" +name := +value := +``` + +An input like this: + +```` Text +``` diagram { img:src="external_figure.svg" figcaption="foo" + .my_class_a .my_class_b #my_id + img:alt="a circle" figure:myattr=foo img:width=10 + svg:class="my_svg_class" svg:width=50 + } +circle 10 +``` +```` + +Will generate an external SVG file named *external_figure.svg*, written under the Hakyll's +configured +[`destinationDirectory`](https://hackage.haskell.org/package/hakyll/docs/Hakyll-Core-Configuration.html#v:destinationDirectory). +The `` tag will have the following attributes: + +``` HTML + +``` + +Besides generating an external file, that input will be replaced in the resulting HTML +file by a code like: + +``` HTML +
+
a circle +
foo
+ +``` + +Regardless of any options, a `` element will always be generated. If we have set an +`img:src="path"` attribute, the rendered SVG will be written to an external file at +*path*, and an `` element will link to it. If we don't have an `img:src="path"` +attribute, the rendered SVG will be inlined in the HTML code. + +If we have set a `figcaption="caption"` attribute, the `` or `` element will be +nested in a `
` element. Otherwise they will be inserted without a parent. + +The attributes must be in the format: `tag:name=value`, and *tag* must be one of: +`figure`, `img`, and `svg`. This means that the pair `name=value` will be assigned to the +*tag* element. If that element would not be generated, such as when we don't have an +`` tag because of an inlined SVG, or if the tag has any other value than those valid +three, it will be ignored without an error. + +The `#id` and `.class` values will be assigned to the outermost element, whether it is +`
`, ``, or ``. + +### Metadata options + +We can use the Hakyll's [metadata +block](https://jaspervdj.be/hakyll/tutorials/02-basics.html#pages-and-metadata) to create +an [`Options`] record to be used as argument to the [`drawDiagramsWith`] functions that +will render that page diagrams. + +This works starting from a base [`Options`] record, whose fields will be modified by the +values at the metadata block. Each one of the record fields can be assigned a value +through a metadata key named the same as that field prefixed with `dg.`. + +- Each field must be formatted as a list where each element is separated by a comma `,`. +- Any occurrence of an ellipsis `...` will be replaced by the current value of that field + as in the base [`Options`]. +- When setting either [`globalModules`] or [`localModules`], a value like `Utils` will + result in an unqualified import of *Utils* module. A value like `Commons as Cm` will + result in a qualified import of *Commons* module under *Cm* name. +- Any field not present will retain the same value as in the base [`Options`]. An empty + string `""` will set the field to an empty list. + +When starting with base: + +```Haskell +Options + { globalModules = + [ ("Prelude", Nothing) + , ("Diagrams.Prelude", Nothing) + , ("Diagrams.Backend.SVG", Nothing) + ] + , localModules = [] + , searchPaths = ["app", "posts"] + , languageExtensions = ["NoMonomorphismRestriction"] + } +``` + +the metadata block: + +```yaml +--- +dg.localModules: Utils, Commons as Cm +dg.searchPaths: lib, ..., foo +dg.languageExtensions: "" +--- +``` + +will result in: + +```Haskell +Options + { globalModules = + [ ("Prelude", Nothing) + , ("Diagrams.Prelude", Nothing) + , ("Diagrams.Backend.SVG", Nothing) + ] + , localModules = [("Utils", Nothing), ("Commons", Just "Cm")] + , searchPaths = ["lib", "app", "posts", "foo"] + , languageExtensions = [] + } +``` + +### Haskell API + +All the API documentation is available in the Haddock generated [project +page](http://renatogarcia.blog.br/hakyll-diagrams). + +The main functions are [`drawDiagrams`] and [`drawDiagramsWith`]. Both functions accept a +[Pandoc](https://hackage.haskell.org/package/pandoc-types/docs/Text-Pandoc-Definition.html#t:Pandoc) +data structure and transform it by replacing +[CodeBlock's](https://hackage.haskell.org/package/pandoc-types/docs/Text-Pandoc-Definition.html#v:CodeBlock) +having a `diagram` class with their rendered diagram figures, as explained in the [Input +format](#input-format) section. + +The simplest way to integrate these functions into a [Hakyll's +rule](https://jaspervdj.be/hakyll/tutorials/03-rules-routes-compilers.html#basic-rules) is +with code like this: + +``` Haskell +match "posts/*.md" $ do + route $ setExtension "html" + compile $ + pandocCompilerWithTransformM + defaultHakyllReaderOptions + defaultHakyllWriterOptions + drawDiagrams +``` + +We can use either [`readOptionsFromMetadata`] or [`readOptionsFromMetadataWith`] function +to control at the input source level what [`Options`] will be used to configure the +interpreter environment when rendering the diagrams on that page. The [Metadata +options](#metadata-options) section explains the metadata block syntax. + +One simple way to add this metadata reading functionality to the example code above is to +replace the `drawDiagrams` function by a `drawDiagrams'` defined as: + +``` Haskell +drawDiagrams' :: Pandoc -> Compiler Pandoc +drawDiagrams' pandoc = readOptionsFromMetadataWith opts >>= flip drawDiagramsWith pandoc + where + opts = defaultOptions { searchPaths = ["app", "posts"] } +``` + +### Package databases + +The [hint library](https://github.com/haskell-hint/hint?tab=readme-ov-file) is used to +interpret the Haskell code, and therefore all of its +[limitations](https://github.com/haskell-hint/hint?tab=readme-ov-file#limitations) will +apply here as well. In particular, if there isn't a `.ghc.environment.\` +[package environment +file](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/packages.html#package-environments) +(as generated by cabal +[`--write-ghc-environment-files=always`](https://cabal.readthedocs.io/en/3.4/cabal-project.html#cfg-field-write-ghc-environment-files) +option), setting either `HAKYLL_DIAGRAMS_PACKAGE_ENV` (a single path) or +`HAKYLL_DIAGRAMS_PACKAGE_DB` (N comma-separated paths) environment variables may be +required. If these environment variables are defined, their values will be used to set the +GHC +[`-package-env`](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/packages.html#ghc-flag-package-env-file-name) +and +[`-package-db`](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/packages.html#ghc-flag-package-db-file) +options respectively. + +## Similar projects + +There are two *diagrams* projects, +[diagrams-pandoc](https://github.com/diagrams/diagrams-pandoc) and +[diagrams-builder](https://github.com/diagrams/diagrams-builder), that implement +a portion of the functionality of this *hakyll-diagrams* library. They are not used +as dependencies because they would not allow some useful features. For example, with +*diagrams-builder* it is not possible to import a local module qualified, and it has +some [potential issues](https://hackage.haskell.org/package/diagrams-builder/docs/Diagrams-Builder-Modules.html#v:combineModules) +when combining them. With *diagrams-pandoc* we cannot add arbitrary attributes to a +specific HTML element, or generate an inlined SVG instead of an externally linked file. + +There is also a homonymous [hakyll-diagrams](https://github.com/cdupont/hakyll-diagrams) +library that integrates the two diagrams libraries with hakyll, running them inside +the +[`Compiler`](https://hackage.haskell.org/package/hakyll/docs/Hakyll-Core-Compiler.html#t:Compiler) +monad. Since it uses those two diagrams libraries, it has the same limitations +discussed above. Because of this, I have decided to create a new hakyll-diagrams library +with all the desired features. + + + +[`Options`]: http://renatogarcia.blog.br/hakyll-diagrams/Hakyll-Web-Pandoc-Diagrams.html#t:Options +[`drawDiagrams`]: http://renatogarcia.blog.br/hakyll-diagrams/Hakyll-Web-Pandoc-Diagrams.html#v:drawDiagrams +[`drawDiagramsWith`]: http://renatogarcia.blog.br/hakyll-diagrams/Hakyll-Web-Pandoc-Diagrams.html#v:drawDiagramsWith +[`globalModules`]: http://renatogarcia.blog.br/hakyll-diagrams/Hakyll-Web-Pandoc-Diagrams.html#v:globalModules +[`localModules`]: http://renatogarcia.blog.br/hakyll-diagrams/Hakyll-Web-Pandoc-Diagrams.html#v:localModules +[`readOptionsFromMetadata`]: http://renatogarcia.blog.br/hakyll-diagrams/Hakyll-Web-Pandoc-Diagrams.html#v:readOptionsFromMetadata +[`readOptionsFromMetadataWith`]: http://renatogarcia.blog.br/hakyll-diagrams/Hakyll-Web-Pandoc-Diagrams.html#v:readOptionsFromMetadataWith diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/docs-data/target.svg b/docs-data/target.svg new file mode 100644 --- /dev/null +++ b/docs-data/target.svg @@ -0,0 +1,3 @@ + + diff --git a/hakyll-diagrams.cabal b/hakyll-diagrams.cabal new file mode 100644 --- /dev/null +++ b/hakyll-diagrams.cabal @@ -0,0 +1,102 @@ +cabal-version: 3.0 +name: hakyll-diagrams +version: 0.1.0.0 + +synopsis: A Hakyll plugin for rendering diagrams figures from embedded Haskell code. + +description: Compiles any Haskell [diagrams](https://diagrams.github.io/) code embedded in + input source files (Markdown, reStructuredText, etc.), replacing them with the rendered + diagrams figures in the generated HTML output. The diagrams figures can be inlined as + SVG code or referenced as external @.svg@ image files using @\@ tags. + + For example, when processing a Markdown input source file, a code block like this: + + @ + ``` diagram { svg:width=300 } + let + target = mconcat + [ circle 1 # lw 0 # fc red + , circle 2 # lw 0 # fc white + , circle 3 # lw 0 # fc red + ] + + background = roundedRect 8 8 0.1 + # lw 0 + # fc (sRGB24read "#808080") + # opacity 0.15 + + in target <> background + ``` + @ + + will be replaced in the resulting HTML page by this figure: + + <> + + A thoughtful documentation with usage examples and results can be found at the [project + repository](https://github.com/renatoGarcia/hakyll-diagrams). + + +homepage: https://github.com/renatoGarcia/hakyll-diagrams + +license: BSD-3-Clause +license-file: LICENSE +author: Renato Garcia +maintainer: fgarcia.renato@gmail.com + +category: Web +build-type: Simple + +extra-doc-files: docs-data/target.svg +extra-source-files: README.md + +tested-with: GHC == { 9.4.8, 9.12.2 } + +source-repository head + type: git + location: https://github.com/renatoGarcia/hakyll-diagrams.git + +common warnings + ghc-options: -Wall + +common common-deps + build-depends: + base >=4.17.2 && <4.22, + hakyll ^>=4.16.2, + text >=2.0.2 && <2.2, + pandoc-types ^>=1.23 + +library + import: warnings, common-deps + exposed-modules: Hakyll.Web.Pandoc.Diagrams + build-depends: + base16-bytestring ^>=1.0.2, + cryptohash-sha1 ^>=0.11.101, + data-default >=0.7.1 && <0.9, + diagrams ^>=1.4.1, + diagrams-core ^>=1.5.1, + diagrams-lib >=1.4.6 && <1.6, + diagrams-svg >=1.4.3 && <1.6, + hint ^>=0.9.0, + split ^>=0.2.3, + svg-builder ^>=0.1.1 + + hs-source-dirs: src + default-language: Haskell2010 + + +test-suite hakyll-diagrams-test + import: warnings, common-deps + default-language: Haskell2010 + other-modules: + Util + , HTMLSVGCompare + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + hspec + , HUnit + , tagsoup + , containers + , hakyll-diagrams diff --git a/src/Hakyll/Web/Pandoc/Diagrams.hs b/src/Hakyll/Web/Pandoc/Diagrams.hs new file mode 100644 --- /dev/null +++ b/src/Hakyll/Web/Pandoc/Diagrams.hs @@ -0,0 +1,352 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +License : BSD-3-Clause +Maintainer : Renato Garcia +-} +module Hakyll.Web.Pandoc.Diagrams ( + drawDiagrams, + drawDiagramsWith, + Options (..), + defaultOptions, + readOptionsFromMetadata, + readOptionsFromMetadataWith, +) where + +import Control.Exception (throw) +import qualified Crypto.Hash.SHA1 as SHA1 +import qualified Data.ByteString.Base16 as B16 +import Data.Default (Default, def) +import Data.Functor ((<&>)) +import Data.List (intercalate) +import Data.List.Split (splitOn) +import Data.Maybe (fromMaybe, maybeToList) +import Data.Text (Text, unpack) +import qualified Data.Text as T (drop, isPrefixOf, length, null, pack, take, unpack, unwords) +import qualified Data.Text.Encoding as TE +import qualified Diagrams.Backend.SVG as SVG +import Diagrams.Core (renderDia) +import Diagrams.Prelude (Any, QDiagram, SizeSpec, V2, mkSizeSpec2D) +import Graphics.Svg.Core (makeAttribute) +import Hakyll (Compiler, destinationDirectory, makeDirectories, splitAll, trim) +import Hakyll.Core.Compiler (getUnderlying, unsafeCompiler) +import Hakyll.Core.Compiler.Internal (CompilerRead (..), compilerAsk) +import Hakyll.Core.Metadata (getMetadataField) +import Language.Haskell.Interpreter (OptionVal ((:=))) +import qualified Language.Haskell.Interpreter as Hint +import qualified Language.Haskell.Interpreter.Unsafe as Hint +import System.Environment (lookupEnv) +import Text.Pandoc.Definition (Block (..), Caption (Caption), Inline (..), Pandoc) +import Text.Pandoc.Walk (walkM) +import Text.Read (readMaybe) + + +-- | Configure the interpreter environment used when rendering the diagrams. +data Options = Options + { globalModules :: [(String, Maybe String)] + -- ^ Global modules to import ("module name", "namespace qualifier") + , localModules :: [(String, Maybe String)] + -- ^ Local modules to import ("module name", "namespace qualifier") + , searchPaths :: [FilePath] + -- ^ The paths where to search for local modules + , languageExtensions :: [String] + -- ^ Language extensions in use by the interpreter + } + deriving (Show, Eq) + + +instance Default Options where + def = defaultOptions + + +{- | The default value will import "Prelude", "Diagrams.Prelude", and +"Diagrams.Backend.SVG" global modules. All other fields will be emtpty. +-} +defaultOptions :: Options +defaultOptions = + Options + { globalModules = + [ ("Prelude", Nothing) + , ("Diagrams.Prelude", Nothing) + , ("Diagrams.Backend.SVG", Nothing) + ] + , localModules = [] + , searchPaths = [] + , languageExtensions = [] + } + + +splitAtComma :: String -> [String] +splitAtComma = fmap trim . splitAll "," + + +readModule :: String -> (String, Maybe String) +readModule x = + case (fmap trim . splitAll " as ") x of + [a] -> (a, Nothing) + [a, b] -> (a, Just b) + a -> throw $ userError ("Invalid syntax of module metadata: " ++ intercalate " as " a) + + +expandEllipsis + :: [a] + -- ^ The original value that will replace any ellipsis occurrence + -> (String -> a) + -- ^ The function that will read the element from a String + -> [String] + -- ^ The list of comma-separated elements from a metadata field + -> [a] + -- ^ The resulting element list with all ellipses replaced +expandEllipsis original transf val = val >>= \x -> if x == "..." then original else [transf x] + + +{- | Read the 'Options' values from +[metadata block](https://jaspervdj.be/hakyll/tutorials/02-basics.html#pages-and-metadata). + +@ +--- +dg.localModules: Utils, Commons as Cm +dg.searchPaths: lib, ..., posts +dg.languageExtensions: "" +--- +@ + +Each field must be prefixed with a @dg.@ string and must be formatted as a list where each +element is separated by a comma (@,@). + +Any occurrence of an ellipsis (@...@) will be replaced by the current value of that field +as in the 'Options' first argument. So to append one element at the end of a list, we can +do: "@..., element@". + +When setting either 'globalModules' or 'localModules', a value like "@Utils@" will +translate to @(\"Utils\", Nothing)@, an unqualified import. A value like "@Commons as Cm@" +will translate to @(\"Commons\", Just \"Cm\")@, a qualified import. + +Any field not present will retain the same value as in the base 'Options'. An empty string +@""@ will set the field to an empty list. +-} +readOptionsFromMetadataWith + :: Options + -- ^ The base 'Options' which will be modified by the metadata values + -> Compiler Options + -- ^ The resulting modified 'Options' +readOptionsFromMetadataWith opts = do + underlyingId <- getUnderlying + gm <- getMetadataField underlyingId "dg.globalModules" + lm <- getMetadataField underlyingId "dg.localModules" + sp <- getMetadataField underlyingId "dg.searchPaths" + le <- getMetadataField underlyingId "dg.languageExtensions" + pure $ + opts + { globalModules = maybe (globalModules opts) (expandEllipsis (globalModules opts) readModule <$> splitAtComma) gm + , localModules = maybe (localModules opts) (expandEllipsis (localModules opts) readModule <$> splitAtComma) lm + , searchPaths = maybe (searchPaths opts) (expandEllipsis (searchPaths opts) id <$> splitAtComma) sp + , languageExtensions = maybe (languageExtensions opts) (expandEllipsis (languageExtensions opts) id <$> splitAtComma) le + } + + +-- | Call 'readOptionsFromMetadataWith' with 'defaultOptions' as the argument +readOptionsFromMetadata :: Compiler Options +readOptionsFromMetadata = readOptionsFromMetadataWith defaultOptions + + +setUpInterpreter :: Options -> Text -> Hint.Interpreter (QDiagram SVG.SVG V2 Double Any) +setUpInterpreter opts code = do + Hint.set + [ Hint.searchPath := searchPaths opts + , Hint.languageExtensions := (parseExtension <$> languageExtensions opts) + ] + Hint.loadModules $ fst <$> localModules opts + Hint.setImportsQ $ globalModules opts ++ localModules opts + Hint.interpret (T.unpack code) (Hint.as :: QDiagram SVG.SVG V2 Double Any) + where + parseExtension :: String -> Hint.Extension + parseExtension t = + fromMaybe (throw $ userError ("Invalid language extension: " ++ t)) (readMaybe t) + + +{- | Parse the values of the HAKYLL_DIAGRAMS_PACKAGE_DB and HAKYLL_DIAGRAMS_PACKAGE_ENV +environment variables and build a list of interpreter arguments. +HAKYLL_DIAGRAMS_PACKAGE_DB can contain N comma-separated values +HAKYLL_DIAGRAMS_PACKAGE_ENV can contain a single value only +-} +getInterpreterArgs :: IO [String] +getInterpreterArgs = do + packageEnv <- lookupEnv "HAKYLL_DIAGRAMS_PACKAGE_ENV" <&> maybe [] (\x -> ["-package-env", x]) + packageDbs <- lookupEnv "HAKYLL_DIAGRAMS_PACKAGE_DB" <&> maybe [] (prependArgNames . splitOn ":") + pure $ packageEnv ++ packageDbs + where + prependArgNames :: [String] -> [String] + prependArgNames = concatMap (\x -> ["-package-db", x]) + + +runInterpreter + :: Hint.Interpreter (QDiagram SVG.SVG V2 Double Any) + -> IO (Either Hint.InterpreterError (QDiagram SVG.SVG V2 Double Any)) +runInterpreter i = do + mSandbox <- getInterpreterArgs + case mSandbox of + [] -> Hint.runInterpreter i + a -> Hint.unsafeRunInterpreterWithArgs a i + + +buildDiagram :: Options -> Text -> IO (QDiagram SVG.SVG V2 Double Any) +buildDiagram opts code = do + result <- runInterpreter $ setUpInterpreter opts code + case result of + Right diagram -> pure diagram + Left (Hint.WontCompile errs) -> + fail $ + foldl (\str err -> str ++ "\n" ++ Hint.errMsg err) "" errs + Left err -> fail $ show err + + +hashCodePrefix :: Text -> Text +hashCodePrefix code = + let hash = T.take 8 . TE.decodeUtf8 . B16.encode . SHA1.hash . TE.encodeUtf8 $ code + in "dia_" <> hash <> "_" + + +genInlineSvg :: Options -> Text -> SizeSpec V2 Double -> Text -> [Text] -> [(Text, Text)] -> IO Text +genInlineSvg opts code imageSize elementId classes attributes = + T.pack . show . renderDia SVG.SVG svgOptions <$> buildDiagram opts code + where + attrs = + attributes + ++ [("id", elementId) | not . T.null $ elementId] + ++ [("class", T.unwords classes) | not . null $ classes] + + svgOptions = + SVG.SVGOptions + imageSize + Nothing + (hashCodePrefix code) + [makeAttribute k v | (k, v) <- attrs] + False + + +genImageFile + :: Options + -- ^ Interpreter configuration + -> FilePath + -- ^ Destination directory + -> FilePath + -- ^ Output path relative to destination + -> Text + -- ^ Haskell code to interpret + -> SizeSpec V2 Double + -- ^ Output image size + -> [(Text, Text)] + -> IO () +genImageFile opts destDir relPath code imageSize attributes + | null relPath = fail "The `relPath` attribute of a diagram can not be an empty string." + | otherwise = do + makeDirectories imagePath + SVG.renderSVG' imagePath svgOptions =<< buildDiagram opts code + where + imagePath = destDir ++ "/" ++ relPath + svgOptions = + SVG.SVGOptions + imageSize + Nothing + (hashCodePrefix code) + [makeAttribute k v | (k, v) <- attributes] + True + + +imageBlock :: Text -> [Text] -> [(Text, Text)] -> [Inline] -> Text -> Text -> Inline +imageBlock elementId classes attributes alt path title = Image (elementId, classes, attributes) alt (path, title) + + +figureBlock :: Text -> [Text] -> [(Text, Text)] -> Text -> Block -> Block +figureBlock elementId classes attributes caption img = + -- ShortCaption is ignored by Pandoc when generating HTML + Figure (elementId, classes, attributes) (Caption Nothing [Plain [Str caption]]) [img] + + +-- | Compiles the Diagrams code and transforms a code block with a .diagram class in a figure block +transformBlock :: Options -> FilePath -> Block -> IO Block +transformBlock opts destDir (CodeBlock (elementId, classes, keyVals) code) + | Just relpath <- lookup "img:src" keyVals + , Just caption <- lookup "figcaption" keyVals = do + genImageFile opts destDir (unpack relpath) code (mkSizeSpec2D svgWidth svgHeight) (tagAttributes "svg") + pure $ + figureBlock elementId classes (tagAttributes "figure") caption $ + Plain [imageBlock "" [] (tagAttributes "img") altText relpath imgTitle] + | Just relpath <- lookup "img:src" keyVals = do + genImageFile opts destDir (unpack relpath) code (mkSizeSpec2D svgWidth svgHeight) (tagAttributes "svg") + pure $ Plain [imageBlock elementId classes (tagAttributes "img") altText relpath imgTitle] + | Just caption <- lookup "figcaption" keyVals = do + svgText <- genInlineSvg opts code (mkSizeSpec2D svgWidth svgHeight) "" [] (tagAttributes "svg") + pure $ figureBlock elementId classes (tagAttributes "figure") caption $ RawBlock "html" svgText + | otherwise = do + svgText <- genInlineSvg opts code (mkSizeSpec2D svgWidth svgHeight) elementId classes (tagAttributes "svg") + pure $ RawBlock "html" svgText + where + tagAttributes :: Text -> [(Text, Text)] + tagAttributes tag = + [ (T.drop (T.length prefix) k, v) + | (k, v) <- keyVals + , T.isPrefixOf prefix k + , k `notElem` specialAttributes + ] + where + prefix = tag <> ":" + specialAttributes = ["img:src", "img:alt", "img:title", "svg:width", "svg:height"] + + altText = maybeToList (Str <$> lookup "img:alt" keyVals) + + imgTitle = fromMaybe "" (lookup "img:title" keyVals) + + svgWidth = + fromMaybe (error "Failed to parse `svg:width` attribute value.") + . readMaybe + . unpack + <$> lookup "svg:width" keyVals + svgHeight = + fromMaybe (error "Failed to parse `svg:height` attribute value.") + . readMaybe + . unpack + <$> lookup "svg:height" keyVals +transformBlock _ _ block = pure block + + +{- | Render the code inside all 'Text.Pandoc.Definition.CodeBlock' with a @.diagram@ class +to either a 'Text.Pandoc.Definition.RawBlock' or an 'Text.Pandoc.Definition.Image' +(depending on if we have received an attribute with a path to an external file), where +these two can or cannot be within a parent 'Text.Pandoc.Definition.Figure' (depending on +if we have received an attribute with a figure caption). + +The [hint library](https://github.com/haskell-hint/hint?tab=readme-ov-file) is used to +interpret the Haskell code, and therefore all of its +[limitations](https://github.com/haskell-hint/hint?tab=readme-ov-file#limitations) will +apply here as well. In particular, if there isn't a @.ghc.environment.\@ +[package environment +file](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/packages.html#package-environments) +(as generated by cabal +[@--write-ghc-environment-files=always@](https://cabal.readthedocs.io/en/3.4/cabal-project.html#cfg-field-write-ghc-environment-files) +option), setting either @HAKYLL_DIAGRAMS_PACKAGE_ENV@ (a single path) or +@HAKYLL_DIAGRAMS_PACKAGE_DB@ (N comma-separated paths) environment variables may be +required. If these environment variables are defined, their values will be used to set the +GHC +[@-package-env@](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/packages.html#ghc-flag-package-env-file-name) +and +[@-package-db@](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/packages.html#ghc-flag-package-db-file) +options respectively. +-} +drawDiagramsWith :: Options -> Pandoc -> Compiler Pandoc +drawDiagramsWith opts = walkM visitor + where + visitor :: Block -> Compiler Block + visitor (CodeBlock (ident, classes, attrs) code) + | "diagram" `elem` classes = do + destDir <- destinationDirectory . compilerConfig <$> compilerAsk + unsafeCompiler $ + transformBlock opts destDir $ + CodeBlock (ident, filter (/= "diagram") classes, attrs) code + visitor b = pure b + + +-- | Call 'drawDiagramsWith' with the 'defaultOptions'. +drawDiagrams :: Pandoc -> Compiler Pandoc +drawDiagrams = drawDiagramsWith (def :: Options) diff --git a/test/HTMLSVGCompare.hs b/test/HTMLSVGCompare.hs new file mode 100644 --- /dev/null +++ b/test/HTMLSVGCompare.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HTMLSVGCompare ( + shouldBeSimilar, +) where + +import Data.List (sortOn) +import Data.Text (Text, strip) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Data.Text.Read as TR +import Test.Hspec +import Text.HTML.TagSoup +import Text.HTML.TagSoup.Tree + + +data Norm = Norm + { nName :: Text + , nAttrs :: [(Text, Text)] + , nChildren :: [Norm] + , nText :: Text + } + deriving (Eq, Show) + + +-- | Expect two HTML snippets to be "structurally equal" +shouldBeSimilar :: Text -> FilePath -> Expectation +shouldBeSimilar actual expectedPath = do + expected <- T.readFile expectedPath + let normA = normalizeTree <$> parseTree (strip actual) + normE = normalizeTree <$> parseTree (strip expected) + normA `shouldBe` normE + + +normalizeTree :: TagTree Text -> Norm +normalizeTree node = case node of + TagBranch name attrs children + | name == "svg" -> + Norm + { nName = name + , nAttrs = normalizeAttrs attrs + , -- We don't care about the actual drawing, that + -- is responsibility of the diagrams library + nChildren = [] + , nText = "" + } + | otherwise -> + Norm + { nName = name + , nAttrs = normalizeAttrs attrs + , nChildren = normalizeTree <$> children + , nText = "" + } + TagLeaf (TagText txt) -> + Norm + { nName = "text" + , nAttrs = [] + , nChildren = [] + , nText = normalizeText txt + } + TagLeaf (TagOpen name _) + | name `elem` ["?xml", "!DOCTYPE"] -> + Norm + { nName = name + , nAttrs = [] + , nChildren = [] + , nText = "" + } + other -> error $ "normalizeTree: expected element but got: " ++ show other + where + normalizeAttrs attrs = sortOn fst [(k, normalizeText v) | (k, v) <- attrs] + normalizeText t = T.unwords $ normalizeNumeric <$> T.words t + + +parseNumber :: T.Text -> Maybe Double +parseNumber t = + case TR.double t of + Right (n, rest) | T.null rest -> Just n + _ -> Nothing + + +epsilon :: Double +epsilon = 0.001 + + +normalizeNumeric :: T.Text -> T.Text +normalizeNumeric t = + case parseNumber t of + Just n -> + let bucket = (fromIntegral :: Int -> Double) (round (n / epsilon)) * epsilon + in T.pack (show bucket) + Nothing -> T.strip t diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import qualified Data.Text as T +import qualified Data.Text.IO as T +import HTMLSVGCompare +import Hakyll (Compiler, Identifier, defaultHakyllReaderOptions, defaultHakyllWriterOptions, itemBody, pandocCompilerWithTransformM) +import Hakyll.Web.Pandoc.Diagrams +import Test.Hspec +import Text.Pandoc.Definition (Pandoc) +import Util + + +main :: IO () +main = hspec $ after_ cleanTestEnv $ do + describe "The four output variations" $ do + describe " linking an external SVG file" $ do + it "evaluates code that has no attributes" $ do + html <- compileMarkdownWith drawDiagrams "data/external_bare.md" + svg <- T.readFile "_testsite/external_bare.svg" + html `shouldBeSimilar` "test/data/external_bare.html" + svg `shouldBeSimilar` "test/data/no_attributes.svg" + it "evaluates code with attributes" $ do + html <- compileMarkdownWith drawDiagrams "data/external.md" + svg <- T.readFile "_testsite/external.svg" + html `shouldBeSimilar` "test/data/external.html" + svg `shouldBeSimilar` "test/data/with_attributes.svg" + + describe " linking an external SVG file within a
" $ do + it "evaluates code that has no attributes" $ do + html <- compileMarkdownWith drawDiagrams "data/external_figure_bare.md" + svg <- T.readFile "_testsite/external_figure_bare.svg" + html `shouldBeSimilar` "test/data/external_figure_bare.html" + svg `shouldBeSimilar` "test/data/no_attributes.svg" + it "evaluates code with attributes" $ do + html <- compileMarkdownWith drawDiagrams "data/external_figure.md" + svg <- T.readFile "_testsite/external_figure.svg" + html `shouldBeSimilar` "test/data/external_figure.html" + svg `shouldBeSimilar` "test/data/with_attributes.svg" + + describe " code inline" $ do + it "evaluates code that has no attributes" $ do + html <- compileMarkdownWith drawDiagrams "data/inline_bare.md" + html `shouldBeSimilar` "test/data/inline_bare.html" + it "evaluates code with attributes" $ do + html <- compileMarkdownWith drawDiagrams "data/inline.md" + html `shouldBeSimilar` "test/data/inline.html" + + describe " code inline within a
" $ do + it "evaluates code that has no attributes" $ do + html <- compileMarkdownWith drawDiagrams "data/inline_figure_bare.md" + html `shouldBeSimilar` "test/data/inline_figure_bare.html" + it "evaluates code with attributes" $ do + html <- compileMarkdownWith drawDiagrams "data/inline_figure.md" + html `shouldBeSimilar` "test/data/inline_figure.html" + + describe "Changing the options" $ do + it "import Data.Maybe global Module to use fromJust" $ do + let opts = + defaultOptions + { globalModules = + [ ("Prelude", Nothing) + , ("Diagrams.Prelude", Nothing) + , ("Diagrams.Backend.SVG", Nothing) + , ("Data.Maybe", Nothing) + ] + } + html <- compileMarkdownWith (drawDiagramsWith opts) "data/global_import.md" + html `shouldBeSimilar` "test/data/global_import.html" + + it "import an invalid global Module" $ do + let opts = + defaultOptions + { globalModules = + [ ("Prelude", Nothing) + , ("Diagrams.Prelude", Nothing) + , ("Diagrams.Backend.SVG", Nothing) + , ("foo", Nothing) + ] + } + let html = compileMarkdownWith (drawDiagramsWith opts) "data/global_import.md" + html `shouldThrow` anyIOException + + it "set a language extension" $ do + let opts = + defaultOptions + { languageExtensions = ["NoMonomorphismRestriction"] + } + html <- compileMarkdownWith (drawDiagramsWith opts) "data/inline.md" + html `shouldBeSimilar` "test/data/inline.html" + + it "set an invalid language extension" $ do + let opts = + defaultOptions + { languageExtensions = ["foo"] + } + let html = compileMarkdownWith (drawDiagramsWith opts) "data/inline.md" + html `shouldThrow` anyIOException + + it "read options from metadata" $ do + opts <- compileReadOptions optDef "data/metadata.md" + opts `shouldBe` optRef + where + optDef = + defaultOptions + { searchPaths = ["app", "posts"] + , languageExtensions = ["NoMonomorphismRestriction"] + } + optRef = + Options + { globalModules = + [ ("Prelude", Nothing) + , ("Diagrams.Prelude", Nothing) + , ("Diagrams.Backend.SVG", Nothing) + ] + , localModules = [("Utils", Nothing), ("Commons", Just "Cm")] + , searchPaths = ["um", "app", "posts", "dois"] + , languageExtensions = [] + } + + +compileReadOptions :: Options -> Identifier -> IO Options +compileReadOptions opts path = do + store <- newTestStore + provider <- newTestProvider store + testCompilerDone store provider path (readOptionsFromMetadataWith opts) + + +compileMarkdownWith :: (Pandoc -> Compiler Pandoc) -> Identifier -> IO T.Text +compileMarkdownWith compiler path = do + store <- newTestStore + provider <- newTestProvider store + item <- testCompilerDone store provider path $ pandocCompWithTransform' compiler + pure . T.pack . itemBody $ item + where + pandocCompWithTransform' = pandocCompilerWithTransformM defaultHakyllReaderOptions defaultHakyllWriterOptions diff --git a/test/Util.hs b/test/Util.hs new file mode 100644 --- /dev/null +++ b/test/Util.hs @@ -0,0 +1,116 @@ +-- Adapted from https://github.com/jaspervdj/hakyll/blob/master/tests/TestSuite/Util.hs + +module Util ( + newTestStore, + newTestProvider, + testCompiler, + testCompilerDone, + testCompilerError, + testConfiguration, + cleanTestEnv, +) where + +-------------------------------------------------------------------------------- +import Data.List (intercalate, isInfixOf) +import qualified Data.Set as S +-- -------------------------------------------------------------------------------- +import Hakyll.Core.Compiler.Internal +import Hakyll.Core.Configuration +import Hakyll.Core.Identifier +import qualified Hakyll.Core.Logger as Logger +import Hakyll.Core.Provider +import Hakyll.Core.Store (Store) +import qualified Hakyll.Core.Store as Store +import Hakyll.Core.Util.File +import Test.HUnit + + +-------------------------------------------------------------------------------- +newTestStore :: IO Store +newTestStore = Store.new True $ storeDirectory testConfiguration + + +-------------------------------------------------------------------------------- +newTestProvider :: Store -> IO Provider +newTestProvider store = + newProvider store (const $ return False) $ + providerDirectory testConfiguration + + +-------------------------------------------------------------------------------- +testCompiler :: + Store -> + Provider -> + Identifier -> + Compiler a -> + IO (CompilerResult a) +testCompiler store provider underlying compiler = do + logger <- Logger.new Logger.Error + let read' = + CompilerRead + { compilerConfig = testConfiguration + , compilerUnderlying = underlying + , compilerProvider = provider + , compilerUniverse = S.empty + , compilerRoutes = mempty + , compilerStore = store + , compilerLogger = logger + } + + result <- runCompiler compiler read' + Logger.flush logger + return result + + +-- -------------------------------------------------------------------------------- +testCompilerDone :: Store -> Provider -> Identifier -> Compiler a -> IO a +testCompilerDone store provider underlying compiler = do + result <- testCompiler store provider underlying compiler + case result of + CompilerDone x _ -> return x + CompilerError e -> + fail $ + "TestSuite.Util.testCompilerDone: compiler " + ++ show underlying + ++ " threw: " + ++ intercalate "; " (compilerErrorMessages e) + CompilerRequire i _ -> + fail $ + "TestSuite.Util.testCompilerDone: compiler " + ++ show underlying + ++ " requires: " + ++ show i + CompilerSnapshot _ _ -> + fail + "TestSuite.Util.testCompilerDone: unexpected CompilerSnapshot" + + +testCompilerError :: Store -> Provider -> Identifier -> Compiler a -> String -> IO () +testCompilerError store provider underlying compiler expectedMessage = do + result <- testCompiler store provider underlying compiler + case result of + CompilerError e -> + any (expectedMessage `isInfixOf`) (compilerErrorMessages e) + @? "Expecting '" + ++ expectedMessage + ++ "' error" + _ -> assertFailure "Expecting CompilerError" + + +-------------------------------------------------------------------------------- +testConfiguration :: Configuration +testConfiguration = + defaultConfiguration + { destinationDirectory = "_testsite" + , storeDirectory = "_teststore" + , tmpDirectory = "_testtmp" + , providerDirectory = "test" + } + + +-------------------------------------------------------------------------------- +cleanTestEnv :: IO () +cleanTestEnv = do + removeDirectory $ destinationDirectory testConfiguration + removeDirectory $ storeDirectory testConfiguration + removeDirectory $ tmpDirectory testConfiguration