Better caching, bundle viewer.

src/Reanimate/Cache.hs

@@ -0,0 +1,81 @@
+module Reanimate.Cache
+  ( cacheMem
+  , cacheDisk
+  , cacheDiskSvg
+  , cacheDiskLines
+  ) where
+
+import           Control.Exception
+import           Data.Hashable
+import           Data.IORef
+import           Data.Map           (Map)
+import qualified Data.Map           as Map
+import           Data.Text          (Text)
+import qualified Data.Text          as T
+import qualified Data.Text.Encoding as T
+import qualified Data.Text.IO       as T
+import           Graphics.SvgTree   (Tree (..), parseSvgFile, unparse)
+import           Reanimate.Monad    (renderTree)
+import           Reanimate.Svg      (unbox)
+import Text.XML.Light ( Content(..), parseXML )
+import           System.Directory
+import           System.FilePath
+import           System.IO.Unsafe
+
+-- Memory cache and disk cache
+
+cacheDisk :: (T.Text -> Maybe a) -> (a -> T.Text) -> (Text -> IO a) -> (Text -> IO a)
+cacheDisk parse render gen key = do
+    root <- getXdgDirectory XdgCache "reanimate"
+    createDirectoryIfMissing True root
+    let path = root </> show (hash key)
+    hit <- doesFileExist path
+    if hit
+      then do
+        inp <- T.readFile path
+        case parse inp of
+          Nothing -> do
+            let tmp = path <.> "tmp"
+            new <- gen key
+            T.writeFile tmp (render new)
+            renameFile tmp path
+            return new
+          Just val -> pure val
+      else do
+        let tmp = path <.> "tmp"
+        new <- gen key
+        T.writeFile tmp (render new)
+        renameFile tmp path
+        return new
+
+cacheDiskSvg :: (Text -> IO Tree) -> (Text -> IO Tree)
+cacheDiskSvg = cacheDisk parse render
+  where
+    parse txt = case parseXML txt of
+      [Elem t] -> Just (unparse t)
+      _   -> Nothing
+    render = T.pack . renderTree
+
+cacheDiskLines :: (Text -> IO [Text]) -> (Text -> IO [Text])
+cacheDiskLines = cacheDisk parse render
+  where
+    parse = Just . T.lines
+    render = T.unlines
+
+
+{-# NOINLINE cache #-}
+cache :: IORef (Map Text Tree)
+cache = unsafePerformIO (newIORef Map.empty)
+
+cacheMem :: (Text -> IO Tree) -> (Text -> IO Tree)
+cacheMem gen key = do
+  store <- readIORef cache
+  case Map.lookup key store of
+    Just svg -> return svg
+    Nothing -> do
+      svg <- gen key
+      case svg of
+        -- None usually indicates that latex or another tool was misconfigured. In this case,
+        -- don't store the result.
+        None -> pure None
+        _ -> atomicModifyIORef cache (\store -> (Map.insert key svg store, svg))

src/Reanimate/Driver.hs

@@ -11,10 +11,12 @@ import           System.INotify     (EventVariety (..), addWatch, withINotify)
 import           System.IO          (BufferMode (..), hPutStrLn, hSetBuffering,
                                      stderr, stdin)
 
-import           Reanimate.Misc     (runCmdLazy, runCmd_, withTempFile)
+import           Reanimate.Misc     (runCmdLazy, runCmd, runCmd_, withTempDir, withTempFile)
 import           Reanimate.Monad    (Animation)
 import           Reanimate.Render   (renderSvgs)
 
+import Paths_reanimate
+
 opts = defaultConnectionOptions
   { connectionCompressionOptions = PermessageDeflateCompression defaultPermessageDeflate }
 
@@ -24,50 +26,55 @@ reanimate animation = do
   hSetBuffering stdin NoBuffering
   case args of
     ["once"] -> renderSvgs animation
-    _ -> runServerWith "127.0.0.1" 9161 opts $ \pending -> do
-      putStrLn "Server pending."
-      prog <- getProgName
-      lst <- listDirectory "."
-      mbSelf <- findFile ("." : lst) prog
-      blocker <- newEmptyMVar :: IO (MVar ())
-      case mbSelf of
-        Nothing -> do
-          hPutStrLn stderr "Failed to find own source code."
-        Just self -> withINotify $ \notify -> do
-          conn <- acceptRequest pending
-          slave <- newEmptyMVar
-          let handler = modifyMVar_ slave $ \tid -> do
-                sendTextData conn (T.pack "Compiling")
-                putStrLn "Kill and respawn."
-                killThread tid
-                tid <- forkIO $ withTempFile ".exe" $ \tmpExecutable -> do
-                  ret <- runCmd_ "stack" $ ["ghc", "--"] ++ ghcOptions ++ [self, "-o", tmpExecutable]
-                  case ret of
-                    Left err ->
-                      sendTextData conn $ T.pack $ "Error" ++ unlines (drop 3 (lines err))
-                    Right{} -> do
-                      getFrame <- runCmdLazy tmpExecutable ["once", "+RTS", "-N", "-M200M", "-RTS"]
-                      flip fix [] $ \loop acc -> do
-                        frame <- getFrame
-                        case frame of
-                          Left "" -> do
-                            sendTextData conn (T.pack "Done")
-                            -- insertCache msg (reverse acc)
-                          Left err -> do
-                            -- _ <- getChanContents queue
-                            sendTextData conn $ T.pack $ "Error" ++ err
-                          Right frame -> do
-                            sendTextData conn frame
-                            loop (frame : acc)
-                return tid
-          putStrLn "Found self. Listening."
-          addWatch notify [Modify] self (const handler)
-          putMVar slave =<< forkIO (return ())
-          let loop = do
-                fps <- receiveData conn :: IO T.Text
-                handler
-                loop
-          loop
+    _ -> withTempDir $ \tmpDir -> do
+      url <- getDataFileName "viewer/build/index.html"
+      runCmd "xdg-open" [url]
+      runServerWith "127.0.0.1" 9161 opts $ \pending -> do
+        putStrLn "Server pending."
+        prog <- getProgName
+        lst <- listDirectory "."
+        mbSelf <- findFile ("." : lst) prog
+        blocker <- newEmptyMVar :: IO (MVar ())
+        case mbSelf of
+          Nothing -> do
+            hPutStrLn stderr "Failed to find own source code."
+          Just self -> withINotify $ \notify -> do
+            conn <- acceptRequest pending
+            slave <- newEmptyMVar
+            let handler = modifyMVar_ slave $ \tid -> do
+                  sendTextData conn (T.pack "Compiling")
+                  putStrLn "Kill and respawn."
+                  killThread tid
+                  tid <- forkIO $ withTempFile ".exe" $ \tmpExecutable -> do
+                    ret <- runCmd_ "stack" $ ["ghc", "--"] ++ ghcOptions tmpDir ++ [self, "-o", tmpExecutable]
+                    case ret of
+                      Left err ->
+                        sendTextData conn $ T.pack $ "Error" ++ unlines (drop 3 (lines err))
+                      Right{} -> do
+                        getFrame <- runCmdLazy tmpExecutable ["once", "+RTS", "-N", "-M200M", "-RTS"]
+                        flip fix [] $ \loop acc -> do
+                          frame <- getFrame
+                          case frame of
+                            Left "" -> do
+                              sendTextData conn (T.pack "Done")
+                              -- insertCache msg (reverse acc)
+                            Left err -> do
+                              -- _ <- getChanContents queue
+                              sendTextData conn $ T.pack $ "Error" ++ err
+                            Right frame -> do
+                              sendTextData conn frame
+                              loop (frame : acc)
+                  return tid
+            putStrLn "Found self. Listening."
+            addWatch notify [Modify] self (const handler)
+            putMVar slave =<< forkIO (return ())
+            let loop = do
+                  fps <- receiveData conn :: IO T.Text
+                  handler
+                  loop
+            loop
 
-ghcOptions :: [String]
-ghcOptions = ["-rtsopts", "--make", "-threaded", "-O2"]
+ghcOptions :: FilePath -> [String]
+ghcOptions tmpDir =
+    ["-rtsopts", "--make", "-threaded", "-O2"] ++
+    ["-odir", tmpDir, "-hidir", tmpDir]

src/Reanimate/LaTeX.hs

@@ -7,74 +7,36 @@ import qualified Data.ByteString       as B
 import           Data.IORef
 import           Data.Map              (Map)
 import qualified Data.Map              as Map
+import Data.Monoid
+import           Reanimate.Cache
 import           Reanimate.Misc
 import           Reanimate.Svg
 import           System.FilePath       (replaceExtension, takeFileName, (</>))
 import           System.IO.Unsafe      (unsafePerformIO)
 
 import           Control.Lens          (over, set, (%~), (&), (.~), (^.))
+import           Data.Text             (Text)
+import qualified Data.Text             as T
+import qualified Data.Text.IO             as T
 import           Graphics.SvgTree      (Document (..), Tree (..), defaultSvg,
                                         elements, loadSvgFile, parseSvgFile,
                                         xmlOfDocument)
 import           Text.XML.Light        (elContent)
 import           Text.XML.Light.Output (ppcContent, ppcElement, prettyConfigPP)
 
--- instance ToHtml Document where
---   toHtml = toHtmlRaw
---   toHtmlRaw = toHtmlRaw . ppcElement prettyConfigPP . xmlOfDocument
+latex :: T.Text -> Tree
+latex tex = (unsafePerformIO . (cacheMem . cacheDiskSvg) latexToSVG)
+  ("% plain latex\n" <> tex)
 
--- instance ToHtml Document where
---   toHtml = toHtmlRaw
---   toHtmlRaw doc = toHtmlRaw $ unlines $ map (ppcContent prettyConfigPP) (elContent elt)
---     where
---       elt = xmlOfDocument doc
---
--- instance ToHtml Tree where
---   toHtml = toHtmlRaw
---   toHtmlRaw tree = toHtmlRaw doc
---     where
---       doc = Document
---         { _viewBox = Nothing
---         , _width = Nothing
---         , _height = Nothing
---         , _elements = [tree]
---         , _definitions = Map.empty
---         , _description = ""
---         , _styleRules = []
---         , _documentLocation = ""
---         }
+xelatex :: Text -> Tree
+xelatex tex = (unsafePerformIO . (cacheMem . cacheDiskSvg) latexToSVG)
+  ("% xelatex\n" <> tex)
 
-{-# NOINLINE cache #-}
-cache :: IORef (Map String Tree)
-cache = unsafePerformIO (newIORef Map.empty)
-
-latex :: String -> Tree
-latex tex = unsafePerformIO $ do
-  store <- readIORef cache
-  case Map.lookup tex store of
-    Just svg -> return svg
-    Nothing -> do
-      svg <- latexToSVG tex
-      case svg of
-        None -> pure None
-        _ -> atomicModifyIORef cache (\store -> (Map.insert tex svg store, svg))
-
-xelatex :: String -> Tree
-xelatex tex = unsafePerformIO $ do
-  store <- readIORef cache
-  case Map.lookup tex store of
-    Just svg -> return svg
-    Nothing -> do
-      svg <- xelatexToSVG tex
-      case svg of
-        None -> pure None
-        _ -> atomicModifyIORef cache (\store -> (Map.insert tex svg store, svg))
-
-latexAlign :: String -> Tree
-latexAlign tex = latex $ unlines ["\\begin{align*}", tex, "\\end{align*}"]
+latexAlign :: Text -> Tree
+latexAlign tex = latex $ T.unlines ["\\begin{align*}", tex, "\\end{align*}"]
 
 
-latexToSVG :: String -> IO Tree
+latexToSVG :: Text -> IO Tree
 latexToSVG tex = handle (\(e::SomeException) -> return (failedSvg tex)) $ do
   latex <- requireExecutable "latex"
   dvisvgm <- requireExecutable "dvisvgm"
@@ -82,7 +44,7 @@ latexToSVG tex = handle (\(e::SomeException) -> return (failedSvg tex)) $ do
     let dvi_file = tmp_dir </> replaceExtension (takeFileName tex_file) "dvi"
     writeFile tex_file tex_document
     appendFile tex_file tex_prologue
-    appendFile tex_file tex
+    T.appendFile tex_file tex
     appendFile tex_file tex_epilogue
     runCmd latex ["-interaction=batchmode", "-halt-on-error", "-output-directory="++tmp_dir, tex_file]
     runCmd dvisvgm [ dvi_file
@@ -95,7 +57,7 @@ latexToSVG tex = handle (\(e::SomeException) -> return (failedSvg tex)) $ do
       Nothing  -> error "Malformed svg"
       Just svg -> return $ unbox $ replaceUses svg
 
-xelatexToSVG :: String -> IO Tree
+xelatexToSVG :: Text -> IO Tree
 xelatexToSVG tex = handle (\(e::SomeException) -> return (failedSvg tex)) $ do
   latex <- requireExecutable "xelatex"
   dvisvgm <- requireExecutable "dvisvgm"
@@ -104,7 +66,7 @@ xelatexToSVG tex = handle (\(e::SomeException) -> return (failedSvg tex)) $ do
     writeFile tex_file tex_document
     appendFile tex_file tex_xelatex
     appendFile tex_file tex_prologue
-    appendFile tex_file tex
+    T.appendFile tex_file tex
     appendFile tex_file tex_epilogue
     runCmd latex ["-no-pdf", "-interaction=batchmode", "-halt-on-error", "-output-directory="++tmp_dir, tex_file]
     runCmd dvisvgm [ dvi_file
@@ -117,7 +79,7 @@ xelatexToSVG tex = handle (\(e::SomeException) -> return (failedSvg tex)) $ do
       Nothing  -> error "Malformed svg"
       Just svg -> return $ unbox $ replaceUses svg
 
-failedSvg :: String -> Tree
+failedSvg :: Text -> Tree
 failedSvg tex = defaultSvg
   -- text_ [ font_size_ "20"
   --       , fill_ "white"] (toHtml $ "bad latex: "++tex)

src/Reanimate/Monad.hs

@@ -10,8 +10,7 @@ import           Data.Monoid           ((<>))
 import           Data.Text             (Text, pack)
 import           Graphics.SvgTree      (Document (..), Number (..), Text (..),
                                         TextSpan (..), TextSpanContent (..),
-                                        Tree, Tree (..), xmlOfDocument)
-import           Reanimate.LaTeX
+                                        Tree, Tree (..), xmlOfDocument, xmlOfTree)
 import           Reanimate.Svg
 import           Text.XML.Light        (elContent)
 import           Text.XML.Light.Output
@@ -101,10 +100,10 @@ frameAt :: Double -> Animation -> Tree
 frameAt t (Animation d (Frame f)) = mkGroup $ execState (f d (min d t)) id []
 
 renderTree :: Tree -> String
-renderTree = renderSizedTree Nothing Nothing
+renderTree t = maybe "" ppElement $ xmlOfTree t
 
-renderSizedTree :: Maybe Number -> Maybe Number -> Tree -> String
-renderSizedTree w h t = ppElement $ xmlOfDocument doc
+renderSvg :: Maybe Number -> Maybe Number -> Tree -> String
+renderSvg w h t = ppElement $ xmlOfDocument doc
   where
     width = 320
     height = width / (16/9)

src/Reanimate/Render.hs

@@ -25,7 +25,7 @@ renderSvgs ani = do
   where
     frames = [0..frameCount-1]
     rate = 60
-    nthFrame nth = renderTree $ frameAt (recip (fromIntegral rate) * fromIntegral nth) ani
+    nthFrame nth = renderSvg Nothing Nothing $ frameAt (recip (fromIntegral rate) * fromIntegral nth) ani
     frameCount = round (duration ani * fromIntegral rate) :: Int
     nameTemplate :: String
     nameTemplate = "render-%05d.svg"
@@ -88,7 +88,7 @@ renderFormat format ani target = do
 -- XXX: Use threads
 generateFrames ani width_ rate action = withTempDir $ \tmp -> do
     let frameName nth = tmp </> printf nameTemplate nth
-        rendered = [ renderSizedTree width height $ nthFrame n | n <- frames]
+        rendered = [ renderSvg width height $ nthFrame n | n <- frames]
                     `using` parBuffer 16 rdeepseq
     forM_ (zip [0::Int ..] rendered) $ \(n, frame) -> do
       writeFile (frameName n) frame