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 ALife.Creatur.Database.FileSystem (FSDatabase, mkFSDatabase)
import ALife.Creatur.Util (stateMap)
import Control.Monad (when)
import Control.Monad.State (StateT, get, gets, modify)
data CachedFSDatabase r = CachedFSDatabase
{
database :: 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)
delete k = do
deleteByKeyFromCache k
withFSDB (delete k)
withFSDB
:: Monad m
=> StateT (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 xs = if null xs then 0 else sum $ map size xs
mkCachedFSDatabase :: FilePath -> Int -> CachedFSDatabase r
mkCachedFSDatabase d s = CachedFSDatabase (mkFSDatabase d) [] s