Extended tex & math support

2 files changed, 50 insertions, 43 deletions

diff --git a/src/Site.hs b/src/Site.hs
index 5f5fbc0..d3ac76d 100644
--- a/src/Site.hs
+++ b/src/Site.hs
@@ -3,7 +3,7 @@
 import Hakyll
 
 import Data.Monoid (Monoid(..), mconcat, (<>))
-import Control.Monad (liftM, forM_)
+import Control.Monad (liftM, forM_, (<=<))
 import Data.Char (toLower, isSpace, isAlphaNum)
 import Data.Maybe (mapMaybe, fromMaybe)
 import Data.Map (Map)
@@ -27,7 +27,7 @@ import qualified Data.ByteString.Char8 as CBS
 import Data.Hex (hex)
 import Data.Char (toLower)
 
-import Math (compileMath)
+import Tex (compileTex)
 import Text.Printf (printf)
 
 main :: IO ()
@@ -38,13 +38,13 @@ main = hakyllWith config $ do
     route idRoute
     compile copyFileCompiler
 
-  math <- getMath "posts/**" mathTranslation'
-  forM_ math $ \(_, mathStr) -> create [mathTranslation' mathStr] $ do
+  tex <- getTex "posts/**" texTranslation'
+  forM_ tex $ \(_, texStr) -> create [texTranslation' texStr] $ do
       route idRoute
       compile $ do
-        item <- makeItem mathStr
-          >>= loadAndApplyTemplate "templates/math.tex" defaultContext
-          >>= withItemBody (unsafeCompiler . compileMath)
+        item <- makeItem texStr
+          >>= loadAndApplyTemplate "templates/preview.tex" defaultContext
+          >>= withItemBody (unsafeCompiler . compileTex)
         saveSnapshot "alignment" $ fmap snd item
         return $ fmap fst item
 
@@ -58,7 +58,7 @@ main = hakyllWith config $ do
                         , tagsFieldWith getTags (\tag _ -> Just . H.li $ H.a ! A.href (toValue . toUrl $ "tags" </> tagTranslation tag <.> "html") $ toHtml tag) (mconcat . intersperse "\n") "tagList" tags
                         ]
       getResourceBody >>= saveSnapshot "content"
-      pandocCompilerWithTransformM defaultHakyllReaderOptions defaultHakyllWriterOptions mathTransform
+      pandocCompilerWithTransformM defaultHakyllReaderOptions defaultHakyllWriterOptions texTransform
         >>= loadAndApplyTemplate "templates/default.html" ctx
         >>= relativizeUrls
 
@@ -158,20 +158,24 @@ 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
+texTranslation' :: String -> Identifier
+texTranslation' = fromCapture "tex/*.svg" . map toLower . CBS.unpack . hex . SHA256.hash . CBS.pack
 
-getMath :: Pattern -> (String -> Identifier) -> Rules [([Identifier], String)]
-getMath pattern makeId = do
+getTex :: Pattern -> (String -> Identifier) -> Rules [([Identifier], String)]
+getTex pattern makeId = do
   ids <- getMatches pattern
-  mathStrs <- concat `liftM` mapM (\id -> map ((,) [id]) `liftM` getMath' (toFilePath' id)) ids
-  return $ mergeGroups $ groupBy ((==) `on` snd) $ mathStrs
+  texStrs <- concat `liftM` mapM (\id -> map ((,) [id]) `liftM` getTex' (toFilePath' id)) ids
+  return $ mergeGroups $ groupBy ((==) `on` snd) $ texStrs
     where
-      getMath' :: FilePath -> Rules [String]
-      getMath' path = preprocess (query extractMath `liftM` readPandoc' path)
-      extractMath :: Inline -> [String]
-      extractMath (Math _ str) = [str]
-      extractMath _ = []
+      getTex' :: FilePath -> Rules [String]
+      getTex' path = preprocess . fmap concat $ (\x -> [query extractTex, query extractTex'] <*> pure x) `liftM` readPandoc' path
+      extractTex :: Inline -> [String]
+      extractTex (Math _ str) = ["\\(" ++ str ++ "\\)"]
+      extractTex (RawInline "latex" str) = [str]
+      extractTex _ = []
+      extractTex' :: Block -> [String]
+      extractTex' (RawBlock "latex" str) = [str]
+      extractTex' _ = []
       mergeGroups :: [[([Identifier], String)]] -> [([Identifier], String)]
       mergeGroups = map mergeGroups' . filter (not . null)
       mergeGroups' :: [([Identifier], String)] -> ([Identifier], String)
@@ -203,21 +207,25 @@ 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'
+texTransform :: Pandoc -> Compiler Pandoc
+texTransform = walkM texTransformInline <=< walkM texTransformBlock
   where
-    mathTransform' :: Inline -> Compiler Inline
-    mathTransform' (Math mathType tex) = do
-      alignment <- loadSnapshotBody texId "alignment"
+    texTransformInline :: Inline -> Compiler Inline
+    texTransformInline (Math mathType tex) = (\html -> Span ("", [classOf mathType], []) [RawInline "html" html]) <$> texTransform' ("\\(" ++ tex ++ "\\)")
+    texTransformInline (RawInline "latex" tex) = (\html -> Span ("", [], []) [RawInline "html" html]) <$> texTransform' tex
+    texTransformInline x = return x
+    texTransformBlock :: Block -> Compiler Block
+    texTransformBlock (RawBlock "latex" tex) = (\html -> Div ("", [], []) [RawBlock "html" html]) <$> texTransform' tex
+    texTransformBlock x = return x
+    texTransform' :: String -> Compiler String
+    texTransform' tex = do
       let
-        html = printf "<object data=\"/%s\" type=\"image/svg+xml\" style=\"vertical-align:-%s\">%s</object>"
+        texId = texTranslation' tex
+      alignment <- loadSnapshotBody texId "alignment"
+      return $ 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
+    classOf DisplayMath = "display-math"
+    classOf InlineMath  = "inline-math"
 
 toFilePath' :: Identifier -> FilePath
 toFilePath' = (providerDirectory config </>) . toFilePath
diff --git a/src/Math.hs b/src/Tex.hs
index db01f75..a247218 100644
--- a/src/Math.hs
+++ b/src/Tex.hs
@@ -1,5 +1,5 @@
-module Math
-       ( compileMath
+module Tex
+       ( compileTex
        ) where
 
 import System.IO (stdout, stderr, hPutStrLn, writeFile, readFile)
@@ -27,22 +27,21 @@ instance Monoid ExitCode where
   ExitSuccess `mappend` ExitSuccess = ExitSuccess
   
 
-compileMath :: String -> IO (String, String)
-compileMath = withSystemTempDirectory "math" . compileMath'
+compileTex :: String -> IO (String, String)
+compileTex = withSystemTempDirectory "tex" . compileTex'
 
-compileMath' :: String -> FilePath -> IO (String, String)
-compileMath' input tmpDir = do
-  mapM_ (copyToTmp . ("tex" </>)) [ "preamble.tex"
-                                  , "preview.dtx"
-                                  , "preview.ins"
-                                  ]
+compileTex' :: String -> FilePath -> IO (String, String)
+compileTex' input tmpDir = do
+  mapM_ (copyToTmp . ("provider/tex" </>)) [ "preview.dtx"
+                                           , "preview.ins"
+                                           ]
   (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 "latex" [ {- "-interaction=batchmode"
+                , -} "image.tex"
                 ] ""
     run "dvisvgm" [ "--exact"
                   , "--no-fonts"