Cursory Math-Support

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

…

dirty-haskell.org: Cursory Math-Support

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

Demonstration

Implementation

`Math.hs`

`Site.hs`