module Reanimate.Cache
  ( cacheFile -- :: FilePath -> (FilePath -> IO ()) -> IO FilePath
  , 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)

-- Memory cache and disk cache

cacheFile :: FilePath -> (FilePath -> IO ()) -> IO FilePath
cacheFile :: FilePath -> (FilePath -> IO ()) -> IO FilePath
cacheFile FilePath
template FilePath -> IO ()
gen = do
    FilePath
root <- IO FilePath
getReanimateCacheDirectory
    let path :: FilePath
path = FilePath
root FilePath -> FilePath -> FilePath
</> FilePath
template
    Bool
hit <- FilePath -> IO Bool
doesFileExist FilePath
path
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
hit (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> (FilePath -> Handle -> IO ()) -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> (FilePath -> Handle -> m a) -> m a
withSystemTempFile FilePath
template ((FilePath -> Handle -> IO ()) -> IO ())
-> (FilePath -> Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
tmp Handle
h -> do
      Handle -> IO ()
hClose Handle
h
      FilePath -> IO ()
gen FilePath
tmp
      FilePath -> FilePath -> IO ()
renameOrCopyFile FilePath
tmp FilePath
path
    FilePath -> IO FilePath
forall a. a -> IO a
evaluate FilePath
path

cacheDisk :: String -> (T.Text -> Maybe a) -> (a -> T.Text) -> (Text -> IO a) -> (Text -> IO a)
cacheDisk :: FilePath
-> (Text -> Maybe a)
-> (a -> Text)
-> (Text -> IO a)
-> Text
-> IO a
cacheDisk FilePath
cacheType Text -> Maybe a
parse a -> Text
render Text -> IO a
gen Text
key = do
    FilePath
root <- IO FilePath
getReanimateCacheDirectory
    let path :: FilePath
path = FilePath
root FilePath -> FilePath -> FilePath
</> Int -> FilePath
encodeInt (Text -> Int
forall a. Hashable a => a -> Int
hash Text
key) FilePath -> FilePath -> FilePath
<.> FilePath
cacheType
    Bool
hit <- FilePath -> IO Bool
doesFileExist FilePath
path
    if Bool
hit
      then do
        Text
inp <- FilePath -> IO Text
T.readFile FilePath
path
        case Text -> Maybe a
parse Text
inp of
          Maybe a
Nothing  -> FilePath -> FilePath -> IO a
genCache FilePath
root FilePath
path
          Just a
val -> a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
val
      else FilePath -> FilePath -> IO a
genCache FilePath
root FilePath
path
  where
    genCache :: FilePath -> FilePath -> IO a
genCache FilePath
root FilePath
path = do
      (FilePath
tmpPath, Handle
tmpHandle) <- FilePath -> FilePath -> IO (FilePath, Handle)
openTempFile FilePath
root (Int -> FilePath
encodeInt (Text -> Int
forall a. Hashable a => a -> Int
hash Text
key))
      a
new <- Text -> IO a
gen Text
key
      Handle -> Text -> IO ()
T.hPutStr Handle
tmpHandle (a -> Text
render a
new)
      Handle -> IO ()
hClose Handle
tmpHandle
      FilePath -> FilePath -> IO ()
renameOrCopyFile FilePath
tmpPath FilePath
path
      a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
new

cacheDiskKey :: Text -> IO Tree -> IO Tree
cacheDiskKey :: Text -> IO Tree -> IO Tree
cacheDiskKey Text
key IO Tree
gen = (Text -> IO Tree) -> Text -> IO Tree
cacheDiskSvg (IO Tree -> Text -> IO Tree
forall a b. a -> b -> a
const IO Tree
gen) Text
key

cacheDiskSvg :: (Text -> IO Tree) -> (Text -> IO Tree)
cacheDiskSvg :: (Text -> IO Tree) -> Text -> IO Tree
cacheDiskSvg = FilePath
-> (Text -> Maybe Tree)
-> (Tree -> Text)
-> (Text -> IO Tree)
-> Text
-> IO Tree
forall a.
FilePath
-> (Text -> Maybe a)
-> (a -> Text)
-> (Text -> IO a)
-> Text
-> IO a
cacheDisk FilePath
"svg" Text -> Maybe Tree
forall s. XmlSource s => s -> Maybe Tree
parse Tree -> Text
render
  where
    parse :: s -> Maybe Tree
parse s
txt = case s -> [Content]
forall s. XmlSource s => s -> [Content]
parseXML s
txt of
      [Elem Element
t] -> Tree -> Maybe Tree
forall a. a -> Maybe a
Just (Element -> Tree
unparse Element
t)
      [Content]
_        -> Maybe Tree
forall a. Maybe a
Nothing
    render :: Tree -> Text
render = FilePath -> Text
T.pack (FilePath -> Text) -> (Tree -> FilePath) -> Tree -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree -> FilePath
renderTree

cacheDiskLines :: (Text -> IO [Text]) -> (Text -> IO [Text])
cacheDiskLines :: (Text -> IO [Text]) -> Text -> IO [Text]
cacheDiskLines = FilePath
-> (Text -> Maybe [Text])
-> ([Text] -> Text)
-> (Text -> IO [Text])
-> Text
-> IO [Text]
forall a.
FilePath
-> (Text -> Maybe a)
-> (a -> Text)
-> (Text -> IO a)
-> Text
-> IO a
cacheDisk FilePath
"txt" Text -> Maybe [Text]
parse [Text] -> Text
render
  where
    parse :: Text -> Maybe [Text]
parse = [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just ([Text] -> Maybe [Text])
-> (Text -> [Text]) -> Text -> Maybe [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines
    render :: [Text] -> Text
render = [Text] -> Text
T.unlines


{-# NOINLINE cache #-}
cache :: IORef (Map Text Tree)
cache :: IORef (Map Text Tree)
cache = IO (IORef (Map Text Tree)) -> IORef (Map Text Tree)
forall a. IO a -> a
unsafePerformIO (Map Text Tree -> IO (IORef (Map Text Tree))
forall a. a -> IO (IORef a)
newIORef Map Text Tree
forall k a. Map k a
Map.empty)

cacheMem :: (Text -> IO Tree) -> (Text -> IO Tree)
cacheMem :: (Text -> IO Tree) -> Text -> IO Tree
cacheMem Text -> IO Tree
gen Text
key = do
  Map Text Tree
store <- IORef (Map Text Tree) -> IO (Map Text Tree)
forall a. IORef a -> IO a
readIORef IORef (Map Text Tree)
cache
  case Text -> Map Text Tree -> Maybe Tree
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
key Map Text Tree
store of
    Just Tree
svg -> Tree -> IO Tree
forall (m :: * -> *) a. Monad m => a -> m a
return Tree
svg
    Maybe Tree
Nothing -> do
      Tree
svg <- Text -> IO Tree
gen Text
key
      case Tree
svg of
        -- None usually indicates that latex or another tool was misconfigured. In this case,
        -- don't store the result.
        Tree
None -> Tree -> IO Tree
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tree
svg
        Tree
_    -> IORef (Map Text Tree)
-> (Map Text Tree -> (Map Text Tree, Tree)) -> IO Tree
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (Map Text Tree)
cache (\Map Text Tree
m -> (Text -> Tree -> Map Text Tree -> Map Text Tree
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
key Tree
svg Map Text Tree
m, Tree
svg))

encodeInt :: Int -> String
encodeInt :: Int -> FilePath
encodeInt Int
i = Word -> Int -> FilePath
worker (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i) Int
60
  where
    worker :: Word -> Int -> String
    worker :: Word -> Int -> FilePath
worker Word
key Int
sh
      | Int
sh Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = []
      | Bool
otherwise =
        case (Word
key Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftR` Int
sh) Word -> Word -> Word
forall a. Integral a => a -> a -> a
`mod` Word
32 of
          Word
idx -> FilePath
alphabet FilePath -> Int -> Char
forall a. [a] -> Int -> a
!! Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
idx Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: Word -> Int -> FilePath
worker Word
key (Int
shInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
5)
    alphabet :: FilePath
alphabet = FilePath
"ABCDEFGHJKLMNPQRSTUVWXYZ23456789"