mirror of
https://github.com/reanimate/reanimate.git
synced 2026-09-14 09:32:22 +00:00
134 lines
12 KiB
HTML
134 lines
12 KiB
HTML
<html>
|
|
<head>
|
|
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
|
|
<style type="text/css">
|
|
span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }
|
|
span.nottickedoff { background: yellow}
|
|
span.istickedoff { background: white }
|
|
span.tickonlyfalse { margin: -1px; border: 1px solid #f20913; background: #f20913 }
|
|
span.tickonlytrue { margin: -1px; border: 1px solid #60de51; background: #60de51 }
|
|
span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }
|
|
span.decl { font-weight: bold }
|
|
span.spaces { background: white }
|
|
</style>
|
|
</head>
|
|
<body>
|
|
<pre>
|
|
<span class="decl"><span class="nottickedoff">never executed</span> <span class="tickonlytrue">always true</span> <span class="tickonlyfalse">always false</span></span>
|
|
</pre>
|
|
<pre>
|
|
<span class="lineno"> 1 </span>module Reanimate.Cache
|
|
<span class="lineno"> 2 </span> ( cacheFile -- :: FilePath -> (FilePath -> IO ()) -> IO FilePath
|
|
<span class="lineno"> 3 </span> , cacheMem
|
|
<span class="lineno"> 4 </span> , cacheDisk
|
|
<span class="lineno"> 5 </span> , cacheDiskSvg
|
|
<span class="lineno"> 6 </span> , cacheDiskKey
|
|
<span class="lineno"> 7 </span> , cacheDiskLines
|
|
<span class="lineno"> 8 </span> , encodeInt
|
|
<span class="lineno"> 9 </span> ) where
|
|
<span class="lineno"> 10 </span>
|
|
<span class="lineno"> 11 </span>import Control.Exception
|
|
<span class="lineno"> 12 </span>import Control.Monad (unless)
|
|
<span class="lineno"> 13 </span>import Data.Bits
|
|
<span class="lineno"> 14 </span>import Data.Hashable
|
|
<span class="lineno"> 15 </span>import Data.IORef
|
|
<span class="lineno"> 16 </span>import Data.Map (Map)
|
|
<span class="lineno"> 17 </span>import qualified Data.Map as Map
|
|
<span class="lineno"> 18 </span>import Data.Text (Text)
|
|
<span class="lineno"> 19 </span>import qualified Data.Text as T
|
|
<span class="lineno"> 20 </span>import qualified Data.Text.IO as T
|
|
<span class="lineno"> 21 </span>import Graphics.SvgTree (Tree, unparse, pattern None)
|
|
<span class="lineno"> 22 </span>import Reanimate.Animation (renderTree)
|
|
<span class="lineno"> 23 </span>import Reanimate.Misc (renameOrCopyFile)
|
|
<span class="lineno"> 24 </span>import System.Directory
|
|
<span class="lineno"> 25 </span>import System.FilePath
|
|
<span class="lineno"> 26 </span>import System.IO
|
|
<span class="lineno"> 27 </span>import System.IO.Temp
|
|
<span class="lineno"> 28 </span>import System.IO.Unsafe
|
|
<span class="lineno"> 29 </span>import Text.XML.Light (Content (..), parseXML)
|
|
<span class="lineno"> 30 </span>
|
|
<span class="lineno"> 31 </span>-- Memory cache and disk cache
|
|
<span class="lineno"> 32 </span>
|
|
<span class="lineno"> 33 </span>cacheFile :: FilePath -> (FilePath -> IO ()) -> IO FilePath
|
|
<span class="lineno"> 34 </span><span class="decl"><span class="nottickedoff">cacheFile template gen = do</span>
|
|
<span class="lineno"> 35 </span><span class="spaces"> </span><span class="nottickedoff">root <- getXdgDirectory XdgCache "reanimate"</span>
|
|
<span class="lineno"> 36 </span><span class="spaces"> </span><span class="nottickedoff">createDirectoryIfMissing True root</span>
|
|
<span class="lineno"> 37 </span><span class="spaces"> </span><span class="nottickedoff">let path = root </> template</span>
|
|
<span class="lineno"> 38 </span><span class="spaces"> </span><span class="nottickedoff">hit <- doesFileExist path</span>
|
|
<span class="lineno"> 39 </span><span class="spaces"> </span><span class="nottickedoff">unless hit $ withSystemTempFile template $ \tmp h -> do</span>
|
|
<span class="lineno"> 40 </span><span class="spaces"> </span><span class="nottickedoff">hClose h</span>
|
|
<span class="lineno"> 41 </span><span class="spaces"> </span><span class="nottickedoff">gen tmp</span>
|
|
<span class="lineno"> 42 </span><span class="spaces"> </span><span class="nottickedoff">renameOrCopyFile tmp path</span>
|
|
<span class="lineno"> 43 </span><span class="spaces"> </span><span class="nottickedoff">evaluate path</span></span>
|
|
<span class="lineno"> 44 </span>
|
|
<span class="lineno"> 45 </span>cacheDisk :: String -> (T.Text -> Maybe a) -> (a -> T.Text) -> (Text -> IO a) -> (Text -> IO a)
|
|
<span class="lineno"> 46 </span><span class="decl"><span class="nottickedoff">cacheDisk cacheType parse render gen key = do</span>
|
|
<span class="lineno"> 47 </span><span class="spaces"> </span><span class="nottickedoff">root <- getXdgDirectory XdgCache "reanimate"</span>
|
|
<span class="lineno"> 48 </span><span class="spaces"> </span><span class="nottickedoff">createDirectoryIfMissing True root</span>
|
|
<span class="lineno"> 49 </span><span class="spaces"> </span><span class="nottickedoff">let path = root </> encodeInt (hash key) <.> cacheType</span>
|
|
<span class="lineno"> 50 </span><span class="spaces"> </span><span class="nottickedoff">hit <- doesFileExist path</span>
|
|
<span class="lineno"> 51 </span><span class="spaces"> </span><span class="nottickedoff">if hit</span>
|
|
<span class="lineno"> 52 </span><span class="spaces"> </span><span class="nottickedoff">then do</span>
|
|
<span class="lineno"> 53 </span><span class="spaces"> </span><span class="nottickedoff">inp <- T.readFile path</span>
|
|
<span class="lineno"> 54 </span><span class="spaces"> </span><span class="nottickedoff">case parse inp of</span>
|
|
<span class="lineno"> 55 </span><span class="spaces"> </span><span class="nottickedoff">Nothing -> genCache root path</span>
|
|
<span class="lineno"> 56 </span><span class="spaces"> </span><span class="nottickedoff">Just val -> pure val</span>
|
|
<span class="lineno"> 57 </span><span class="spaces"> </span><span class="nottickedoff">else genCache root path</span>
|
|
<span class="lineno"> 58 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
|
<span class="lineno"> 59 </span><span class="spaces"> </span><span class="nottickedoff">genCache root path = do</span>
|
|
<span class="lineno"> 60 </span><span class="spaces"> </span><span class="nottickedoff">(tmpPath, tmpHandle) <- openTempFile root (encodeInt (hash key))</span>
|
|
<span class="lineno"> 61 </span><span class="spaces"> </span><span class="nottickedoff">new <- gen key</span>
|
|
<span class="lineno"> 62 </span><span class="spaces"> </span><span class="nottickedoff">T.hPutStr tmpHandle (render new)</span>
|
|
<span class="lineno"> 63 </span><span class="spaces"> </span><span class="nottickedoff">hClose tmpHandle</span>
|
|
<span class="lineno"> 64 </span><span class="spaces"> </span><span class="nottickedoff">renameOrCopyFile tmpPath path</span>
|
|
<span class="lineno"> 65 </span><span class="spaces"> </span><span class="nottickedoff">return new</span></span>
|
|
<span class="lineno"> 66 </span>
|
|
<span class="lineno"> 67 </span>cacheDiskKey :: Text -> IO Tree -> IO Tree
|
|
<span class="lineno"> 68 </span><span class="decl"><span class="nottickedoff">cacheDiskKey key gen = cacheDiskSvg (const gen) key</span></span>
|
|
<span class="lineno"> 69 </span>
|
|
<span class="lineno"> 70 </span>cacheDiskSvg :: (Text -> IO Tree) -> (Text -> IO Tree)
|
|
<span class="lineno"> 71 </span><span class="decl"><span class="nottickedoff">cacheDiskSvg = cacheDisk "svg" parse render</span>
|
|
<span class="lineno"> 72 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
|
<span class="lineno"> 73 </span><span class="spaces"> </span><span class="nottickedoff">parse txt = case parseXML txt of</span>
|
|
<span class="lineno"> 74 </span><span class="spaces"> </span><span class="nottickedoff">[Elem t] -> Just (unparse t)</span>
|
|
<span class="lineno"> 75 </span><span class="spaces"> </span><span class="nottickedoff">_ -> Nothing</span>
|
|
<span class="lineno"> 76 </span><span class="spaces"> </span><span class="nottickedoff">render = T.pack . renderTree</span></span>
|
|
<span class="lineno"> 77 </span>
|
|
<span class="lineno"> 78 </span>cacheDiskLines :: (Text -> IO [Text]) -> (Text -> IO [Text])
|
|
<span class="lineno"> 79 </span><span class="decl"><span class="nottickedoff">cacheDiskLines = cacheDisk "txt" parse render</span>
|
|
<span class="lineno"> 80 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
|
<span class="lineno"> 81 </span><span class="spaces"> </span><span class="nottickedoff">parse = Just . T.lines</span>
|
|
<span class="lineno"> 82 </span><span class="spaces"> </span><span class="nottickedoff">render = T.unlines</span></span>
|
|
<span class="lineno"> 83 </span>
|
|
<span class="lineno"> 84 </span>
|
|
<span class="lineno"> 85 </span>{-# NOINLINE cache #-}
|
|
<span class="lineno"> 86 </span>cache :: IORef (Map Text Tree)
|
|
<span class="lineno"> 87 </span><span class="decl"><span class="nottickedoff">cache = unsafePerformIO (newIORef Map.empty)</span></span>
|
|
<span class="lineno"> 88 </span>
|
|
<span class="lineno"> 89 </span>cacheMem :: (Text -> IO Tree) -> (Text -> IO Tree)
|
|
<span class="lineno"> 90 </span><span class="decl"><span class="nottickedoff">cacheMem gen key = do</span>
|
|
<span class="lineno"> 91 </span><span class="spaces"> </span><span class="nottickedoff">store <- readIORef cache</span>
|
|
<span class="lineno"> 92 </span><span class="spaces"> </span><span class="nottickedoff">case Map.lookup key store of</span>
|
|
<span class="lineno"> 93 </span><span class="spaces"> </span><span class="nottickedoff">Just svg -> return svg</span>
|
|
<span class="lineno"> 94 </span><span class="spaces"> </span><span class="nottickedoff">Nothing -> do</span>
|
|
<span class="lineno"> 95 </span><span class="spaces"> </span><span class="nottickedoff">svg <- gen key</span>
|
|
<span class="lineno"> 96 </span><span class="spaces"> </span><span class="nottickedoff">case svg of</span>
|
|
<span class="lineno"> 97 </span><span class="spaces"> </span><span class="nottickedoff">-- None usually indicates that latex or another tool was misconfigured. In this case,</span>
|
|
<span class="lineno"> 98 </span><span class="spaces"> </span><span class="nottickedoff">-- don't store the result.</span>
|
|
<span class="lineno"> 99 </span><span class="spaces"> </span><span class="nottickedoff">None -> pure svg</span>
|
|
<span class="lineno"> 100 </span><span class="spaces"> </span><span class="nottickedoff">_ -> atomicModifyIORef cache (\m -> (Map.insert key svg m, svg))</span></span>
|
|
<span class="lineno"> 101 </span>
|
|
<span class="lineno"> 102 </span>encodeInt :: Int -> String
|
|
<span class="lineno"> 103 </span><span class="decl"><span class="nottickedoff">encodeInt i = worker (fromIntegral i) 60</span>
|
|
<span class="lineno"> 104 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
|
<span class="lineno"> 105 </span><span class="spaces"> </span><span class="nottickedoff">worker :: Word -> Int -> String</span>
|
|
<span class="lineno"> 106 </span><span class="spaces"> </span><span class="nottickedoff">worker key sh</span>
|
|
<span class="lineno"> 107 </span><span class="spaces"> </span><span class="nottickedoff">| sh < 0 = []</span>
|
|
<span class="lineno"> 108 </span><span class="spaces"> </span><span class="nottickedoff">| otherwise =</span>
|
|
<span class="lineno"> 109 </span><span class="spaces"> </span><span class="nottickedoff">case (key `shiftR` sh) `mod` 64 of</span>
|
|
<span class="lineno"> 110 </span><span class="spaces"> </span><span class="nottickedoff">idx -> alphabet !! fromIntegral idx : worker key (sh-6)</span>
|
|
<span class="lineno"> 111 </span><span class="spaces"> </span><span class="nottickedoff">alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+$"</span></span>
|
|
|
|
</pre>
|
|
</body>
|
|
</html>
|