creatur 5.2.10 → 5.2.11
raw patch · 6 files changed
+244/−4 lines, 6 files
Files
- creatur.cabal +5/−2
- src/ALife/Creatur/Database.hs +6/−2
- src/ALife/Creatur/Database/CachedFileSystem.hs +22/−0
- src/ALife/Creatur/Database/CachedFileSystemInternal.hs +119/−0
- test/ALife/Creatur/Database/CachedFileSystemQC.hs +90/−0
- test/TestAll.hs +2/−0
creatur.cabal view
@@ -1,5 +1,5 @@ Name: creatur-Version: 5.2.10+Version: 5.2.11 Stability: experimental Synopsis: Framework for artificial life experiments. Description: A software framework for automating experiments@@ -36,7 +36,7 @@ source-repository this type: git location: https://github.com/mhwombat/creatur.git- tag: 5.2.9+ tag: 5.2.11 library GHC-Options: -Wall -fno-warn-orphans@@ -48,6 +48,8 @@ ALife.Creatur.Counter, ALife.Creatur.Daemon, ALife.Creatur.Database,+ ALife.Creatur.Database.CachedFileSystem,+ ALife.Creatur.Database.CachedFileSystemInternal, ALife.Creatur.Database.FileSystem, ALife.Creatur.Genetics.Analysis, ALife.Creatur.Genetics.BRGCBool,@@ -108,6 +110,7 @@ QuickCheck ==2.6.* Other-modules: ALife.Creatur.UtilQC ALife.Creatur.CounterQC+ ALife.Creatur.Database.CachedFileSystemQC ALife.Creatur.Database.FileSystemQC ALife.Creatur.Genetics.DiploidQC, ALife.Creatur.Genetics.BRGCBoolQC
src/ALife/Creatur/Database.hs view
@@ -15,7 +15,8 @@ module ALife.Creatur.Database ( Database(..),- Record(..)+ Record(..),+ SizedRecord(..) ) where import Control.Monad.State (StateT)@@ -23,7 +24,10 @@ class Record r where key :: r -> String- ++class (Record r) => SizedRecord r where+ size :: r -> Int+ -- | A database offering storage and retrieval for records. class Database d where type DBRecord d
+ src/ALife/Creatur/Database/CachedFileSystem.hs view
@@ -0,0 +1,22 @@+------------------------------------------------------------------------+-- |+-- Module : ALife.Creatur.Database.CachedFileSystem+-- Copyright : (c) Amy de Buitléir 2014+-- License : BSD-style+-- Maintainer : amy@nualeargais.ie+-- Stability : experimental+-- Portability : portable+--+-- A database that stores each record in a separate file and maintains+-- a cache of recently-accessed records. The name of the file is the+-- record's key.+--+------------------------------------------------------------------------+{-# LANGUAGE TypeFamilies, FlexibleContexts #-}+module ALife.Creatur.Database.CachedFileSystem+ (+ CachedFSDatabase,+ mkCachedFSDatabase+ ) where++import ALife.Creatur.Database.CachedFileSystemInternal
+ src/ALife/Creatur/Database/CachedFileSystemInternal.hs view
@@ -0,0 +1,119 @@+------------------------------------------------------------------------+-- |+-- Module : ALife.Creatur.Database.CachedFileSystemInternal+-- Copyright : (c) Amy de Buitléir 2014+-- License : BSD-style+-- Maintainer : amy@nualeargais.ie+-- Stability : experimental+-- Portability : portable+--+-- A module containing private CachedFileSystem internals.+-- Most developers should use CachedFileSystem instead.+-- This module is subject to change without notice.+--+------------------------------------------------------------------------+{-# LANGUAGE TypeFamilies, FlexibleContexts #-}+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)++-- | A simple database where each record is stored in a separate file, +-- and the name of the file is the record's key.+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)+ -- only the main dir is cached++ 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++-- | @'mkFSDatabase' d@ (re)creates the FSDatabase in the+-- directory @d@.+mkCachedFSDatabase :: FilePath -> Int -> CachedFSDatabase r+mkCachedFSDatabase d s = CachedFSDatabase (mkFSDatabase d) [] s
+ test/ALife/Creatur/Database/CachedFileSystemQC.hs view
@@ -0,0 +1,90 @@+------------------------------------------------------------------------+-- |+-- Module : ALife.Creatur.Database.CachedFileSystemQC+-- Copyright : (c) Amy de Buitléir 2014+-- License : BSD-style+-- Maintainer : amy@nualeargais.ie+-- Stability : experimental+-- Portability : portable+--+-- QuickCheck tests.+--+------------------------------------------------------------------------+{-# LANGUAGE DeriveGeneric #-}++module ALife.Creatur.Database.CachedFileSystemQC+ (+ test+ ) where++import Prelude hiding (lookup)+import ALife.Creatur.Database (Record, SizedRecord, key, store, lookup,+ delete, size)+import ALife.Creatur.Database.CachedFileSystemInternal+import Control.Monad.State (execStateT, evalStateT)+import Data.Serialize (Serialize)+import GHC.Generics (Generic)+import System.IO.Temp (withSystemTempDirectory)+import Test.Framework as TF (Test, testGroup)+import Test.HUnit as TH (assertEqual, assertBool)+import Test.Framework.Providers.HUnit (testCase)++data TestRecord = TestRecord String Int+ deriving (Show, Eq, Generic)++instance Record TestRecord where+ key (TestRecord k _) = k++instance SizedRecord TestRecord where+ size (TestRecord _ s) = s++instance Serialize TestRecord++tryCachedLookup :: FilePath -> IO ()+tryCachedLookup dir = do+ let record = TestRecord "alpha" 7+ let db = (mkCachedFSDatabase dir 10) { cache=[record] }+ -- We didn't create a file for the record, but as long as the database+ -- finds the record in the cache, this should work.+ Right record' <- evalStateT (lookup (key record)) db+ assertEqual "wombat" record record'++testCachedLookup :: IO ()+testCachedLookup = withSystemTempDirectory "creaturTest.tmp" tryCachedLookup++tryStoreDelete :: FilePath -> IO ()+tryStoreDelete dir = do+ let db = mkCachedFSDatabase dir 10+ let record = TestRecord "alpha" 7+ db' <- execStateT (store record) db+ assertBool "record not in cache" $ record `elem` (cache db')+ db2 <- execStateT (delete $ key record) db'+ assertBool "record still in cache" $ record `notElem` (cache db2)++testStoreDelete :: IO ()+testStoreDelete = withSystemTempDirectory "creaturTest.tmp" tryStoreDelete++tryCachedSize :: FilePath -> IO ()+tryCachedSize dir = do+ let records = map (\n -> TestRecord (show n) 1) ([1..5] :: [Int])+ let db = (mkCachedFSDatabase dir 5) { cache=records }+ let record = TestRecord "one too many" 1+ db' <- execStateT (store record) db+ assertEqual "cache too big" (length (cache db')) 5+ assertBool "record not in cache" $ record `elem` (cache db')++testCachedSize :: IO ()+testCachedSize = withSystemTempDirectory "creaturTest.tmp" tryCachedSize++test :: TF.Test+test = testGroup "HUnit ALife.Creatur.Database.CachedFileSystemQC"+ [+ testCase "cached lookup"+ testCachedLookup,+ testCase "store and delete"+ testStoreDelete,+ testCase "cache size"+ testCachedSize+ ]++
test/TestAll.hs view
@@ -16,6 +16,7 @@ import ALife.Creatur.ChecklistQC (test) import ALife.Creatur.UniverseQC (test) import ALife.Creatur.Database.FileSystemQC (test)+import ALife.Creatur.Database.CachedFileSystemQC (test) import ALife.Creatur.UtilQC (test) import ALife.Creatur.Genetics.DiploidQC (test) import ALife.Creatur.Genetics.RecombinationQC (test)@@ -32,6 +33,7 @@ ALife.Creatur.ChecklistQC.test, ALife.Creatur.UniverseQC.test, ALife.Creatur.Database.FileSystemQC.test,+ ALife.Creatur.Database.CachedFileSystemQC.test, ALife.Creatur.UtilQC.test, ALife.Creatur.Genetics.DiploidQC.test, ALife.Creatur.Genetics.RecombinationQC.test,