diff --git a/examples/latex_color.hs b/examples/latex_color.hs index c4309ad..605ef8f 100755 --- a/examples/latex_color.hs +++ b/examples/latex_color.hs @@ -1,5 +1,6 @@ #!/usr/bin/env stack -- stack --resolver lts-11.22 runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} module Main (main) where import Control.Lens diff --git a/reanimate.cabal b/reanimate.cabal index 6ff586c..16dc069 100644 --- a/reanimate.cabal +++ b/reanimate.cabal @@ -13,6 +13,14 @@ build-type: Simple extra-source-files: ChangeLog.md cabal-version: >=1.10 +data-files: viewer/build/*.js + viewer/build/*.html + viewer/build/static/js/2.772a56e7.chunk.js + viewer/build/static/js/main.db22f45d.chunk.js + viewer/build/static/js/runtime~main.9eb600ee.js + viewer/build/static/css/main.6efe09fd.chunk.css + + library hs-source-dirs: src default-language: Haskell2010 @@ -28,12 +36,15 @@ library Reanimate.Driver Reanimate.Misc other-modules: Reanimate.Svg.NamedColors + Reanimate.Cache + Paths_reanimate build-depends: base >=4.10 && <4.13, time, text, unix, filepath, process, directory, containers, reanimate-svg >= 0.7.0.0, xml, bytestring, lens, linear, mtl, matrix, JuicyPixels, attoparsec, parallel, diagrams, diagrams-svg, diagrams-core, diagrams-lib, diagrams-contrib, - svg-builder, matrices, cubicbezier, palette, hinotify, websockets + svg-builder, matrices, cubicbezier, palette, hinotify, websockets, + hashable Flag gtk-viewer Description: Enable gtk-based viewer diff --git a/src/Reanimate/Cache.hs b/src/Reanimate/Cache.hs new file mode 100644 index 0000000..69f5c81 --- /dev/null +++ b/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)) diff --git a/src/Reanimate/Driver.hs b/src/Reanimate/Driver.hs index 7e29306..5a2464f 100644 --- a/src/Reanimate/Driver.hs +++ b/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] diff --git a/src/Reanimate/LaTeX.hs b/src/Reanimate/LaTeX.hs index aed8c6c..b6c8219 100644 --- a/src/Reanimate/LaTeX.hs +++ b/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) diff --git a/src/Reanimate/Monad.hs b/src/Reanimate/Monad.hs index cb4cbff..54b1c39 100644 --- a/src/Reanimate/Monad.hs +++ b/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) diff --git a/src/Reanimate/Render.hs b/src/Reanimate/Render.hs index 42de400..cd913f5 100644 --- a/src/Reanimate/Render.hs +++ b/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 diff --git a/stack.yaml b/stack.yaml index 746b31f..475f9c1 100644 --- a/stack.yaml +++ b/stack.yaml @@ -3,7 +3,7 @@ resolver: lts-11.22 allow-newer: false extra-deps: -- reanimate-svg-0.8.1.0 +- reanimate-svg-0.8.2.0 - diagrams-1.4@sha256:3e36369e84115b900fd9dcb570672a188339a470eb19ca62170775cd835cf8ca - diagrams-contrib-1.4.3@sha256:bcfa6c85f8c33b8c48c3a61b7216afdebd51cd793c50da3a2dd358827d25fc76 - diagrams-core-1.4.1.1@sha256:6ef6b17785d77997c481eb085570e21b6a00cc91d086fbf49490504130ebc7d1 diff --git a/viewer/.gitignore b/viewer/.gitignore new file mode 100755 index 0000000..58b21fe --- /dev/null +++ b/viewer/.gitignore @@ -0,0 +1,23 @@ +# See https://help.github.com/articles/ignoring-files/ for more about ignoring files. + +# dependencies +/node_modules +/.pnp +.pnp.js + +# testing +/coverage + +# production +# /build + +# misc +.DS_Store +.env.local +.env.development.local +.env.test.local +.env.production.local + +npm-debug.log* +yarn-debug.log* +yarn-error.log* diff --git a/viewer/build/asset-manifest.json b/viewer/build/asset-manifest.json new file mode 100644 index 0000000..720fb8b --- /dev/null +++ b/viewer/build/asset-manifest.json @@ -0,0 +1,13 @@ +{ + "main.css": "./static/css/main.6efe09fd.chunk.css", + "main.js": "./static/js/main.db22f45d.chunk.js", + "main.js.map": "./static/js/main.db22f45d.chunk.js.map", + "runtime~main.js": "./static/js/runtime~main.9eb600ee.js", + "runtime~main.js.map": "./static/js/runtime~main.9eb600ee.js.map", + "static/js/2.772a56e7.chunk.js": "./static/js/2.772a56e7.chunk.js", + "static/js/2.772a56e7.chunk.js.map": "./static/js/2.772a56e7.chunk.js.map", + "index.html": "./index.html", + "precache-manifest.15b8d497ab10704d87b84878b92d08cf.js": "./precache-manifest.15b8d497ab10704d87b84878b92d08cf.js", + "service-worker.js": "./service-worker.js", + "static/css/main.6efe09fd.chunk.css.map": "./static/css/main.6efe09fd.chunk.css.map" +} \ No newline at end of file diff --git a/viewer/build/favicon.ico b/viewer/build/favicon.ico new file mode 100755 index 0000000..a11777c Binary files /dev/null and b/viewer/build/favicon.ico differ diff --git a/viewer/build/index.html b/viewer/build/index.html new file mode 100644 index 0000000..602bc31 --- /dev/null +++ b/viewer/build/index.html @@ -0,0 +1 @@ +
component higher in the tree to provide a loading indicator or placeholder to display."+ut(s))}Ro=!0,f=lo(f,s),u=c;do{switch(u.tag){case 3:u.effectTag|=2048,u.expirationTime=a,Ji(u,a=wo(u,f,a));break e;case 1:if(p=f,m=u.type,s=u.stateNode,0===(64&u.effectTag)&&("function"===typeof m.getDerivedStateFromError||null!==s&&"function"===typeof s.componentDidCatch&&(null===Lo||!Lo.has(s)))){u.effectTag|=2048,u.expirationTime=a,Ji(u,a=xo(u,p,a));break e}}u=u.return}while(null!==u)}Po=$o(i);continue}l=!0,Ra(v)}}break}if(Co=!1,So.current=n,Fi=Di=Ui=null,Gl(),l)No=null,e.finishedWork=null;else if(null!==Po)e.finishedWork=null;else{if(null===(n=e.current.alternate)&&o("281"),No=null,Ro){if(l=e.latestPendingTime,i=e.latestSuspendedTime,a=e.latestPingedTime,0!==l&&l{message}\n