never executed always true always false

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