From 6af9f6bb534f121d9acce6f49cf7acd18973ccde Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 2 Feb 2016 19:14:43 +0100 Subject: Extended tex & math support --- src/Math.hs | 73 ------------------------------------------------------------- src/Site.hs | 70 ++++++++++++++++++++++++++++++++-------------------------- src/Tex.hs | 72 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 111 insertions(+), 104 deletions(-) delete mode 100644 src/Math.hs create mode 100644 src/Tex.hs (limited to 'src') diff --git a/src/Math.hs b/src/Math.hs deleted file mode 100644 index db01f75..0000000 --- a/src/Math.hs +++ /dev/null @@ -1,73 +0,0 @@ -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 ((=~)) - -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, String) -compileMath' input tmpDir = do - mapM_ (copyToTmp . ("tex" )) [ "preamble.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 "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 - -> IO a -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 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 "%s" + texId = texTranslation' tex + alignment <- loadSnapshotBody texId "alignment" + return $ printf "%s" (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/Tex.hs b/src/Tex.hs new file mode 100644 index 0000000..a247218 --- /dev/null +++ b/src/Tex.hs @@ -0,0 +1,72 @@ +module Tex + ( compileTex + ) 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 ((=~)) + +instance Monoid ExitCode where + mempty = ExitSuccess + (ExitFailure a) `mappend` _ = ExitFailure a + ExitSuccess `mappend` x@(ExitFailure _) = x + ExitSuccess `mappend` ExitSuccess = ExitSuccess + + +compileTex :: String -> IO (String, String) +compileTex = withSystemTempDirectory "tex" . compileTex' + +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 "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 + -> IO a +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 -- cgit v1.2.3