dirty-haskell.org: Cursory Math-Support

It's not crazy — it's having fun with types.

Demonstration

I added some cursory support for math as shown below:

Formulae are rendered with \text{\LaTeX} and included as SVG.

e^{ix} =\text{cos}(x) + i \text{sin} (x)

Inline formulae get correctly aligned to match the baseline of the surrounding text.

\text{tan}(\phi) = \frac{\text{sin}(\phi)}{\text{cos}(\phi)}

Implementation

Theorem environments are written using pandocs support for block environments:

<div class="theorem">

Formulae are rendered with $\text{\LaTeX}$ and included as [SVG](https://en.wikipedia.org/wiki/SVG).

<div class="proof">
$$e^{ix} =\text{cos}(x) + i \text{sin} (x)$$
</div>
<div class="lemma">

Inline formulae get correctly aligned to match the baseline of the surrounding text.

<div class="proof">
$\text{tan}(\phi) = \frac{\text{sin}(\phi)}{\text{cos}(\phi)}$
</div>
</div>
</div>

Combined with a smattering of CSS this works nicely. \text{\LaTeX} support is, however, lacking as I opted not to patch pandoc (math.kleen.org did).

Math.hs

The actual compilation happens in a new module I named Math.hs. We´ll start there. For your reading pleasure I added some comments to the reproduction below.

module Math
       ( compileMath
       ) where

import System.IO (stdout, stderr, hPutStrLn, writeFile, readFile)
import System.IO.Temp (withSystemTempDirectory)
import System.Process (callProcess, readProcessWithExitCode)
import System.Directory (copyFile, getCurrentDirectory, setCurrentDirectory)
import System.FilePath (takeFileName, FilePath(..), (</>))
import System.Exit (ExitCode(..))

import Control.Monad (when)
import Control.Exception (bracket, throwIO)
import Data.Maybe (fromMaybe, listToMaybe)

import Control.Monad.Writer.Strict (WriterT(..), execWriterT, tell)
import Control.Monad.Trans (liftIO)

import Control.DeepSeq (($!!))

import Text.Regex.TDFA ((=~))

-- We built a monoid instance for `ExitCode` so we can easily collect failure using a `MonadWriter`
instance Monoid ExitCode where
  mempty = ExitSuccess
  (ExitFailure a) `mappend` _ = ExitFailure a
  ExitSuccess `mappend` x@(ExitFailure _) = x
  ExitSuccess `mappend` ExitSuccess = ExitSuccess


compileMath :: String -> IO (String, String)
compileMath = withSystemTempDirectory "math" . compileMath' -- Create a temporary directory, run `compileMath'`, and make sure the directory get's deleted

compileMath' :: String -> FilePath -> IO (String, String)
compileMath' input tmpDir = do
  mapM_ (copyToTmp . ("tex" </>)) [ "preamble.tex"
                                  , "preview.dtx"
                                  , "preview.ins"
                                  ]
  (exitCode, out, err) <- withCurrentDirectory tmpDir $ execWriterT $ do -- Collect stdout, stderr, and exitCode of all subprocesses (stdout and stderr simply get appended to one another)
    run "latex" [ "-interaction=batchmode"
                , "preview.ins"
                ] ""
    liftIO $ writeFile (tmpDir </> "image.tex") input
    run "latex" [ "-interaction=batchmode"
                , "image.tex"
                ] ""
    run "dvisvgm" [ "--exact"
                  , "--no-fonts"
                  , tmpDir </> "image.dvi"
                  ] ""
  when (exitCode /= ExitSuccess) $ do -- Fail with maximum noise if any of the latex passes fail -- otherwise be silent
    hPutStrLn stdout out
    hPutStrLn stderr err
    throwIO exitCode
  (\x -> return $!! (x, extractAlignment err)) =<< (readFile $ tmpDir </> "image.svg") -- Note the call to `($!!)` -- since we'll be deleting `tmpDir` we need to make sure the entire generated output resides in memory before we leave this block
  where
    copyToTmp fp = copyFile fp (tmpDir </> takeFileName fp)
    run :: String -> [String] -> String -> WriterT (ExitCode, String, String) IO ()
    run bin args stdin = tell =<< liftIO (readProcessWithExitCode bin args stdin)

withCurrentDirectory :: FilePath  -- ^ Directory to execute in
                     -> IO a      -- ^ Action to be executed
                     -> IO a
-- ^ This is provided in newer versions of temporary
withCurrentDirectory dir action =
  bracket getCurrentDirectory setCurrentDirectory $ \ _ -> do
    setCurrentDirectory dir
    action

extractAlignment :: String -> String
extractAlignment = fromMaybe "0pt" . extract . (=~ "depth=([^\\s]+)") -- One of the few places where regular expressions really prove usefull
  where
    extract :: (String, String, String, [String]) -> Maybe String
    extract (_, _, _, xs) = listToMaybe xs

Site.hs

The more trick part proved to be integration into the framework as provided by Hakyll.

import qualified Crypto.Hash.SHA256 as SHA256 (hash)
import qualified Data.ByteString.Char8 as CBS
import Data.Hex (hex)
import Data.Char (toLower)

import Math (compileMath)
import Text.Printf (printf)

main :: IO ()
main = hakyllWith config $ do
  …

  math <- getMath "posts/*" mathTranslation'
  forM_ math $ \(_, mathStr) -> create [mathTranslation' mathStr] $ do
      route idRoute
      compile $ do
        item <- makeItem mathStr
          >>= loadAndApplyTemplate "templates/math.tex" defaultContext
          >>= withItemBody (unsafeCompiler . compileMath) -- unsafeCompiler :: IO a -> Compiler a
        saveSnapshot "alignment" $ fmap snd item
        return $ fmap fst item

  match "posts/*" $ do
    route $ setExtension ".html"
    compile $ do
      getResourceBody >>= saveSnapshot "content"
      pandocCompilerWithTransformM defaultHakyllReaderOptions defaultHakyllWriterOptions mathTransform -- pandocCompilerWithTransformM :: ReaderOptions -> WriterOptions -> (Pandoc -> Compiler Pandoc) -> Item String
        >>= loadAndApplyTemplate "templates/default.html" defaultContext
        >>= relativizeUrls
  …

…

mathTranslation' :: String -> Identifier
-- ^ This generates the filename for a svg file given the TeX-source
mathTranslation' = fromCapture "math/*.svg" . map toLower . CBS.unpack . hex . SHA256.hash . CBS.pack

getMath :: Pattern -> (String -> Identifier) -> Rules [([Identifier], String)]
-- ^ We scrape all posts for math, calls `readPandoc'`
getMath pattern makeId = do
  ids <- getMatches pattern
  mathStrs <- concat `liftM` mapM (\id -> map ((,) [id]) `liftM` getMath' (toFilePath' id)) ids
  return $ mergeGroups $ groupBy ((==) `on` snd) $ mathStrs
    where
      getMath' :: FilePath -> Rules [String]
      getMath' path = preprocess (query extractMath `liftM` readPandoc' path)
      extractMath :: Inline -> [String]
      extractMath (Math _ str) = [str]
      extractMath _ = []
      mergeGroups :: [[([Identifier], String)]] -> [([Identifier], String)]
      mergeGroups = map mergeGroups' . filter (not . null)
      mergeGroups' :: [([Identifier], String)] -> ([Identifier], String)
      mergeGroups' xs@((_, str):_) = (concatMap fst xs, str)

