From bb296bb319a1d9a0050577dfed96e30298390db7 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 7 Nov 2015 19:24:34 +0000 Subject: Working math support --- src/Math.hs | 63 +++++++++++++++++++++++++++++++++++++++++++------------------ src/Site.hs | 53 +++++++++++++++++++++++++++++++++------------------ 2 files changed, 80 insertions(+), 36 deletions(-) (limited to 'src') 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 "%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 + toFilePath' :: Identifier -> FilePath toFilePath' = (providerDirectory config ) . toFilePath -- cgit v1.2.3