module ALife.Creatur.Database.CachedFileSystemInternal where
import Prelude hiding (readFile, writeFile, lookup)
import ALife.Creatur.Database (Database(..), DBRecord, Record,
SizedRecord, delete, key, keys, store, size)
import qualified ALife.Creatur.Database.FileSystem as FS
import ALife.Creatur.Util (stateMap)
import Control.Monad (when)
import Control.Monad.State (StateT, get, gets, modify)
data CachedFSDatabase r = CachedFSDatabase
{
database :: FS.FSDatabase r,
cache :: [r],
maxCacheSize :: Int
} deriving (Show, Eq)
instance (SizedRecord r) => Database (CachedFSDatabase r) where
type DBRecord (CachedFSDatabase r) = r
keys = withFSDB keys
numRecords = withFSDB numRecords
archivedKeys = withFSDB archivedKeys
lookup k = do
x <- fromCache k
case x of
Just r -> return $ Right r
Nothing -> do
y <- withFSDB (lookup k)
case y of
Right r -> do
addToCache r
return $ Right r
Left s -> return $ Left s
lookupInArchive k = withFSDB (lookupInArchive k)
store r = do
addToCache r
withFSDB (store r :: StateT (FS.FSDatabase r) IO ())
delete k = do
deleteByKeyFromCache k
withFSDB (delete k)
withFSDB
:: Monad m
=> StateT (FS.FSDatabase r) m a -> StateT (CachedFSDatabase r) m a
withFSDB f = do
d <- get
stateMap (\x -> d{database=x}) database f
fromCache :: Record r => String -> StateT (CachedFSDatabase r) IO (Maybe r)
fromCache k = do
c <- gets cache
let rs = filter (\r -> key r == k) c
return $ if null rs
then Nothing
else Just (head rs)
addToCache :: SizedRecord r => r -> StateT (CachedFSDatabase r) IO ()
addToCache r = do
deleteFromCache r
modify (\d -> d {cache=r:cache d})
trimCache
deleteByKeyFromCache
:: SizedRecord r
=> String -> StateT (CachedFSDatabase r) IO ()
deleteByKeyFromCache k
= modify (\d -> d {cache=filter (\x -> key x /= k) (cache d)})
deleteFromCache
:: SizedRecord r
=> r -> StateT (CachedFSDatabase r) IO ()
deleteFromCache r =
modify (\d -> d {cache=filter (\x -> key x /= key r) (cache d)})
trimCache :: SizedRecord r => StateT (CachedFSDatabase r) IO ()
trimCache = do
m <- gets maxCacheSize
xs <- gets cache
when (listSize xs > m) $
modify (\d -> d {cache=trim m xs})
trim :: SizedRecord r => Int -> [r] -> [r]
trim m xs = if listSize xs > m
then trim m (init xs)
else xs
listSize :: SizedRecord r => [r] -> Int
listSize [] = 0
listSize xs = sum $ map size xs
mkCachedFSDatabase :: FilePath -> Int -> CachedFSDatabase r
mkCachedFSDatabase d s = CachedFSDatabase (FS.mkFSDatabase d) [] s