readPandoc' :: FilePath -> IO Pandoc
-- ^ This is copied, almost verbatim, from Hakyll source -- Does what it says on the tin
readPandoc' path = readFile path >>= either fail return . result'
  where
    result' str = case result str of
        Left (ParseFailure err)  -> Left $
            "parse failed: " ++ err
        Left (ParsecError _ err) -> Left $
            "parse failed: " ++ show err
        Right item'              -> Right item'
    result str = reader defaultHakyllReaderOptions (fileType path) str
    reader ro t = case t of
        DocBook            -> readDocBook ro
        Html               -> readHtml ro
        LaTeX              -> readLaTeX ro
        LiterateHaskell t' -> reader (addExt ro Ext_literate_haskell) t'
        Markdown           -> readMarkdown ro
        MediaWiki          -> readMediaWiki ro
        OrgMode            -> readOrg ro
        Rst                -> readRST ro
        Textile            -> readTextile ro
        _                  -> error $
            "I don't know how to read a file of " ++
            "the type " ++ show t ++ " for: " ++ path

    addExt ro e = ro {readerExtensions = Set.insert e $ readerExtensions ro}

mathTransform :: Pandoc -> Compiler Pandoc
-- ^ We replace math by raw html includes of the respective svg files here
mathTransform = walkM mathTransform'
  where
    mathTransform' :: Inline -> Compiler Inline
    mathTransform' (Math mathType tex) = do
      alignment <- loadSnapshotBody texId "alignment"
      let
        html = printf "<object data=\"/%s\" type=\"image/svg+xml\" style=\"vertical-align:-%s\">%s</object>"
               (toFilePath texId) (alignment :: String) tex
      return $ Span ("", [classOf mathType], []) [RawInline (Format "html") html]
      where
        texId = mathTranslation' tex
        classOf DisplayMath = "display-math"
        classOf InlineMath  = "inline-math"
    mathTransform' x = return x

…