Working math support

1 files changed, 232 insertions, 3 deletions

diff --git a/provider/posts/tex-support.md b/provider/posts/tex-support.md
index 16468ca..0beade1 100644
--- a/provider/posts/tex-support.md
+++ b/provider/posts/tex-support.md
@@ -1,14 +1,243 @@
 ---
-title: Cursory LaTeX-Support
+title: Cursory Math-Support
 published: 2015-11-05
 tags: Blog Software
 ---
 
-I added some cursory support for LaTeX as shown below:
+## Demonstration
+
+I added some cursory support for math as shown below:
 
 <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>
+
+## Implementation
+
+Theorem environments are written using [pandoc](http://pandoc.org)s support for block environments:
+
+~~~ {.markdown .numberLines}
 <div class="theorem">
-$$\text{tan}(\phi) = \frac{\text{sin}(\phi)}{\text{cos}(\phi)}$$
+
+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](https://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.
+
+~~~ {.haskell .numberLines}
+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](http://jaspervdj.be/hakyll/).
+
+~~~ {.haskell .numberLines}
+…
+
+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
+
+…
+~~~