module Reanimate.Cache
( cacheFile
, cacheMem
, cacheDisk
, cacheDiskSvg
, cacheDiskKey
, cacheDiskLines
, encodeInt
) where
import Control.Exception (evaluate)
import Control.Monad (unless)
import Data.Bits (Bits (shiftR))
import Data.Hashable (Hashable (hash))
import Data.IORef (IORef, atomicModifyIORef, newIORef, readIORef)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Graphics.SvgTree (Tree, pattern None, unparse)
import Reanimate.Animation (renderTree)
import Reanimate.Misc (getReanimateCacheDirectory, renameOrCopyFile)
import System.Directory (doesFileExist)
import System.FilePath ((<.>), (</>))
import System.IO (hClose)
import System.IO.Temp (openTempFile, withSystemTempFile)
import System.IO.Unsafe (unsafePerformIO)
import Text.XML.Light (Content (..), parseXML)
cacheFile :: FilePath -> (FilePath -> IO ()) -> IO FilePath
cacheFile template gen = do
root <- getReanimateCacheDirectory
let path = root </> template
hit <- doesFileExist path
unless hit $ withSystemTempFile template $ \tmp h -> do
hClose h
gen tmp
renameOrCopyFile tmp path
evaluate path
cacheDisk :: String -> (T.Text -> Maybe a) -> (a -> T.Text) -> (Text -> IO a) -> (Text -> IO a)
cacheDisk cacheType parse render gen key = do
root <- getReanimateCacheDirectory
let path = root </> encodeInt (hash key) <.> cacheType
hit <- doesFileExist path
if hit
then do
inp <- T.readFile path
case parse inp of
Nothing -> genCache root path
Just val -> pure val
else genCache root path
where
genCache root path = do
(tmpPath, tmpHandle) <- openTempFile root (encodeInt (hash key))
new <- gen key
T.hPutStr tmpHandle (render new)
hClose tmpHandle
renameOrCopyFile tmpPath path
return new
cacheDiskKey :: Text -> IO Tree -> IO Tree
cacheDiskKey key gen = cacheDiskSvg (const gen) key
cacheDiskSvg :: (Text -> IO Tree) -> (Text -> IO Tree)
cacheDiskSvg = cacheDisk "svg" 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 "txt" 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 -> pure svg
_ -> atomicModifyIORef cache (\m -> (Map.insert key svg m, svg))
encodeInt :: Int -> String
encodeInt i = worker (fromIntegral i) 60
where
worker :: Word -> Int -> String
worker key sh
| sh < 0 = []
| otherwise =
case (key `shiftR` sh) `mod` 64 of
idx -> alphabet !! fromIntegral idx : worker key (sh-6)
alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+$"