hakyll-diagrams (empty) → 0.1.0.0

raw patch · 9 files changed

+1176/−0 lines, 9 filesdep +HUnitdep +basedep +base16-bytestringsetup-changed

Dependencies added: HUnit, base, base16-bytestring, containers, cryptohash-sha1, data-default, diagrams, diagrams-core, diagrams-lib, diagrams-svg, hakyll, hakyll-diagrams, hint, hspec, pandoc-types, split, svg-builder, tagsoup, text

Files

• LICENSE +29/−0
• README.md +343/−0
• Setup.hs +2/−0
• docs-data/target.svg +3/−0
• hakyll-diagrams.cabal +102/−0
• src/Hakyll/Web/Pandoc/Diagrams.hs +352/−0
• test/HTMLSVGCompare.hs +92/−0
• test/Main.hs +137/−0
• test/Util.hs +116/−0

@@ -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.

@@ -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 `<img>` 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 {+        <options>+    }+<code>+```+````++Where `<options>` is a list of library and HTML tag attributes, fully described in the+[Options](#options) section, and `<code>` 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       := <any valid HTML attribute name>+value      := <any valid HTML attribute 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 `<svg>` tag will have the following attributes:++``` HTML+<svg width="50.0000" class="my_svg_class" ... >+```++Besides generating an external file, that input will be replaced in the resulting HTML+file by a code like:++``` HTML+<figure id="my_id" class="my_class_a my_class_b" data-myattr="foo">+  <img src="external_figure.svg" alt="a circle" width="10" />+  <figcaption>foo</figcaption>+</figure>+```++Regardless of any options, a `<svg>` 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 `<img>` 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 `<svg>` or `<img>` element will be+nested in a `<figure>` 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+`<img>` 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+`<figure>`, `<img>`, or `<svg>`.++### 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.\<something>`+[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

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,3 @@+<?xml version="1.0" encoding="UTF-8"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"+    "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd"><svg font-size="1" viewBox="0.0 0.0 300.0 300.0" stroke="rgb(0,0,0)" xmlns="http://www.w3.org/2000/svg" width="300.0000" stroke-opacity="1" height="300.0000" version="1.1" xmlns:xlink="http://www.w3.org/1999/xlink"><defs></defs><g stroke-linejoin="miter" fill-opacity="1.0" fill="rgb(128,128,128)" stroke="rgb(0,0,0)" stroke-linecap="butt" opacity="0.15" stroke-miterlimit="10.0" stroke-opacity="1.0" stroke-width="0.0"><path d="M 300.0000,295.7143 v -291.4286 c 0.0000,-2.3669 -1.9188,-4.2857 -4.2857 -4.2857h -291.4286 c -2.3669,-0.0000 -4.2857,1.9188 -4.2857 4.2857v 291.4286 c -0.0000,2.3669 1.9188,4.2857 4.2857 4.2857h 291.4286 c 2.3669,0.0000 4.2857,-1.9188 4.2857 -4.2857Z"/></g><g stroke-linejoin="miter" fill-opacity="1.0" fill="rgb(255,0,0)" stroke="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-opacity="1.0" stroke-width="0.0"><path d="M 278.5714,150.0000 c 0.0000,-71.0080 -57.5634,-128.5714 -128.5714 -128.5714c -71.0080,-0.0000 -128.5714,57.5634 -128.5714 128.5714c -0.0000,71.0080 57.5634,128.5714 128.5714 128.5714c 71.0080,0.0000 128.5714,-57.5634 128.5714 -128.5714Z"/></g><g stroke-linejoin="miter" fill-opacity="1.0" fill="rgb(255,255,255)" stroke="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-opacity="1.0" stroke-width="0.0"><path d="M 235.7143,150.0000 c 0.0000,-47.3387 -38.3756,-85.7143 -85.7143 -85.7143c -47.3387,-0.0000 -85.7143,38.3756 -85.7143 85.7143c -0.0000,47.3387 38.3756,85.7143 85.7143 85.7143c 47.3387,0.0000 85.7143,-38.3756 85.7143 -85.7143Z"/></g><g stroke-linejoin="miter" fill-opacity="1.0" fill="rgb(255,0,0)" stroke="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-opacity="1.0" stroke-width="0.0"><path d="M 192.8571,150.0000 c 0.0000,-23.6693 -19.1878,-42.8571 -42.8571 -42.8571c -23.6693,-0.0000 -42.8571,19.1878 -42.8571 42.8571c -0.0000,23.6693 19.1878,42.8571 42.8571 42.8571c 23.6693,0.0000 42.8571,-19.1878 42.8571 -42.8571Z"/></g></svg>

@@ -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 @\<img>@ 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:++  <<docs-data/target.svg>>++  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

@@ -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.\<something>@+[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)

@@ -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

@@ -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 "<img> 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 "<img> linking an external SVG file within a <figure>" $ 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 "<svg> 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 "<svg> code inline within a <figure>" $ 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

@@ -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