Working math support

2 files changed, 80 insertions, 36 deletions

diff --git a/src/Math.hs b/src/Math.hs
index e927fdd..db01f75 100644
--- a/src/Math.hs
+++ b/src/Math.hs
@@ -2,40 +2,61 @@ module Math
        ( compileMath
        ) where
 
+import System.IO (stdout, stderr, hPutStrLn, writeFile, readFile)
 import System.IO.Temp (withSystemTempDirectory)
-import System.Process (callProcess)
+import System.Process (callProcess, readProcessWithExitCode)
 import System.Directory (copyFile, getCurrentDirectory, setCurrentDirectory)
 import System.FilePath (takeFileName, FilePath(..), (</>))
+import System.Exit (ExitCode(..))
 
-import Control.Monad
-import Control.Exception (bracket)
+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 (($!!))
 
-compileMath :: String -> IO String
+import Text.Regex.TDFA ((=~))
+
+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'
 
-compileMath' :: String -> FilePath -> IO String
+compileMath' :: String -> FilePath -> IO (String, String)
 compileMath' input tmpDir = do
   mapM_ (copyToTmp . ("tex" </>)) [ "preamble.tex"
                                   , "preview.dtx"
                                   , "preview.ins"
                                   ]
-  withCurrentDirectory tmpDir $ do
-    callProcess "latex" [ "-interaction=batchmode"
-                        , "preview.ins"
-                        ]
-    writeFile (tmpDir </> "image.tex") input
-    callProcess "latex" [ "-interaction=batchmode"
-                        , "image.tex"
-                        ]
-    callProcess "dvisvgm" [ "--exact"
-                          , "--no-fonts"
-                          , tmpDir </> "image.dvi"
-                          ]
-  (\x -> return $!! x) =<< (readFile $ tmpDir </> "image.svg")
+  (exitCode, out, err) <- withCurrentDirectory tmpDir $ execWriterT $ do
+    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
+    hPutStrLn stdout out
+    hPutStrLn stderr err
+    throwIO exitCode
+  (\x -> return $!! (x, extractAlignment err)) =<< (readFile $ tmpDir </> "image.svg")
   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
@@ -44,3 +65,9 @@ withCurrentDirectory dir action =
   bracket getCurrentDirectory setCurrentDirectory $ \ _ -> do
     setCurrentDirectory dir
     action
+
+extractAlignment :: String -> String
+extractAlignment = fromMaybe "0pt" . extract . (=~ "depth=([^\\s]+)")
+  where
+    extract :: (String, String, String, [String]) -> Maybe String
+    extract (_, _, _, xs) = listToMaybe xs
diff --git a/src/Site.hs b/src/Site.hs
index e821322..dcb9a7d 100644
--- a/src/Site.hs
+++ b/src/Site.hs
@@ -13,18 +13,19 @@ import Data.List (take, reverse, nub, groupBy, concatMap)
 import Data.Function (on)
 import Data.Default
 import Text.Pandoc
-import Text.Pandoc.Walk (query)
+import Text.Pandoc.Walk (query, walkM)
 import Text.Pandoc.Error
 import Control.Applicative (Alternative(..), Applicative(..))
 
+import System.FilePath (takeBaseName, (</>), (<.>))
+
 import qualified Crypto.Hash.SHA256 as SHA256 (hash)
 import qualified Data.ByteString.Char8 as CBS
-import Data.Hex
+import Data.Hex (hex)
 import Data.Char (toLower)
 
-import System.FilePath (takeBaseName, (</>), (<.>))
-
 import Math (compileMath)
+import Text.Printf (printf)
 
 main :: IO ()
 main = hakyllWith config $ do
@@ -34,24 +35,24 @@ main = hakyllWith config $ do
     route idRoute
     compile copyFileCompiler
 
+  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)
+        saveSnapshot "alignment" $ fmap snd item
+        return $ fmap fst item
+
   match "posts/*" $ do
     route $ setExtension ".html"
     compile $ do
       getResourceBody >>= saveSnapshot "content"
-      pandocCompiler
+      pandocCompilerWithTransformM defaultHakyllReaderOptions defaultHakyllWriterOptions mathTransform
         >>= loadAndApplyTemplate "templates/default.html" defaultContext
         >>= relativizeUrls
 
-  math <- getMath "posts/*" mathTranslation'
-  forM_ math $ \(deps, mathStr) ->
-    rulesExtraDependencies (map IdentifierDependency deps) $
-    create [mathTranslation' mathStr] $ do
-      route idRoute
-      compile $ do
-        makeItem mathStr
-          >>= loadAndApplyTemplate "templates/math.tex" defaultContext
-          >>= withItemBody (unsafeCompiler . compileMath)
-
   tags <- buildTags "posts/*" tagTranslation' >>= addTag "All Posts" "posts/*"
 
   tagsRules tags $ \tag pattern -> do
@@ -143,14 +144,14 @@ tagTranslation = mapMaybe charTrans
       | isAlphaNum c = Just $ toLower c
       | otherwise = Nothing
 
-mathTranslation' :: String -> Identifier
-mathTranslation' = fromCapture "math/*.svg" . map toLower . CBS.unpack . hex . SHA256.hash . CBS.pack
-
 addTag :: MonadMetadata m => String -> Pattern -> Tags -> m Tags
 addTag name pattern tags = do
   ids <- getMatches pattern
   return $ tags { tagsMap = tagsMap tags ++ [(name, ids)] }
 
+mathTranslation' :: String -> Identifier
+mathTranslation' = fromCapture "math/*.svg" . map toLower . CBS.unpack . hex . SHA256.hash . CBS.pack
+
 getMath :: Pattern -> (String -> Identifier) -> Rules [([Identifier], String)]
 getMath pattern makeId = do
   ids <- getMatches pattern
@@ -193,6 +194,22 @@ readPandoc' path = readFile path >>= either fail return . result'
 
     addExt ro e = ro {readerExtensions = Set.insert e $ readerExtensions ro}
 
+mathTransform :: Pandoc -> Compiler Pandoc
+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
+
 toFilePath' :: Identifier -> FilePath
 toFilePath' = (providerDirectory config </>) . toFilePath